FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
   5              $dir_prefix @shells $usernamemin
   6              $usernamemax $passwordmin $passwordmax
   7              $username_ampersand $username_letter $username_letterfirst
   8              $username_noperiod $username_nounderscore $username_nodash
   9              $username_uppercase $username_percent
  10              $password_noampersand $password_noexclamation
  11              $welcome_template $welcome_from
  12              $welcome_subject $welcome_subject_template $welcome_mimetype
  13              $warning_template $warning_from $warning_subject $warning_mimetype
  14              $warning_cc
  15              $smtpmachine
  16              $radius_password $radius_ip
  17              $dirhash
  18              @saltset @pw_set );
  19 use Carp;
  20 use Fcntl qw(:flock);
  21 use Date::Format;
  22 use Crypt::PasswdMD5 1.2;
  23 use Data::Dumper;
  24 use FS::UID qw( datasrc driver_name );
  25 use FS::Conf;
  26 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  27 use FS::Msgcat qw(gettext);
  28 use FS::UI::bytecount;
  29 use FS::svc_Common;
  30 use FS::cust_svc;
  31 use FS::part_svc;
  32 use FS::svc_acct_pop;
  33 use FS::cust_main_invoice;
  34 use FS::svc_domain;
  35 use FS::raddb;
  36 use FS::queue;
  37 use FS::radius_usergroup;
  38 use FS::export_svc;
  39 use FS::part_export;
  40 use FS::svc_forward;
  41 use FS::svc_www;
  42 use FS::cdr;
  43
  44 @ISA = qw( FS::svc_Common );
  45
  46 $DEBUG = 0;
  47 $me = '[FS::svc_acct]';
  48
  49 #ask FS::UID to run this stuff for us later
  50 $FS::UID::callback{'FS::svc_acct'} = sub {
  51   $conf = new FS::Conf;
  52   $dir_prefix = $conf->config('home');
  53   @shells = $conf->config('shells');
  54   $usernamemin = $conf->config('usernamemin') || 2;
  55   $usernamemax = $conf->config('usernamemax');
  56   $passwordmin = $conf->config('passwordmin') || 6;
  57   $passwordmax = $conf->config('passwordmax') || 8;
  58   $username_letter = $conf->exists('username-letter');
  59   $username_letterfirst = $conf->exists('username-letterfirst');
  60   $username_noperiod = $conf->exists('username-noperiod');
  61   $username_nounderscore = $conf->exists('username-nounderscore');
  62   $username_nodash = $conf->exists('username-nodash');
  63   $username_uppercase = $conf->exists('username-uppercase');
  64   $username_ampersand = $conf->exists('username-ampersand');
  65   $username_percent = $conf->exists('username-percent');
  66   $password_noampersand = $conf->exists('password-noexclamation');
  67   $password_noexclamation = $conf->exists('password-noexclamation');
  68   $dirhash = $conf->config('dirhash') || 0;
  69   if ( $conf->exists('welcome_email') ) {
  70     $welcome_template = new Text::Template (
  71       TYPE   => 'ARRAY',
  72       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  73     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  74     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  75     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  76     $welcome_subject_template = new Text::Template (
  77       TYPE   => 'STRING',
  78       SOURCE => $welcome_subject,
  79     ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
  80     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  81   } else {
  82     $welcome_template = '';
  83     $welcome_from = '';
  84     $welcome_subject = '';
  85     $welcome_mimetype = '';
  86   }
  87   if ( $conf->exists('warning_email') ) {
  88     $warning_template = new Text::Template (
  89       TYPE   => 'ARRAY',
  90       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  91     ) or warn "can't create warning email template: $Text::Template::ERROR";
  92     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  93     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  94     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  95     $warning_cc = $conf->config('warning_email-cc');
  96   } else {
  97     $warning_template = '';
  98     $warning_from = '';
  99     $warning_subject = '';
 100     $warning_mimetype = '';
 101     $warning_cc = '';
 102   }
 103   $smtpmachine = $conf->config('smtpmachine');
 104   $radius_password = $conf->config('radius-password') || 'Password';
 105   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
 106   @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
 107 };
 108
 109 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
 110 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
 111
 112 sub _cache {
 113   my $self = shift;
 114   my ( $hashref, $cache ) = @_;
 115   if ( $hashref->{'svc_acct_svcnum'} ) {
 116     $self->{'_domsvc'} = FS::svc_domain->new( {
 117       'svcnum'   => $hashref->{'domsvc'},
 118       'domain'   => $hashref->{'svc_acct_domain'},
 119       'catchall' => $hashref->{'svc_acct_catchall'},
 120     } );
 121   }
 122 }
 123
 124 =head1 NAME
 125
 126 FS::svc_acct - Object methods for svc_acct records
 127
 128 =head1 SYNOPSIS
 129
 130   use FS::svc_acct;
 131
 132   $record = new FS::svc_acct \%hash;
 133   $record = new FS::svc_acct { 'column' => 'value' };
 134
 135   $error = $record->insert;
 136
 137   $error = $new_record->replace($old_record);
 138
 139   $error = $record->delete;
 140
 141   $error = $record->check;
 142
 143   $error = $record->suspend;
 144
 145   $error = $record->unsuspend;
 146
 147   $error = $record->cancel;
 148
 149   %hash = $record->radius;
 150
 151   %hash = $record->radius_reply;
 152
 153   %hash = $record->radius_check;
 154
 155   $domain = $record->domain;
 156
 157   $svc_domain = $record->svc_domain;
 158
 159   $email = $record->email;
 160
 161   $seconds_since = $record->seconds_since($timestamp);
 162
 163 =head1 DESCRIPTION
 164
 165 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 166 FS::svc_Common.  The following fields are currently supported:
 167
 168 =over 4
 169
 170 =item svcnum - primary key (assigned automatcially for new accounts)
 171
 172 =item username
 173
 174 =item _password - generated if blank
 175
 176 =item sec_phrase - security phrase
 177
 178 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 179
 180 =item uid
 181
 182 =item gid
 183
 184 =item finger - GECOS
 185
 186 =item dir - set automatically if blank (and uid is not)
 187
 188 =item shell
 189
 190 =item quota - (unimplementd)
 191
 192 =item slipip - IP address
 193
 194 =item seconds -
 195
 196 =item upbytes -
 197
 198 =item downbytes -
 199
 200 =item totalbytes -
 201
 202 =item domsvc - svcnum from svc_domain
 203
 204 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 205
 206 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 207
 208 =back
 209
 210 =head1 METHODS
 211
 212 =over 4
 213
 214 =item new HASHREF
 215
 216 Creates a new account.  To add the account to the database, see L<"insert">.
 217
 218 =cut
 219
 220 sub table_info {
 221   {
 222     'name'   => 'Account',
 223     'longname_plural' => 'Access accounts and mailboxes',
 224     'sorts' => [ 'username', 'uid', 'last_login', ],
 225     'display_weight' => 10,
 226     'cancel_weight'  => 50,
 227     'fields' => {
 228         'dir'       => 'Home directory',
 229         'uid'       => {
 230                          label     => 'UID',
 231                          def_label => 'UID (set to fixed and blank for no UIDs)',
 232                          type      => 'text',
 233                        },
 234         'slipip'    => 'IP address',
 235     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 236         'popnum'    => {
 237                          label => 'Access number',
 238                          type => 'select',
 239                          select_table => 'svc_acct_pop',
 240                          select_key   => 'popnum',
 241                          select_label => 'city',
 242                          disable_select => 1,
 243                        },
 244         'username'  => {
 245                          label => 'Username',
 246                          type => 'text',
 247                          disable_default => 1,
 248                          disable_fixed => 1,
 249                          disable_select => 1,
 250                        },
 251         'quota'     => {
 252                          label => 'Quota',
 253                          type => 'text',
 254                          disable_inventory => 1,
 255                          disable_select => 1,
 256                        },
 257         '_password' => 'Password',
 258         'gid'       => {
 259                          label     => 'GID',
 260                          def_label => 'GID (when blank, defaults to UID)',
 261                          type      => 'text',
 262                        },
 263         'shell'     => {
 264                          #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
 265                          label    => 'Shell',
 266                          def_label=> 'Shell (set to blank for no shell tracking)',
 267                          type     =>'select',
 268                          select_list => [ $conf->config('shells') ],
 269                          disable_inventory => 1,
 270                          disable_select => 1,
 271                        },
 272         'finger'    => 'Real name', # (GECOS)',
 273         'domsvc'    => {
 274                          label     => 'Domain',
 275                          #def_label => 'svcnum from svc_domain',
 276                          type      => 'select',
 277                          select_table => 'svc_domain',
 278                          select_key   => 'svcnum',
 279                          select_label => 'domain',
 280                          disable_inventory => 1,
 281
 282                        },
 283         'usergroup' => {
 284                          label => 'RADIUS groups',
 285                          type  => 'radius_usergroup_selector',
 286                          disable_inventory => 1,
 287                          disable_select => 1,
 288                        },
 289         'seconds'   => { label => 'Seconds',
 290                          type  => 'text',
 291                          disable_inventory => 1,
 292                          disable_select => 1,
 293                        },
 294         'upbytes'   => { label => 'Upload',
 295                          type  => 'text',
 296                          disable_inventory => 1,
 297                          disable_select => 1,
 298                          'format' => \&FS::UI::bytecount::display_bytecount,
 299                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 300                        },
 301         'downbytes' => { label => 'Download',
 302                          type  => 'text',
 303                          disable_inventory => 1,
 304                          disable_select => 1,
 305                          'format' => \&FS::UI::bytecount::display_bytecount,
 306                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 307                        },
 308         'totalbytes'=> { label => 'Total up and download',
 309                          type  => 'text',
 310                          disable_inventory => 1,
 311                          disable_select => 1,
 312                          'format' => \&FS::UI::bytecount::display_bytecount,
 313                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 314                        },
 315         'seconds_threshold'   => { label => 'Seconds threshold',
 316                                    type  => 'text',
 317                                    disable_inventory => 1,
 318                                    disable_select => 1,
 319                                  },
 320         'upbytes_threshold'   => { label => 'Upload threshold',
 321                                    type  => 'text',
 322                                    disable_inventory => 1,
 323                                    disable_select => 1,
 324                                    'format' => \&FS::UI::bytecount::display_bytecount,
 325                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 326                                  },
 327         'downbytes_threshold' => { label => 'Download threshold',
 328                                    type  => 'text',
 329                                    disable_inventory => 1,
 330                                    disable_select => 1,
 331                                    'format' => \&FS::UI::bytecount::display_bytecount,
 332                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 333                                  },
 334         'totalbytes_threshold'=> { label => 'Total up and download threshold',
 335                                    type  => 'text',
 336                                    disable_inventory => 1,
 337                                    disable_select => 1,
 338                                    'format' => \&FS::UI::bytecount::display_bytecount,
 339                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 340                                  },
 341         'last_login'=>           {
 342                                    label     => 'Last login',
 343                                    type      => 'disabled',
 344                                  },
 345         'last_logout'=>          {
 346                                    label     => 'Last logout',
 347                                    type      => 'disabled',
 348                                  },
 349     },
 350   };
 351 }
 352
 353 sub table { 'svc_acct'; }
 354
 355 sub _fieldhandlers {
 356   {
 357     #false laziness with edit/svc_acct.cgi
 358     'usergroup' => sub {
 359                          my( $self, $groups ) = @_;
 360                          if ( ref($groups) eq 'ARRAY' ) {
 361                            $groups;
 362                          } elsif ( length($groups) ) {
 363                            [ split(/\s*,\s*/, $groups) ];
 364                          } else {
 365                            [];
 366                          }
 367                        },
 368   };
 369 }
 370
 371 sub last_login {
 372   shift->_lastlog('in', @_);
 373 }
 374
 375 sub last_logout {
 376   shift->_lastlog('out', @_);
 377 }
 378
 379 sub _lastlog {
 380   my( $self, $op, $time ) = @_;
 381
 382   if ( defined($time) ) {
 383     warn "$me last_log$op called on svcnum ". $self->svcnum.
 384          ' ('. $self->email. "): $time\n"
 385       if $DEBUG;
 386
 387     my $dbh = dbh;
 388
 389     my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
 390     warn "$me $sql\n"
 391       if $DEBUG;
 392
 393     my $sth = $dbh->prepare( $sql )
 394       or die "Error preparing $sql: ". $dbh->errstr;
 395     my $rv = $sth->execute($time, $self->svcnum);
 396     die "Error executing $sql: ". $sth->errstr
 397       unless defined($rv);
 398     die "Can't update last_log$op for svcnum". $self->svcnum
 399       if $rv == 0;
 400
 401     $self->{'Hash'}->{"last_log$op"} = $time;
 402   }else{
 403     $self->getfield("last_log$op");
 404   }
 405 }
 406
 407 =item search_sql STRING
 408
 409 Class method which returns an SQL fragment to search for the given string.
 410
 411 =cut
 412
 413 sub search_sql {
 414   my( $class, $string ) = @_;
 415   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 416     my( $username, $domain ) = ( $1, $2 );
 417     my $q_username = dbh->quote($username);
 418     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 419     if ( @svc_domain ) {
 420       "svc_acct.username = $q_username AND ( ".
 421         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 422       " )";
 423     } else {
 424       '1 = 0'; #false
 425     }
 426   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 427     ' ( '.
 428       $class->search_sql_field('slipip',   $string ).
 429     ' OR '.
 430       $class->search_sql_field('username', $string ).
 431     ' ) ';
 432   } else {
 433     $class->search_sql_field('username', $string);
 434   }
 435 }
 436
 437 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 438
 439 Returns the "username@domain" string for this account.
 440
 441 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 442 history records.
 443
 444 =cut
 445
 446 sub label {
 447   my $self = shift;
 448   $self->email(@_);
 449 }
 450
 451 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 452
 453 Returns a longer string label for this acccount ("Real Name <username@domain>"
 454 if available, or "username@domain").
 455
 456 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 457 history records.
 458
 459 =cut
 460
 461 sub label_long {
 462   my $self = shift;
 463   ( $self->finger =~ /\S/ )
 464     ? $self->finger. ' <'.$self->label(@_).'>'
 465     : $self->label(@_);
 466 }
 467
 468 =item insert [ , OPTION => VALUE ... ]
 469
 470 Adds this account to the database.  If there is an error, returns the error,
 471 otherwise returns false.
 472
 473 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 474 defined.  An FS::cust_svc record will be created and inserted.
 475
 476 The additional field I<usergroup> can optionally be defined; if so it should
 477 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 478
 479 The additional field I<child_objects> can optionally be defined; if so it
 480 should contain an arrayref of FS::tablename objects.  They will have their
 481 svcnum fields set and will be inserted after this record, but before any
 482 exports are run.  Each element of the array can also optionally be a
 483 two-element array reference containing the child object and the name of an
 484 alternate field to be filled in with the newly-inserted svcnum, for example
 485 C<[ $svc_forward, 'srcsvc' ]>
 486
 487 Currently available options are: I<depend_jobnum>
 488
 489 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 490 jobnums), all provisioning jobs will have a dependancy on the supplied
 491 jobnum(s) (they will not run until the specific job(s) complete(s)).
 492
 493 (TODOC: L<FS::queue> and L<freeside-queued>)
 494
 495 (TODOC: new exports!)
 496
 497 =cut
 498
 499 sub insert {
 500   my $self = shift;
 501   my %options = @_;
 502
 503   if ( $DEBUG ) {
 504     warn "[$me] insert called on $self: ". Dumper($self).
 505          "\nwith options: ". Dumper(%options);
 506   }
 507
 508   local $SIG{HUP} = 'IGNORE';
 509   local $SIG{INT} = 'IGNORE';
 510   local $SIG{QUIT} = 'IGNORE';
 511   local $SIG{TERM} = 'IGNORE';
 512   local $SIG{TSTP} = 'IGNORE';
 513   local $SIG{PIPE} = 'IGNORE';
 514
 515   my $oldAutoCommit = $FS::UID::AutoCommit;
 516   local $FS::UID::AutoCommit = 0;
 517   my $dbh = dbh;
 518
 519   my $error = $self->check;
 520   return $error if $error;
 521
 522   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 523     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 524     unless ( $cust_svc ) {
 525       $dbh->rollback if $oldAutoCommit;
 526       return "no cust_svc record found for svcnum ". $self->svcnum;
 527     }
 528     $self->pkgnum($cust_svc->pkgnum);
 529     $self->svcpart($cust_svc->svcpart);
 530   }
 531
 532   $error = $self->_check_duplicate;
 533   if ( $error ) {
 534     $dbh->rollback if $oldAutoCommit;
 535     return $error;
 536   }
 537
 538   my @jobnums;
 539   $error = $self->SUPER::insert(
 540     'jobnums'       => \@jobnums,
 541     'child_objects' => $self->child_objects,
 542     %options,
 543   );
 544   if ( $error ) {
 545     $dbh->rollback if $oldAutoCommit;
 546     return $error;
 547   }
 548
 549   if ( $self->usergroup ) {
 550     foreach my $groupname ( @{$self->usergroup} ) {
 551       my $radius_usergroup = new FS::radius_usergroup ( {
 552         svcnum    => $self->svcnum,
 553         groupname => $groupname,
 554       } );
 555       my $error = $radius_usergroup->insert;
 556       if ( $error ) {
 557         $dbh->rollback if $oldAutoCommit;
 558         return $error;
 559       }
 560     }
 561   }
 562
 563   unless ( $skip_fuzzyfiles ) {
 564     $error = $self->queue_fuzzyfiles_update;
 565     if ( $error ) {
 566       $dbh->rollback if $oldAutoCommit;
 567       return "updating fuzzy search cache: $error";
 568     }
 569   }
 570
 571   my $cust_pkg = $self->cust_svc->cust_pkg;
 572
 573   if ( $cust_pkg ) {
 574     my $cust_main = $cust_pkg->cust_main;
 575
 576     if (   $conf->exists('emailinvoiceautoalways')
 577         || $conf->exists('emailinvoiceauto')
 578         && ! $cust_main->invoicing_list_emailonly
 579        ) {
 580       my @invoicing_list = $cust_main->invoicing_list;
 581       push @invoicing_list, $self->email;
 582       $cust_main->invoicing_list(\@invoicing_list);
 583     }
 584
 585     #welcome email
 586     my $to = '';
 587     if ( $welcome_template && $cust_pkg ) {
 588       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 589       if ( $to ) {
 590
 591         my %hash = (
 592                      'custnum'  => $self->custnum,
 593                      'username' => $self->username,
 594                      'password' => $self->_password,
 595                      'first'    => $cust_main->first,
 596                      'last'     => $cust_main->getfield('last'),
 597                      'pkg'      => $cust_pkg->part_pkg->pkg,
 598                    );
 599         my $wqueue = new FS::queue {
 600           'svcnum' => $self->svcnum,
 601           'job'    => 'FS::svc_acct::send_email'
 602         };
 603         my $error = $wqueue->insert(
 604           'to'       => $to,
 605           'from'     => $welcome_from,
 606           'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 607           'mimetype' => $welcome_mimetype,
 608           'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 609         );
 610         if ( $error ) {
 611           $dbh->rollback if $oldAutoCommit;
 612           return "error queuing welcome email: $error";
 613         }
 614
 615         if ( $options{'depend_jobnum'} ) {
 616           warn "$me depend_jobnum found; adding to welcome email dependancies"
 617             if $DEBUG;
 618           if ( ref($options{'depend_jobnum'}) ) {
 619             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 620                  "to welcome email dependancies"
 621               if $DEBUG;
 622             push @jobnums, @{ $options{'depend_jobnum'} };
 623           } else {
 624             warn "$me adding job $options{'depend_jobnum'} ".
 625                  "to welcome email dependancies"
 626               if $DEBUG;
 627             push @jobnums, $options{'depend_jobnum'};
 628           }
 629         }
 630
 631         foreach my $jobnum ( @jobnums ) {
 632           my $error = $wqueue->depend_insert($jobnum);
 633           if ( $error ) {
 634             $dbh->rollback if $oldAutoCommit;
 635             return "error queuing welcome email job dependancy: $error";
 636           }
 637         }
 638
 639       }
 640
 641     }
 642
 643   } # if ( $cust_pkg )
 644
 645   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 646   ''; #no error
 647 }
 648
 649 =item delete
 650
 651 Deletes this account from the database.  If there is an error, returns the
 652 error, otherwise returns false.
 653
 654 The corresponding FS::cust_svc record will be deleted as well.
 655
 656 (TODOC: new exports!)
 657
 658 =cut
 659
 660 sub delete {
 661   my $self = shift;
 662
 663   return "can't delete system account" if $self->_check_system;
 664
 665   return "Can't delete an account which is a (svc_forward) source!"
 666     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 667
 668   return "Can't delete an account which is a (svc_forward) destination!"
 669     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 670
 671   return "Can't delete an account with (svc_www) web service!"
 672     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 673
 674   # what about records in session ? (they should refer to history table)
 675
 676   local $SIG{HUP} = 'IGNORE';
 677   local $SIG{INT} = 'IGNORE';
 678   local $SIG{QUIT} = 'IGNORE';
 679   local $SIG{TERM} = 'IGNORE';
 680   local $SIG{TSTP} = 'IGNORE';
 681   local $SIG{PIPE} = 'IGNORE';
 682
 683   my $oldAutoCommit = $FS::UID::AutoCommit;
 684   local $FS::UID::AutoCommit = 0;
 685   my $dbh = dbh;
 686
 687   foreach my $cust_main_invoice (
 688     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 689   ) {
 690     unless ( defined($cust_main_invoice) ) {
 691       warn "WARNING: something's wrong with qsearch";
 692       next;
 693     }
 694     my %hash = $cust_main_invoice->hash;
 695     $hash{'dest'} = $self->email;
 696     my $new = new FS::cust_main_invoice \%hash;
 697     my $error = $new->replace($cust_main_invoice);
 698     if ( $error ) {
 699       $dbh->rollback if $oldAutoCommit;
 700       return $error;
 701     }
 702   }
 703
 704   foreach my $svc_domain (
 705     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 706   ) {
 707     my %hash = new FS::svc_domain->hash;
 708     $hash{'catchall'} = '';
 709     my $new = new FS::svc_domain \%hash;
 710     my $error = $new->replace($svc_domain);
 711     if ( $error ) {
 712       $dbh->rollback if $oldAutoCommit;
 713       return $error;
 714     }
 715   }
 716
 717   my $error = $self->SUPER::delete;
 718   if ( $error ) {
 719     $dbh->rollback if $oldAutoCommit;
 720     return $error;
 721   }
 722
 723   foreach my $radius_usergroup (
 724     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 725   ) {
 726     my $error = $radius_usergroup->delete;
 727     if ( $error ) {
 728       $dbh->rollback if $oldAutoCommit;
 729       return $error;
 730     }
 731   }
 732
 733   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 734   '';
 735 }
 736
 737 =item replace OLD_RECORD
 738
 739 Replaces OLD_RECORD with this one in the database.  If there is an error,
 740 returns the error, otherwise returns false.
 741
 742 The additional field I<usergroup> can optionally be defined; if so it should
 743 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 744
 745
 746 =cut
 747
 748 sub replace {
 749   my ( $new, $old ) = ( shift, shift );
 750   my $error;
 751   warn "$me replacing $old with $new\n" if $DEBUG;
 752
 753   # We absolutely have to have an old vs. new record to make this work.
 754   if (!defined($old)) {
 755     $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
 756   }
 757
 758   return "can't modify system account" if $old->_check_system;
 759
 760   {
 761     #no warnings 'numeric';  #alas, a 5.006-ism
 762     local($^W) = 0;
 763
 764     foreach my $xid (qw( uid gid )) {
 765
 766       return "Can't change $xid!"
 767         if ! $conf->exists("svc_acct-edit_$xid")
 768            && $old->$xid() != $new->$xid()
 769            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 770     }
 771
 772   }
 773
 774   #change homdir when we change username
 775   $new->setfield('dir', '') if $old->username ne $new->username;
 776
 777   local $SIG{HUP} = 'IGNORE';
 778   local $SIG{INT} = 'IGNORE';
 779   local $SIG{QUIT} = 'IGNORE';
 780   local $SIG{TERM} = 'IGNORE';
 781   local $SIG{TSTP} = 'IGNORE';
 782   local $SIG{PIPE} = 'IGNORE';
 783
 784   my $oldAutoCommit = $FS::UID::AutoCommit;
 785   local $FS::UID::AutoCommit = 0;
 786   my $dbh = dbh;
 787
 788   # redundant, but so $new->usergroup gets set
 789   $error = $new->check;
 790   return $error if $error;
 791
 792   $old->usergroup( [ $old->radius_groups ] );
 793   if ( $DEBUG ) {
 794     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 795     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 796   }
 797   if ( $new->usergroup ) {
 798     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 799     my @newgroups = @{$new->usergroup};
 800     foreach my $oldgroup ( @{$old->usergroup} ) {
 801       if ( grep { $oldgroup eq $_ } @newgroups ) {
 802         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 803         next;
 804       }
 805       my $radius_usergroup = qsearchs('radius_usergroup', {
 806         svcnum    => $old->svcnum,
 807         groupname => $oldgroup,
 808       } );
 809       my $error = $radius_usergroup->delete;
 810       if ( $error ) {
 811         $dbh->rollback if $oldAutoCommit;
 812         return "error deleting radius_usergroup $oldgroup: $error";
 813       }
 814     }
 815
 816     foreach my $newgroup ( @newgroups ) {
 817       my $radius_usergroup = new FS::radius_usergroup ( {
 818         svcnum    => $new->svcnum,
 819         groupname => $newgroup,
 820       } );
 821       my $error = $radius_usergroup->insert;
 822       if ( $error ) {
 823         $dbh->rollback if $oldAutoCommit;
 824         return "error adding radius_usergroup $newgroup: $error";
 825       }
 826     }
 827
 828   }
 829
 830   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 831     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 832     $error = $new->_check_duplicate;
 833     if ( $error ) {
 834       $dbh->rollback if $oldAutoCommit;
 835       return $error;
 836     }
 837   }
 838
 839   $error = $new->SUPER::replace($old);
 840   if ( $error ) {
 841     $dbh->rollback if $oldAutoCommit;
 842     return $error if $error;
 843   }
 844
 845   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 846     $error = $new->queue_fuzzyfiles_update;
 847     if ( $error ) {
 848       $dbh->rollback if $oldAutoCommit;
 849       return "updating fuzzy search cache: $error";
 850     }
 851   }
 852
 853   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 854   ''; #no error
 855 }
 856
 857 =item queue_fuzzyfiles_update
 858
 859 Used by insert & replace to update the fuzzy search cache
 860
 861 =cut
 862
 863 sub queue_fuzzyfiles_update {
 864   my $self = shift;
 865
 866   local $SIG{HUP} = 'IGNORE';
 867   local $SIG{INT} = 'IGNORE';
 868   local $SIG{QUIT} = 'IGNORE';
 869   local $SIG{TERM} = 'IGNORE';
 870   local $SIG{TSTP} = 'IGNORE';
 871   local $SIG{PIPE} = 'IGNORE';
 872
 873   my $oldAutoCommit = $FS::UID::AutoCommit;
 874   local $FS::UID::AutoCommit = 0;
 875   my $dbh = dbh;
 876
 877   my $queue = new FS::queue {
 878     'svcnum' => $self->svcnum,
 879     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 880   };
 881   my $error = $queue->insert($self->username);
 882   if ( $error ) {
 883     $dbh->rollback if $oldAutoCommit;
 884     return "queueing job (transaction rolled back): $error";
 885   }
 886
 887   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 888   '';
 889
 890 }
 891
 892
 893 =item suspend
 894
 895 Suspends this account by calling export-specific suspend hooks.  If there is
 896 an error, returns the error, otherwise returns false.
 897
 898 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 899
 900 =cut
 901
 902 sub suspend {
 903   my $self = shift;
 904   return "can't suspend system account" if $self->_check_system;
 905   $self->SUPER::suspend;
 906 }
 907
 908 =item unsuspend
 909
 910 Unsuspends this account by by calling export-specific suspend hooks.  If there
 911 is an error, returns the error, otherwise returns false.
 912
 913 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 914
 915 =cut
 916
 917 sub unsuspend {
 918   my $self = shift;
 919   my %hash = $self->hash;
 920   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 921     $hash{_password} = $1;
 922     my $new = new FS::svc_acct ( \%hash );
 923     my $error = $new->replace($self);
 924     return $error if $error;
 925   }
 926
 927   $self->SUPER::unsuspend;
 928 }
 929
 930 =item cancel
 931
 932 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 933
 934 If the B<auto_unset_catchall> configuration option is set, this method will
 935 automatically remove any references to the canceled service in the catchall
 936 field of svc_domain.  This allows packages that contain both a svc_domain and
 937 its catchall svc_acct to be canceled in one step.
 938
 939 =cut
 940
 941 sub cancel {
 942   # Only one thing to do at this level
 943   my $self = shift;
 944   foreach my $svc_domain (
 945       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 946     if($conf->exists('auto_unset_catchall')) {
 947       my %hash = $svc_domain->hash;
 948       $hash{catchall} = '';
 949       my $new = new FS::svc_domain ( \%hash );
 950       my $error = $new->replace($svc_domain);
 951       return $error if $error;
 952     } else {
 953       return "cannot unprovision svc_acct #".$self->svcnum.
 954           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 955     }
 956   }
 957
 958   $self->SUPER::cancel;
 959 }
 960
 961
 962 =item check
 963
 964 Checks all fields to make sure this is a valid service.  If there is an error,
 965 returns the error, otherwise returns false.  Called by the insert and replace
 966 methods.
 967
 968 Sets any fixed values; see L<FS::part_svc>.
 969
 970 =cut
 971
 972 sub check {
 973   my $self = shift;
 974
 975   my($recref) = $self->hashref;
 976
 977   my $x = $self->setfixed( $self->_fieldhandlers );
 978   return $x unless ref($x);
 979   my $part_svc = $x;
 980
 981   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 982     $self->usergroup(
 983       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 984   }
 985
 986   my $error = $self->ut_numbern('svcnum')
 987               #|| $self->ut_number('domsvc')
 988               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 989               || $self->ut_textn('sec_phrase')
 990               || $self->ut_snumbern('seconds')
 991               || $self->ut_snumbern('upbytes')
 992               || $self->ut_snumbern('downbytes')
 993               || $self->ut_snumbern('totalbytes')
 994   ;
 995   return $error if $error;
 996
 997   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 998   if ( $username_uppercase ) {
 999     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
1000       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1001     $recref->{username} = $1;
1002   } else {
1003     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
1004       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1005     $recref->{username} = $1;
1006   }
1007
1008   if ( $username_letterfirst ) {
1009     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1010   } elsif ( $username_letter ) {
1011     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1012   }
1013   if ( $username_noperiod ) {
1014     $recref->{username} =~ /\./ and return gettext('illegal_username');
1015   }
1016   if ( $username_nounderscore ) {
1017     $recref->{username} =~ /_/ and return gettext('illegal_username');
1018   }
1019   if ( $username_nodash ) {
1020     $recref->{username} =~ /\-/ and return gettext('illegal_username');
1021   }
1022   unless ( $username_ampersand ) {
1023     $recref->{username} =~ /\&/ and return gettext('illegal_username');
1024   }
1025   if ( $password_noampersand ) {
1026     $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1027   }
1028   if ( $password_noexclamation ) {
1029     $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1030   }
1031   unless ( $username_percent ) {
1032     $recref->{username} =~ /\%/ and return gettext('illegal_username');
1033   }
1034
1035   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1036   $recref->{popnum} = $1;
1037   return "Unknown popnum" unless
1038     ! $recref->{popnum} ||
1039     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1040
1041   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1042
1043     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1044     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1045
1046     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1047     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1048     #not all systems use gid=uid
1049     #you can set a fixed gid in part_svc
1050
1051     return "Only root can have uid 0"
1052       if $recref->{uid} == 0
1053          && $recref->{username} !~ /^(root|toor|smtp)$/;
1054
1055     unless ( $recref->{username} eq 'sync' ) {
1056       if ( grep $_ eq $recref->{shell}, @shells ) {
1057         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1058       } else {
1059         return "Illegal shell \`". $self->shell. "\'; ".
1060                $conf->dir. "/shells contains: @shells";
1061       }
1062     } else {
1063       $recref->{shell} = '/bin/sync';
1064     }
1065
1066   } else {
1067     $recref->{gid} ne '' ?
1068       return "Can't have gid without uid" : ( $recref->{gid}='' );
1069     #$recref->{dir} ne '' ?
1070     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1071     $recref->{shell} ne '' ?
1072       return "Can't have shell without uid" : ( $recref->{shell}='' );
1073   }
1074
1075   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1076
1077     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1078       or return "Illegal directory: ". $recref->{dir};
1079     $recref->{dir} = $1;
1080     return "Illegal directory"
1081       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1082     return "Illegal directory"
1083       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1084     unless ( $recref->{dir} ) {
1085       $recref->{dir} = $dir_prefix . '/';
1086       if ( $dirhash > 0 ) {
1087         for my $h ( 1 .. $dirhash ) {
1088           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1089         }
1090       } elsif ( $dirhash < 0 ) {
1091         for my $h ( reverse $dirhash .. -1 ) {
1092           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1093         }
1094       }
1095       $recref->{dir} .= $recref->{username};
1096     ;
1097     }
1098
1099   }
1100
1101   #  $error = $self->ut_textn('finger');
1102   #  return $error if $error;
1103   if ( $self->getfield('finger') eq '' ) {
1104     my $cust_pkg = $self->svcnum
1105       ? $self->cust_svc->cust_pkg
1106       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1107     if ( $cust_pkg ) {
1108       my $cust_main = $cust_pkg->cust_main;
1109       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1110     }
1111   }
1112   $self->getfield('finger') =~
1113     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1114       or return "Illegal finger: ". $self->getfield('finger');
1115   $self->setfield('finger', $1);
1116
1117   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1118   $recref->{quota} = $1;
1119
1120   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1121     if ( $recref->{slipip} eq '' ) {
1122       $recref->{slipip} = '';
1123     } elsif ( $recref->{slipip} eq '0e0' ) {
1124       $recref->{slipip} = '0e0';
1125     } else {
1126       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1127         or return "Illegal slipip: ". $self->slipip;
1128       $recref->{slipip} = $1;
1129     }
1130
1131   }
1132
1133   #arbitrary RADIUS stuff; allow ut_textn for now
1134   foreach ( grep /^radius_/, fields('svc_acct') ) {
1135     $self->ut_textn($_);
1136   }
1137
1138   #generate a password if it is blank
1139   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1140     unless ( $recref->{_password} );
1141
1142   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1143   if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1144     $recref->{_password} = $1.$3;
1145     #uncomment this to encrypt password immediately upon entry, or run
1146     #bin/crypt_pw in cron to give new users a window during which their
1147     #password is available to techs, for faxing, etc.  (also be aware of
1148     #radius issues!)
1149     #$recref->{password} = $1.
1150     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
1151     #;
1152   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1153     $recref->{_password} = $1.$3;
1154   } elsif ( $recref->{_password} eq '*' ) {
1155     $recref->{_password} = '*';
1156   } elsif ( $recref->{_password} eq '!' ) {
1157     $recref->{_password} = '!';
1158   } elsif ( $recref->{_password} eq '!!' ) {
1159     $recref->{_password} = '!!';
1160   } else {
1161     #return "Illegal password";
1162     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1163            FS::Msgcat::_gettext('illegal_password_characters').
1164            ": ". $recref->{_password};
1165   }
1166
1167   $self->SUPER::check;
1168 }
1169
1170 =item _check_system
1171
1172 Internal function to check the username against the list of system usernames
1173 from the I<system_usernames> configuration value.  Returns true if the username
1174 is listed on the system username list.
1175
1176 =cut
1177
1178 sub _check_system {
1179   my $self = shift;
1180   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1181                $conf->config('system_usernames')
1182         );
1183 }
1184
1185 =item _check_duplicate
1186
1187 Internal function to check for duplicates usernames, username@domain pairs and
1188 uids.
1189
1190 If the I<global_unique-username> configuration value is set to B<username> or
1191 B<username@domain>, enforces global username or username@domain uniqueness.
1192
1193 In all cases, check for duplicate uids and usernames or username@domain pairs
1194 per export and with identical I<svcpart> values.
1195
1196 =cut
1197
1198 sub _check_duplicate {
1199   my $self = shift;
1200
1201   my $global_unique = $conf->config('global_unique-username') || 'none';
1202   return '' if $global_unique eq 'disabled';
1203
1204   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1205   if ( driver_name =~ /^Pg/i ) {
1206     dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1207       or die dbh->errstr;
1208   } elsif ( driver_name =~ /^mysql/i ) {
1209     dbh->do("SELECT * FROM duplicate_lock
1210                WHERE lockname = 'svc_acct'
1211                FOR UPDATE"
1212            ) or die dbh->errstr;
1213   } else {
1214     die "unknown database ". driver_name.
1215         "; don't know how to lock for duplicate search";
1216   }
1217   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1218
1219   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1220   unless ( $part_svc ) {
1221     return 'unknown svcpart '. $self->svcpart;
1222   }
1223
1224   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1225                  qsearch( 'svc_acct', { 'username' => $self->username } );
1226   return gettext('username_in_use')
1227     if $global_unique eq 'username' && @dup_user;
1228
1229   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1230                        qsearch( 'svc_acct', { 'username' => $self->username,
1231                                               'domsvc'   => $self->domsvc } );
1232   return gettext('username_in_use')
1233     if $global_unique eq 'username@domain' && @dup_userdomain;
1234
1235   my @dup_uid;
1236   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1237        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1238     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1239                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1240   } else {
1241     @dup_uid = ();
1242   }
1243
1244   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1245     my $exports = FS::part_export::export_info('svc_acct');
1246     my %conflict_user_svcpart;
1247     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1248
1249     foreach my $part_export ( $part_svc->part_export ) {
1250
1251       #this will catch to the same exact export
1252       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1253
1254       #this will catch to exports w/same exporthost+type ???
1255       #my @other_part_export = qsearch('part_export', {
1256       #  'machine'    => $part_export->machine,
1257       #  'exporttype' => $part_export->exporttype,
1258       #} );
1259       #foreach my $other_part_export ( @other_part_export ) {
1260       #  push @svcparts, map { $_->svcpart }
1261       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1262       #}
1263
1264       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1265       #silly kludge to avoid uninitialized value errors
1266       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1267                      ? $exports->{$part_export->exporttype}{'nodomain'}
1268                      : '';
1269       if ( $nodomain =~ /^Y/i ) {
1270         $conflict_user_svcpart{$_} = $part_export->exportnum
1271           foreach @svcparts;
1272       } else {
1273         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1274           foreach @svcparts;
1275       }
1276     }
1277
1278     foreach my $dup_user ( @dup_user ) {
1279       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1280       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1281         return "duplicate username ". $self->username.
1282                ": conflicts with svcnum ". $dup_user->svcnum.
1283                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1284       }
1285     }
1286
1287     foreach my $dup_userdomain ( @dup_userdomain ) {
1288       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1289       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1290         return "duplicate username\@domain ". $self->email.
1291                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1292                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1293       }
1294     }
1295
1296     foreach my $dup_uid ( @dup_uid ) {
1297       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1298       if ( exists($conflict_user_svcpart{$dup_svcpart})
1299            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1300         return "duplicate uid ". $self->uid.
1301                ": conflicts with svcnum ". $dup_uid->svcnum.
1302                " via exportnum ".
1303                ( $conflict_user_svcpart{$dup_svcpart}
1304                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1305       }
1306     }
1307
1308   }
1309
1310   return '';
1311
1312 }
1313
1314 =item radius
1315
1316 Depriciated, use radius_reply instead.
1317
1318 =cut
1319
1320 sub radius {
1321   carp "FS::svc_acct::radius depriciated, use radius_reply";
1322   $_[0]->radius_reply;
1323 }
1324
1325 =item radius_reply
1326
1327 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1328 reply attributes of this record.
1329
1330 Note that this is now the preferred method for reading RADIUS attributes -
1331 accessing the columns directly is discouraged, as the column names are
1332 expected to change in the future.
1333
1334 =cut
1335
1336 sub radius_reply {
1337   my $self = shift;
1338
1339   return %{ $self->{'radius_reply'} }
1340     if exists $self->{'radius_reply'};
1341
1342   my %reply =
1343     map {
1344       /^(radius_(.*))$/;
1345       my($column, $attrib) = ($1, $2);
1346       #$attrib =~ s/_/\-/g;
1347       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1348     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1349
1350   if ( $self->slipip && $self->slipip ne '0e0' ) {
1351     $reply{$radius_ip} = $self->slipip;
1352   }
1353
1354   if ( $self->seconds !~ /^$/ ) {
1355     $reply{'Session-Timeout'} = $self->seconds;
1356   }
1357
1358   %reply;
1359 }
1360
1361 =item radius_check
1362
1363 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1364 check attributes of this record.
1365
1366 Note that this is now the preferred method for reading RADIUS attributes -
1367 accessing the columns directly is discouraged, as the column names are
1368 expected to change in the future.
1369
1370 =cut
1371
1372 sub radius_check {
1373   my $self = shift;
1374
1375   return %{ $self->{'radius_check'} }
1376     if exists $self->{'radius_check'};
1377
1378   my %check =
1379     map {
1380       /^(rc_(.*))$/;
1381       my($column, $attrib) = ($1, $2);
1382       #$attrib =~ s/_/\-/g;
1383       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1384     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1385
1386   my $password = $self->_password;
1387   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1388
1389   my $cust_svc = $self->cust_svc;
1390   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1391     unless $cust_svc;
1392   my $cust_pkg = $cust_svc->cust_pkg;
1393   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1394     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1395   }
1396
1397   %check;
1398
1399 }
1400
1401 =item snapshot
1402
1403 This method instructs the object to "snapshot" or freeze RADIUS check and
1404 reply attributes to the current values.
1405
1406 =cut
1407
1408 #bah, my english is too broken this morning
1409 #Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill.  (This is used by
1410 #the FS::cust_pkg's replace method to trigger the correct export updates when
1411 #package dates change)
1412
1413 sub snapshot {
1414   my $self = shift;
1415
1416   $self->{$_} = { $self->$_() }
1417     foreach qw( radius_reply radius_check );
1418
1419 }
1420
1421 =item forget_snapshot
1422
1423 This methos instructs the object to forget any previously snapshotted
1424 RADIUS check and reply attributes.
1425
1426 =cut
1427
1428 sub forget_snapshot {
1429   my $self = shift;
1430
1431   delete $self->{$_}
1432     foreach qw( radius_reply radius_check );
1433
1434 }
1435
1436 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1437
1438 Returns the domain associated with this account.
1439
1440 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1441 history records.
1442
1443 =cut
1444
1445 sub domain {
1446   my $self = shift;
1447   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1448   my $svc_domain = $self->svc_domain(@_)
1449     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1450   $svc_domain->domain;
1451 }
1452
1453 =item svc_domain
1454
1455 Returns the FS::svc_domain record for this account's domain (see
1456 L<FS::svc_domain>).
1457
1458 =cut
1459
1460 # FS::h_svc_acct has a history-aware svc_domain override
1461
1462 sub svc_domain {
1463   my $self = shift;
1464   $self->{'_domsvc'}
1465     ? $self->{'_domsvc'}
1466     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1467 }
1468
1469 =item cust_svc
1470
1471 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1472
1473 =cut
1474
1475 #inherited from svc_Common
1476
1477 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1478
1479 Returns an email address associated with the account.
1480
1481 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1482 history records.
1483
1484 =cut
1485
1486 sub email {
1487   my $self = shift;
1488   $self->username. '@'. $self->domain(@_);
1489 }
1490
1491 =item acct_snarf
1492
1493 Returns an array of FS::acct_snarf records associated with the account.
1494 If the acct_snarf table does not exist or there are no associated records,
1495 an empty list is returned
1496
1497 =cut
1498
1499 sub acct_snarf {
1500   my $self = shift;
1501   return () unless dbdef->table('acct_snarf');
1502   eval "use FS::acct_snarf;";
1503   die $@ if $@;
1504   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1505 }
1506
1507 =item decrement_upbytes OCTETS
1508
1509 Decrements the I<upbytes> field of this record by the given amount.  If there
1510 is an error, returns the error, otherwise returns false.
1511
1512 =cut
1513
1514 sub decrement_upbytes {
1515   shift->_op_usage('-', 'upbytes', @_);
1516 }
1517
1518 =item increment_upbytes OCTETS
1519
1520 Increments the I<upbytes> field of this record by the given amount.  If there
1521 is an error, returns the error, otherwise returns false.
1522
1523 =cut
1524
1525 sub increment_upbytes {
1526   shift->_op_usage('+', 'upbytes', @_);
1527 }
1528
1529 =item decrement_downbytes OCTETS
1530
1531 Decrements the I<downbytes> field of this record by the given amount.  If there
1532 is an error, returns the error, otherwise returns false.
1533
1534 =cut
1535
1536 sub decrement_downbytes {
1537   shift->_op_usage('-', 'downbytes', @_);
1538 }
1539
1540 =item increment_downbytes OCTETS
1541
1542 Increments the I<downbytes> field of this record by the given amount.  If there
1543 is an error, returns the error, otherwise returns false.
1544
1545 =cut
1546
1547 sub increment_downbytes {
1548   shift->_op_usage('+', 'downbytes', @_);
1549 }
1550
1551 =item decrement_totalbytes OCTETS
1552
1553 Decrements the I<totalbytes> field of this record by the given amount.  If there
1554 is an error, returns the error, otherwise returns false.
1555
1556 =cut
1557
1558 sub decrement_totalbytes {
1559   shift->_op_usage('-', 'totalbytes', @_);
1560 }
1561
1562 =item increment_totalbytes OCTETS
1563
1564 Increments the I<totalbytes> field of this record by the given amount.  If there
1565 is an error, returns the error, otherwise returns false.
1566
1567 =cut
1568
1569 sub increment_totalbytes {
1570   shift->_op_usage('+', 'totalbytes', @_);
1571 }
1572
1573 =item decrement_seconds SECONDS
1574
1575 Decrements the I<seconds> field of this record by the given amount.  If there
1576 is an error, returns the error, otherwise returns false.
1577
1578 =cut
1579
1580 sub decrement_seconds {
1581   shift->_op_usage('-', 'seconds', @_);
1582 }
1583
1584 =item increment_seconds SECONDS
1585
1586 Increments the I<seconds> field of this record by the given amount.  If there
1587 is an error, returns the error, otherwise returns false.
1588
1589 =cut
1590
1591 sub increment_seconds {
1592   shift->_op_usage('+', 'seconds', @_);
1593 }
1594
1595
1596 my %op2action = (
1597   '-' => 'suspend',
1598   '+' => 'unsuspend',
1599 );
1600 my %op2condition = (
1601   '-' => sub { my($self, $column, $amount) = @_;
1602                $self->$column - $amount <= 0;
1603              },
1604   '+' => sub { my($self, $column, $amount) = @_;
1605                $self->$column + $amount > 0;
1606              },
1607 );
1608 my %op2warncondition = (
1609   '-' => sub { my($self, $column, $amount) = @_;
1610                my $threshold = $column . '_threshold';
1611                $self->$column - $amount <= $self->$threshold + 0;
1612              },
1613   '+' => sub { my($self, $column, $amount) = @_;
1614                $self->$column + $amount > 0;
1615              },
1616 );
1617
1618 sub _op_usage {
1619   my( $self, $op, $column, $amount ) = @_;
1620
1621   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1622        ' ('. $self->email. "): $op $amount\n"
1623     if $DEBUG;
1624
1625   return '' unless $amount;
1626
1627   local $SIG{HUP} = 'IGNORE';
1628   local $SIG{INT} = 'IGNORE';
1629   local $SIG{QUIT} = 'IGNORE';
1630   local $SIG{TERM} = 'IGNORE';
1631   local $SIG{TSTP} = 'IGNORE';
1632   local $SIG{PIPE} = 'IGNORE';
1633
1634   my $oldAutoCommit = $FS::UID::AutoCommit;
1635   local $FS::UID::AutoCommit = 0;
1636   my $dbh = dbh;
1637
1638   my $sql = "UPDATE svc_acct SET $column = ".
1639             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1640             " $op ? WHERE svcnum = ?";
1641   warn "$me $sql\n"
1642     if $DEBUG;
1643
1644   my $sth = $dbh->prepare( $sql )
1645     or die "Error preparing $sql: ". $dbh->errstr;
1646   my $rv = $sth->execute($amount, $self->svcnum);
1647   die "Error executing $sql: ". $sth->errstr
1648     unless defined($rv);
1649   die "Can't update $column for svcnum". $self->svcnum
1650     if $rv == 0;
1651
1652   my $action = $op2action{$op};
1653
1654   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1655         ( $action eq 'suspend'   && !$self->overlimit
1656        || $action eq 'unsuspend' &&  $self->overlimit )
1657      ) {
1658     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1659       if ($part_export->option('overlimit_groups')) {
1660         my ($new,$old);
1661         my $other = new FS::svc_acct $self->hashref;
1662         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1663                        ($self, $part_export->option('overlimit_groups'));
1664         $other->usergroup( $groups );
1665         if ($action eq 'suspend'){
1666           $new = $other; $old = $self;
1667         }else{
1668           $new = $self; $old = $other;
1669         }
1670         my $error = $part_export->export_replace($new, $old);
1671         $error ||= $self->overlimit($action);
1672         if ( $error ) {
1673           $dbh->rollback if $oldAutoCommit;
1674           return "Error replacing radius groups in export, ${op}: $error";
1675         }
1676       }
1677     }
1678   }
1679
1680   if ( $conf->exists("svc_acct-usage_$action")
1681        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1682     #my $error = $self->$action();
1683     my $error = $self->cust_svc->cust_pkg->$action();
1684     # $error ||= $self->overlimit($action);
1685     if ( $error ) {
1686       $dbh->rollback if $oldAutoCommit;
1687       return "Error ${action}ing: $error";
1688     }
1689   }
1690
1691   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1692     my $wqueue = new FS::queue {
1693       'svcnum' => $self->svcnum,
1694       'job'    => 'FS::svc_acct::reached_threshold',
1695     };
1696
1697     my $to = '';
1698     if ($op eq '-'){
1699       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1700     }
1701
1702     # x_threshold race
1703     my $error = $wqueue->insert(
1704       'svcnum' => $self->svcnum,
1705       'op'     => $op,
1706       'column' => $column,
1707       'to'     => $to,
1708     );
1709     if ( $error ) {
1710       $dbh->rollback if $oldAutoCommit;
1711       return "Error queuing threshold activity: $error";
1712     }
1713   }
1714
1715   warn "$me update successful; committing\n"
1716     if $DEBUG;
1717   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1718   '';
1719
1720 }
1721
1722 sub set_usage {
1723   my( $self, $valueref ) = @_;
1724
1725   warn "$me set_usage called for svcnum ". $self->svcnum.
1726        ' ('. $self->email. "): ".
1727        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1728     if $DEBUG;
1729
1730   local $SIG{HUP} = 'IGNORE';
1731   local $SIG{INT} = 'IGNORE';
1732   local $SIG{QUIT} = 'IGNORE';
1733   local $SIG{TERM} = 'IGNORE';
1734   local $SIG{TSTP} = 'IGNORE';
1735   local $SIG{PIPE} = 'IGNORE';
1736
1737   local $FS::svc_Common::noexport_hack = 1;
1738   my $oldAutoCommit = $FS::UID::AutoCommit;
1739   local $FS::UID::AutoCommit = 0;
1740   my $dbh = dbh;
1741
1742   my $reset = 0;
1743   my %handyhash = ();
1744   foreach my $field (keys %$valueref){
1745     $reset = 1 if $valueref->{$field};
1746     $self->setfield($field, $valueref->{$field});
1747     $self->setfield( $field.'_threshold',
1748                      int($self->getfield($field)
1749                          * ( $conf->exists('svc_acct-usage_threshold')
1750                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1751                              : 0.20
1752                            )
1753                        )
1754                      );
1755     $handyhash{$field} = $self->getfield($field);
1756     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1757   }
1758   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1759   #die $error if $error;         #services not explicity changed via the UI
1760
1761   my $sql = "UPDATE svc_acct SET " .
1762     join (',', map { "$_ =  ?" } (keys %handyhash) ).
1763     " WHERE svcnum = ?";
1764
1765   warn "$me $sql\n"
1766     if $DEBUG;
1767
1768   if (scalar(keys %handyhash)) {
1769     my $sth = $dbh->prepare( $sql )
1770       or die "Error preparing $sql: ". $dbh->errstr;
1771     my $rv = $sth->execute((values %handyhash), $self->svcnum);
1772     die "Error executing $sql: ". $sth->errstr
1773       unless defined($rv);
1774     die "Can't update usage for svcnum ". $self->svcnum
1775       if $rv == 0;
1776   }
1777
1778   if ( $reset ) {
1779     my $error;
1780
1781     if ($self->overlimit) {
1782       $error = $self->overlimit('unsuspend');
1783       foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1784         if ($part_export->option('overlimit_groups')) {
1785           my $old = new FS::svc_acct $self->hashref;
1786           my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1787                          ($self, $part_export->option('overlimit_groups'));
1788           $old->usergroup( $groups );
1789           $error ||= $part_export->export_replace($self, $old);
1790         }
1791       }
1792     }
1793
1794     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1795       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1796     }
1797     if ( $error ) {
1798       $dbh->rollback if $oldAutoCommit;
1799       return "Error unsuspending: $error";
1800     }
1801   }
1802
1803   warn "$me update successful; committing\n"
1804     if $DEBUG;
1805   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1806   '';
1807
1808 }
1809
1810
1811 =item recharge HASHREF
1812
1813   Increments usage columns by the amount specified in HASHREF as
1814   column=>amount pairs.
1815
1816 =cut
1817
1818 sub recharge {
1819   my ($self, $vhash) = @_;
1820
1821   if ( $DEBUG ) {
1822     warn "[$me] recharge called on $self: ". Dumper($self).
1823          "\nwith vhash: ". Dumper($vhash);
1824   }
1825
1826   my $oldAutoCommit = $FS::UID::AutoCommit;
1827   local $FS::UID::AutoCommit = 0;
1828   my $dbh = dbh;
1829   my $error = '';
1830
1831   foreach my $column (keys %$vhash){
1832     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1833   }
1834
1835   if ( $error ) {
1836     $dbh->rollback if $oldAutoCommit;
1837   }else{
1838     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1839   }
1840   return $error;
1841 }
1842
1843 =item is_rechargeable
1844
1845 Returns true if this svc_account can be "recharged" and false otherwise.
1846
1847 =cut
1848
1849 sub is_rechargable {
1850   my $self = shift;
1851   $self->seconds ne ''
1852     || $self->upbytes ne ''
1853     || $self->downbytes ne ''
1854     || $self->totalbytes ne '';
1855 }
1856
1857 =item seconds_since TIMESTAMP
1858
1859 Returns the number of seconds this account has been online since TIMESTAMP,
1860 according to the session monitor (see L<FS::Session>).
1861
1862 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1863 L<Time::Local> and L<Date::Parse> for conversion functions.
1864
1865 =cut
1866
1867 #note: POD here, implementation in FS::cust_svc
1868 sub seconds_since {
1869   my $self = shift;
1870   $self->cust_svc->seconds_since(@_);
1871 }
1872
1873 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1874
1875 Returns the numbers of seconds this account has been online between
1876 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1877 external SQL radacct table, specified via sqlradius export.  Sessions which
1878 started in the specified range but are still open are counted from session
1879 start to the end of the range (unless they are over 1 day old, in which case
1880 they are presumed missing their stop record and not counted).  Also, sessions
1881 which end in the range but started earlier are counted from the start of the
1882 range to session end.  Finally, sessions which start before the range but end
1883 after are counted for the entire range.
1884
1885 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1886 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1887 functions.
1888
1889 =cut
1890
1891 #note: POD here, implementation in FS::cust_svc
1892 sub seconds_since_sqlradacct {
1893   my $self = shift;
1894   $self->cust_svc->seconds_since_sqlradacct(@_);
1895 }
1896
1897 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1898
1899 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1900 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1901 TIMESTAMP_END (exclusive).
1902
1903 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1904 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1905 functions.
1906
1907 =cut
1908
1909 #note: POD here, implementation in FS::cust_svc
1910 sub attribute_since_sqlradacct {
1911   my $self = shift;
1912   $self->cust_svc->attribute_since_sqlradacct(@_);
1913 }
1914
1915 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1916
1917 Returns an array of hash references of this customers login history for the
1918 given time range.  (document this better)
1919
1920 =cut
1921
1922 sub get_session_history {
1923   my $self = shift;
1924   $self->cust_svc->get_session_history(@_);
1925 }
1926
1927 =item last_login_text
1928
1929 Returns text describing the time of last login.
1930
1931 =cut
1932
1933 sub last_login_text {
1934   my $self = shift;
1935   $self->last_login ? ctime($self->last_login) : 'unknown';
1936 }
1937
1938 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1939
1940 =cut
1941
1942 sub get_cdrs {
1943   my($self, $start, $end, %opt ) = @_;
1944
1945   my $did = $self->username; #yup
1946
1947   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1948
1949   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1950
1951   #SELECT $for_update * FROM cdr
1952   #  WHERE calldate >= $start #need a conversion
1953   #    AND calldate <  $end   #ditto
1954   #    AND (    charged_party = "$did"
1955   #          OR charged_party = "$prefix$did" #if length($prefix);
1956   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1957   #               AND
1958   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1959   #             )
1960   #        )
1961   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1962
1963   my $charged_or_src;
1964   if ( length($prefix) ) {
1965     $charged_or_src =
1966       " AND (    charged_party = '$did'
1967               OR charged_party = '$prefix$did'
1968               OR ( ( charged_party IS NULL OR charged_party = '' )
1969                    AND
1970                    ( src = '$did' OR src = '$prefix$did' )
1971                  )
1972             )
1973       ";
1974   } else {
1975     $charged_or_src =
1976       " AND (    charged_party = '$did'
1977               OR ( ( charged_party IS NULL OR charged_party = '' )
1978                    AND
1979                    src = '$did'
1980                  )
1981             )
1982       ";
1983
1984   }
1985
1986   qsearch(
1987     'select'    => "$for_update *",
1988     'table'     => 'cdr',
1989     'hashref'   => {
1990                      #( freesidestatus IS NULL OR freesidestatus = '' )
1991                      'freesidestatus' => '',
1992                    },
1993     'extra_sql' => $charged_or_src,
1994
1995   );
1996
1997 }
1998
1999 =item radius_groups
2000
2001 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2002
2003 =cut
2004
2005 sub radius_groups {
2006   my $self = shift;
2007   if ( $self->usergroup ) {
2008     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2009       unless ref($self->usergroup) eq 'ARRAY';
2010     #when provisioning records, export callback runs in svc_Common.pm before
2011     #radius_usergroup records can be inserted...
2012     @{$self->usergroup};
2013   } else {
2014     map { $_->groupname }
2015       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2016   }
2017 }
2018
2019 =item clone_suspended
2020
2021 Constructor used by FS::part_export::_export_suspend fallback.  Document
2022 better.
2023
2024 =cut
2025
2026 sub clone_suspended {
2027   my $self = shift;
2028   my %hash = $self->hash;
2029   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2030   new FS::svc_acct \%hash;
2031 }
2032
2033 =item clone_kludge_unsuspend
2034
2035 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2036 better.
2037
2038 =cut
2039
2040 sub clone_kludge_unsuspend {
2041   my $self = shift;
2042   my %hash = $self->hash;
2043   $hash{_password} = '';
2044   new FS::svc_acct \%hash;
2045 }
2046
2047 =item check_password
2048
2049 Checks the supplied password against the (possibly encrypted) password in the
2050 database.  Returns true for a successful authentication, false for no match.
2051
2052 Currently supported encryptions are: classic DES crypt() and MD5
2053
2054 =cut
2055
2056 sub check_password {
2057   my($self, $check_password) = @_;
2058
2059   #remove old-style SUSPENDED kludge, they should be allowed to login to
2060   #self-service and pay up
2061   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2062
2063   #eventually should check a "password-encoding" field
2064   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2065     return 0;
2066   } elsif ( length($password) < 13 ) { #plaintext
2067     $check_password eq $password;
2068   } elsif ( length($password) == 13 ) { #traditional DES crypt
2069     crypt($check_password, $password) eq $password;
2070   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2071     unix_md5_crypt($check_password, $password) eq $password;
2072   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2073     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
2074          $self->svcnum. "\n";
2075     0;
2076   } else {
2077     warn "Can't check password: Unrecognized encryption for svcnum ".
2078          $self->svcnum. "\n";
2079     0;
2080   }
2081
2082 }
2083
2084 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2085
2086 Returns an encrypted password, either by passing through an encrypted password
2087 in the database or by encrypting a plaintext password from the database.
2088
2089 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2090 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2091 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2092 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2093 encryption type is only used if the password is not already encrypted in the
2094 database.
2095
2096 =cut
2097
2098 sub crypt_password {
2099   my $self = shift;
2100   #eventually should check a "password-encoding" field
2101   if ( length($self->_password) == 13
2102        || $self->_password =~ /^\$(1|2a?)\$/
2103        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2104      )
2105   {
2106     $self->_password;
2107   } else {
2108     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2109     if ( $encryption eq 'crypt' ) {
2110       crypt(
2111         $self->_password,
2112         $saltset[int(rand(64))].$saltset[int(rand(64))]
2113       );
2114     } elsif ( $encryption eq 'md5' ) {
2115       unix_md5_crypt( $self->_password );
2116     } elsif ( $encryption eq 'blowfish' ) {
2117       croak "unknown encryption method $encryption";
2118     } else {
2119       croak "unknown encryption method $encryption";
2120     }
2121   }
2122 }
2123
2124 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2125
2126 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2127 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
2128 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
2129
2130 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2131 to work the same as the B</crypt_password> method.
2132
2133 =cut
2134
2135 sub ldap_password {
2136   my $self = shift;
2137   #eventually should check a "password-encoding" field
2138   if ( length($self->_password) == 13 ) { #crypt
2139     return '{CRYPT}'. $self->_password;
2140   } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2141     return '{MD5}'. $1;
2142   } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2143     warn "Blowfish encryption not supported in this context, svcnum ".
2144          $self->svcnum. "\n";
2145     return '{CRYPT}*'; #unsupported, should not auth
2146   } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2147     return '{SSHA}'. $1;
2148   } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2149     return '{NS-MTA-MD5}'. $1;
2150   } else { #plaintext
2151     return '{PLAIN}'. $self->_password;
2152     #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2153     #if ( $encryption eq 'crypt' ) {
2154     #  return '{CRYPT}'. crypt(
2155     #    $self->_password,
2156     #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2157     #  );
2158     #} elsif ( $encryption eq 'md5' ) {
2159     #  unix_md5_crypt( $self->_password );
2160     #} elsif ( $encryption eq 'blowfish' ) {
2161     #  croak "unknown encryption method $encryption";
2162     #} else {
2163     #  croak "unknown encryption method $encryption";
2164     #}
2165   }
2166 }
2167
2168 =item domain_slash_username
2169
2170 Returns $domain/$username/
2171
2172 =cut
2173
2174 sub domain_slash_username {
2175   my $self = shift;
2176   $self->domain. '/'. $self->username. '/';
2177 }
2178
2179 =item virtual_maildir
2180
2181 Returns $domain/maildirs/$username/
2182
2183 =cut
2184
2185 sub virtual_maildir {
2186   my $self = shift;
2187   $self->domain. '/maildirs/'. $self->username. '/';
2188 }
2189
2190 =back
2191
2192 =head1 SUBROUTINES
2193
2194 =over 4
2195
2196 =item send_email
2197
2198 This is the FS::svc_acct job-queue-able version.  It still uses
2199 FS::Misc::send_email under-the-hood.
2200
2201 =cut
2202
2203 sub send_email {
2204   my %opt = @_;
2205
2206   eval "use FS::Misc qw(send_email)";
2207   die $@ if $@;
2208
2209   $opt{mimetype} ||= 'text/plain';
2210   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2211
2212   my $error = send_email(
2213     'from'         => $opt{from},
2214     'to'           => $opt{to},
2215     'subject'      => $opt{subject},
2216     'content-type' => $opt{mimetype},
2217     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2218   );
2219   die $error if $error;
2220 }
2221
2222 =item check_and_rebuild_fuzzyfiles
2223
2224 =cut
2225
2226 sub check_and_rebuild_fuzzyfiles {
2227   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2228   -e "$dir/svc_acct.username"
2229     or &rebuild_fuzzyfiles;
2230 }
2231
2232 =item rebuild_fuzzyfiles
2233
2234 =cut
2235
2236 sub rebuild_fuzzyfiles {
2237
2238   use Fcntl qw(:flock);
2239
2240   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2241
2242   #username
2243
2244   open(USERNAMELOCK,">>$dir/svc_acct.username")
2245     or die "can't open $dir/svc_acct.username: $!";
2246   flock(USERNAMELOCK,LOCK_EX)
2247     or die "can't lock $dir/svc_acct.username: $!";
2248
2249   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2250
2251   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2252     or die "can't open $dir/svc_acct.username.tmp: $!";
2253   print USERNAMECACHE join("\n", @all_username), "\n";
2254   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2255
2256   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2257   close USERNAMELOCK;
2258
2259 }
2260
2261 =item all_username
2262
2263 =cut
2264
2265 sub all_username {
2266   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2267   open(USERNAMECACHE,"<$dir/svc_acct.username")
2268     or die "can't open $dir/svc_acct.username: $!";
2269   my @array = map { chomp; $_; } <USERNAMECACHE>;
2270   close USERNAMECACHE;
2271   \@array;
2272 }
2273
2274 =item append_fuzzyfiles USERNAME
2275
2276 =cut
2277
2278 sub append_fuzzyfiles {
2279   my $username = shift;
2280
2281   &check_and_rebuild_fuzzyfiles;
2282
2283   use Fcntl qw(:flock);
2284
2285   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2286
2287   open(USERNAME,">>$dir/svc_acct.username")
2288     or die "can't open $dir/svc_acct.username: $!";
2289   flock(USERNAME,LOCK_EX)
2290     or die "can't lock $dir/svc_acct.username: $!";
2291
2292   print USERNAME "$username\n";
2293
2294   flock(USERNAME,LOCK_UN)
2295     or die "can't unlock $dir/svc_acct.username: $!";
2296   close USERNAME;
2297
2298   1;
2299 }
2300
2301
2302
2303 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2304
2305 =cut
2306
2307 sub radius_usergroup_selector {
2308   my $sel_groups = shift;
2309   my %sel_groups = map { $_=>1 } @$sel_groups;
2310
2311   my $selectname = shift || 'radius_usergroup';
2312
2313   my $dbh = dbh;
2314   my $sth = $dbh->prepare(
2315     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2316   ) or die $dbh->errstr;
2317   $sth->execute() or die $sth->errstr;
2318   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2319
2320   my $html = <<END;
2321     <SCRIPT>
2322     function ${selectname}_doadd(object) {
2323       var myvalue = object.${selectname}_add.value;
2324       var optionName = new Option(myvalue,myvalue,false,true);
2325       var length = object.$selectname.length;
2326       object.$selectname.options[length] = optionName;
2327       object.${selectname}_add.value = "";
2328     }
2329     </SCRIPT>
2330     <SELECT MULTIPLE NAME="$selectname">
2331 END
2332
2333   foreach my $group ( @all_groups ) {
2334     $html .= qq(<OPTION VALUE="$group");
2335     if ( $sel_groups{$group} ) {
2336       $html .= ' SELECTED';
2337       $sel_groups{$group} = 0;
2338     }
2339     $html .= ">$group</OPTION>\n";
2340   }
2341   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2342     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2343   };
2344   $html .= '</SELECT>';
2345
2346   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2347            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2348
2349   $html;
2350 }
2351
2352 =item reached_threshold
2353
2354 Performs some activities when svc_acct thresholds (such as number of seconds
2355 remaining) are reached.
2356
2357 =cut
2358
2359 sub reached_threshold {
2360   my %opt = @_;
2361
2362   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2363   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2364
2365   if ( $opt{'op'} eq '+' ){
2366     $svc_acct->setfield( $opt{'column'}.'_threshold',
2367                          int($svc_acct->getfield($opt{'column'})
2368                              * ( $conf->exists('svc_acct-usage_threshold')
2369                                  ? $conf->config('svc_acct-usage_threshold')/100
2370                                  : 0.80
2371                                )
2372                          )
2373                        );
2374     my $error = $svc_acct->replace;
2375     die $error if $error;
2376   }elsif ( $opt{'op'} eq '-' ){
2377
2378     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2379     return '' if ($threshold eq '' );
2380
2381     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2382     my $error = $svc_acct->replace;
2383     die $error if $error; # email next time, i guess
2384
2385     if ( $warning_template ) {
2386       eval "use FS::Misc qw(send_email)";
2387       die $@ if $@;
2388
2389       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2390       my $cust_main = $cust_pkg->cust_main;
2391
2392       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2393                                $cust_main->invoicing_list,
2394                                ($opt{'to'} ? $opt{'to'} : ())
2395                    );
2396
2397       my $mimetype = $warning_mimetype;
2398       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2399
2400       my $body       =  $warning_template->fill_in( HASH => {
2401                         'custnum'   => $cust_main->custnum,
2402                         'username'  => $svc_acct->username,
2403                         'password'  => $svc_acct->_password,
2404                         'first'     => $cust_main->first,
2405                         'last'      => $cust_main->getfield('last'),
2406                         'pkg'       => $cust_pkg->part_pkg->pkg,
2407                         'column'    => $opt{'column'},
2408                         'amount'    => $opt{'column'} =~/bytes/
2409                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2410                                        : $svc_acct->getfield($opt{'column'}),
2411                         'threshold' => $opt{'column'} =~/bytes/
2412                                        ? FS::UI::bytecount::display_bytecount($threshold)
2413                                        : $threshold,
2414                       } );
2415
2416
2417       my $error = send_email(
2418         'from'         => $warning_from,
2419         'to'           => $to,
2420         'subject'      => $warning_subject,
2421         'content-type' => $mimetype,
2422         'body'         => [ map "$_\n", split("\n", $body) ],
2423       );
2424       die $error if $error;
2425     }
2426   }else{
2427     die "unknown op: " . $opt{'op'};
2428   }
2429 }
2430
2431 =back
2432
2433 =head1 BUGS
2434
2435 The $recref stuff in sub check should be cleaned up.
2436
2437 The suspend, unsuspend and cancel methods update the database, but not the
2438 current object.  This is probably a bug as it's unexpected and
2439 counterintuitive.
2440
2441 radius_usergroup_selector?  putting web ui components in here?  they should
2442 probably live somewhere else...
2443
2444 insertion of RADIUS group stuff in insert could be done with child_objects now
2445 (would probably clean up export of them too)
2446
2447 =head1 SEE ALSO
2448
2449 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2450 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2451 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2452 L<freeside-queued>), L<FS::svc_acct_pop>,
2453 schema.html from the base documentation.
2454
2455 =cut
2456
2457 =item domain_select_hash %OPTIONS
2458
2459 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
2460 may at present purchase.
2461
2462 Currently available options are: I<pkgnum> I<svcpart>
2463
2464 =cut
2465
2466 sub domain_select_hash {
2467   my ($self, %options) = @_;
2468   my %domains = ();
2469   my $part_svc;
2470   my $cust_pkg;
2471
2472   if (ref($self)) {
2473     $part_svc = $self->part_svc;
2474     $cust_pkg = $self->cust_svc->cust_pkg
2475       if $self->cust_svc;
2476   }
2477
2478   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2479     if $options{'svcpart'};
2480
2481   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2482     if $options{'pkgnum'};
2483
2484   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2485                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2486     %domains = map { $_->svcnum => $_->domain }
2487                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2488                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2489   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2490     %domains = map { $_->svcnum => $_->domain }
2491                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2492                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2493                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2494   }else{
2495     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2496   }
2497
2498   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2499     my $svc_domain = qsearchs('svc_domain',
2500       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2501     if ( $svc_domain ) {
2502       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
2503     }else{
2504       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2505            $part_svc->part_svc_column('domsvc')->columnvalue;
2506
2507     }
2508   }
2509
2510   (%domains);
2511 }
2512
2513 1;
2514