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              $warning_template $warning_from $warning_subject $warning_mimetype
  13              $warning_cc
  14              $smtpmachine
  15              $radius_password $radius_ip
  16              $dirhash
  17              @saltset @pw_set );
  18 use Carp;
  19 use Fcntl qw(:flock);
  20 use Date::Format;
  21 use Crypt::PasswdMD5 1.2;
  22 use Data::Dumper;
  23 use FS::UID qw( datasrc );
  24 use FS::Conf;
  25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  26 use FS::Msgcat qw(gettext);
  27 use FS::svc_Common;
  28 use FS::cust_svc;
  29 use FS::part_svc;
  30 use FS::svc_acct_pop;
  31 use FS::cust_main_invoice;
  32 use FS::svc_domain;
  33 use FS::raddb;
  34 use FS::queue;
  35 use FS::radius_usergroup;
  36 use FS::export_svc;
  37 use FS::part_export;
  38 use FS::svc_forward;
  39 use FS::svc_www;
  40 use FS::cdr;
  41
  42 @ISA = qw( FS::svc_Common );
  43
  44 $DEBUG = 0;
  45 $me = '[FS::svc_acct]';
  46
  47 #ask FS::UID to run this stuff for us later
  48 $FS::UID::callback{'FS::svc_acct'} = sub {
  49   $conf = new FS::Conf;
  50   $dir_prefix = $conf->config('home');
  51   @shells = $conf->config('shells');
  52   $usernamemin = $conf->config('usernamemin') || 2;
  53   $usernamemax = $conf->config('usernamemax');
  54   $passwordmin = $conf->config('passwordmin') || 6;
  55   $passwordmax = $conf->config('passwordmax') || 8;
  56   $username_letter = $conf->exists('username-letter');
  57   $username_letterfirst = $conf->exists('username-letterfirst');
  58   $username_noperiod = $conf->exists('username-noperiod');
  59   $username_nounderscore = $conf->exists('username-nounderscore');
  60   $username_nodash = $conf->exists('username-nodash');
  61   $username_uppercase = $conf->exists('username-uppercase');
  62   $username_ampersand = $conf->exists('username-ampersand');
  63   $username_percent = $conf->exists('username-percent');
  64   $password_noampersand = $conf->exists('password-noexclamation');
  65   $password_noexclamation = $conf->exists('password-noexclamation');
  66   $dirhash = $conf->config('dirhash') || 0;
  67   if ( $conf->exists('welcome_email') ) {
  68     $welcome_template = new Text::Template (
  69       TYPE   => 'ARRAY',
  70       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  71     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  72     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  73     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  74     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  75   } else {
  76     $welcome_template = '';
  77     $welcome_from = '';
  78     $welcome_subject = '';
  79     $welcome_mimetype = '';
  80   }
  81   if ( $conf->exists('warning_email') ) {
  82     $warning_template = new Text::Template (
  83       TYPE   => 'ARRAY',
  84       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  85     ) or warn "can't create warning email template: $Text::Template::ERROR";
  86     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  87     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  88     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  89     $warning_cc = $conf->config('warning_email-cc');
  90   } else {
  91     $warning_template = '';
  92     $warning_from = '';
  93     $warning_subject = '';
  94     $warning_mimetype = '';
  95     $warning_cc = '';
  96   }
  97   $smtpmachine = $conf->config('smtpmachine');
  98   $radius_password = $conf->config('radius-password') || 'Password';
  99   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
 100 };
 101
 102 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
 103 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
 104
 105 sub _cache {
 106   my $self = shift;
 107   my ( $hashref, $cache ) = @_;
 108   if ( $hashref->{'svc_acct_svcnum'} ) {
 109     $self->{'_domsvc'} = FS::svc_domain->new( {
 110       'svcnum'   => $hashref->{'domsvc'},
 111       'domain'   => $hashref->{'svc_acct_domain'},
 112       'catchall' => $hashref->{'svc_acct_catchall'},
 113     } );
 114   }
 115 }
 116
 117 =head1 NAME
 118
 119 FS::svc_acct - Object methods for svc_acct records
 120
 121 =head1 SYNOPSIS
 122
 123   use FS::svc_acct;
 124
 125   $record = new FS::svc_acct \%hash;
 126   $record = new FS::svc_acct { 'column' => 'value' };
 127
 128   $error = $record->insert;
 129
 130   $error = $new_record->replace($old_record);
 131
 132   $error = $record->delete;
 133
 134   $error = $record->check;
 135
 136   $error = $record->suspend;
 137
 138   $error = $record->unsuspend;
 139
 140   $error = $record->cancel;
 141
 142   %hash = $record->radius;
 143
 144   %hash = $record->radius_reply;
 145
 146   %hash = $record->radius_check;
 147
 148   $domain = $record->domain;
 149
 150   $svc_domain = $record->svc_domain;
 151
 152   $email = $record->email;
 153
 154   $seconds_since = $record->seconds_since($timestamp);
 155
 156 =head1 DESCRIPTION
 157
 158 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 159 FS::svc_Common.  The following fields are currently supported:
 160
 161 =over 4
 162
 163 =item svcnum - primary key (assigned automatcially for new accounts)
 164
 165 =item username
 166
 167 =item _password - generated if blank
 168
 169 =item sec_phrase - security phrase
 170
 171 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 172
 173 =item uid
 174
 175 =item gid
 176
 177 =item finger - GECOS
 178
 179 =item dir - set automatically if blank (and uid is not)
 180
 181 =item shell
 182
 183 =item quota - (unimplementd)
 184
 185 =item slipip - IP address
 186
 187 =item seconds -
 188
 189 =item upbytes -
 190
 191 =item downbytes -
 192
 193 =item totalbytes -
 194
 195 =item domsvc - svcnum from svc_domain
 196
 197 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 198
 199 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 200
 201 =back
 202
 203 =head1 METHODS
 204
 205 =over 4
 206
 207 =item new HASHREF
 208
 209 Creates a new account.  To add the account to the database, see L<"insert">.
 210
 211 =cut
 212
 213 sub table_info {
 214   {
 215     'name'   => 'Account',
 216     'longname_plural' => 'Access accounts and mailboxes',
 217     'sorts' => [ 'username', 'uid', ],
 218     'display_weight' => 10,
 219     'cancel_weight'  => 50,
 220     'fields' => {
 221         'dir'       => 'Home directory',
 222         'uid'       => {
 223                          label     => 'UID',
 224                          def_label => 'UID (set to fixed and blank for no UIDs)',
 225                          type      => 'text',
 226                        },
 227         'slipip'    => 'IP address',
 228     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 229         'popnum'    => {
 230                          label => 'Access number',
 231                          type => 'select',
 232                          select_table => 'svc_acct_pop',
 233                          select_key   => 'popnum',
 234                          select_label => 'city',
 235                        },
 236         'username'  => {
 237                          label => 'Username',
 238                          type => 'text',
 239                          disable_default => 1,
 240                          disable_fixed => 1,
 241                        },
 242         'quota'     => {
 243                          label => 'Quota',
 244                          type => 'text',
 245                          disable_inventory => 1,
 246                        },
 247         '_password' => 'Password',
 248         'gid'       => {
 249                          label     => 'GID',
 250                          def_label => 'GID (when blank, defaults to UID)',
 251                          type      => 'text',
 252                        },
 253         'shell'     => {
 254                          #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
 255                          label    => 'Shell',
 256                          def_label=> 'Shell (set to blank for no shell tracking)',
 257                          type     =>'select',
 258                          select_list => [ $conf->config('shells') ],
 259                          disable_inventory => 1,
 260                        },
 261         'finger'    => 'Real name (GECOS)',
 262         'domsvc'    => {
 263                          label     => 'Domain',
 264                          def_label => 'svcnum from svc_domain',
 265                          type      => 'select',
 266                          select_table => 'svc_domain',
 267                          select_key   => 'svcnum',
 268                          select_label => 'domain',
 269                          disable_inventory => 1,
 270                        },
 271         'usergroup' => {
 272                          label => 'RADIUS groups',
 273                          type  => 'radius_usergroup_selector',
 274                          disable_inventory => 1,
 275                        },
 276         'seconds'   => { label => 'Seconds',
 277                          type  => 'text',
 278                          disable_inventory => 1,
 279                        },
 280     },
 281   };
 282 }
 283
 284 sub table { 'svc_acct'; }
 285
 286 sub _fieldhandlers {
 287   {
 288     #false laziness with edit/svc_acct.cgi
 289     'usergroup' => sub {
 290                          my( $self, $groups ) = @_;
 291                          if ( ref($groups) eq 'ARRAY' ) {
 292                            $groups;
 293                          } elsif ( length($groups) ) {
 294                            [ split(/\s*,\s*/, $groups) ];
 295                          } else {
 296                            [];
 297                          }
 298                        },
 299   };
 300 }
 301
 302 =item search_sql STRING
 303
 304 Class method which returns an SQL fragment to search for the given string.
 305
 306 =cut
 307
 308 sub search_sql {
 309   my( $class, $string ) = @_;
 310   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 311     my( $username, $domain ) = ( $1, $2 );
 312     my $q_username = dbh->quote($username);
 313     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 314     if ( @svc_domain ) {
 315       "svc_acct.username = $q_username AND ( ".
 316         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 317       " )";
 318     } else {
 319       '1 = 0'; #false
 320     }
 321   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 322     ' ( '.
 323       $class->search_sql_field('slipip',   $string ).
 324     ' OR '.
 325       $class->search_sql_field('username', $string ).
 326     ' ) ';
 327   } else {
 328     $class->search_sql_field('username', $string);
 329   }
 330 }
 331
 332 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 333
 334 Returns the "username@domain" string for this account.
 335
 336 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 337 history records.
 338
 339 =cut
 340
 341 sub label {
 342   my $self = shift;
 343   $self->email(@_);
 344 }
 345
 346 =cut
 347
 348 =item insert [ , OPTION => VALUE ... ]
 349
 350 Adds this account to the database.  If there is an error, returns the error,
 351 otherwise returns false.
 352
 353 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 354 defined.  An FS::cust_svc record will be created and inserted.
 355
 356 The additional field I<usergroup> can optionally be defined; if so it should
 357 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 358
 359 The additional field I<child_objects> can optionally be defined; if so it
 360 should contain an arrayref of FS::tablename objects.  They will have their
 361 svcnum fields set and will be inserted after this record, but before any
 362 exports are run.  Each element of the array can also optionally be a
 363 two-element array reference containing the child object and the name of an
 364 alternate field to be filled in with the newly-inserted svcnum, for example
 365 C<[ $svc_forward, 'srcsvc' ]>
 366
 367 Currently available options are: I<depend_jobnum>
 368
 369 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 370 jobnums), all provisioning jobs will have a dependancy on the supplied
 371 jobnum(s) (they will not run until the specific job(s) complete(s)).
 372
 373 (TODOC: L<FS::queue> and L<freeside-queued>)
 374
 375 (TODOC: new exports!)
 376
 377 =cut
 378
 379 sub insert {
 380   my $self = shift;
 381   my %options = @_;
 382
 383   if ( $DEBUG ) {
 384     warn "[$me] insert called on $self: ". Dumper($self).
 385          "\nwith options: ". Dumper(%options);
 386   }
 387
 388   local $SIG{HUP} = 'IGNORE';
 389   local $SIG{INT} = 'IGNORE';
 390   local $SIG{QUIT} = 'IGNORE';
 391   local $SIG{TERM} = 'IGNORE';
 392   local $SIG{TSTP} = 'IGNORE';
 393   local $SIG{PIPE} = 'IGNORE';
 394
 395   my $oldAutoCommit = $FS::UID::AutoCommit;
 396   local $FS::UID::AutoCommit = 0;
 397   my $dbh = dbh;
 398
 399   my $error = $self->check;
 400   return $error if $error;
 401
 402   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 403     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 404     unless ( $cust_svc ) {
 405       $dbh->rollback if $oldAutoCommit;
 406       return "no cust_svc record found for svcnum ". $self->svcnum;
 407     }
 408     $self->pkgnum($cust_svc->pkgnum);
 409     $self->svcpart($cust_svc->svcpart);
 410   }
 411
 412   $error = $self->_check_duplicate;
 413   if ( $error ) {
 414     $dbh->rollback if $oldAutoCommit;
 415     return $error;
 416   }
 417
 418   my @jobnums;
 419   $error = $self->SUPER::insert(
 420     'jobnums'       => \@jobnums,
 421     'child_objects' => $self->child_objects,
 422     %options,
 423   );
 424   if ( $error ) {
 425     $dbh->rollback if $oldAutoCommit;
 426     return $error;
 427   }
 428
 429   if ( $self->usergroup ) {
 430     foreach my $groupname ( @{$self->usergroup} ) {
 431       my $radius_usergroup = new FS::radius_usergroup ( {
 432         svcnum    => $self->svcnum,
 433         groupname => $groupname,
 434       } );
 435       my $error = $radius_usergroup->insert;
 436       if ( $error ) {
 437         $dbh->rollback if $oldAutoCommit;
 438         return $error;
 439       }
 440     }
 441   }
 442
 443   unless ( $skip_fuzzyfiles ) {
 444     $error = $self->queue_fuzzyfiles_update;
 445     if ( $error ) {
 446       $dbh->rollback if $oldAutoCommit;
 447       return "updating fuzzy search cache: $error";
 448     }
 449   }
 450
 451   my $cust_pkg = $self->cust_svc->cust_pkg;
 452
 453   if ( $cust_pkg ) {
 454     my $cust_main = $cust_pkg->cust_main;
 455
 456     if (   $conf->exists('emailinvoiceautoalways')
 457         || $conf->exists('emailinvoiceauto')
 458         && ! $cust_main->invoicing_list_emailonly
 459        ) {
 460       my @invoicing_list = $cust_main->invoicing_list;
 461       push @invoicing_list, $self->email;
 462       $cust_main->invoicing_list(\@invoicing_list);
 463     }
 464
 465     #welcome email
 466     my $to = '';
 467     if ( $welcome_template && $cust_pkg ) {
 468       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 469       if ( $to ) {
 470         my $wqueue = new FS::queue {
 471           'svcnum' => $self->svcnum,
 472           'job'    => 'FS::svc_acct::send_email'
 473         };
 474         my $error = $wqueue->insert(
 475           'to'       => $to,
 476           'from'     => $welcome_from,
 477           'subject'  => $welcome_subject,
 478           'mimetype' => $welcome_mimetype,
 479           'body'     => $welcome_template->fill_in( HASH => {
 480                           'custnum'  => $self->custnum,
 481                           'username' => $self->username,
 482                           'password' => $self->_password,
 483                           'first'    => $cust_main->first,
 484                           'last'     => $cust_main->getfield('last'),
 485                           'pkg'      => $cust_pkg->part_pkg->pkg,
 486                         } ),
 487         );
 488         if ( $error ) {
 489           $dbh->rollback if $oldAutoCommit;
 490           return "error queuing welcome email: $error";
 491         }
 492
 493         if ( $options{'depend_jobnum'} ) {
 494           warn "$me depend_jobnum found; adding to welcome email dependancies"
 495             if $DEBUG;
 496           if ( ref($options{'depend_jobnum'}) ) {
 497             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 498                  "to welcome email dependancies"
 499               if $DEBUG;
 500             push @jobnums, @{ $options{'depend_jobnum'} };
 501           } else {
 502             warn "$me adding job $options{'depend_jobnum'} ".
 503                  "to welcome email dependancies"
 504               if $DEBUG;
 505             push @jobnums, $options{'depend_jobnum'};
 506           }
 507         }
 508
 509         foreach my $jobnum ( @jobnums ) {
 510           my $error = $wqueue->depend_insert($jobnum);
 511           if ( $error ) {
 512             $dbh->rollback if $oldAutoCommit;
 513             return "error queuing welcome email job dependancy: $error";
 514           }
 515         }
 516
 517       }
 518
 519     }
 520
 521   } # if ( $cust_pkg )
 522
 523   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 524   ''; #no error
 525 }
 526
 527 =item delete
 528
 529 Deletes this account from the database.  If there is an error, returns the
 530 error, otherwise returns false.
 531
 532 The corresponding FS::cust_svc record will be deleted as well.
 533
 534 (TODOC: new exports!)
 535
 536 =cut
 537
 538 sub delete {
 539   my $self = shift;
 540
 541   return "can't delete system account" if $self->_check_system;
 542
 543   return "Can't delete an account which is a (svc_forward) source!"
 544     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 545
 546   return "Can't delete an account which is a (svc_forward) destination!"
 547     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 548
 549   return "Can't delete an account with (svc_www) web service!"
 550     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 551
 552   # what about records in session ? (they should refer to history table)
 553
 554   local $SIG{HUP} = 'IGNORE';
 555   local $SIG{INT} = 'IGNORE';
 556   local $SIG{QUIT} = 'IGNORE';
 557   local $SIG{TERM} = 'IGNORE';
 558   local $SIG{TSTP} = 'IGNORE';
 559   local $SIG{PIPE} = 'IGNORE';
 560
 561   my $oldAutoCommit = $FS::UID::AutoCommit;
 562   local $FS::UID::AutoCommit = 0;
 563   my $dbh = dbh;
 564
 565   foreach my $cust_main_invoice (
 566     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 567   ) {
 568     unless ( defined($cust_main_invoice) ) {
 569       warn "WARNING: something's wrong with qsearch";
 570       next;
 571     }
 572     my %hash = $cust_main_invoice->hash;
 573     $hash{'dest'} = $self->email;
 574     my $new = new FS::cust_main_invoice \%hash;
 575     my $error = $new->replace($cust_main_invoice);
 576     if ( $error ) {
 577       $dbh->rollback if $oldAutoCommit;
 578       return $error;
 579     }
 580   }
 581
 582   foreach my $svc_domain (
 583     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 584   ) {
 585     my %hash = new FS::svc_domain->hash;
 586     $hash{'catchall'} = '';
 587     my $new = new FS::svc_domain \%hash;
 588     my $error = $new->replace($svc_domain);
 589     if ( $error ) {
 590       $dbh->rollback if $oldAutoCommit;
 591       return $error;
 592     }
 593   }
 594
 595   foreach my $radius_usergroup (
 596     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 597   ) {
 598     my $error = $radius_usergroup->delete;
 599     if ( $error ) {
 600       $dbh->rollback if $oldAutoCommit;
 601       return $error;
 602     }
 603   }
 604
 605   my $error = $self->SUPER::delete;
 606   if ( $error ) {
 607     $dbh->rollback if $oldAutoCommit;
 608     return $error;
 609   }
 610
 611   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 612   '';
 613 }
 614
 615 =item replace OLD_RECORD
 616
 617 Replaces OLD_RECORD with this one in the database.  If there is an error,
 618 returns the error, otherwise returns false.
 619
 620 The additional field I<usergroup> can optionally be defined; if so it should
 621 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 622
 623
 624 =cut
 625
 626 sub replace {
 627   my ( $new, $old ) = ( shift, shift );
 628   my $error;
 629   warn "$me replacing $old with $new\n" if $DEBUG;
 630
 631   # We absolutely have to have an old vs. new record to make this work.
 632   if (!defined($old)) {
 633     $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
 634   }
 635
 636   return "can't modify system account" if $old->_check_system;
 637
 638   {
 639     #no warnings 'numeric';  #alas, a 5.006-ism
 640     local($^W) = 0;
 641
 642     foreach my $xid (qw( uid gid )) {
 643
 644       return "Can't change $xid!"
 645         if ! $conf->exists("svc_acct-edit_$xid")
 646            && $old->$xid() != $new->$xid()
 647            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 648     }
 649
 650   }
 651
 652   #change homdir when we change username
 653   $new->setfield('dir', '') if $old->username ne $new->username;
 654
 655   local $SIG{HUP} = 'IGNORE';
 656   local $SIG{INT} = 'IGNORE';
 657   local $SIG{QUIT} = 'IGNORE';
 658   local $SIG{TERM} = 'IGNORE';
 659   local $SIG{TSTP} = 'IGNORE';
 660   local $SIG{PIPE} = 'IGNORE';
 661
 662   my $oldAutoCommit = $FS::UID::AutoCommit;
 663   local $FS::UID::AutoCommit = 0;
 664   my $dbh = dbh;
 665
 666   # redundant, but so $new->usergroup gets set
 667   $error = $new->check;
 668   return $error if $error;
 669
 670   $old->usergroup( [ $old->radius_groups ] );
 671   if ( $DEBUG ) {
 672     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 673     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 674   }
 675   if ( $new->usergroup ) {
 676     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 677     my @newgroups = @{$new->usergroup};
 678     foreach my $oldgroup ( @{$old->usergroup} ) {
 679       if ( grep { $oldgroup eq $_ } @newgroups ) {
 680         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 681         next;
 682       }
 683       my $radius_usergroup = qsearchs('radius_usergroup', {
 684         svcnum    => $old->svcnum,
 685         groupname => $oldgroup,
 686       } );
 687       my $error = $radius_usergroup->delete;
 688       if ( $error ) {
 689         $dbh->rollback if $oldAutoCommit;
 690         return "error deleting radius_usergroup $oldgroup: $error";
 691       }
 692     }
 693
 694     foreach my $newgroup ( @newgroups ) {
 695       my $radius_usergroup = new FS::radius_usergroup ( {
 696         svcnum    => $new->svcnum,
 697         groupname => $newgroup,
 698       } );
 699       my $error = $radius_usergroup->insert;
 700       if ( $error ) {
 701         $dbh->rollback if $oldAutoCommit;
 702         return "error adding radius_usergroup $newgroup: $error";
 703       }
 704     }
 705
 706   }
 707
 708   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 709     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 710     $error = $new->_check_duplicate;
 711     if ( $error ) {
 712       $dbh->rollback if $oldAutoCommit;
 713       return $error;
 714     }
 715   }
 716
 717   $error = $new->SUPER::replace($old);
 718   if ( $error ) {
 719     $dbh->rollback if $oldAutoCommit;
 720     return $error if $error;
 721   }
 722
 723   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 724     $error = $new->queue_fuzzyfiles_update;
 725     if ( $error ) {
 726       $dbh->rollback if $oldAutoCommit;
 727       return "updating fuzzy search cache: $error";
 728     }
 729   }
 730
 731   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 732   ''; #no error
 733 }
 734
 735 =item queue_fuzzyfiles_update
 736
 737 Used by insert & replace to update the fuzzy search cache
 738
 739 =cut
 740
 741 sub queue_fuzzyfiles_update {
 742   my $self = shift;
 743
 744   local $SIG{HUP} = 'IGNORE';
 745   local $SIG{INT} = 'IGNORE';
 746   local $SIG{QUIT} = 'IGNORE';
 747   local $SIG{TERM} = 'IGNORE';
 748   local $SIG{TSTP} = 'IGNORE';
 749   local $SIG{PIPE} = 'IGNORE';
 750
 751   my $oldAutoCommit = $FS::UID::AutoCommit;
 752   local $FS::UID::AutoCommit = 0;
 753   my $dbh = dbh;
 754
 755   my $queue = new FS::queue {
 756     'svcnum' => $self->svcnum,
 757     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 758   };
 759   my $error = $queue->insert($self->username);
 760   if ( $error ) {
 761     $dbh->rollback if $oldAutoCommit;
 762     return "queueing job (transaction rolled back): $error";
 763   }
 764
 765   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 766   '';
 767
 768 }
 769
 770
 771 =item suspend
 772
 773 Suspends this account by calling export-specific suspend hooks.  If there is
 774 an error, returns the error, otherwise returns false.
 775
 776 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 777
 778 =cut
 779
 780 sub suspend {
 781   my $self = shift;
 782   return "can't suspend system account" if $self->_check_system;
 783   $self->SUPER::suspend;
 784 }
 785
 786 =item unsuspend
 787
 788 Unsuspends this account by by calling export-specific suspend hooks.  If there
 789 is an error, returns the error, otherwise returns false.
 790
 791 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 792
 793 =cut
 794
 795 sub unsuspend {
 796   my $self = shift;
 797   my %hash = $self->hash;
 798   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 799     $hash{_password} = $1;
 800     my $new = new FS::svc_acct ( \%hash );
 801     my $error = $new->replace($self);
 802     return $error if $error;
 803   }
 804
 805   $self->SUPER::unsuspend;
 806 }
 807
 808 =item cancel
 809
 810 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 811
 812 If the B<auto_unset_catchall> configuration option is set, this method will
 813 automatically remove any references to the canceled service in the catchall
 814 field of svc_domain.  This allows packages that contain both a svc_domain and
 815 its catchall svc_acct to be canceled in one step.
 816
 817 =cut
 818
 819 sub cancel {
 820   # Only one thing to do at this level
 821   my $self = shift;
 822   foreach my $svc_domain (
 823       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 824     if($conf->exists('auto_unset_catchall')) {
 825       my %hash = $svc_domain->hash;
 826       $hash{catchall} = '';
 827       my $new = new FS::svc_domain ( \%hash );
 828       my $error = $new->replace($svc_domain);
 829       return $error if $error;
 830     } else {
 831       return "cannot unprovision svc_acct #".$self->svcnum.
 832           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 833     }
 834   }
 835
 836   $self->SUPER::cancel;
 837 }
 838
 839
 840 =item check
 841
 842 Checks all fields to make sure this is a valid service.  If there is an error,
 843 returns the error, otherwise returns false.  Called by the insert and replace
 844 methods.
 845
 846 Sets any fixed values; see L<FS::part_svc>.
 847
 848 =cut
 849
 850 sub check {
 851   my $self = shift;
 852
 853   my($recref) = $self->hashref;
 854
 855   my $x = $self->setfixed( $self->_fieldhandlers );
 856   return $x unless ref($x);
 857   my $part_svc = $x;
 858
 859   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 860     $self->usergroup(
 861       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 862   }
 863
 864   my $error = $self->ut_numbern('svcnum')
 865               #|| $self->ut_number('domsvc')
 866               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 867               || $self->ut_textn('sec_phrase')
 868               || $self->ut_snumbern('seconds')
 869               || $self->ut_snumbern('upbytes')
 870               || $self->ut_snumbern('downbytes')
 871               || $self->ut_snumbern('totalbytes')
 872   ;
 873   return $error if $error;
 874
 875   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 876   if ( $username_uppercase ) {
 877     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
 878       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 879     $recref->{username} = $1;
 880   } else {
 881     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
 882       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 883     $recref->{username} = $1;
 884   }
 885
 886   if ( $username_letterfirst ) {
 887     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 888   } elsif ( $username_letter ) {
 889     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 890   }
 891   if ( $username_noperiod ) {
 892     $recref->{username} =~ /\./ and return gettext('illegal_username');
 893   }
 894   if ( $username_nounderscore ) {
 895     $recref->{username} =~ /_/ and return gettext('illegal_username');
 896   }
 897   if ( $username_nodash ) {
 898     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 899   }
 900   unless ( $username_ampersand ) {
 901     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 902   }
 903   if ( $password_noampersand ) {
 904     $recref->{_password} =~ /\&/ and return gettext('illegal_password');
 905   }
 906   if ( $password_noexclamation ) {
 907     $recref->{_password} =~ /\!/ and return gettext('illegal_password');
 908   }
 909   unless ( $username_percent ) {
 910     $recref->{username} =~ /\%/ and return gettext('illegal_username');
 911   }
 912
 913   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 914   $recref->{popnum} = $1;
 915   return "Unknown popnum" unless
 916     ! $recref->{popnum} ||
 917     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 918
 919   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 920
 921     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 922     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 923
 924     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 925     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 926     #not all systems use gid=uid
 927     #you can set a fixed gid in part_svc
 928
 929     return "Only root can have uid 0"
 930       if $recref->{uid} == 0
 931          && $recref->{username} !~ /^(root|toor|smtp)$/;
 932
 933     unless ( $recref->{username} eq 'sync' ) {
 934       if ( grep $_ eq $recref->{shell}, @shells ) {
 935         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 936       } else {
 937         return "Illegal shell \`". $self->shell. "\'; ".
 938                $conf->dir. "/shells contains: @shells";
 939       }
 940     } else {
 941       $recref->{shell} = '/bin/sync';
 942     }
 943
 944   } else {
 945     $recref->{gid} ne '' ?
 946       return "Can't have gid without uid" : ( $recref->{gid}='' );
 947     #$recref->{dir} ne '' ?
 948     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
 949     $recref->{shell} ne '' ?
 950       return "Can't have shell without uid" : ( $recref->{shell}='' );
 951   }
 952
 953   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
 954
 955     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 956       or return "Illegal directory: ". $recref->{dir};
 957     $recref->{dir} = $1;
 958     return "Illegal directory"
 959       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 960     return "Illegal directory"
 961       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 962     unless ( $recref->{dir} ) {
 963       $recref->{dir} = $dir_prefix . '/';
 964       if ( $dirhash > 0 ) {
 965         for my $h ( 1 .. $dirhash ) {
 966           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 967         }
 968       } elsif ( $dirhash < 0 ) {
 969         for my $h ( reverse $dirhash .. -1 ) {
 970           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 971         }
 972       }
 973       $recref->{dir} .= $recref->{username};
 974     ;
 975     }
 976
 977   }
 978
 979   #  $error = $self->ut_textn('finger');
 980   #  return $error if $error;
 981   if ( $self->getfield('finger') eq '' ) {
 982     my $cust_pkg = $self->svcnum
 983       ? $self->cust_svc->cust_pkg
 984       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
 985     if ( $cust_pkg ) {
 986       my $cust_main = $cust_pkg->cust_main;
 987       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
 988     }
 989   }
 990   $self->getfield('finger') =~
 991     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 992       or return "Illegal finger: ". $self->getfield('finger');
 993   $self->setfield('finger', $1);
 994
 995   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 996   $recref->{quota} = $1;
 997
 998   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 999     if ( $recref->{slipip} eq '' ) {
1000       $recref->{slipip} = '';
1001     } elsif ( $recref->{slipip} eq '0e0' ) {
1002       $recref->{slipip} = '0e0';
1003     } else {
1004       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1005         or return "Illegal slipip: ". $self->slipip;
1006       $recref->{slipip} = $1;
1007     }
1008
1009   }
1010
1011   #arbitrary RADIUS stuff; allow ut_textn for now
1012   foreach ( grep /^radius_/, fields('svc_acct') ) {
1013     $self->ut_textn($_);
1014   }
1015
1016   #generate a password if it is blank
1017   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1018     unless ( $recref->{_password} );
1019
1020   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1021   if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1022     $recref->{_password} = $1.$3;
1023     #uncomment this to encrypt password immediately upon entry, or run
1024     #bin/crypt_pw in cron to give new users a window during which their
1025     #password is available to techs, for faxing, etc.  (also be aware of
1026     #radius issues!)
1027     #$recref->{password} = $1.
1028     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
1029     #;
1030   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1031     $recref->{_password} = $1.$3;
1032   } elsif ( $recref->{_password} eq '*' ) {
1033     $recref->{_password} = '*';
1034   } elsif ( $recref->{_password} eq '!' ) {
1035     $recref->{_password} = '!';
1036   } elsif ( $recref->{_password} eq '!!' ) {
1037     $recref->{_password} = '!!';
1038   } else {
1039     #return "Illegal password";
1040     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1041            FS::Msgcat::_gettext('illegal_password_characters').
1042            ": ". $recref->{_password};
1043   }
1044
1045   $self->SUPER::check;
1046 }
1047
1048 =item _check_system
1049
1050 Internal function to check the username against the list of system usernames
1051 from the I<system_usernames> configuration value.  Returns true if the username
1052 is listed on the system username list.
1053
1054 =cut
1055
1056 sub _check_system {
1057   my $self = shift;
1058   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1059                $conf->config('system_usernames')
1060         );
1061 }
1062
1063 =item _check_duplicate
1064
1065 Internal function to check for duplicates usernames, username@domain pairs and
1066 uids.
1067
1068 If the I<global_unique-username> configuration value is set to B<username> or
1069 B<username@domain>, enforces global username or username@domain uniqueness.
1070
1071 In all cases, check for duplicate uids and usernames or username@domain pairs
1072 per export and with identical I<svcpart> values.
1073
1074 =cut
1075
1076 sub _check_duplicate {
1077   my $self = shift;
1078
1079   my $global_unique = $conf->config('global_unique-username') || 'none';
1080   return '' if $global_unique eq 'disabled';
1081
1082   #this is Pg-specific.  what to do for mysql etc?
1083   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
1084   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1085   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1086     or die dbh->errstr;
1087   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1088
1089   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1090   unless ( $part_svc ) {
1091     return 'unknown svcpart '. $self->svcpart;
1092   }
1093
1094   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1095                  qsearch( 'svc_acct', { 'username' => $self->username } );
1096   return gettext('username_in_use')
1097     if $global_unique eq 'username' && @dup_user;
1098
1099   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1100                        qsearch( 'svc_acct', { 'username' => $self->username,
1101                                               'domsvc'   => $self->domsvc } );
1102   return gettext('username_in_use')
1103     if $global_unique eq 'username@domain' && @dup_userdomain;
1104
1105   my @dup_uid;
1106   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1107        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1108     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1109                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1110   } else {
1111     @dup_uid = ();
1112   }
1113
1114   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1115     my $exports = FS::part_export::export_info('svc_acct');
1116     my %conflict_user_svcpart;
1117     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1118
1119     foreach my $part_export ( $part_svc->part_export ) {
1120
1121       #this will catch to the same exact export
1122       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1123
1124       #this will catch to exports w/same exporthost+type ???
1125       #my @other_part_export = qsearch('part_export', {
1126       #  'machine'    => $part_export->machine,
1127       #  'exporttype' => $part_export->exporttype,
1128       #} );
1129       #foreach my $other_part_export ( @other_part_export ) {
1130       #  push @svcparts, map { $_->svcpart }
1131       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1132       #}
1133
1134       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1135       #silly kludge to avoid uninitialized value errors
1136       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1137                      ? $exports->{$part_export->exporttype}{'nodomain'}
1138                      : '';
1139       if ( $nodomain =~ /^Y/i ) {
1140         $conflict_user_svcpart{$_} = $part_export->exportnum
1141           foreach @svcparts;
1142       } else {
1143         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1144           foreach @svcparts;
1145       }
1146     }
1147
1148     foreach my $dup_user ( @dup_user ) {
1149       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1150       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1151         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1152                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1153       }
1154     }
1155
1156     foreach my $dup_userdomain ( @dup_userdomain ) {
1157       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1158       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1159         return "duplicate username\@domain: conflicts with svcnum ".
1160                $dup_userdomain->svcnum. " via exportnum ".
1161                $conflict_userdomain_svcpart{$dup_svcpart};
1162       }
1163     }
1164
1165     foreach my $dup_uid ( @dup_uid ) {
1166       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1167       if ( exists($conflict_user_svcpart{$dup_svcpart})
1168            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1169         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1170                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1171                                  || $conflict_userdomain_svcpart{$dup_svcpart};
1172       }
1173     }
1174
1175   }
1176
1177   return '';
1178
1179 }
1180
1181 =item radius
1182
1183 Depriciated, use radius_reply instead.
1184
1185 =cut
1186
1187 sub radius {
1188   carp "FS::svc_acct::radius depriciated, use radius_reply";
1189   $_[0]->radius_reply;
1190 }
1191
1192 =item radius_reply
1193
1194 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1195 reply attributes of this record.
1196
1197 Note that this is now the preferred method for reading RADIUS attributes -
1198 accessing the columns directly is discouraged, as the column names are
1199 expected to change in the future.
1200
1201 =cut
1202
1203 sub radius_reply {
1204   my $self = shift;
1205
1206   return %{ $self->{'radius_reply'} }
1207     if exists $self->{'radius_reply'};
1208
1209   my %reply =
1210     map {
1211       /^(radius_(.*))$/;
1212       my($column, $attrib) = ($1, $2);
1213       #$attrib =~ s/_/\-/g;
1214       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1215     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1216
1217   if ( $self->slipip && $self->slipip ne '0e0' ) {
1218     $reply{$radius_ip} = $self->slipip;
1219   }
1220
1221   if ( $self->seconds !~ /^$/ ) {
1222     $reply{'Session-Timeout'} = $self->seconds;
1223   }
1224
1225   %reply;
1226 }
1227
1228 =item radius_check
1229
1230 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1231 check attributes of this record.
1232
1233 Note that this is now the preferred method for reading RADIUS attributes -
1234 accessing the columns directly is discouraged, as the column names are
1235 expected to change in the future.
1236
1237 =cut
1238
1239 sub radius_check {
1240   my $self = shift;
1241
1242   return %{ $self->{'radius_check'} }
1243     if exists $self->{'radius_check'};
1244
1245   my %check =
1246     map {
1247       /^(rc_(.*))$/;
1248       my($column, $attrib) = ($1, $2);
1249       #$attrib =~ s/_/\-/g;
1250       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1251     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1252
1253   my $password = $self->_password;
1254   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1255
1256   my $cust_svc = $self->cust_svc;
1257   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1258     unless $cust_svc;
1259   my $cust_pkg = $cust_svc->cust_pkg;
1260   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1261     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1262   }
1263
1264   %check;
1265
1266 }
1267
1268 =item snapshot
1269
1270 This method instructs the object to "snapshot" or freeze RADIUS check and
1271 reply attributes to the current values.
1272
1273 =cut
1274
1275 #bah, my english is too broken this morning
1276 #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
1277 #the FS::cust_pkg's replace method to trigger the correct export updates when
1278 #package dates change)
1279
1280 sub snapshot {
1281   my $self = shift;
1282
1283   $self->{$_} = { $self->$_() }
1284     foreach qw( radius_reply radius_check );
1285
1286 }
1287
1288 =item forget_snapshot
1289
1290 This methos instructs the object to forget any previously snapshotted
1291 RADIUS check and reply attributes.
1292
1293 =cut
1294
1295 sub forget_snapshot {
1296   my $self = shift;
1297
1298   delete $self->{$_}
1299     foreach qw( radius_reply radius_check );
1300
1301 }
1302
1303 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1304
1305 Returns the domain associated with this account.
1306
1307 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1308 history records.
1309
1310 =cut
1311
1312 sub domain {
1313   my $self = shift;
1314   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1315   my $svc_domain = $self->svc_domain(@_)
1316     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1317   $svc_domain->domain;
1318 }
1319
1320 =item svc_domain
1321
1322 Returns the FS::svc_domain record for this account's domain (see
1323 L<FS::svc_domain>).
1324
1325 =cut
1326
1327 # FS::h_svc_acct has a history-aware svc_domain override
1328
1329 sub svc_domain {
1330   my $self = shift;
1331   $self->{'_domsvc'}
1332     ? $self->{'_domsvc'}
1333     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1334 }
1335
1336 =item cust_svc
1337
1338 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1339
1340 =cut
1341
1342 #inherited from svc_Common
1343
1344 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1345
1346 Returns an email address associated with the account.
1347
1348 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1349 history records.
1350
1351 =cut
1352
1353 sub email {
1354   my $self = shift;
1355   $self->username. '@'. $self->domain(@_);
1356 }
1357
1358 =item acct_snarf
1359
1360 Returns an array of FS::acct_snarf records associated with the account.
1361 If the acct_snarf table does not exist or there are no associated records,
1362 an empty list is returned
1363
1364 =cut
1365
1366 sub acct_snarf {
1367   my $self = shift;
1368   return () unless dbdef->table('acct_snarf');
1369   eval "use FS::acct_snarf;";
1370   die $@ if $@;
1371   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1372 }
1373
1374 =item decrement_upbytes OCTETS
1375
1376 Decrements the I<upbytes> field of this record by the given amount.  If there
1377 is an error, returns the error, otherwise returns false.
1378
1379 =cut
1380
1381 sub decrement_upbytes {
1382   shift->_op_usage('-', 'upbytes', @_);
1383 }
1384
1385 =item increment_upbytes OCTETS
1386
1387 Increments the I<upbytes> field of this record by the given amount.  If there
1388 is an error, returns the error, otherwise returns false.
1389
1390 =cut
1391
1392 sub increment_upbytes {
1393   shift->_op_usage('+', 'upbytes', @_);
1394 }
1395
1396 =item decrement_downbytes OCTETS
1397
1398 Decrements the I<downbytes> field of this record by the given amount.  If there
1399 is an error, returns the error, otherwise returns false.
1400
1401 =cut
1402
1403 sub decrement_downbytes {
1404   shift->_op_usage('-', 'downbytes', @_);
1405 }
1406
1407 =item increment_downbytes OCTETS
1408
1409 Increments the I<downbytes> field of this record by the given amount.  If there
1410 is an error, returns the error, otherwise returns false.
1411
1412 =cut
1413
1414 sub increment_downbytes {
1415   shift->_op_usage('+', 'downbytes', @_);
1416 }
1417
1418 =item decrement_totalbytes OCTETS
1419
1420 Decrements the I<totalbytes> field of this record by the given amount.  If there
1421 is an error, returns the error, otherwise returns false.
1422
1423 =cut
1424
1425 sub decrement_totalbytes {
1426   shift->_op_usage('-', 'totalbytes', @_);
1427 }
1428
1429 =item increment_totalbytes OCTETS
1430
1431 Increments the I<totalbytes> field of this record by the given amount.  If there
1432 is an error, returns the error, otherwise returns false.
1433
1434 =cut
1435
1436 sub increment_totalbytes {
1437   shift->_op_usage('+', 'totalbytes', @_);
1438 }
1439
1440 =item decrement_seconds SECONDS
1441
1442 Decrements the I<seconds> field of this record by the given amount.  If there
1443 is an error, returns the error, otherwise returns false.
1444
1445 =cut
1446
1447 sub decrement_seconds {
1448   shift->_op_usage('-', 'seconds', @_);
1449 }
1450
1451 =item increment_seconds SECONDS
1452
1453 Increments the I<seconds> field of this record by the given amount.  If there
1454 is an error, returns the error, otherwise returns false.
1455
1456 =cut
1457
1458 sub increment_seconds {
1459   shift->_op_usage('+', 'seconds', @_);
1460 }
1461
1462
1463 my %op2action = (
1464   '-' => 'suspend',
1465   '+' => 'unsuspend',
1466 );
1467 my %op2condition = (
1468   '-' => sub { my($self, $column, $amount) = @_;
1469                $self->$column - $amount <= 0;
1470              },
1471   '+' => sub { my($self, $column, $amount) = @_;
1472                $self->$column + $amount > 0;
1473              },
1474 );
1475 my %op2warncondition = (
1476   '-' => sub { my($self, $column, $amount) = @_;
1477                my $threshold = $column . '_threshold';
1478                $self->$column - $amount <= $self->$threshold + 0;
1479              },
1480   '+' => sub { my($self, $column, $amount) = @_;
1481                $self->$column + $amount > 0;
1482              },
1483 );
1484
1485 sub _op_usage {
1486   my( $self, $op, $column, $amount ) = @_;
1487
1488   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1489        ' ('. $self->email. "): $op $amount\n"
1490     if $DEBUG;
1491
1492   return '' unless $amount;
1493
1494   local $SIG{HUP} = 'IGNORE';
1495   local $SIG{INT} = 'IGNORE';
1496   local $SIG{QUIT} = 'IGNORE';
1497   local $SIG{TERM} = 'IGNORE';
1498   local $SIG{TSTP} = 'IGNORE';
1499   local $SIG{PIPE} = 'IGNORE';
1500
1501   my $oldAutoCommit = $FS::UID::AutoCommit;
1502   local $FS::UID::AutoCommit = 0;
1503   my $dbh = dbh;
1504
1505   my $sql = "UPDATE svc_acct SET $column = ".
1506             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1507             " $op ? WHERE svcnum = ?";
1508   warn "$me $sql\n"
1509     if $DEBUG;
1510
1511   my $sth = $dbh->prepare( $sql )
1512     or die "Error preparing $sql: ". $dbh->errstr;
1513   my $rv = $sth->execute($amount, $self->svcnum);
1514   die "Error executing $sql: ". $sth->errstr
1515     unless defined($rv);
1516   die "Can't update $column for svcnum". $self->svcnum
1517     if $rv == 0;
1518
1519   my $action = $op2action{$op};
1520
1521   if ( &{$op2condition{$op}}($self, $column, $amount) ) {
1522     my $cust_pkg = $self->cust_svc->cust_pkg;
1523     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1524       if ($part_export->option('overlimit_groups')) {
1525         my ($new,$old);
1526         my $other = new FS::svc_acct $self->hashref;
1527         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1528                        ($self, $part_export->option('overlimit_groups'));
1529         $other->usergroup( $groups );
1530         if ($action eq 'suspend'){
1531           $new = $other; $old = $self;
1532         }else{
1533           $new = $self; $old = $other;
1534         }
1535         my $error = $part_export->export_replace($new, $old);
1536         if ( $error ) {
1537           $dbh->rollback if $oldAutoCommit;
1538           return "Error replacing radius groups in export, ${op}: $error";
1539         }
1540       }
1541     }
1542   }
1543
1544   if ( $conf->exists("svc_acct-usage_$action")
1545        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1546     #my $error = $self->$action();
1547     my $error = $self->cust_svc->cust_pkg->$action();
1548     if ( $error ) {
1549       $dbh->rollback if $oldAutoCommit;
1550       return "Error ${action}ing: $error";
1551     }
1552   }
1553
1554   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1555     my $wqueue = new FS::queue {
1556       'svcnum' => $self->svcnum,
1557       'job'    => 'FS::svc_acct::reached_threshold',
1558     };
1559
1560     my $to = '';
1561     if ($op eq '-'){
1562       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1563     }
1564
1565     # x_threshold race
1566     my $error = $wqueue->insert(
1567       'svcnum' => $self->svcnum,
1568       'op'     => $op,
1569       'column' => $column,
1570       'to'     => $to,
1571     );
1572     if ( $error ) {
1573       $dbh->rollback if $oldAutoCommit;
1574       return "Error queuing threshold activity: $error";
1575     }
1576   }
1577
1578   warn "$me update successful; committing\n"
1579     if $DEBUG;
1580   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1581   '';
1582
1583 }
1584
1585 sub set_usage {
1586   my( $self, $valueref ) = @_;
1587
1588   warn "$me set_usage called for svcnum ". $self->svcnum.
1589        ' ('. $self->email. "): ".
1590        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1591     if $DEBUG;
1592
1593   local $SIG{HUP} = 'IGNORE';
1594   local $SIG{INT} = 'IGNORE';
1595   local $SIG{QUIT} = 'IGNORE';
1596   local $SIG{TERM} = 'IGNORE';
1597   local $SIG{TSTP} = 'IGNORE';
1598   local $SIG{PIPE} = 'IGNORE';
1599
1600   local $FS::svc_Common::noexport_hack = 1;
1601   my $oldAutoCommit = $FS::UID::AutoCommit;
1602   local $FS::UID::AutoCommit = 0;
1603   my $dbh = dbh;
1604
1605   my $reset = 0;
1606   foreach my $field (keys %$valueref){
1607     $reset = 1 if $valueref->{$field};
1608     $self->setfield($field, $valueref->{$field});
1609     $self->setfield( $field.'_threshold',
1610                      int($self->getfield($field)
1611                          * ( $conf->exists('svc_acct-usage_threshold')
1612                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1613                              : 0.20
1614                            )
1615                        )
1616                      );
1617   }
1618   my $error = $self->replace;
1619   die $error if $error;
1620
1621   if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) {
1622     my $error = $self->cust_svc->cust_pkg->unsuspend;
1623     if ( $error ) {
1624       $dbh->rollback if $oldAutoCommit;
1625       return "Error unsuspending: $error";
1626     }
1627   }
1628
1629   warn "$me update successful; committing\n"
1630     if $DEBUG;
1631   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1632   '';
1633
1634 }
1635
1636
1637 =item recharge HASHREF
1638
1639   Increments usage columns by the amount specified in HASHREF as
1640   column=>amount pairs.
1641
1642 =cut
1643
1644 sub recharge {
1645   my ($self, $vhash) = @_;
1646
1647   if ( $DEBUG ) {
1648     warn "[$me] recharge called on $self: ". Dumper($self).
1649          "\nwith vhash: ". Dumper($vhash);
1650   }
1651
1652   my $oldAutoCommit = $FS::UID::AutoCommit;
1653   local $FS::UID::AutoCommit = 0;
1654   my $dbh = dbh;
1655   my $error = '';
1656
1657   foreach my $column (keys %$vhash){
1658     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1659   }
1660
1661   if ( $error ) {
1662     $dbh->rollback if $oldAutoCommit;
1663   }else{
1664     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1665   }
1666   return $error;
1667 }
1668
1669 =item is_rechargeable
1670
1671 Returns true if this svc_account can be "recharged" and false otherwise.
1672
1673 =cut
1674
1675 sub is_rechargable {
1676   my $self = shift;
1677   $self->seconds ne ''
1678     || $self->upbytes ne ''
1679     || $self->downbytes ne ''
1680     || $self->totalbytes ne '';
1681 }
1682
1683 =item seconds_since TIMESTAMP
1684
1685 Returns the number of seconds this account has been online since TIMESTAMP,
1686 according to the session monitor (see L<FS::Session>).
1687
1688 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1689 L<Time::Local> and L<Date::Parse> for conversion functions.
1690
1691 =cut
1692
1693 #note: POD here, implementation in FS::cust_svc
1694 sub seconds_since {
1695   my $self = shift;
1696   $self->cust_svc->seconds_since(@_);
1697 }
1698
1699 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1700
1701 Returns the numbers of seconds this account has been online between
1702 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1703 external SQL radacct table, specified via sqlradius export.  Sessions which
1704 started in the specified range but are still open are counted from session
1705 start to the end of the range (unless they are over 1 day old, in which case
1706 they are presumed missing their stop record and not counted).  Also, sessions
1707 which end in the range but started earlier are counted from the start of the
1708 range to session end.  Finally, sessions which start before the range but end
1709 after are counted for the entire range.
1710
1711 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1712 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1713 functions.
1714
1715 =cut
1716
1717 #note: POD here, implementation in FS::cust_svc
1718 sub seconds_since_sqlradacct {
1719   my $self = shift;
1720   $self->cust_svc->seconds_since_sqlradacct(@_);
1721 }
1722
1723 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1724
1725 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1726 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1727 TIMESTAMP_END (exclusive).
1728
1729 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1730 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1731 functions.
1732
1733 =cut
1734
1735 #note: POD here, implementation in FS::cust_svc
1736 sub attribute_since_sqlradacct {
1737   my $self = shift;
1738   $self->cust_svc->attribute_since_sqlradacct(@_);
1739 }
1740
1741 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1742
1743 Returns an array of hash references of this customers login history for the
1744 given time range.  (document this better)
1745
1746 =cut
1747
1748 sub get_session_history {
1749   my $self = shift;
1750   $self->cust_svc->get_session_history(@_);
1751 }
1752
1753 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1754
1755 =cut
1756
1757 sub get_cdrs {
1758   my($self, $start, $end, %opt ) = @_;
1759
1760   my $did = $self->username; #yup
1761
1762   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1763
1764   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1765
1766   #SELECT $for_update * FROM cdr
1767   #  WHERE calldate >= $start #need a conversion
1768   #    AND calldate <  $end   #ditto
1769   #    AND (    charged_party = "$did"
1770   #          OR charged_party = "$prefix$did" #if length($prefix);
1771   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1772   #               AND
1773   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1774   #             )
1775   #        )
1776   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1777
1778   my $charged_or_src;
1779   if ( length($prefix) ) {
1780     $charged_or_src =
1781       " AND (    charged_party = '$did'
1782               OR charged_party = '$prefix$did'
1783               OR ( ( charged_party IS NULL OR charged_party = '' )
1784                    AND
1785                    ( src = '$did' OR src = '$prefix$did' )
1786                  )
1787             )
1788       ";
1789   } else {
1790     $charged_or_src =
1791       " AND (    charged_party = '$did'
1792               OR ( ( charged_party IS NULL OR charged_party = '' )
1793                    AND
1794                    src = '$did'
1795                  )
1796             )
1797       ";
1798
1799   }
1800
1801   qsearch(
1802     'select'    => "$for_update *",
1803     'table'     => 'cdr',
1804     'hashref'   => {
1805                      #( freesidestatus IS NULL OR freesidestatus = '' )
1806                      'freesidestatus' => '',
1807                    },
1808     'extra_sql' => $charged_or_src,
1809
1810   );
1811
1812 }
1813
1814 =item radius_groups
1815
1816 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1817
1818 =cut
1819
1820 sub radius_groups {
1821   my $self = shift;
1822   if ( $self->usergroup ) {
1823     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1824       unless ref($self->usergroup) eq 'ARRAY';
1825     #when provisioning records, export callback runs in svc_Common.pm before
1826     #radius_usergroup records can be inserted...
1827     @{$self->usergroup};
1828   } else {
1829     map { $_->groupname }
1830       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1831   }
1832 }
1833
1834 =item clone_suspended
1835
1836 Constructor used by FS::part_export::_export_suspend fallback.  Document
1837 better.
1838
1839 =cut
1840
1841 sub clone_suspended {
1842   my $self = shift;
1843   my %hash = $self->hash;
1844   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1845   new FS::svc_acct \%hash;
1846 }
1847
1848 =item clone_kludge_unsuspend
1849
1850 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1851 better.
1852
1853 =cut
1854
1855 sub clone_kludge_unsuspend {
1856   my $self = shift;
1857   my %hash = $self->hash;
1858   $hash{_password} = '';
1859   new FS::svc_acct \%hash;
1860 }
1861
1862 =item check_password
1863
1864 Checks the supplied password against the (possibly encrypted) password in the
1865 database.  Returns true for a successful authentication, false for no match.
1866
1867 Currently supported encryptions are: classic DES crypt() and MD5
1868
1869 =cut
1870
1871 sub check_password {
1872   my($self, $check_password) = @_;
1873
1874   #remove old-style SUSPENDED kludge, they should be allowed to login to
1875   #self-service and pay up
1876   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1877
1878   #eventually should check a "password-encoding" field
1879   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1880     return 0;
1881   } elsif ( length($password) < 13 ) { #plaintext
1882     $check_password eq $password;
1883   } elsif ( length($password) == 13 ) { #traditional DES crypt
1884     crypt($check_password, $password) eq $password;
1885   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1886     unix_md5_crypt($check_password, $password) eq $password;
1887   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1888     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1889          $self->svcnum. "\n";
1890     0;
1891   } else {
1892     warn "Can't check password: Unrecognized encryption for svcnum ".
1893          $self->svcnum. "\n";
1894     0;
1895   }
1896
1897 }
1898
1899 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1900
1901 Returns an encrypted password, either by passing through an encrypted password
1902 in the database or by encrypting a plaintext password from the database.
1903
1904 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1905 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1906 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1907 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1908 encryption type is only used if the password is not already encrypted in the
1909 database.
1910
1911 =cut
1912
1913 sub crypt_password {
1914   my $self = shift;
1915   #eventually should check a "password-encoding" field
1916   if ( length($self->_password) == 13
1917        || $self->_password =~ /^\$(1|2a?)\$/
1918        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1919      )
1920   {
1921     $self->_password;
1922   } else {
1923     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1924     if ( $encryption eq 'crypt' ) {
1925       crypt(
1926         $self->_password,
1927         $saltset[int(rand(64))].$saltset[int(rand(64))]
1928       );
1929     } elsif ( $encryption eq 'md5' ) {
1930       unix_md5_crypt( $self->_password );
1931     } elsif ( $encryption eq 'blowfish' ) {
1932       croak "unknown encryption method $encryption";
1933     } else {
1934       croak "unknown encryption method $encryption";
1935     }
1936   }
1937 }
1938
1939 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
1940
1941 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
1942 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
1943 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
1944
1945 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
1946 to work the same as the B</crypt_password> method.
1947
1948 =cut
1949
1950 sub ldap_password {
1951   my $self = shift;
1952   #eventually should check a "password-encoding" field
1953   if ( length($self->_password) == 13 ) { #crypt
1954     return '{CRYPT}'. $self->_password;
1955   } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
1956     return '{MD5}'. $1;
1957   } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
1958     die "Blowfish encryption not supported in this context, svcnum ".
1959         $self->svcnum. "\n";
1960   } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
1961     return '{SSHA}'. $1;
1962   } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
1963     return '{NS-MTA-MD5}'. $1;
1964   } else { #plaintext
1965     return '{PLAIN}'. $self->_password;
1966     #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1967     #if ( $encryption eq 'crypt' ) {
1968     #  return '{CRYPT}'. crypt(
1969     #    $self->_password,
1970     #    $saltset[int(rand(64))].$saltset[int(rand(64))]
1971     #  );
1972     #} elsif ( $encryption eq 'md5' ) {
1973     #  unix_md5_crypt( $self->_password );
1974     #} elsif ( $encryption eq 'blowfish' ) {
1975     #  croak "unknown encryption method $encryption";
1976     #} else {
1977     #  croak "unknown encryption method $encryption";
1978     #}
1979   }
1980 }
1981
1982 =item domain_slash_username
1983
1984 Returns $domain/$username/
1985
1986 =cut
1987
1988 sub domain_slash_username {
1989   my $self = shift;
1990   $self->domain. '/'. $self->username. '/';
1991 }
1992
1993 =item virtual_maildir
1994
1995 Returns $domain/maildirs/$username/
1996
1997 =cut
1998
1999 sub virtual_maildir {
2000   my $self = shift;
2001   $self->domain. '/maildirs/'. $self->username. '/';
2002 }
2003
2004 =back
2005
2006 =head1 SUBROUTINES
2007
2008 =over 4
2009
2010 =item send_email
2011
2012 This is the FS::svc_acct job-queue-able version.  It still uses
2013 FS::Misc::send_email under-the-hood.
2014
2015 =cut
2016
2017 sub send_email {
2018   my %opt = @_;
2019
2020   eval "use FS::Misc qw(send_email)";
2021   die $@ if $@;
2022
2023   $opt{mimetype} ||= 'text/plain';
2024   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2025
2026   my $error = send_email(
2027     'from'         => $opt{from},
2028     'to'           => $opt{to},
2029     'subject'      => $opt{subject},
2030     'content-type' => $opt{mimetype},
2031     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2032   );
2033   die $error if $error;
2034 }
2035
2036 =item check_and_rebuild_fuzzyfiles
2037
2038 =cut
2039
2040 sub check_and_rebuild_fuzzyfiles {
2041   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2042   -e "$dir/svc_acct.username"
2043     or &rebuild_fuzzyfiles;
2044 }
2045
2046 =item rebuild_fuzzyfiles
2047
2048 =cut
2049
2050 sub rebuild_fuzzyfiles {
2051
2052   use Fcntl qw(:flock);
2053
2054   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2055
2056   #username
2057
2058   open(USERNAMELOCK,">>$dir/svc_acct.username")
2059     or die "can't open $dir/svc_acct.username: $!";
2060   flock(USERNAMELOCK,LOCK_EX)
2061     or die "can't lock $dir/svc_acct.username: $!";
2062
2063   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2064
2065   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2066     or die "can't open $dir/svc_acct.username.tmp: $!";
2067   print USERNAMECACHE join("\n", @all_username), "\n";
2068   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2069
2070   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2071   close USERNAMELOCK;
2072
2073 }
2074
2075 =item all_username
2076
2077 =cut
2078
2079 sub all_username {
2080   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2081   open(USERNAMECACHE,"<$dir/svc_acct.username")
2082     or die "can't open $dir/svc_acct.username: $!";
2083   my @array = map { chomp; $_; } <USERNAMECACHE>;
2084   close USERNAMECACHE;
2085   \@array;
2086 }
2087
2088 =item append_fuzzyfiles USERNAME
2089
2090 =cut
2091
2092 sub append_fuzzyfiles {
2093   my $username = shift;
2094
2095   &check_and_rebuild_fuzzyfiles;
2096
2097   use Fcntl qw(:flock);
2098
2099   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2100
2101   open(USERNAME,">>$dir/svc_acct.username")
2102     or die "can't open $dir/svc_acct.username: $!";
2103   flock(USERNAME,LOCK_EX)
2104     or die "can't lock $dir/svc_acct.username: $!";
2105
2106   print USERNAME "$username\n";
2107
2108   flock(USERNAME,LOCK_UN)
2109     or die "can't unlock $dir/svc_acct.username: $!";
2110   close USERNAME;
2111
2112   1;
2113 }
2114
2115
2116
2117 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2118
2119 =cut
2120
2121 sub radius_usergroup_selector {
2122   my $sel_groups = shift;
2123   my %sel_groups = map { $_=>1 } @$sel_groups;
2124
2125   my $selectname = shift || 'radius_usergroup';
2126
2127   my $dbh = dbh;
2128   my $sth = $dbh->prepare(
2129     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2130   ) or die $dbh->errstr;
2131   $sth->execute() or die $sth->errstr;
2132   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2133
2134   my $html = <<END;
2135     <SCRIPT>
2136     function ${selectname}_doadd(object) {
2137       var myvalue = object.${selectname}_add.value;
2138       var optionName = new Option(myvalue,myvalue,false,true);
2139       var length = object.$selectname.length;
2140       object.$selectname.options[length] = optionName;
2141       object.${selectname}_add.value = "";
2142     }
2143     </SCRIPT>
2144     <SELECT MULTIPLE NAME="$selectname">
2145 END
2146
2147   foreach my $group ( @all_groups ) {
2148     $html .= qq(<OPTION VALUE="$group");
2149     if ( $sel_groups{$group} ) {
2150       $html .= ' SELECTED';
2151       $sel_groups{$group} = 0;
2152     }
2153     $html .= ">$group</OPTION>\n";
2154   }
2155   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2156     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2157   };
2158   $html .= '</SELECT>';
2159
2160   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2161            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2162
2163   $html;
2164 }
2165
2166 =item reached_threshold
2167
2168 Performs some activities when svc_acct thresholds (such as number of seconds
2169 remaining) are reached.
2170
2171 =cut
2172
2173 sub reached_threshold {
2174   my %opt = @_;
2175
2176   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2177   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2178
2179   if ( $opt{'op'} eq '+' ){
2180     $svc_acct->setfield( $opt{'column'}.'_threshold',
2181                          int($svc_acct->getfield($opt{'column'})
2182                              * ( $conf->exists('svc_acct-usage_threshold')
2183                                  ? $conf->config('svc_acct-usage_threshold')/100
2184                                  : 0.80
2185                                )
2186                          )
2187                        );
2188     my $error = $svc_acct->replace;
2189     die $error if $error;
2190   }elsif ( $opt{'op'} eq '-' ){
2191
2192     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2193     return '' if ($threshold eq '' );
2194
2195     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2196     my $error = $svc_acct->replace;
2197     die $error if $error; # email next time, i guess
2198
2199     if ( $warning_template ) {
2200       eval "use FS::Misc qw(send_email)";
2201       die $@ if $@;
2202
2203       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2204       my $cust_main = $cust_pkg->cust_main;
2205
2206       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2207                                $cust_main->invoicing_list,
2208                                $svc_acct->email,
2209                                ($opt{'to'} ? $opt{'to'} : ())
2210                    );
2211
2212       my $mimetype = $warning_mimetype;
2213       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2214
2215       my $body       =  $warning_template->fill_in( HASH => {
2216                         'custnum'   => $cust_main->custnum,
2217                         'username'  => $svc_acct->username,
2218                         'password'  => $svc_acct->_password,
2219                         'first'     => $cust_main->first,
2220                         'last'      => $cust_main->getfield('last'),
2221                         'pkg'       => $cust_pkg->part_pkg->pkg,
2222                         'column'    => $opt{'column'},
2223                         'amount'    => $svc_acct->getfield($opt{'column'}),
2224                         'threshold' => $threshold,
2225                       } );
2226
2227
2228       my $error = send_email(
2229         'from'         => $warning_from,
2230         'to'           => $to,
2231         'subject'      => $warning_subject,
2232         'content-type' => $mimetype,
2233         'body'         => [ map "$_\n", split("\n", $body) ],
2234       );
2235       die $error if $error;
2236     }
2237   }else{
2238     die "unknown op: " . $opt{'op'};
2239   }
2240 }
2241
2242 =back
2243
2244 =head1 BUGS
2245
2246 The $recref stuff in sub check should be cleaned up.
2247
2248 The suspend, unsuspend and cancel methods update the database, but not the
2249 current object.  This is probably a bug as it's unexpected and
2250 counterintuitive.
2251
2252 radius_usergroup_selector?  putting web ui components in here?  they should
2253 probably live somewhere else...
2254
2255 insertion of RADIUS group stuff in insert could be done with child_objects now
2256 (would probably clean up export of them too)
2257
2258 =head1 SEE ALSO
2259
2260 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2261 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2262 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2263 L<freeside-queued>), L<FS::svc_acct_pop>,
2264 schema.html from the base documentation.
2265
2266 =cut
2267
2268 1;
2269