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 #$DEBUG = 1;
  41 $me = '[FS::svc_acct]';
  42
  43 #ask FS::UID to run this stuff for us later
  44 $FS::UID::callback{'FS::svc_acct'} = sub {
  45   $conf = new FS::Conf;
  46   $dir_prefix = $conf->config('home');
  47   @shells = $conf->config('shells');
  48   $usernamemin = $conf->config('usernamemin') || 2;
  49   $usernamemax = $conf->config('usernamemax');
  50   $passwordmin = $conf->config('passwordmin') || 6;
  51   $passwordmax = $conf->config('passwordmax') || 8;
  52   $username_letter = $conf->exists('username-letter');
  53   $username_letterfirst = $conf->exists('username-letterfirst');
  54   $username_noperiod = $conf->exists('username-noperiod');
  55   $username_nounderscore = $conf->exists('username-nounderscore');
  56   $username_nodash = $conf->exists('username-nodash');
  57   $username_uppercase = $conf->exists('username-uppercase');
  58   $username_ampersand = $conf->exists('username-ampersand');
  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   return "Username in use"
 467     if $old->username ne $new->username &&
 468       qsearchs( 'svc_acct', { 'username' => $new->username,
 469                                'domsvc'   => $new->domsvc,
 470                              } );
 471   {
 472     #no warnings 'numeric';  #alas, a 5.006-ism
 473     local($^W) = 0;
 474     return "Can't change uid!" if $old->uid != $new->uid;
 475   }
 476
 477   #change homdir when we change username
 478   $new->setfield('dir', '') if $old->username ne $new->username;
 479
 480   local $SIG{HUP} = 'IGNORE';
 481   local $SIG{INT} = 'IGNORE';
 482   local $SIG{QUIT} = 'IGNORE';
 483   local $SIG{TERM} = 'IGNORE';
 484   local $SIG{TSTP} = 'IGNORE';
 485   local $SIG{PIPE} = 'IGNORE';
 486
 487   my $oldAutoCommit = $FS::UID::AutoCommit;
 488   local $FS::UID::AutoCommit = 0;
 489   my $dbh = dbh;
 490
 491   # redundant, but so $new->usergroup gets set
 492   $error = $new->check;
 493   return $error if $error;
 494
 495   $old->usergroup( [ $old->radius_groups ] );
 496   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 497   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 498   if ( $new->usergroup ) {
 499     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 500     my @newgroups = @{$new->usergroup};
 501     foreach my $oldgroup ( @{$old->usergroup} ) {
 502       if ( grep { $oldgroup eq $_ } @newgroups ) {
 503         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 504         next;
 505       }
 506       my $radius_usergroup = qsearchs('radius_usergroup', {
 507         svcnum    => $old->svcnum,
 508         groupname => $oldgroup,
 509       } );
 510       my $error = $radius_usergroup->delete;
 511       if ( $error ) {
 512         $dbh->rollback if $oldAutoCommit;
 513         return "error deleting radius_usergroup $oldgroup: $error";
 514       }
 515     }
 516
 517     foreach my $newgroup ( @newgroups ) {
 518       my $radius_usergroup = new FS::radius_usergroup ( {
 519         svcnum    => $new->svcnum,
 520         groupname => $newgroup,
 521       } );
 522       my $error = $radius_usergroup->insert;
 523       if ( $error ) {
 524         $dbh->rollback if $oldAutoCommit;
 525         return "error adding radius_usergroup $newgroup: $error";
 526       }
 527     }
 528
 529   }
 530
 531   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 532     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 533     $error = $new->_check_duplicate;
 534     if ( $error ) {
 535       $dbh->rollback if $oldAutoCommit;
 536       return $error;
 537     }
 538   }
 539
 540   $error = $new->SUPER::replace($old);
 541   if ( $error ) {
 542     $dbh->rollback if $oldAutoCommit;
 543     return $error if $error;
 544   }
 545
 546   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 547     $error = $new->queue_fuzzyfiles_update;
 548     if ( $error ) {
 549       $dbh->rollback if $oldAutoCommit;
 550       return "updating fuzzy search cache: $error";
 551     }
 552   }
 553
 554   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 555   ''; #no error
 556 }
 557
 558 =item queue_fuzzyfiles_update
 559
 560 Used by insert & replace to update the fuzzy search cache
 561
 562 =cut
 563
 564 sub queue_fuzzyfiles_update {
 565   my $self = shift;
 566
 567   local $SIG{HUP} = 'IGNORE';
 568   local $SIG{INT} = 'IGNORE';
 569   local $SIG{QUIT} = 'IGNORE';
 570   local $SIG{TERM} = 'IGNORE';
 571   local $SIG{TSTP} = 'IGNORE';
 572   local $SIG{PIPE} = 'IGNORE';
 573
 574   my $oldAutoCommit = $FS::UID::AutoCommit;
 575   local $FS::UID::AutoCommit = 0;
 576   my $dbh = dbh;
 577
 578   my $queue = new FS::queue {
 579     'svcnum' => $self->svcnum,
 580     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 581   };
 582   my $error = $queue->insert($self->username);
 583   if ( $error ) {
 584     $dbh->rollback if $oldAutoCommit;
 585     return "queueing job (transaction rolled back): $error";
 586   }
 587
 588   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 589   '';
 590
 591 }
 592
 593
 594 =item suspend
 595
 596 Suspends this account by calling export-specific suspend hooks.  If there is
 597 an error, returns the error, otherwise returns false.
 598
 599 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 600
 601 =cut
 602
 603 sub suspend {
 604   my $self = shift;
 605   return "can't suspend system account" if $self->_check_system;
 606   $self->SUPER::suspend;
 607 }
 608
 609 =item unsuspend
 610
 611 Unsuspends this account by by calling export-specific suspend hooks.  If there
 612 is an error, returns the error, otherwise returns false.
 613
 614 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 615
 616 =cut
 617
 618 sub unsuspend {
 619   my $self = shift;
 620   my %hash = $self->hash;
 621   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 622     $hash{_password} = $1;
 623     my $new = new FS::svc_acct ( \%hash );
 624     my $error = $new->replace($self);
 625     return $error if $error;
 626   }
 627
 628   $self->SUPER::unsuspend;
 629 }
 630
 631 =item cancel
 632
 633 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 634
 635 If the B<auto_unset_catchall> configuration option is set, this method will
 636 automatically remove any references to the canceled service in the catchall
 637 field of svc_domain.  This allows packages that contain both a svc_domain and
 638 its catchall svc_acct to be canceled in one step.
 639
 640 =cut
 641
 642 sub cancel {
 643   # Only one thing to do at this level
 644   my $self = shift;
 645   foreach my $svc_domain (
 646       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 647     if($conf->exists('auto_unset_catchall')) {
 648       my %hash = $svc_domain->hash;
 649       $hash{catchall} = '';
 650       my $new = new FS::svc_domain ( \%hash );
 651       my $error = $new->replace($svc_domain);
 652       return $error if $error;
 653     } else {
 654       return "cannot unprovision svc_acct #".$self->svcnum.
 655           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 656     }
 657   }
 658
 659   $self->SUPER::cancel;
 660 }
 661
 662
 663 =item check
 664
 665 Checks all fields to make sure this is a valid service.  If there is an error,
 666 returns the error, otherwise returns false.  Called by the insert and replace
 667 methods.
 668
 669 Sets any fixed values; see L<FS::part_svc>.
 670
 671 =cut
 672
 673 sub check {
 674   my $self = shift;
 675
 676   my($recref) = $self->hashref;
 677
 678   my $x = $self->setfixed;
 679   return $x unless ref($x);
 680   my $part_svc = $x;
 681
 682   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 683     $self->usergroup(
 684       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 685   }
 686
 687   my $error = $self->ut_numbern('svcnum')
 688               #|| $self->ut_number('domsvc')
 689               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 690               || $self->ut_textn('sec_phrase')
 691   ;
 692   return $error if $error;
 693
 694   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 695   if ( $username_uppercase ) {
 696     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 697       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 698     $recref->{username} = $1;
 699   } else {
 700     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 701       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 702     $recref->{username} = $1;
 703   }
 704
 705   if ( $username_letterfirst ) {
 706     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 707   } elsif ( $username_letter ) {
 708     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 709   }
 710   if ( $username_noperiod ) {
 711     $recref->{username} =~ /\./ and return gettext('illegal_username');
 712   }
 713   if ( $username_nounderscore ) {
 714     $recref->{username} =~ /_/ and return gettext('illegal_username');
 715   }
 716   if ( $username_nodash ) {
 717     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 718   }
 719   unless ( $username_ampersand ) {
 720     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 721   }
 722   if ( $password_noampersand ) {
 723     $recref->{_password} =~ /\&/ and return gettext('illegal_password');
 724   }
 725   if ( $password_noexclamation ) {
 726     $recref->{_password} =~ /\!/ and return gettext('illegal_password');
 727   }
 728
 729   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 730   $recref->{popnum} = $1;
 731   return "Unknown popnum" unless
 732     ! $recref->{popnum} ||
 733     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 734
 735   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 736
 737     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 738     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 739
 740     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 741     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 742     #not all systems use gid=uid
 743     #you can set a fixed gid in part_svc
 744
 745     return "Only root can have uid 0"
 746       if $recref->{uid} == 0
 747          && $recref->{username} !~ /^(root|toor|smtp)$/;
 748
 749     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 750       or return "Illegal directory: ". $recref->{dir};
 751     $recref->{dir} = $1;
 752     return "Illegal directory"
 753       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 754     return "Illegal directory"
 755       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 756     unless ( $recref->{dir} ) {
 757       $recref->{dir} = $dir_prefix . '/';
 758       if ( $dirhash > 0 ) {
 759         for my $h ( 1 .. $dirhash ) {
 760           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 761         }
 762       } elsif ( $dirhash < 0 ) {
 763         for my $h ( reverse $dirhash .. -1 ) {
 764           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 765         }
 766       }
 767       $recref->{dir} .= $recref->{username};
 768     ;
 769     }
 770
 771     unless ( $recref->{username} eq 'sync' ) {
 772       if ( grep $_ eq $recref->{shell}, @shells ) {
 773         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 774       } else {
 775         return "Illegal shell \`". $self->shell. "\'; ".
 776                $conf->dir. "/shells contains: @shells";
 777       }
 778     } else {
 779       $recref->{shell} = '/bin/sync';
 780     }
 781
 782   } else {
 783     $recref->{gid} ne '' ?
 784       return "Can't have gid without uid" : ( $recref->{gid}='' );
 785     $recref->{dir} ne '' ?
 786       return "Can't have directory without uid" : ( $recref->{dir}='' );
 787     $recref->{shell} ne '' ?
 788       return "Can't have shell without uid" : ( $recref->{shell}='' );
 789   }
 790
 791   #  $error = $self->ut_textn('finger');
 792   #  return $error if $error;
 793   if ( $self->getfield('finger') eq '' ) {
 794     my $cust_pkg = $self->svcnum
 795       ? $self->cust_svc->cust_pkg
 796       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
 797     if ( $cust_pkg ) {
 798       my $cust_main = $cust_pkg->cust_main;
 799       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
 800     }
 801   }
 802   $self->getfield('finger') =~
 803     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 804       or return "Illegal finger: ". $self->getfield('finger');
 805   $self->setfield('finger', $1);
 806
 807   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 808   $recref->{quota} = $1;
 809
 810   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 811     if ( $recref->{slipip} eq '' ) {
 812       $recref->{slipip} = '';
 813     } elsif ( $recref->{slipip} eq '0e0' ) {
 814       $recref->{slipip} = '0e0';
 815     } else {
 816       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 817         or return "Illegal slipip: ". $self->slipip;
 818       $recref->{slipip} = $1;
 819     }
 820
 821   }
 822
 823   #arbitrary RADIUS stuff; allow ut_textn for now
 824   foreach ( grep /^radius_/, fields('svc_acct') ) {
 825     $self->ut_textn($_);
 826   }
 827
 828   #generate a password if it is blank
 829   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 830     unless ( $recref->{_password} );
 831
 832   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 833   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 834     $recref->{_password} = $1.$3;
 835     #uncomment this to encrypt password immediately upon entry, or run
 836     #bin/crypt_pw in cron to give new users a window during which their
 837     #password is available to techs, for faxing, etc.  (also be aware of
 838     #radius issues!)
 839     #$recref->{password} = $1.
 840     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 841     #;
 842   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 843     $recref->{_password} = $1.$3;
 844   } elsif ( $recref->{_password} eq '*' ) {
 845     $recref->{_password} = '*';
 846   } elsif ( $recref->{_password} eq '!' ) {
 847     $recref->{_password} = '!';
 848   } elsif ( $recref->{_password} eq '!!' ) {
 849     $recref->{_password} = '!!';
 850   } else {
 851     #return "Illegal password";
 852     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 853            FS::Msgcat::_gettext('illegal_password_characters').
 854            ": ". $recref->{_password};
 855   }
 856
 857   $self->SUPER::check;
 858 }
 859
 860 =item _check_system
 861
 862 Internal function to check the username against the list of system usernames
 863 from the I<system_usernames> configuration value.  Returns true if the username
 864 is listed on the system username list.
 865
 866 =cut
 867
 868 sub _check_system {
 869   my $self = shift;
 870   scalar( grep { $self->username eq $_ || $self->email eq $_ }
 871                $conf->config('system_usernames')
 872         );
 873 }
 874
 875 =item _check_duplicate
 876
 877 Internal function to check for duplicates usernames, username@domain pairs and
 878 uids.
 879
 880 If the I<global_unique-username> configuration value is set to B<username> or
 881 B<username@domain>, enforces global username or username@domain uniqueness.
 882
 883 In all cases, check for duplicate uids and usernames or username@domain pairs
 884 per export and with identical I<svcpart> values.
 885
 886 =cut
 887
 888 sub _check_duplicate {
 889   my $self = shift;
 890
 891   #this is Pg-specific.  what to do for mysql etc?
 892   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
 893   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
 894   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
 895     or die dbh->errstr;
 896   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
 897
 898   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 899   unless ( $part_svc ) {
 900     return 'unknown svcpart '. $self->svcpart;
 901   }
 902
 903   my $global_unique = $conf->config('global_unique-username') || 'none';
 904
 905   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 906                  qsearch( 'svc_acct', { 'username' => $self->username } );
 907   return gettext('username_in_use')
 908     if $global_unique eq 'username' && @dup_user;
 909
 910   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 911                        qsearch( 'svc_acct', { 'username' => $self->username,
 912                                               'domsvc'   => $self->domsvc } );
 913   return gettext('username_in_use')
 914     if $global_unique eq 'username@domain' && @dup_userdomain;
 915
 916   my @dup_uid;
 917   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 918        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 919     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 920                qsearch( 'svc_acct', { 'uid' => $self->uid } );
 921   } else {
 922     @dup_uid = ();
 923   }
 924
 925   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 926     my $exports = FS::part_export::export_info('svc_acct');
 927     my %conflict_user_svcpart;
 928     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 929
 930     foreach my $part_export ( $part_svc->part_export ) {
 931
 932       #this will catch to the same exact export
 933       my @svcparts = map { $_->svcpart } $part_export->export_svc;
 934
 935       #this will catch to exports w/same exporthost+type ???
 936       #my @other_part_export = qsearch('part_export', {
 937       #  'machine'    => $part_export->machine,
 938       #  'exporttype' => $part_export->exporttype,
 939       #} );
 940       #foreach my $other_part_export ( @other_part_export ) {
 941       #  push @svcparts, map { $_->svcpart }
 942       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 943       #}
 944
 945       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 946       #silly kludge to avoid uninitialized value errors
 947       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 948                      ? $exports->{$part_export->exporttype}{'nodomain'}
 949                      : '';
 950       if ( $nodomain =~ /^Y/i ) {
 951         $conflict_user_svcpart{$_} = $part_export->exportnum
 952           foreach @svcparts;
 953       } else {
 954         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 955           foreach @svcparts;
 956       }
 957     }
 958
 959     foreach my $dup_user ( @dup_user ) {
 960       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 961       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 962         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 963                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 964       }
 965     }
 966
 967     foreach my $dup_userdomain ( @dup_userdomain ) {
 968       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 969       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 970         return "duplicate username\@domain: conflicts with svcnum ".
 971                $dup_userdomain->svcnum. " via exportnum ".
 972                $conflict_userdomain_svcpart{$dup_svcpart};
 973       }
 974     }
 975
 976     foreach my $dup_uid ( @dup_uid ) {
 977       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 978       if ( exists($conflict_user_svcpart{$dup_svcpart})
 979            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 980         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
 981                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 982                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 983       }
 984     }
 985
 986   }
 987
 988   return '';
 989
 990 }
 991
 992 =item radius
 993
 994 Depriciated, use radius_reply instead.
 995
 996 =cut
 997
 998 sub radius {
 999   carp "FS::svc_acct::radius depriciated, use radius_reply";
1000   $_[0]->radius_reply;
1001 }
1002
1003 =item radius_reply
1004
1005 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1006 reply attributes of this record.
1007
1008 Note that this is now the preferred method for reading RADIUS attributes -
1009 accessing the columns directly is discouraged, as the column names are
1010 expected to change in the future.
1011
1012 =cut
1013
1014 sub radius_reply {
1015   my $self = shift;
1016   my %reply =
1017     map {
1018       /^(radius_(.*))$/;
1019       my($column, $attrib) = ($1, $2);
1020       #$attrib =~ s/_/\-/g;
1021       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1022     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1023   if ( $self->slipip && $self->slipip ne '0e0' ) {
1024     $reply{$radius_ip} = $self->slipip;
1025   }
1026   if ( $self->seconds !~ /^$/ ) {
1027     $reply{'Session-Timeout'} = $self->seconds;
1028   }
1029   %reply;
1030 }
1031
1032 =item radius_check
1033
1034 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1035 check attributes of this record.
1036
1037 Note that this is now the preferred method for reading RADIUS attributes -
1038 accessing the columns directly is discouraged, as the column names are
1039 expected to change in the future.
1040
1041 =cut
1042
1043 sub radius_check {
1044   my $self = shift;
1045   my $password = $self->_password;
1046   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1047   ( $pw_attrib => $password,
1048     map {
1049       /^(rc_(.*))$/;
1050       my($column, $attrib) = ($1, $2);
1051       #$attrib =~ s/_/\-/g;
1052       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1053     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1054   );
1055 }
1056
1057 =item domain
1058
1059 Returns the domain associated with this account.
1060
1061 =cut
1062
1063 sub domain {
1064   my $self = shift;
1065   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1066   my $svc_domain = $self->svc_domain(@_)
1067     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1068   $svc_domain->domain;
1069 }
1070
1071 =item svc_domain
1072
1073 Returns the FS::svc_domain record for this account's domain (see
1074 L<FS::svc_domain>).
1075
1076 =cut
1077
1078 sub svc_domain {
1079   my $self = shift;
1080   $self->{'_domsvc'}
1081     ? $self->{'_domsvc'}
1082     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1083 }
1084
1085 =item cust_svc
1086
1087 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1088
1089 =cut
1090
1091 sub cust_svc {
1092   my $self = shift;
1093   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1094 }
1095
1096 =item email
1097
1098 Returns an email address associated with the account.
1099
1100 =cut
1101
1102 sub email {
1103   my $self = shift;
1104   $self->username. '@'. $self->domain(@_);
1105 }
1106
1107 =item acct_snarf
1108
1109 Returns an array of FS::acct_snarf records associated with the account.
1110 If the acct_snarf table does not exist or there are no associated records,
1111 an empty list is returned
1112
1113 =cut
1114
1115 sub acct_snarf {
1116   my $self = shift;
1117   return () unless dbdef->table('acct_snarf');
1118   eval "use FS::acct_snarf;";
1119   die $@ if $@;
1120   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1121 }
1122
1123 =item decrement_seconds SECONDS
1124
1125 Decrements the I<seconds> field of this record by the given amount.
1126
1127 =cut
1128
1129 sub decrement_seconds {
1130   my( $self, $seconds ) = @_;
1131
1132   local $SIG{HUP} = 'IGNORE';
1133   local $SIG{INT} = 'IGNORE';
1134   local $SIG{QUIT} = 'IGNORE';
1135   local $SIG{TERM} = 'IGNORE';
1136   local $SIG{TSTP} = 'IGNORE';
1137   local $SIG{PIPE} = 'IGNORE';
1138
1139   my $oldAutoCommit = $FS::UID::AutoCommit;
1140   local $FS::UID::AutoCommit = 0;
1141   my $dbh = dbh;
1142
1143   my $sth = dbh->prepare(
1144     'UPDATE svc_acct SET seconds = seconds - ? WHERE svcnum = ?'
1145   ) or die dbh->errstr;;
1146   $sth->execute($seconds, $self->svcnum) or die $sth->errstr;
1147   if ( $conf->exists('svc_acct-usage_suspend')
1148        && $self->seconds - $seconds <= 0       ) {
1149     #my $error = $self->suspend;
1150     my $error = $self->cust_svc->cust_pkg->suspend;
1151     die $error if $error;
1152   }
1153
1154   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1155
1156 }
1157
1158 =item seconds_since TIMESTAMP
1159
1160 Returns the number of seconds this account has been online since TIMESTAMP,
1161 according to the session monitor (see L<FS::Session>).
1162
1163 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1164 L<Time::Local> and L<Date::Parse> for conversion functions.
1165
1166 =cut
1167
1168 #note: POD here, implementation in FS::cust_svc
1169 sub seconds_since {
1170   my $self = shift;
1171   $self->cust_svc->seconds_since(@_);
1172 }
1173
1174 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1175
1176 Returns the numbers of seconds this account has been online between
1177 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1178 external SQL radacct table, specified via sqlradius export.  Sessions which
1179 started in the specified range but are still open are counted from session
1180 start to the end of the range (unless they are over 1 day old, in which case
1181 they are presumed missing their stop record and not counted).  Also, sessions
1182 which end in the range but started earlier are counted from the start of the
1183 range to session end.  Finally, sessions which start before the range but end
1184 after are counted for the entire range.
1185
1186 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1187 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1188 functions.
1189
1190 =cut
1191
1192 #note: POD here, implementation in FS::cust_svc
1193 sub seconds_since_sqlradacct {
1194   my $self = shift;
1195   $self->cust_svc->seconds_since_sqlradacct(@_);
1196 }
1197
1198 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1199
1200 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1201 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1202 TIMESTAMP_END (exclusive).
1203
1204 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1205 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1206 functions.
1207
1208 =cut
1209
1210 #note: POD here, implementation in FS::cust_svc
1211 sub attribute_since_sqlradacct {
1212   my $self = shift;
1213   $self->cust_svc->attribute_since_sqlradacct(@_);
1214 }
1215
1216 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1217
1218 Returns an array of hash references of this customers login history for the
1219 given time range.  (document this better)
1220
1221 =cut
1222
1223 sub get_session_history {
1224   my $self = shift;
1225   $self->cust_svc->get_session_history(@_);
1226 }
1227
1228 =item radius_groups
1229
1230 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1231
1232 =cut
1233
1234 sub radius_groups {
1235   my $self = shift;
1236   if ( $self->usergroup ) {
1237     #when provisioning records, export callback runs in svc_Common.pm before
1238     #radius_usergroup records can be inserted...
1239     @{$self->usergroup};
1240   } else {
1241     map { $_->groupname }
1242       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1243   }
1244 }
1245
1246 =item clone_suspended
1247
1248 Constructor used by FS::part_export::_export_suspend fallback.  Document
1249 better.
1250
1251 =cut
1252
1253 sub clone_suspended {
1254   my $self = shift;
1255   my %hash = $self->hash;
1256   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1257   new FS::svc_acct \%hash;
1258 }
1259
1260 =item clone_kludge_unsuspend
1261
1262 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1263 better.
1264
1265 =cut
1266
1267 sub clone_kludge_unsuspend {
1268   my $self = shift;
1269   my %hash = $self->hash;
1270   $hash{_password} = '';
1271   new FS::svc_acct \%hash;
1272 }
1273
1274 =item check_password
1275
1276 Checks the supplied password against the (possibly encrypted) password in the
1277 database.  Returns true for a sucessful authentication, false for no match.
1278
1279 Currently supported encryptions are: classic DES crypt() and MD5
1280
1281 =cut
1282
1283 sub check_password {
1284   my($self, $check_password) = @_;
1285
1286   #remove old-style SUSPENDED kludge, they should be allowed to login to
1287   #self-service and pay up
1288   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1289
1290   #eventually should check a "password-encoding" field
1291   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1292     return 0;
1293   } elsif ( length($password) < 13 ) { #plaintext
1294     $check_password eq $password;
1295   } elsif ( length($password) == 13 ) { #traditional DES crypt
1296     crypt($check_password, $password) eq $password;
1297   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1298     unix_md5_crypt($check_password, $password) eq $password;
1299   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1300     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1301          $self->svcnum. "\n";
1302     0;
1303   } else {
1304     warn "Can't check password: Unrecognized encryption for svcnum ".
1305          $self->svcnum. "\n";
1306     0;
1307   }
1308
1309 }
1310
1311 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1312
1313 Returns an encrypted password, either by passing through an encrypted password
1314 in the database or by encrypting a plaintext password from the database.
1315
1316 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1317 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1318 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1319 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1320 encryption type is only used if the password is not already encrypted in the
1321 database.
1322
1323 =cut
1324
1325 sub crypt_password {
1326   my $self = shift;
1327   #false laziness w/shellcommands.pm
1328   #eventually should check a "password-encoding" field
1329   if ( length($self->_password) == 13
1330        || $self->_password =~ /^\$(1|2a?)\$/ ) {
1331     $self->_password;
1332   } else {
1333     my $encryption = scalar(@_) ? shift : 'crypt';
1334     if ( $encryption eq 'crypt' ) {
1335       crypt(
1336         $self->_password,
1337         $saltset[int(rand(64))].$saltset[int(rand(64))]
1338       );
1339     } elsif ( $encryption eq 'md5' ) {
1340       unix_md5_crypt( $self->_password );
1341     } elsif ( $encryption eq 'blowfish' ) {
1342       die "unknown encryption method $encryption";
1343     } else {
1344       die "unknown encryption method $encryption";
1345     }
1346   }
1347 }
1348
1349 =item virtual_maildir
1350
1351 Returns $domain/maildirs/$username/
1352
1353 =cut
1354
1355 sub virtual_maildir {
1356   my $self = shift;
1357   $self->domain. '/maildirs/'. $self->username. '/';
1358 }
1359
1360 =back
1361
1362 =head1 SUBROUTINES
1363
1364 =over 4
1365
1366 =item send_email
1367
1368 This is the FS::svc_acct job-queue-able version.  It still uses
1369 FS::Misc::send_email under-the-hood.
1370
1371 =cut
1372
1373 sub send_email {
1374   my %opt = @_;
1375
1376   eval "use FS::Misc qw(send_email)";
1377   die $@ if $@;
1378
1379   $opt{mimetype} ||= 'text/plain';
1380   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1381
1382   my $error = send_email(
1383     'from'         => $opt{from},
1384     'to'           => $opt{to},
1385     'subject'      => $opt{subject},
1386     'content-type' => $opt{mimetype},
1387     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1388   );
1389   die $error if $error;
1390 }
1391
1392 =item check_and_rebuild_fuzzyfiles
1393
1394 =cut
1395
1396 sub check_and_rebuild_fuzzyfiles {
1397   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1398   -e "$dir/svc_acct.username"
1399     or &rebuild_fuzzyfiles;
1400 }
1401
1402 =item rebuild_fuzzyfiles
1403
1404 =cut
1405
1406 sub rebuild_fuzzyfiles {
1407
1408   use Fcntl qw(:flock);
1409
1410   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1411
1412   #username
1413
1414   open(USERNAMELOCK,">>$dir/svc_acct.username")
1415     or die "can't open $dir/svc_acct.username: $!";
1416   flock(USERNAMELOCK,LOCK_EX)
1417     or die "can't lock $dir/svc_acct.username: $!";
1418
1419   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1420
1421   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1422     or die "can't open $dir/svc_acct.username.tmp: $!";
1423   print USERNAMECACHE join("\n", @all_username), "\n";
1424   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1425
1426   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1427   close USERNAMELOCK;
1428
1429 }
1430
1431 =item all_username
1432
1433 =cut
1434
1435 sub all_username {
1436   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1437   open(USERNAMECACHE,"<$dir/svc_acct.username")
1438     or die "can't open $dir/svc_acct.username: $!";
1439   my @array = map { chomp; $_; } <USERNAMECACHE>;
1440   close USERNAMECACHE;
1441   \@array;
1442 }
1443
1444 =item append_fuzzyfiles USERNAME
1445
1446 =cut
1447
1448 sub append_fuzzyfiles {
1449   my $username = shift;
1450
1451   &check_and_rebuild_fuzzyfiles;
1452
1453   use Fcntl qw(:flock);
1454
1455   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1456
1457   open(USERNAME,">>$dir/svc_acct.username")
1458     or die "can't open $dir/svc_acct.username: $!";
1459   flock(USERNAME,LOCK_EX)
1460     or die "can't lock $dir/svc_acct.username: $!";
1461
1462   print USERNAME "$username\n";
1463
1464   flock(USERNAME,LOCK_UN)
1465     or die "can't unlock $dir/svc_acct.username: $!";
1466   close USERNAME;
1467
1468   1;
1469 }
1470
1471
1472
1473 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1474
1475 =cut
1476
1477 sub radius_usergroup_selector {
1478   my $sel_groups = shift;
1479   my %sel_groups = map { $_=>1 } @$sel_groups;
1480
1481   my $selectname = shift || 'radius_usergroup';
1482
1483   my $dbh = dbh;
1484   my $sth = $dbh->prepare(
1485     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1486   ) or die $dbh->errstr;
1487   $sth->execute() or die $sth->errstr;
1488   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1489
1490   my $html = <<END;
1491     <SCRIPT>
1492     function ${selectname}_doadd(object) {
1493       var myvalue = object.${selectname}_add.value;
1494       var optionName = new Option(myvalue,myvalue,false,true);
1495       var length = object.$selectname.length;
1496       object.$selectname.options[length] = optionName;
1497       object.${selectname}_add.value = "";
1498     }
1499     </SCRIPT>
1500     <SELECT MULTIPLE NAME="$selectname">
1501 END
1502
1503   foreach my $group ( @all_groups ) {
1504     $html .= qq(<OPTION VALUE="$group");
1505     if ( $sel_groups{$group} ) {
1506       $html .= ' SELECTED';
1507       $sel_groups{$group} = 0;
1508     }
1509     $html .= ">$group</OPTION>\n";
1510   }
1511   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1512     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1513   };
1514   $html .= '</SELECT>';
1515
1516   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1517            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1518
1519   $html;
1520 }
1521
1522 =back
1523
1524 =head1 BUGS
1525
1526 The $recref stuff in sub check should be cleaned up.
1527
1528 The suspend, unsuspend and cancel methods update the database, but not the
1529 current object.  This is probably a bug as it's unexpected and
1530 counterintuitive.
1531
1532 radius_usergroup_selector?  putting web ui components in here?  they should
1533 probably live somewhere else...
1534
1535 insertion of RADIUS group stuff in insert could be done with child_objects now
1536 (would probably clean up export of them too)
1537
1538 =head1 SEE ALSO
1539
1540 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1541 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1542 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1543 L<freeside-queued>), L<FS::svc_acct_pop>,
1544 schema.html from the base documentation.
1545
1546 =cut
1547
1548 1;
1549