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