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