FS/FS/svc_acct.pm

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