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