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
  10              $password_noampersand $password_noexclamation
  11              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
  12              $smtpmachine
  13              $radius_password $radius_ip
  14              $dirhash
  15              @saltset @pw_set );
  16 use Carp;
  17 use Fcntl qw(:flock);
  18 use Crypt::PasswdMD5 1.2;
  19 use FS::UID qw( datasrc );
  20 use FS::Conf;
  21 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  22 use FS::svc_Common;
  23 use FS::cust_svc;
  24 use FS::part_svc;
  25 use FS::svc_acct_pop;
  26 use FS::cust_main_invoice;
  27 use FS::svc_domain;
  28 use FS::raddb;
  29 use FS::queue;
  30 use FS::radius_usergroup;
  31 use FS::export_svc;
  32 use FS::part_export;
  33 use FS::Msgcat qw(gettext);
  34 use FS::svc_forward;
  35 use FS::svc_www;
  36
  37 @ISA = qw( FS::svc_Common );
  38
  39 $DEBUG = 0;
  40 $me = '[FS::svc_acct]';
  41
  42 #ask FS::UID to run this stuff for us later
  43 $FS::UID::callback{'FS::svc_acct'} = sub {
  44   $conf = new FS::Conf;
  45   $dir_prefix = $conf->config('home');
  46   @shells = $conf->config('shells');
  47   $usernamemin = $conf->config('usernamemin') || 2;
  48   $usernamemax = $conf->config('usernamemax');
  49   $passwordmin = $conf->config('passwordmin') || 6;
  50   $passwordmax = $conf->config('passwordmax') || 8;
  51   $username_letter = $conf->exists('username-letter');
  52   $username_letterfirst = $conf->exists('username-letterfirst');
  53   $username_noperiod = $conf->exists('username-noperiod');
  54   $username_nounderscore = $conf->exists('username-nounderscore');
  55   $username_nodash = $conf->exists('username-nodash');
  56   $username_uppercase = $conf->exists('username-uppercase');
  57   $username_ampersand = $conf->exists('username-ampersand');
  58   $password_noampersand = $conf->exists('password-noexclamation');
  59   $password_noexclamation = $conf->exists('password-noexclamation');
  60   $dirhash = $conf->config('dirhash') || 0;
  61   if ( $conf->exists('welcome_email') ) {
  62     $welcome_template = new Text::Template (
  63       TYPE   => 'ARRAY',
  64       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  65     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  66     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  67     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  68     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  69   } else {
  70     $welcome_template = '';
  71     $welcome_from = '';
  72     $welcome_subject = '';
  73     $welcome_mimetype = '';
  74   }
  75   $smtpmachine = $conf->config('smtpmachine');
  76   $radius_password = $conf->config('radius-password') || 'Password';
  77   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  78 };
  79
  80 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  81 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  82
  83 sub _cache {
  84   my $self = shift;
  85   my ( $hashref, $cache ) = @_;
  86   if ( $hashref->{'svc_acct_svcnum'} ) {
  87     $self->{'_domsvc'} = FS::svc_domain->new( {
  88       'svcnum'   => $hashref->{'domsvc'},
  89       'domain'   => $hashref->{'svc_acct_domain'},
  90       'catchall' => $hashref->{'svc_acct_catchall'},
  91     } );
  92   }
  93 }
  94
  95 =head1 NAME
  96
  97 FS::svc_acct - Object methods for svc_acct records
  98
  99 =head1 SYNOPSIS
 100
 101   use FS::svc_acct;
 102
 103   $record = new FS::svc_acct \%hash;
 104   $record = new FS::svc_acct { 'column' => 'value' };
 105
 106   $error = $record->insert;
 107
 108   $error = $new_record->replace($old_record);
 109
 110   $error = $record->delete;
 111
 112   $error = $record->check;
 113
 114   $error = $record->suspend;
 115
 116   $error = $record->unsuspend;
 117
 118   $error = $record->cancel;
 119
 120   %hash = $record->radius;
 121
 122   %hash = $record->radius_reply;
 123
 124   %hash = $record->radius_check;
 125
 126   $domain = $record->domain;
 127
 128   $svc_domain = $record->svc_domain;
 129
 130   $email = $record->email;
 131
 132   $seconds_since = $record->seconds_since($timestamp);
 133
 134 =head1 DESCRIPTION
 135
 136 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 137 FS::svc_Common.  The following fields are currently supported:
 138
 139 =over 4
 140
 141 =item svcnum - primary key (assigned automatcially for new accounts)
 142
 143 =item username
 144
 145 =item _password - generated if blank
 146
 147 =item sec_phrase - security phrase
 148
 149 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 150
 151 =item uid
 152
 153 =item gid
 154
 155 =item finger - GECOS
 156
 157 =item dir - set automatically if blank (and uid is not)
 158
 159 =item shell
 160
 161 =item quota - (unimplementd)
 162
 163 =item slipip - IP address
 164
 165 =item seconds -
 166
 167 =item domsvc - svcnum from svc_domain
 168
 169 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 170
 171 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 172
 173 =back
 174
 175 =head1 METHODS
 176
 177 =over 4
 178
 179 =item new HASHREF
 180
 181 Creates a new account.  To add the account to the database, see L<"insert">.
 182
 183 =cut
 184
 185 sub table { 'svc_acct'; }
 186
 187 =item insert [ , OPTION => VALUE ... ]
 188
 189 Adds this account to the database.  If there is an error, returns the error,
 190 otherwise returns false.
 191
 192 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 193 defined.  An FS::cust_svc record will be created and inserted.
 194
 195 The additional field I<usergroup> can optionally be defined; if so it should
 196 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 197
 198 The additional field I<child_objects> can optionally be defined; if so it
 199 should contain an arrayref of FS::tablename objects.  They will have their
 200 svcnum fields set and will be inserted after this record, but before any
 201 exports are run.  Each element of the array can also optionally be a
 202 two-element array reference containing the child object and the name of an
 203 alternate field to be filled in with the newly-inserted svcnum, for example
 204 C<[ $svc_forward, 'srcsvc' ]>
 205
 206 Currently available options are: I<depend_jobnum>
 207
 208 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 209 jobnums), all provisioning jobs will have a dependancy on the supplied
 210 jobnum(s) (they will not run until the specific job(s) complete(s)).
 211
 212 (TODOC: L<FS::queue> and L<freeside-queued>)
 213
 214 (TODOC: new exports!)
 215
 216 =cut
 217
 218 sub insert {
 219   my $self = shift;
 220   my %options = @_;
 221   my $error;
 222
 223   local $SIG{HUP} = 'IGNORE';
 224   local $SIG{INT} = 'IGNORE';
 225   local $SIG{QUIT} = 'IGNORE';
 226   local $SIG{TERM} = 'IGNORE';
 227   local $SIG{TSTP} = 'IGNORE';
 228   local $SIG{PIPE} = 'IGNORE';
 229
 230   my $oldAutoCommit = $FS::UID::AutoCommit;
 231   local $FS::UID::AutoCommit = 0;
 232   my $dbh = dbh;
 233
 234   $error = $self->check;
 235   return $error if $error;
 236
 237   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 238     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 239     unless ( $cust_svc ) {
 240       $dbh->rollback if $oldAutoCommit;
 241       return "no cust_svc record found for svcnum ". $self->svcnum;
 242     }
 243     $self->pkgnum($cust_svc->pkgnum);
 244     $self->svcpart($cust_svc->svcpart);
 245   }
 246
 247   $error = $self->_check_duplicate;
 248   if ( $error ) {
 249     $dbh->rollback if $oldAutoCommit;
 250     return $error;
 251   }
 252
 253   my @jobnums;
 254   $error = $self->SUPER::insert(
 255     'jobnums'       => \@jobnums,
 256     'child_objects' => $self->child_objects,
 257     %options,
 258   );
 259   if ( $error ) {
 260     $dbh->rollback if $oldAutoCommit;
 261     return $error;
 262   }
 263
 264   if ( $self->usergroup ) {
 265     foreach my $groupname ( @{$self->usergroup} ) {
 266       my $radius_usergroup = new FS::radius_usergroup ( {
 267         svcnum    => $self->svcnum,
 268         groupname => $groupname,
 269       } );
 270       my $error = $radius_usergroup->insert;
 271       if ( $error ) {
 272         $dbh->rollback if $oldAutoCommit;
 273         return $error;
 274       }
 275     }
 276   }
 277
 278   unless ( $skip_fuzzyfiles ) {
 279     $error = $self->queue_fuzzyfiles_update;
 280     if ( $error ) {
 281       $dbh->rollback if $oldAutoCommit;
 282       return "updating fuzzy search cache: $error";
 283     }
 284   }
 285
 286   my $cust_pkg = $self->cust_svc->cust_pkg;
 287
 288   if ( $cust_pkg ) {
 289     my $cust_main = $cust_pkg->cust_main;
 290
 291     if ( $conf->exists('emailinvoiceauto') ) {
 292       my @invoicing_list = $cust_main->invoicing_list;
 293       push @invoicing_list, $self->email;
 294       $cust_main->invoicing_list(\@invoicing_list);
 295     }
 296
 297     #welcome email
 298     my $to = '';
 299     if ( $welcome_template && $cust_pkg ) {
 300       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 301       if ( $to ) {
 302         my $wqueue = new FS::queue {
 303           'svcnum' => $self->svcnum,
 304           'job'    => 'FS::svc_acct::send_email'
 305         };
 306         my $error = $wqueue->insert(
 307           'to'       => $to,
 308           'from'     => $welcome_from,
 309           'subject'  => $welcome_subject,
 310           'mimetype' => $welcome_mimetype,
 311           'body'     => $welcome_template->fill_in( HASH => {
 312                           'custnum'  => $self->custnum,
 313                           'username' => $self->username,
 314                           'password' => $self->_password,
 315                           'first'    => $cust_main->first,
 316                           'last'     => $cust_main->getfield('last'),
 317                           'pkg'      => $cust_pkg->part_pkg->pkg,
 318                         } ),
 319         );
 320         if ( $error ) {
 321           $dbh->rollback if $oldAutoCommit;
 322           return "error queuing welcome email: $error";
 323         }
 324
 325         if ( $options{'depend_jobnum'} ) {
 326           warn "$me depend_jobnum found; adding to welcome email dependancies"
 327             if $DEBUG;
 328           if ( ref($options{'depend_jobnum'}) ) {
 329             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 330                  "to welcome email dependancies"
 331               if $DEBUG;
 332             push @jobnums, @{ $options{'depend_jobnum'} };
 333           } else {
 334             warn "$me adding job $options{'depend_jobnum'} ".
 335                  "to welcome email dependancies"
 336               if $DEBUG;
 337             push @jobnums, $options{'depend_jobnum'};
 338           }
 339         }
 340
 341         foreach my $jobnum ( @jobnums ) {
 342           my $error = $wqueue->depend_insert($jobnum);
 343           if ( $error ) {
 344             $dbh->rollback if $oldAutoCommit;
 345             return "error queuing welcome email job dependancy: $error";
 346           }
 347         }
 348
 349       }
 350
 351     }
 352
 353   } # if ( $cust_pkg )
 354
 355   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 356   ''; #no error
 357 }
 358
 359 =item delete
 360
 361 Deletes this account from the database.  If there is an error, returns the
 362 error, otherwise returns false.
 363
 364 The corresponding FS::cust_svc record will be deleted as well.
 365
 366 (TODOC: new exports!)
 367
 368 =cut
 369
 370 sub delete {
 371   my $self = shift;
 372
 373   return "can't delete system account" if $self->_check_system;
 374
 375   return "Can't delete an account which is a (svc_forward) source!"
 376     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 377
 378   return "Can't delete an account which is a (svc_forward) destination!"
 379     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 380
 381   return "Can't delete an account with (svc_www) web service!"
 382     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 383
 384   # what about records in session ? (they should refer to history table)
 385
 386   local $SIG{HUP} = 'IGNORE';
 387   local $SIG{INT} = 'IGNORE';
 388   local $SIG{QUIT} = 'IGNORE';
 389   local $SIG{TERM} = 'IGNORE';
 390   local $SIG{TSTP} = 'IGNORE';
 391   local $SIG{PIPE} = 'IGNORE';
 392
 393   my $oldAutoCommit = $FS::UID::AutoCommit;
 394   local $FS::UID::AutoCommit = 0;
 395   my $dbh = dbh;
 396
 397   foreach my $cust_main_invoice (
 398     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 399   ) {
 400     unless ( defined($cust_main_invoice) ) {
 401       warn "WARNING: something's wrong with qsearch";
 402       next;
 403     }
 404     my %hash = $cust_main_invoice->hash;
 405     $hash{'dest'} = $self->email;
 406     my $new = new FS::cust_main_invoice \%hash;
 407     my $error = $new->replace($cust_main_invoice);
 408     if ( $error ) {
 409       $dbh->rollback if $oldAutoCommit;
 410       return $error;
 411     }
 412   }
 413
 414   foreach my $svc_domain (
 415     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 416   ) {
 417     my %hash = new FS::svc_domain->hash;
 418     $hash{'catchall'} = '';
 419     my $new = new FS::svc_domain \%hash;
 420     my $error = $new->replace($svc_domain);
 421     if ( $error ) {
 422       $dbh->rollback if $oldAutoCommit;
 423       return $error;
 424     }
 425   }
 426
 427   foreach my $radius_usergroup (
 428     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 429   ) {
 430     my $error = $radius_usergroup->delete;
 431     if ( $error ) {
 432       $dbh->rollback if $oldAutoCommit;
 433       return $error;
 434     }
 435   }
 436
 437   my $error = $self->SUPER::delete;
 438   if ( $error ) {
 439     $dbh->rollback if $oldAutoCommit;
 440     return $error;
 441   }
 442
 443   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 444   '';
 445 }
 446
 447 =item replace OLD_RECORD
 448
 449 Replaces OLD_RECORD with this one in the database.  If there is an error,
 450 returns the error, otherwise returns false.
 451
 452 The additional field I<usergroup> can optionally be defined; if so it should
 453 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 454
 455
 456 =cut
 457
 458 sub replace {
 459   my ( $new, $old ) = ( shift, shift );
 460   my $error;
 461   warn "$me replacing $old with $new\n" if $DEBUG;
 462
 463   return "can't modify system account" if $old->_check_system;
 464
 465   {
 466     #no warnings 'numeric';  #alas, a 5.006-ism
 467     local($^W) = 0;
 468     return "Can't change uid!" if $old->uid != $new->uid;
 469   }
 470
 471   #change homdir when we change username
 472   $new->setfield('dir', '') if $old->username ne $new->username;
 473
 474   local $SIG{HUP} = 'IGNORE';
 475   local $SIG{INT} = 'IGNORE';
 476   local $SIG{QUIT} = 'IGNORE';
 477   local $SIG{TERM} = 'IGNORE';
 478   local $SIG{TSTP} = 'IGNORE';
 479   local $SIG{PIPE} = 'IGNORE';
 480
 481   my $oldAutoCommit = $FS::UID::AutoCommit;
 482   local $FS::UID::AutoCommit = 0;
 483   my $dbh = dbh;
 484
 485   # redundant, but so $new->usergroup gets set
 486   $error = $new->check;
 487   return $error if $error;
 488
 489   $old->usergroup( [ $old->radius_groups ] );
 490   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 491   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 492   if ( $new->usergroup ) {
 493     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 494     my @newgroups = @{$new->usergroup};
 495     foreach my $oldgroup ( @{$old->usergroup} ) {
 496       if ( grep { $oldgroup eq $_ } @newgroups ) {
 497         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 498         next;
 499       }
 500       my $radius_usergroup = qsearchs('radius_usergroup', {
 501         svcnum    => $old->svcnum,
 502         groupname => $oldgroup,
 503       } );
 504       my $error = $radius_usergroup->delete;
 505       if ( $error ) {
 506         $dbh->rollback if $oldAutoCommit;
 507         return "error deleting radius_usergroup $oldgroup: $error";
 508       }
 509     }
 510
 511     foreach my $newgroup ( @newgroups ) {
 512       my $radius_usergroup = new FS::radius_usergroup ( {
 513         svcnum    => $new->svcnum,
 514         groupname => $newgroup,
 515       } );
 516       my $error = $radius_usergroup->insert;
 517       if ( $error ) {
 518         $dbh->rollback if $oldAutoCommit;
 519         return "error adding radius_usergroup $newgroup: $error";
 520       }
 521     }
 522
 523   }
 524
 525   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 526     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 527     $error = $new->_check_duplicate;
 528     if ( $error ) {
 529       $dbh->rollback if $oldAutoCommit;
 530       return $error;
 531     }
 532   }
 533
 534   $error = $new->SUPER::replace($old);
 535   if ( $error ) {
 536     $dbh->rollback if $oldAutoCommit;
 537     return $error if $error;
 538   }
 539
 540   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 541     $error = $new->queue_fuzzyfiles_update;
 542     if ( $error ) {
 543       $dbh->rollback if $oldAutoCommit;
 544       return "updating fuzzy search cache: $error";
 545     }
 546   }
 547
 548   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 549   ''; #no error
 550 }
 551
 552 =item queue_fuzzyfiles_update
 553
 554 Used by insert & replace to update the fuzzy search cache
 555
 556 =cut
 557
 558 sub queue_fuzzyfiles_update {
 559   my $self = shift;
 560
 561   local $SIG{HUP} = 'IGNORE';
 562   local $SIG{INT} = 'IGNORE';
 563   local $SIG{QUIT} = 'IGNORE';
 564   local $SIG{TERM} = 'IGNORE';
 565   local $SIG{TSTP} = 'IGNORE';
 566   local $SIG{PIPE} = 'IGNORE';
 567
 568   my $oldAutoCommit = $FS::UID::AutoCommit;
 569   local $FS::UID::AutoCommit = 0;
 570   my $dbh = dbh;
 571
 572   my $queue = new FS::queue {
 573     'svcnum' => $self->svcnum,
 574     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 575   };
 576   my $error = $queue->insert($self->username);
 577   if ( $error ) {
 578     $dbh->rollback if $oldAutoCommit;
 579     return "queueing job (transaction rolled back): $error";
 580   }
 581
 582   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 583   '';
 584
 585 }
 586
 587
 588 =item suspend
 589
 590 Suspends this account by calling export-specific suspend hooks.  If there is
 591 an error, returns the error, otherwise returns false.
 592
 593 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 594
 595 =cut
 596
 597 sub suspend {
 598   my $self = shift;
 599   return "can't suspend system account" if $self->_check_system;
 600   $self->SUPER::suspend;
 601 }
 602
 603 =item unsuspend
 604
 605 Unsuspends this account by by calling export-specific suspend hooks.  If there
 606 is an error, returns the error, otherwise returns false.
 607
 608 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 609
 610 =cut
 611
 612 sub unsuspend {
 613   my $self = shift;
 614   my %hash = $self->hash;
 615   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 616     $hash{_password} = $1;
 617     my $new = new FS::svc_acct ( \%hash );
 618     my $error = $new->replace($self);
 619     return $error if $error;
 620   }
 621
 622   $self->SUPER::unsuspend;
 623 }
 624
 625 =item cancel
 626
 627 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 628
 629 If the B<auto_unset_catchall> configuration option is set, this method will
 630 automatically remove any references to the canceled service in the catchall
 631 field of svc_domain.  This allows packages that contain both a svc_domain and
 632 its catchall svc_acct to be canceled in one step.
 633
 634 =cut
 635
 636 sub cancel {
 637   # Only one thing to do at this level
 638   my $self = shift;
 639   foreach my $svc_domain (
 640       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 641     if($conf->exists('auto_unset_catchall')) {
 642       my %hash = $svc_domain->hash;
 643       $hash{catchall} = '';
 644       my $new = new FS::svc_domain ( \%hash );
 645       my $error = $new->replace($svc_domain);
 646       return $error if $error;
 647     } else {
 648       return "cannot unprovision svc_acct #".$self->svcnum.
 649           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 650     }
 651   }
 652
 653   $self->SUPER::cancel;
 654 }
 655
 656
 657 =item check
 658
 659 Checks all fields to make sure this is a valid service.  If there is an error,
 660 returns the error, otherwise returns false.  Called by the insert and replace
 661 methods.
 662
 663 Sets any fixed values; see L<FS::part_svc>.
 664
 665 =cut
 666
 667 sub check {
 668   my $self = shift;
 669
 670   my($recref) = $self->hashref;
 671
 672   my $x = $self->setfixed;
 673   return $x unless ref($x);
 674   my $part_svc = $x;
 675
 676   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 677     $self->usergroup(
 678       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 679   }
 680
 681   my $error = $self->ut_numbern('svcnum')
 682               #|| $self->ut_number('domsvc')
 683               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 684               || $self->ut_textn('sec_phrase')
 685   ;
 686   return $error if $error;
 687
 688   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 689   if ( $username_uppercase ) {
 690     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 691       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 692     $recref->{username} = $1;
 693   } else {
 694     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 695       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 696     $recref->{username} = $1;
 697   }
 698
 699   if ( $username_letterfirst ) {
 700     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 701   } elsif ( $username_letter ) {
 702     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 703   }
 704   if ( $username_noperiod ) {
 705     $recref->{username} =~ /\./ and return gettext('illegal_username');
 706   }
 707   if ( $username_nounderscore ) {
 708     $recref->{username} =~ /_/ and return gettext('illegal_username');
 709   }
 710   if ( $username_nodash ) {
 711     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 712   }
 713   unless ( $username_ampersand ) {
 714     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 715   }
 716   if ( $password_noampersand ) {
 717     $recref->{_password} =~ /\&/ and return gettext('illegal_password');
 718   }
 719   if ( $password_noexclamation ) {
 720     $recref->{_password} =~ /\!/ and return gettext('illegal_password');
 721   }
 722
 723   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 724   $recref->{popnum} = $1;
 725   return "Unknown popnum" unless
 726     ! $recref->{popnum} ||
 727     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 728
 729   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 730
 731     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 732     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 733
 734     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 735     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 736     #not all systems use gid=uid
 737     #you can set a fixed gid in part_svc
 738
 739     return "Only root can have uid 0"
 740       if $recref->{uid} == 0
 741          && $recref->{username} !~ /^(root|toor|smtp)$/;
 742
 743     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 744       or return "Illegal directory: ". $recref->{dir};
 745     $recref->{dir} = $1;
 746     return "Illegal directory"
 747       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 748     return "Illegal directory"
 749       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 750     unless ( $recref->{dir} ) {
 751       $recref->{dir} = $dir_prefix . '/';
 752       if ( $dirhash > 0 ) {
 753         for my $h ( 1 .. $dirhash ) {
 754           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 755         }
 756       } elsif ( $dirhash < 0 ) {
 757         for my $h ( reverse $dirhash .. -1 ) {
 758           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 759         }
 760       }
 761       $recref->{dir} .= $recref->{username};
 762     ;
 763     }
 764
 765     unless ( $recref->{username} eq 'sync' ) {
 766       if ( grep $_ eq $recref->{shell}, @shells ) {
 767         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 768       } else {
 769         return "Illegal shell \`". $self->shell. "\'; ".
 770                $conf->dir. "/shells contains: @shells";
 771       }
 772     } else {
 773       $recref->{shell} = '/bin/sync';
 774     }
 775
 776   } else {
 777     $recref->{gid} ne '' ?
 778       return "Can't have gid without uid" : ( $recref->{gid}='' );
 779     $recref->{dir} ne '' ?
 780       return "Can't have directory without uid" : ( $recref->{dir}='' );
 781     $recref->{shell} ne '' ?
 782       return "Can't have shell without uid" : ( $recref->{shell}='' );
 783   }
 784
 785   #  $error = $self->ut_textn('finger');
 786   #  return $error if $error;
 787   if ( $self->getfield('finger') eq '' ) {
 788     my $cust_pkg = $self->svcnum
 789       ? $self->cust_svc->cust_pkg
 790       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
 791     if ( $cust_pkg ) {
 792       my $cust_main = $cust_pkg->cust_main;
 793       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
 794     }
 795   }
 796   $self->getfield('finger') =~
 797     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 798       or return "Illegal finger: ". $self->getfield('finger');
 799   $self->setfield('finger', $1);
 800
 801   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 802   $recref->{quota} = $1;
 803
 804   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 805     if ( $recref->{slipip} eq '' ) {
 806       $recref->{slipip} = '';
 807     } elsif ( $recref->{slipip} eq '0e0' ) {
 808       $recref->{slipip} = '0e0';
 809     } else {
 810       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 811         or return "Illegal slipip: ". $self->slipip;
 812       $recref->{slipip} = $1;
 813     }
 814
 815   }
 816
 817   #arbitrary RADIUS stuff; allow ut_textn for now
 818   foreach ( grep /^radius_/, fields('svc_acct') ) {
 819     $self->ut_textn($_);
 820   }
 821
 822   #generate a password if it is blank
 823   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 824     unless ( $recref->{_password} );
 825
 826   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 827   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 828     $recref->{_password} = $1.$3;
 829     #uncomment this to encrypt password immediately upon entry, or run
 830     #bin/crypt_pw in cron to give new users a window during which their
 831     #password is available to techs, for faxing, etc.  (also be aware of
 832     #radius issues!)
 833     #$recref->{password} = $1.
 834     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 835     #;
 836   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 837     $recref->{_password} = $1.$3;
 838   } elsif ( $recref->{_password} eq '*' ) {
 839     $recref->{_password} = '*';
 840   } elsif ( $recref->{_password} eq '!' ) {
 841     $recref->{_password} = '!';
 842   } elsif ( $recref->{_password} eq '!!' ) {
 843     $recref->{_password} = '!!';
 844   } else {
 845     #return "Illegal password";
 846     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 847            FS::Msgcat::_gettext('illegal_password_characters').
 848            ": ". $recref->{_password};
 849   }
 850
 851   $self->SUPER::check;
 852 }
 853
 854 =item _check_system
 855
 856 Internal function to check the username against the list of system usernames
 857 from the I<system_usernames> configuration value.  Returns true if the username
 858 is listed on the system username list.
 859
 860 =cut
 861
 862 sub _check_system {
 863   my $self = shift;
 864   scalar( grep { $self->username eq $_ || $self->email eq $_ }
 865                $conf->config('system_usernames')
 866         );
 867 }
 868
 869 =item _check_duplicate
 870
 871 Internal function to check for duplicates usernames, username@domain pairs and
 872 uids.
 873
 874 If the I<global_unique-username> configuration value is set to B<username> or
 875 B<username@domain>, enforces global username or username@domain uniqueness.
 876
 877 In all cases, check for duplicate uids and usernames or username@domain pairs
 878 per export and with identical I<svcpart> values.
 879
 880 =cut
 881
 882 sub _check_duplicate {
 883   my $self = shift;
 884
 885   #this is Pg-specific.  what to do for mysql etc?
 886   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
 887   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
 888   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
 889     or die dbh->errstr;
 890   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
 891
 892   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 893   unless ( $part_svc ) {
 894     return 'unknown svcpart '. $self->svcpart;
 895   }
 896
 897   my $global_unique = $conf->config('global_unique-username') || 'none';
 898
 899   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 900                  qsearch( 'svc_acct', { 'username' => $self->username } );
 901   return gettext('username_in_use')
 902     if $global_unique eq 'username' && @dup_user;
 903
 904   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 905                        qsearch( 'svc_acct', { 'username' => $self->username,
 906                                               'domsvc'   => $self->domsvc } );
 907   return gettext('username_in_use')
 908     if $global_unique eq 'username@domain' && @dup_userdomain;
 909
 910   my @dup_uid;
 911   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 912        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 913     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 914                qsearch( 'svc_acct', { 'uid' => $self->uid } );
 915   } else {
 916     @dup_uid = ();
 917   }
 918
 919   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 920     my $exports = FS::part_export::export_info('svc_acct');
 921     my %conflict_user_svcpart;
 922     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 923
 924     foreach my $part_export ( $part_svc->part_export ) {
 925
 926       #this will catch to the same exact export
 927       my @svcparts = map { $_->svcpart } $part_export->export_svc;
 928
 929       #this will catch to exports w/same exporthost+type ???
 930       #my @other_part_export = qsearch('part_export', {
 931       #  'machine'    => $part_export->machine,
 932       #  'exporttype' => $part_export->exporttype,
 933       #} );
 934       #foreach my $other_part_export ( @other_part_export ) {
 935       #  push @svcparts, map { $_->svcpart }
 936       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 937       #}
 938
 939       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 940       #silly kludge to avoid uninitialized value errors
 941       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 942                      ? $exports->{$part_export->exporttype}{'nodomain'}
 943                      : '';
 944       if ( $nodomain =~ /^Y/i ) {
 945         $conflict_user_svcpart{$_} = $part_export->exportnum
 946           foreach @svcparts;
 947       } else {
 948         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 949           foreach @svcparts;
 950       }
 951     }
 952
 953     foreach my $dup_user ( @dup_user ) {
 954       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 955       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 956         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 957                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 958       }
 959     }
 960
 961     foreach my $dup_userdomain ( @dup_userdomain ) {
 962       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 963       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 964         return "duplicate username\@domain: conflicts with svcnum ".
 965                $dup_userdomain->svcnum. " via exportnum ".
 966                $conflict_userdomain_svcpart{$dup_svcpart};
 967       }
 968     }
 969
 970     foreach my $dup_uid ( @dup_uid ) {
 971       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 972       if ( exists($conflict_user_svcpart{$dup_svcpart})
 973            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 974         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
 975                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 976                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 977       }
 978     }
 979
 980   }
 981
 982   return '';
 983
 984 }
 985
 986 =item radius
 987
 988 Depriciated, use radius_reply instead.
 989
 990 =cut
 991
 992 sub radius {
 993   carp "FS::svc_acct::radius depriciated, use radius_reply";
 994   $_[0]->radius_reply;
 995 }
 996
 997 =item radius_reply
 998
 999 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1000 reply attributes of this record.
1001
1002 Note that this is now the preferred method for reading RADIUS attributes -
1003 accessing the columns directly is discouraged, as the column names are
1004 expected to change in the future.
1005
1006 =cut
1007
1008 sub radius_reply {
1009   my $self = shift;
1010   my %reply =
1011     map {
1012       /^(radius_(.*))$/;
1013       my($column, $attrib) = ($1, $2);
1014       #$attrib =~ s/_/\-/g;
1015       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1016     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1017   if ( $self->slipip && $self->slipip ne '0e0' ) {
1018     $reply{$radius_ip} = $self->slipip;
1019   }
1020   if ( $self->seconds !~ /^$/ ) {
1021     $reply{'Session-Timeout'} = $self->seconds;
1022   }
1023   %reply;
1024 }
1025
1026 =item radius_check
1027
1028 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1029 check attributes of this record.
1030
1031 Note that this is now the preferred method for reading RADIUS attributes -
1032 accessing the columns directly is discouraged, as the column names are
1033 expected to change in the future.
1034
1035 =cut
1036
1037 sub radius_check {
1038   my $self = shift;
1039   my $password = $self->_password;
1040   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1041   ( $pw_attrib => $password,
1042     map {
1043       /^(rc_(.*))$/;
1044       my($column, $attrib) = ($1, $2);
1045       #$attrib =~ s/_/\-/g;
1046       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1047     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1048   );
1049 }
1050
1051 =item domain
1052
1053 Returns the domain associated with this account.
1054
1055 =cut
1056
1057 sub domain {
1058   my $self = shift;
1059   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1060   my $svc_domain = $self->svc_domain(@_)
1061     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1062   $svc_domain->domain;
1063 }
1064
1065 =item svc_domain
1066
1067 Returns the FS::svc_domain record for this account's domain (see
1068 L<FS::svc_domain>).
1069
1070 =cut
1071
1072 sub svc_domain {
1073   my $self = shift;
1074   $self->{'_domsvc'}
1075     ? $self->{'_domsvc'}
1076     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1077 }
1078
1079 =item cust_svc
1080
1081 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1082
1083 =cut
1084
1085 sub cust_svc {
1086   my $self = shift;
1087   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1088 }
1089
1090 =item email
1091
1092 Returns an email address associated with the account.
1093
1094 =cut
1095
1096 sub email {
1097   my $self = shift;
1098   $self->username. '@'. $self->domain(@_);
1099 }
1100
1101 =item acct_snarf
1102
1103 Returns an array of FS::acct_snarf records associated with the account.
1104 If the acct_snarf table does not exist or there are no associated records,
1105 an empty list is returned
1106
1107 =cut
1108
1109 sub acct_snarf {
1110   my $self = shift;
1111   return () unless dbdef->table('acct_snarf');
1112   eval "use FS::acct_snarf;";
1113   die $@ if $@;
1114   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1115 }
1116
1117 =item decrement_seconds SECONDS
1118
1119 Decrements the I<seconds> field of this record by the given amount.  If there
1120 is an error, returns the error, otherwise returns false.
1121
1122 =cut
1123
1124 sub decrement_seconds {
1125   shift->_op_seconds('-', @_);
1126 }
1127
1128 =item increment_seconds SECONDS
1129
1130 Increments the I<seconds> field of this record by the given amount.  If there
1131 is an error, returns the error, otherwise returns false.
1132
1133 =cut
1134
1135 sub increment_seconds {
1136   shift->_op_seconds('+', @_);
1137 }
1138
1139
1140 my %op2action = (
1141   '-' => 'suspend',
1142   '+' => 'unsuspend',
1143 );
1144 my %op2condition = (
1145   '-' => sub { my($self, $seconds) = @_;
1146                $self->seconds - $seconds <= 0;
1147              },
1148   '+' => sub { my($self, $seconds) = @_;
1149                $self->seconds + $seconds > 0;
1150              },
1151 );
1152
1153 sub _op_seconds {
1154   my( $self, $op, $seconds ) = @_;
1155   warn "$me _op_seconds called for svcnum ". $self->svcnum.
1156        ' ('. $self->email. "): $op $seconds\n"
1157     if $DEBUG;
1158
1159   local $SIG{HUP} = 'IGNORE';
1160   local $SIG{INT} = 'IGNORE';
1161   local $SIG{QUIT} = 'IGNORE';
1162   local $SIG{TERM} = 'IGNORE';
1163   local $SIG{TSTP} = 'IGNORE';
1164   local $SIG{PIPE} = 'IGNORE';
1165
1166   my $oldAutoCommit = $FS::UID::AutoCommit;
1167   local $FS::UID::AutoCommit = 0;
1168   my $dbh = dbh;
1169
1170   my $sql = "UPDATE svc_acct SET seconds = ".
1171             " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1172             " $op ? WHERE svcnum = ?";
1173   warn "$me $sql\n"
1174     if $DEBUG;
1175
1176   my $sth = $dbh->prepare( $sql )
1177     or die "Error preparing $sql: ". $dbh->errstr;
1178   my $rv = $sth->execute($seconds, $self->svcnum);
1179   die "Error executing $sql: ". $sth->errstr
1180     unless defined($rv);
1181   die "Can't update seconds for svcnum". $self->svcnum
1182     if $rv == 0;
1183
1184   my $action = $op2action{$op};
1185
1186   if ( $conf->exists("svc_acct-usage_$action")
1187        && &{$op2condition{$op}}($self, $seconds)    ) {
1188     #my $error = $self->$action();
1189     my $error = $self->cust_svc->cust_pkg->$action();
1190     if ( $error ) {
1191       $dbh->rollback if $oldAutoCommit;
1192       return "Error ${action}ing: $error";
1193     }
1194   }
1195
1196   warn "$me update sucessful; committing\n"
1197     if $DEBUG;
1198   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1199   '';
1200
1201 }
1202
1203
1204 =item seconds_since TIMESTAMP
1205
1206 Returns the number of seconds this account has been online since TIMESTAMP,
1207 according to the session monitor (see L<FS::Session>).
1208
1209 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1210 L<Time::Local> and L<Date::Parse> for conversion functions.
1211
1212 =cut
1213
1214 #note: POD here, implementation in FS::cust_svc
1215 sub seconds_since {
1216   my $self = shift;
1217   $self->cust_svc->seconds_since(@_);
1218 }
1219
1220 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1221
1222 Returns the numbers of seconds this account has been online between
1223 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1224 external SQL radacct table, specified via sqlradius export.  Sessions which
1225 started in the specified range but are still open are counted from session
1226 start to the end of the range (unless they are over 1 day old, in which case
1227 they are presumed missing their stop record and not counted).  Also, sessions
1228 which end in the range but started earlier are counted from the start of the
1229 range to session end.  Finally, sessions which start before the range but end
1230 after are counted for the entire range.
1231
1232 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1233 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1234 functions.
1235
1236 =cut
1237
1238 #note: POD here, implementation in FS::cust_svc
1239 sub seconds_since_sqlradacct {
1240   my $self = shift;
1241   $self->cust_svc->seconds_since_sqlradacct(@_);
1242 }
1243
1244 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1245
1246 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1247 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1248 TIMESTAMP_END (exclusive).
1249
1250 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1251 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1252 functions.
1253
1254 =cut
1255
1256 #note: POD here, implementation in FS::cust_svc
1257 sub attribute_since_sqlradacct {
1258   my $self = shift;
1259   $self->cust_svc->attribute_since_sqlradacct(@_);
1260 }
1261
1262 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1263
1264 Returns an array of hash references of this customers login history for the
1265 given time range.  (document this better)
1266
1267 =cut
1268
1269 sub get_session_history {
1270   my $self = shift;
1271   $self->cust_svc->get_session_history(@_);
1272 }
1273
1274 =item radius_groups
1275
1276 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1277
1278 =cut
1279
1280 sub radius_groups {
1281   my $self = shift;
1282   if ( $self->usergroup ) {
1283     #when provisioning records, export callback runs in svc_Common.pm before
1284     #radius_usergroup records can be inserted...
1285     @{$self->usergroup};
1286   } else {
1287     map { $_->groupname }
1288       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1289   }
1290 }
1291
1292 =item clone_suspended
1293
1294 Constructor used by FS::part_export::_export_suspend fallback.  Document
1295 better.
1296
1297 =cut
1298
1299 sub clone_suspended {
1300   my $self = shift;
1301   my %hash = $self->hash;
1302   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1303   new FS::svc_acct \%hash;
1304 }
1305
1306 =item clone_kludge_unsuspend
1307
1308 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1309 better.
1310
1311 =cut
1312
1313 sub clone_kludge_unsuspend {
1314   my $self = shift;
1315   my %hash = $self->hash;
1316   $hash{_password} = '';
1317   new FS::svc_acct \%hash;
1318 }
1319
1320 =item check_password
1321
1322 Checks the supplied password against the (possibly encrypted) password in the
1323 database.  Returns true for a sucessful authentication, false for no match.
1324
1325 Currently supported encryptions are: classic DES crypt() and MD5
1326
1327 =cut
1328
1329 sub check_password {
1330   my($self, $check_password) = @_;
1331
1332   #remove old-style SUSPENDED kludge, they should be allowed to login to
1333   #self-service and pay up
1334   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1335
1336   #eventually should check a "password-encoding" field
1337   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1338     return 0;
1339   } elsif ( length($password) < 13 ) { #plaintext
1340     $check_password eq $password;
1341   } elsif ( length($password) == 13 ) { #traditional DES crypt
1342     crypt($check_password, $password) eq $password;
1343   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1344     unix_md5_crypt($check_password, $password) eq $password;
1345   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1346     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1347          $self->svcnum. "\n";
1348     0;
1349   } else {
1350     warn "Can't check password: Unrecognized encryption for svcnum ".
1351          $self->svcnum. "\n";
1352     0;
1353   }
1354
1355 }
1356
1357 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1358
1359 Returns an encrypted password, either by passing through an encrypted password
1360 in the database or by encrypting a plaintext password from the database.
1361
1362 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1363 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1364 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1365 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1366 encryption type is only used if the password is not already encrypted in the
1367 database.
1368
1369 =cut
1370
1371 sub crypt_password {
1372   my $self = shift;
1373   #eventually should check a "password-encoding" field
1374   if ( length($self->_password) == 13
1375        || $self->_password =~ /^\$(1|2a?)\$/
1376        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1377      )
1378   {
1379     $self->_password;
1380   } else {
1381     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1382     if ( $encryption eq 'crypt' ) {
1383       crypt(
1384         $self->_password,
1385         $saltset[int(rand(64))].$saltset[int(rand(64))]
1386       );
1387     } elsif ( $encryption eq 'md5' ) {
1388       unix_md5_crypt( $self->_password );
1389     } elsif ( $encryption eq 'blowfish' ) {
1390       die "unknown encryption method $encryption";
1391     } else {
1392       die "unknown encryption method $encryption";
1393     }
1394   }
1395 }
1396
1397 =item virtual_maildir
1398
1399 Returns $domain/maildirs/$username/
1400
1401 =cut
1402
1403 sub virtual_maildir {
1404   my $self = shift;
1405   $self->domain. '/maildirs/'. $self->username. '/';
1406 }
1407
1408 =back
1409
1410 =head1 SUBROUTINES
1411
1412 =over 4
1413
1414 =item send_email
1415
1416 This is the FS::svc_acct job-queue-able version.  It still uses
1417 FS::Misc::send_email under-the-hood.
1418
1419 =cut
1420
1421 sub send_email {
1422   my %opt = @_;
1423
1424   eval "use FS::Misc qw(send_email)";
1425   die $@ if $@;
1426
1427   $opt{mimetype} ||= 'text/plain';
1428   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1429
1430   my $error = send_email(
1431     'from'         => $opt{from},
1432     'to'           => $opt{to},
1433     'subject'      => $opt{subject},
1434     'content-type' => $opt{mimetype},
1435     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1436   );
1437   die $error if $error;
1438 }
1439
1440 =item check_and_rebuild_fuzzyfiles
1441
1442 =cut
1443
1444 sub check_and_rebuild_fuzzyfiles {
1445   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1446   -e "$dir/svc_acct.username"
1447     or &rebuild_fuzzyfiles;
1448 }
1449
1450 =item rebuild_fuzzyfiles
1451
1452 =cut
1453
1454 sub rebuild_fuzzyfiles {
1455
1456   use Fcntl qw(:flock);
1457
1458   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1459
1460   #username
1461
1462   open(USERNAMELOCK,">>$dir/svc_acct.username")
1463     or die "can't open $dir/svc_acct.username: $!";
1464   flock(USERNAMELOCK,LOCK_EX)
1465     or die "can't lock $dir/svc_acct.username: $!";
1466
1467   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1468
1469   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1470     or die "can't open $dir/svc_acct.username.tmp: $!";
1471   print USERNAMECACHE join("\n", @all_username), "\n";
1472   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1473
1474   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1475   close USERNAMELOCK;
1476
1477 }
1478
1479 =item all_username
1480
1481 =cut
1482
1483 sub all_username {
1484   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1485   open(USERNAMECACHE,"<$dir/svc_acct.username")
1486     or die "can't open $dir/svc_acct.username: $!";
1487   my @array = map { chomp; $_; } <USERNAMECACHE>;
1488   close USERNAMECACHE;
1489   \@array;
1490 }
1491
1492 =item append_fuzzyfiles USERNAME
1493
1494 =cut
1495
1496 sub append_fuzzyfiles {
1497   my $username = shift;
1498
1499   &check_and_rebuild_fuzzyfiles;
1500
1501   use Fcntl qw(:flock);
1502
1503   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1504
1505   open(USERNAME,">>$dir/svc_acct.username")
1506     or die "can't open $dir/svc_acct.username: $!";
1507   flock(USERNAME,LOCK_EX)
1508     or die "can't lock $dir/svc_acct.username: $!";
1509
1510   print USERNAME "$username\n";
1511
1512   flock(USERNAME,LOCK_UN)
1513     or die "can't unlock $dir/svc_acct.username: $!";
1514   close USERNAME;
1515
1516   1;
1517 }
1518
1519
1520
1521 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1522
1523 =cut
1524
1525 sub radius_usergroup_selector {
1526   my $sel_groups = shift;
1527   my %sel_groups = map { $_=>1 } @$sel_groups;
1528
1529   my $selectname = shift || 'radius_usergroup';
1530
1531   my $dbh = dbh;
1532   my $sth = $dbh->prepare(
1533     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1534   ) or die $dbh->errstr;
1535   $sth->execute() or die $sth->errstr;
1536   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1537
1538   my $html = <<END;
1539     <SCRIPT>
1540     function ${selectname}_doadd(object) {
1541       var myvalue = object.${selectname}_add.value;
1542       var optionName = new Option(myvalue,myvalue,false,true);
1543       var length = object.$selectname.length;
1544       object.$selectname.options[length] = optionName;
1545       object.${selectname}_add.value = "";
1546     }
1547     </SCRIPT>
1548     <SELECT MULTIPLE NAME="$selectname">
1549 END
1550
1551   foreach my $group ( @all_groups ) {
1552     $html .= qq(<OPTION VALUE="$group");
1553     if ( $sel_groups{$group} ) {
1554       $html .= ' SELECTED';
1555       $sel_groups{$group} = 0;
1556     }
1557     $html .= ">$group</OPTION>\n";
1558   }
1559   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1560     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1561   };
1562   $html .= '</SELECT>';
1563
1564   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1565            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1566
1567   $html;
1568 }
1569
1570 =back
1571
1572 =head1 BUGS
1573
1574 The $recref stuff in sub check should be cleaned up.
1575
1576 The suspend, unsuspend and cancel methods update the database, but not the
1577 current object.  This is probably a bug as it's unexpected and
1578 counterintuitive.
1579
1580 radius_usergroup_selector?  putting web ui components in here?  they should
1581 probably live somewhere else...
1582
1583 insertion of RADIUS group stuff in insert could be done with child_objects now
1584 (would probably clean up export of them too)
1585
1586 =head1 SEE ALSO
1587
1588 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1589 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1590 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1591 L<freeside-queued>), L<FS::svc_acct_pop>,
1592 schema.html from the base documentation.
1593
1594 =cut
1595
1596 1;
1597