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