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 seconds_since TIMESTAMP
1124
1125 Returns the number of seconds this account has been online since TIMESTAMP,
1126 according to the session monitor (see L<FS::Session>).
1127
1128 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1129 L<Time::Local> and L<Date::Parse> for conversion functions.
1130
1131 =cut
1132
1133 #note: POD here, implementation in FS::cust_svc
1134 sub seconds_since {
1135   my $self = shift;
1136   $self->cust_svc->seconds_since(@_);
1137 }
1138
1139 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1140
1141 Returns the numbers of seconds this account has been online between
1142 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1143 external SQL radacct table, specified via sqlradius export.  Sessions which
1144 started in the specified range but are still open are counted from session
1145 start to the end of the range (unless they are over 1 day old, in which case
1146 they are presumed missing their stop record and not counted).  Also, sessions
1147 which end in the range but started earlier are counted from the start of the
1148 range to session end.  Finally, sessions which start before the range but end
1149 after are counted for the entire range.
1150
1151 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1152 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1153 functions.
1154
1155 =cut
1156
1157 #note: POD here, implementation in FS::cust_svc
1158 sub seconds_since_sqlradacct {
1159   my $self = shift;
1160   $self->cust_svc->seconds_since_sqlradacct(@_);
1161 }
1162
1163 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1164
1165 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1166 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1167 TIMESTAMP_END (exclusive).
1168
1169 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1170 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1171 functions.
1172
1173 =cut
1174
1175 #note: POD here, implementation in FS::cust_svc
1176 sub attribute_since_sqlradacct {
1177   my $self = shift;
1178   $self->cust_svc->attribute_since_sqlradacct(@_);
1179 }
1180
1181 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1182
1183 Returns an array of hash references of this customers login history for the
1184 given time range.  (document this better)
1185
1186 =cut
1187
1188 sub get_session_history {
1189   my $self = shift;
1190   $self->cust_svc->get_session_history(@_);
1191 }
1192
1193 =item radius_groups
1194
1195 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1196
1197 =cut
1198
1199 sub radius_groups {
1200   my $self = shift;
1201   if ( $self->usergroup ) {
1202     #when provisioning records, export callback runs in svc_Common.pm before
1203     #radius_usergroup records can be inserted...
1204     @{$self->usergroup};
1205   } else {
1206     map { $_->groupname }
1207       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1208   }
1209 }
1210
1211 =item clone_suspended
1212
1213 Constructor used by FS::part_export::_export_suspend fallback.  Document
1214 better.
1215
1216 =cut
1217
1218 sub clone_suspended {
1219   my $self = shift;
1220   my %hash = $self->hash;
1221   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1222   new FS::svc_acct \%hash;
1223 }
1224
1225 =item clone_kludge_unsuspend
1226
1227 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1228 better.
1229
1230 =cut
1231
1232 sub clone_kludge_unsuspend {
1233   my $self = shift;
1234   my %hash = $self->hash;
1235   $hash{_password} = '';
1236   new FS::svc_acct \%hash;
1237 }
1238
1239 =item check_password
1240
1241 Checks the supplied password against the (possibly encrypted) password in the
1242 database.  Returns true for a sucessful authentication, false for no match.
1243
1244 Currently supported encryptions are: classic DES crypt() and MD5
1245
1246 =cut
1247
1248 sub check_password {
1249   my($self, $check_password) = @_;
1250
1251   #remove old-style SUSPENDED kludge, they should be allowed to login to
1252   #self-service and pay up
1253   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1254
1255   #eventually should check a "password-encoding" field
1256   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1257     return 0;
1258   } elsif ( length($password) < 13 ) { #plaintext
1259     $check_password eq $password;
1260   } elsif ( length($password) == 13 ) { #traditional DES crypt
1261     crypt($check_password, $password) eq $password;
1262   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1263     unix_md5_crypt($check_password, $password) eq $password;
1264   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1265     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1266          $self->svcnum. "\n";
1267     0;
1268   } else {
1269     warn "Can't check password: Unrecognized encryption for svcnum ".
1270          $self->svcnum. "\n";
1271     0;
1272   }
1273
1274 }
1275
1276 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1277
1278 Returns an encrypted password, either by passing through an encrypted password
1279 in the database or by encrypting a plaintext password from the database.
1280
1281 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1282 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1283 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1284 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1285 encryption type is only used if the password is not already encrypted in the
1286 database.
1287
1288 =cut
1289
1290 sub crypt_password {
1291   my $self = shift;
1292   #false laziness w/shellcommands.pm
1293   #eventually should check a "password-encoding" field
1294   if ( length($self->_password) == 13
1295        || $self->_password =~ /^\$(1|2a?)\$/ ) {
1296     $self->_password;
1297   } else {
1298     my $encryption = scalar(@_) ? shift : 'crypt';
1299     if ( $encryption eq 'crypt' ) {
1300       crypt(
1301         $self->_password,
1302         $saltset[int(rand(64))].$saltset[int(rand(64))]
1303       );
1304     } elsif ( $encryption eq 'md5' ) {
1305       unix_md5_crypt( $self->_password );
1306     } elsif ( $encryption eq 'blowfish' ) {
1307       die "unknown encryption method $encryption";
1308     } else {
1309       die "unknown encryption method $encryption";
1310     }
1311   }
1312 }
1313
1314 =item virtual_maildir
1315
1316 Returns $domain/maildirs/$username/
1317
1318 =cut
1319
1320 sub virtual_maildir {
1321   my $self = shift;
1322   $self->domain. '/maildirs/'. $self->username. '/';
1323 }
1324
1325 =back
1326
1327 =head1 SUBROUTINES
1328
1329 =over 4
1330
1331 =item send_email
1332
1333 This is the FS::svc_acct job-queue-able version.  It still uses
1334 FS::Misc::send_email under-the-hood.
1335
1336 =cut
1337
1338 sub send_email {
1339   my %opt = @_;
1340
1341   eval "use FS::Misc qw(send_email)";
1342   die $@ if $@;
1343
1344   $opt{mimetype} ||= 'text/plain';
1345   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1346
1347   my $error = send_email(
1348     'from'         => $opt{from},
1349     'to'           => $opt{to},
1350     'subject'      => $opt{subject},
1351     'content-type' => $opt{mimetype},
1352     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1353   );
1354   die $error if $error;
1355 }
1356
1357 =item check_and_rebuild_fuzzyfiles
1358
1359 =cut
1360
1361 sub check_and_rebuild_fuzzyfiles {
1362   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1363   -e "$dir/svc_acct.username"
1364     or &rebuild_fuzzyfiles;
1365 }
1366
1367 =item rebuild_fuzzyfiles
1368
1369 =cut
1370
1371 sub rebuild_fuzzyfiles {
1372
1373   use Fcntl qw(:flock);
1374
1375   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1376
1377   #username
1378
1379   open(USERNAMELOCK,">>$dir/svc_acct.username")
1380     or die "can't open $dir/svc_acct.username: $!";
1381   flock(USERNAMELOCK,LOCK_EX)
1382     or die "can't lock $dir/svc_acct.username: $!";
1383
1384   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1385
1386   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1387     or die "can't open $dir/svc_acct.username.tmp: $!";
1388   print USERNAMECACHE join("\n", @all_username), "\n";
1389   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1390
1391   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1392   close USERNAMELOCK;
1393
1394 }
1395
1396 =item all_username
1397
1398 =cut
1399
1400 sub all_username {
1401   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1402   open(USERNAMECACHE,"<$dir/svc_acct.username")
1403     or die "can't open $dir/svc_acct.username: $!";
1404   my @array = map { chomp; $_; } <USERNAMECACHE>;
1405   close USERNAMECACHE;
1406   \@array;
1407 }
1408
1409 =item append_fuzzyfiles USERNAME
1410
1411 =cut
1412
1413 sub append_fuzzyfiles {
1414   my $username = shift;
1415
1416   &check_and_rebuild_fuzzyfiles;
1417
1418   use Fcntl qw(:flock);
1419
1420   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1421
1422   open(USERNAME,">>$dir/svc_acct.username")
1423     or die "can't open $dir/svc_acct.username: $!";
1424   flock(USERNAME,LOCK_EX)
1425     or die "can't lock $dir/svc_acct.username: $!";
1426
1427   print USERNAME "$username\n";
1428
1429   flock(USERNAME,LOCK_UN)
1430     or die "can't unlock $dir/svc_acct.username: $!";
1431   close USERNAME;
1432
1433   1;
1434 }
1435
1436
1437
1438 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1439
1440 =cut
1441
1442 sub radius_usergroup_selector {
1443   my $sel_groups = shift;
1444   my %sel_groups = map { $_=>1 } @$sel_groups;
1445
1446   my $selectname = shift || 'radius_usergroup';
1447
1448   my $dbh = dbh;
1449   my $sth = $dbh->prepare(
1450     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1451   ) or die $dbh->errstr;
1452   $sth->execute() or die $sth->errstr;
1453   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1454
1455   my $html = <<END;
1456     <SCRIPT>
1457     function ${selectname}_doadd(object) {
1458       var myvalue = object.${selectname}_add.value;
1459       var optionName = new Option(myvalue,myvalue,false,true);
1460       var length = object.$selectname.length;
1461       object.$selectname.options[length] = optionName;
1462       object.${selectname}_add.value = "";
1463     }
1464     </SCRIPT>
1465     <SELECT MULTIPLE NAME="$selectname">
1466 END
1467
1468   foreach my $group ( @all_groups ) {
1469     $html .= qq(<OPTION VALUE="$group");
1470     if ( $sel_groups{$group} ) {
1471       $html .= ' SELECTED';
1472       $sel_groups{$group} = 0;
1473     }
1474     $html .= ">$group</OPTION>\n";
1475   }
1476   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1477     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1478   };
1479   $html .= '</SELECT>';
1480
1481   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1482            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1483
1484   $html;
1485 }
1486
1487 =back
1488
1489 =head1 BUGS
1490
1491 The $recref stuff in sub check should be cleaned up.
1492
1493 The suspend, unsuspend and cancel methods update the database, but not the
1494 current object.  This is probably a bug as it's unexpected and
1495 counterintuitive.
1496
1497 radius_usergroup_selector?  putting web ui components in here?  they should
1498 probably live somewhere else...
1499
1500 insertion of RADIUS group stuff in insert could be done with child_objects now
1501 (would probably clean up export of them too)
1502
1503 =head1 SEE ALSO
1504
1505 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1506 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1507 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1508 L<freeside-queued>), L<FS::svc_acct_pop>,
1509 schema.html from the base documentation.
1510
1511 =cut
1512
1513 1;
1514