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