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_svc = $self->cust_svc;
1081   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1082     unless $cust_svc;
1083   my $cust_pkg = $cust_svc->cust_pkg;
1084   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1085     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1086   }
1087
1088   %check;
1089
1090 }
1091
1092 =item snapshot
1093
1094 This method instructs the object to "snapshot" or freeze RADIUS check and
1095 reply attributes to the current values.
1096
1097 =cut
1098
1099 #bah, my english is too broken this morning
1100 #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
1101 #the FS::cust_pkg's replace method to trigger the correct export updates when
1102 #package dates change)
1103
1104 sub snapshot {
1105   my $self = shift;
1106
1107   $self->{$_} = { $self->$_() }
1108     foreach qw( radius_reply radius_check );
1109
1110 }
1111
1112 =item forget_snapshot
1113
1114 This methos instructs the object to forget any previously snapshotted
1115 RADIUS check and reply attributes.
1116
1117 =cut
1118
1119 sub forget_snapshot {
1120   my $self = shift;
1121
1122   delete $self->{$_}
1123     foreach qw( radius_reply radius_check );
1124
1125 }
1126
1127 =item domain
1128
1129 Returns the domain associated with this account.
1130
1131 =cut
1132
1133 sub domain {
1134   my $self = shift;
1135   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1136   my $svc_domain = $self->svc_domain(@_)
1137     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1138   $svc_domain->domain;
1139 }
1140
1141 =item svc_domain
1142
1143 Returns the FS::svc_domain record for this account's domain (see
1144 L<FS::svc_domain>).
1145
1146 =cut
1147
1148 sub svc_domain {
1149   my $self = shift;
1150   $self->{'_domsvc'}
1151     ? $self->{'_domsvc'}
1152     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1153 }
1154
1155 =item cust_svc
1156
1157 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1158
1159 =cut
1160
1161 #inherited from svc_Common
1162
1163 =item email
1164
1165 Returns an email address associated with the account.
1166
1167 =cut
1168
1169 sub email {
1170   my $self = shift;
1171   $self->username. '@'. $self->domain(@_);
1172 }
1173
1174 =item acct_snarf
1175
1176 Returns an array of FS::acct_snarf records associated with the account.
1177 If the acct_snarf table does not exist or there are no associated records,
1178 an empty list is returned
1179
1180 =cut
1181
1182 sub acct_snarf {
1183   my $self = shift;
1184   return () unless dbdef->table('acct_snarf');
1185   eval "use FS::acct_snarf;";
1186   die $@ if $@;
1187   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1188 }
1189
1190 =item decrement_seconds SECONDS
1191
1192 Decrements the I<seconds> field of this record by the given amount.  If there
1193 is an error, returns the error, otherwise returns false.
1194
1195 =cut
1196
1197 sub decrement_seconds {
1198   shift->_op_seconds('-', @_);
1199 }
1200
1201 =item increment_seconds SECONDS
1202
1203 Increments the I<seconds> field of this record by the given amount.  If there
1204 is an error, returns the error, otherwise returns false.
1205
1206 =cut
1207
1208 sub increment_seconds {
1209   shift->_op_seconds('+', @_);
1210 }
1211
1212
1213 my %op2action = (
1214   '-' => 'suspend',
1215   '+' => 'unsuspend',
1216 );
1217 my %op2condition = (
1218   '-' => sub { my($self, $seconds) = @_;
1219                $self->seconds - $seconds <= 0;
1220              },
1221   '+' => sub { my($self, $seconds) = @_;
1222                $self->seconds + $seconds > 0;
1223              },
1224 );
1225
1226 sub _op_seconds {
1227   my( $self, $op, $seconds ) = @_;
1228   warn "$me _op_seconds called for svcnum ". $self->svcnum.
1229        ' ('. $self->email. "): $op $seconds\n"
1230     if $DEBUG;
1231
1232   local $SIG{HUP} = 'IGNORE';
1233   local $SIG{INT} = 'IGNORE';
1234   local $SIG{QUIT} = 'IGNORE';
1235   local $SIG{TERM} = 'IGNORE';
1236   local $SIG{TSTP} = 'IGNORE';
1237   local $SIG{PIPE} = 'IGNORE';
1238
1239   my $oldAutoCommit = $FS::UID::AutoCommit;
1240   local $FS::UID::AutoCommit = 0;
1241   my $dbh = dbh;
1242
1243   my $sql = "UPDATE svc_acct SET seconds = ".
1244             " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1245             " $op ? WHERE svcnum = ?";
1246   warn "$me $sql\n"
1247     if $DEBUG;
1248
1249   my $sth = $dbh->prepare( $sql )
1250     or die "Error preparing $sql: ". $dbh->errstr;
1251   my $rv = $sth->execute($seconds, $self->svcnum);
1252   die "Error executing $sql: ". $sth->errstr
1253     unless defined($rv);
1254   die "Can't update seconds for svcnum". $self->svcnum
1255     if $rv == 0;
1256
1257   my $action = $op2action{$op};
1258
1259   if ( $conf->exists("svc_acct-usage_$action")
1260        && &{$op2condition{$op}}($self, $seconds)    ) {
1261     #my $error = $self->$action();
1262     my $error = $self->cust_svc->cust_pkg->$action();
1263     if ( $error ) {
1264       $dbh->rollback if $oldAutoCommit;
1265       return "Error ${action}ing: $error";
1266     }
1267   }
1268
1269   warn "$me update sucessful; committing\n"
1270     if $DEBUG;
1271   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1272   '';
1273
1274 }
1275
1276
1277 =item seconds_since TIMESTAMP
1278
1279 Returns the number of seconds this account has been online since TIMESTAMP,
1280 according to the session monitor (see L<FS::Session>).
1281
1282 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1283 L<Time::Local> and L<Date::Parse> for conversion functions.
1284
1285 =cut
1286
1287 #note: POD here, implementation in FS::cust_svc
1288 sub seconds_since {
1289   my $self = shift;
1290   $self->cust_svc->seconds_since(@_);
1291 }
1292
1293 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1294
1295 Returns the numbers of seconds this account has been online between
1296 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1297 external SQL radacct table, specified via sqlradius export.  Sessions which
1298 started in the specified range but are still open are counted from session
1299 start to the end of the range (unless they are over 1 day old, in which case
1300 they are presumed missing their stop record and not counted).  Also, sessions
1301 which end in the range but started earlier are counted from the start of the
1302 range to session end.  Finally, sessions which start before the range but end
1303 after are counted for the entire range.
1304
1305 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1306 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1307 functions.
1308
1309 =cut
1310
1311 #note: POD here, implementation in FS::cust_svc
1312 sub seconds_since_sqlradacct {
1313   my $self = shift;
1314   $self->cust_svc->seconds_since_sqlradacct(@_);
1315 }
1316
1317 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1318
1319 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1320 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1321 TIMESTAMP_END (exclusive).
1322
1323 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1324 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1325 functions.
1326
1327 =cut
1328
1329 #note: POD here, implementation in FS::cust_svc
1330 sub attribute_since_sqlradacct {
1331   my $self = shift;
1332   $self->cust_svc->attribute_since_sqlradacct(@_);
1333 }
1334
1335 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1336
1337 Returns an array of hash references of this customers login history for the
1338 given time range.  (document this better)
1339
1340 =cut
1341
1342 sub get_session_history {
1343   my $self = shift;
1344   $self->cust_svc->get_session_history(@_);
1345 }
1346
1347 =item radius_groups
1348
1349 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1350
1351 =cut
1352
1353 sub radius_groups {
1354   my $self = shift;
1355   if ( $self->usergroup ) {
1356     #when provisioning records, export callback runs in svc_Common.pm before
1357     #radius_usergroup records can be inserted...
1358     @{$self->usergroup};
1359   } else {
1360     map { $_->groupname }
1361       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1362   }
1363 }
1364
1365 =item clone_suspended
1366
1367 Constructor used by FS::part_export::_export_suspend fallback.  Document
1368 better.
1369
1370 =cut
1371
1372 sub clone_suspended {
1373   my $self = shift;
1374   my %hash = $self->hash;
1375   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1376   new FS::svc_acct \%hash;
1377 }
1378
1379 =item clone_kludge_unsuspend
1380
1381 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1382 better.
1383
1384 =cut
1385
1386 sub clone_kludge_unsuspend {
1387   my $self = shift;
1388   my %hash = $self->hash;
1389   $hash{_password} = '';
1390   new FS::svc_acct \%hash;
1391 }
1392
1393 =item check_password
1394
1395 Checks the supplied password against the (possibly encrypted) password in the
1396 database.  Returns true for a sucessful authentication, false for no match.
1397
1398 Currently supported encryptions are: classic DES crypt() and MD5
1399
1400 =cut
1401
1402 sub check_password {
1403   my($self, $check_password) = @_;
1404
1405   #remove old-style SUSPENDED kludge, they should be allowed to login to
1406   #self-service and pay up
1407   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1408
1409   #eventually should check a "password-encoding" field
1410   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1411     return 0;
1412   } elsif ( length($password) < 13 ) { #plaintext
1413     $check_password eq $password;
1414   } elsif ( length($password) == 13 ) { #traditional DES crypt
1415     crypt($check_password, $password) eq $password;
1416   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1417     unix_md5_crypt($check_password, $password) eq $password;
1418   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1419     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1420          $self->svcnum. "\n";
1421     0;
1422   } else {
1423     warn "Can't check password: Unrecognized encryption for svcnum ".
1424          $self->svcnum. "\n";
1425     0;
1426   }
1427
1428 }
1429
1430 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1431
1432 Returns an encrypted password, either by passing through an encrypted password
1433 in the database or by encrypting a plaintext password from the database.
1434
1435 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1436 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1437 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1438 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1439 encryption type is only used if the password is not already encrypted in the
1440 database.
1441
1442 =cut
1443
1444 sub crypt_password {
1445   my $self = shift;
1446   #eventually should check a "password-encoding" field
1447   if ( length($self->_password) == 13
1448        || $self->_password =~ /^\$(1|2a?)\$/
1449        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1450      )
1451   {
1452     $self->_password;
1453   } else {
1454     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1455     if ( $encryption eq 'crypt' ) {
1456       crypt(
1457         $self->_password,
1458         $saltset[int(rand(64))].$saltset[int(rand(64))]
1459       );
1460     } elsif ( $encryption eq 'md5' ) {
1461       unix_md5_crypt( $self->_password );
1462     } elsif ( $encryption eq 'blowfish' ) {
1463       die "unknown encryption method $encryption";
1464     } else {
1465       die "unknown encryption method $encryption";
1466     }
1467   }
1468 }
1469
1470 =item virtual_maildir
1471
1472 Returns $domain/maildirs/$username/
1473
1474 =cut
1475
1476 sub virtual_maildir {
1477   my $self = shift;
1478   $self->domain. '/maildirs/'. $self->username. '/';
1479 }
1480
1481 =back
1482
1483 =head1 SUBROUTINES
1484
1485 =over 4
1486
1487 =item send_email
1488
1489 This is the FS::svc_acct job-queue-able version.  It still uses
1490 FS::Misc::send_email under-the-hood.
1491
1492 =cut
1493
1494 sub send_email {
1495   my %opt = @_;
1496
1497   eval "use FS::Misc qw(send_email)";
1498   die $@ if $@;
1499
1500   $opt{mimetype} ||= 'text/plain';
1501   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1502
1503   my $error = send_email(
1504     'from'         => $opt{from},
1505     'to'           => $opt{to},
1506     'subject'      => $opt{subject},
1507     'content-type' => $opt{mimetype},
1508     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1509   );
1510   die $error if $error;
1511 }
1512
1513 =item check_and_rebuild_fuzzyfiles
1514
1515 =cut
1516
1517 sub check_and_rebuild_fuzzyfiles {
1518   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1519   -e "$dir/svc_acct.username"
1520     or &rebuild_fuzzyfiles;
1521 }
1522
1523 =item rebuild_fuzzyfiles
1524
1525 =cut
1526
1527 sub rebuild_fuzzyfiles {
1528
1529   use Fcntl qw(:flock);
1530
1531   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1532
1533   #username
1534
1535   open(USERNAMELOCK,">>$dir/svc_acct.username")
1536     or die "can't open $dir/svc_acct.username: $!";
1537   flock(USERNAMELOCK,LOCK_EX)
1538     or die "can't lock $dir/svc_acct.username: $!";
1539
1540   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1541
1542   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1543     or die "can't open $dir/svc_acct.username.tmp: $!";
1544   print USERNAMECACHE join("\n", @all_username), "\n";
1545   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1546
1547   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1548   close USERNAMELOCK;
1549
1550 }
1551
1552 =item all_username
1553
1554 =cut
1555
1556 sub all_username {
1557   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1558   open(USERNAMECACHE,"<$dir/svc_acct.username")
1559     or die "can't open $dir/svc_acct.username: $!";
1560   my @array = map { chomp; $_; } <USERNAMECACHE>;
1561   close USERNAMECACHE;
1562   \@array;
1563 }
1564
1565 =item append_fuzzyfiles USERNAME
1566
1567 =cut
1568
1569 sub append_fuzzyfiles {
1570   my $username = shift;
1571
1572   &check_and_rebuild_fuzzyfiles;
1573
1574   use Fcntl qw(:flock);
1575
1576   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1577
1578   open(USERNAME,">>$dir/svc_acct.username")
1579     or die "can't open $dir/svc_acct.username: $!";
1580   flock(USERNAME,LOCK_EX)
1581     or die "can't lock $dir/svc_acct.username: $!";
1582
1583   print USERNAME "$username\n";
1584
1585   flock(USERNAME,LOCK_UN)
1586     or die "can't unlock $dir/svc_acct.username: $!";
1587   close USERNAME;
1588
1589   1;
1590 }
1591
1592
1593
1594 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1595
1596 =cut
1597
1598 sub radius_usergroup_selector {
1599   my $sel_groups = shift;
1600   my %sel_groups = map { $_=>1 } @$sel_groups;
1601
1602   my $selectname = shift || 'radius_usergroup';
1603
1604   my $dbh = dbh;
1605   my $sth = $dbh->prepare(
1606     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1607   ) or die $dbh->errstr;
1608   $sth->execute() or die $sth->errstr;
1609   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1610
1611   my $html = <<END;
1612     <SCRIPT>
1613     function ${selectname}_doadd(object) {
1614       var myvalue = object.${selectname}_add.value;
1615       var optionName = new Option(myvalue,myvalue,false,true);
1616       var length = object.$selectname.length;
1617       object.$selectname.options[length] = optionName;
1618       object.${selectname}_add.value = "";
1619     }
1620     </SCRIPT>
1621     <SELECT MULTIPLE NAME="$selectname">
1622 END
1623
1624   foreach my $group ( @all_groups ) {
1625     $html .= qq(<OPTION VALUE="$group");
1626     if ( $sel_groups{$group} ) {
1627       $html .= ' SELECTED';
1628       $sel_groups{$group} = 0;
1629     }
1630     $html .= ">$group</OPTION>\n";
1631   }
1632   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1633     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1634   };
1635   $html .= '</SELECT>';
1636
1637   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1638            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1639
1640   $html;
1641 }
1642
1643 =back
1644
1645 =head1 BUGS
1646
1647 The $recref stuff in sub check should be cleaned up.
1648
1649 The suspend, unsuspend and cancel methods update the database, but not the
1650 current object.  This is probably a bug as it's unexpected and
1651 counterintuitive.
1652
1653 radius_usergroup_selector?  putting web ui components in here?  they should
1654 probably live somewhere else...
1655
1656 insertion of RADIUS group stuff in insert could be done with child_objects now
1657 (would probably clean up export of them too)
1658
1659 =head1 SEE ALSO
1660
1661 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1662 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1663 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1664 L<freeside-queued>), L<FS::svc_acct_pop>,
1665 schema.html from the base documentation.
1666
1667 =cut
1668
1669 1;
1670