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