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     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1523       if ($part_export->option('overlimit_groups')) {
1524         my ($new,$old);
1525         my $other = new FS::svc_acct $self->hashref;
1526         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1527                        ($self, $part_export->option('overlimit_groups'));
1528         $other->usergroup( $groups );
1529         if ($action eq 'suspend'){
1530           $new = $other; $old = $self;
1531         }else{
1532           $new = $self; $old = $other;
1533         }
1534         my $error = $part_export->export_replace($new, $old);
1535         if ( $error ) {
1536           $dbh->rollback if $oldAutoCommit;
1537           return "Error replacing radius groups in export, ${op}: $error";
1538         }
1539       }
1540     }
1541   }
1542
1543   if ( $conf->exists("svc_acct-usage_$action")
1544        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1545     #my $error = $self->$action();
1546     my $error = $self->cust_svc->cust_pkg->$action();
1547     if ( $error ) {
1548       $dbh->rollback if $oldAutoCommit;
1549       return "Error ${action}ing: $error";
1550     }
1551   }
1552
1553   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1554     my $wqueue = new FS::queue {
1555       'svcnum' => $self->svcnum,
1556       'job'    => 'FS::svc_acct::reached_threshold',
1557     };
1558
1559     my $to = '';
1560     if ($op eq '-'){
1561       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1562     }
1563
1564     # x_threshold race
1565     my $error = $wqueue->insert(
1566       'svcnum' => $self->svcnum,
1567       'op'     => $op,
1568       'column' => $column,
1569       'to'     => $to,
1570     );
1571     if ( $error ) {
1572       $dbh->rollback if $oldAutoCommit;
1573       return "Error queuing threshold activity: $error";
1574     }
1575   }
1576
1577   warn "$me update successful; committing\n"
1578     if $DEBUG;
1579   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1580   '';
1581
1582 }
1583
1584 sub set_usage {
1585   my( $self, $valueref ) = @_;
1586
1587   warn "$me set_usage called for svcnum ". $self->svcnum.
1588        ' ('. $self->email. "): ".
1589        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1590     if $DEBUG;
1591
1592   local $SIG{HUP} = 'IGNORE';
1593   local $SIG{INT} = 'IGNORE';
1594   local $SIG{QUIT} = 'IGNORE';
1595   local $SIG{TERM} = 'IGNORE';
1596   local $SIG{TSTP} = 'IGNORE';
1597   local $SIG{PIPE} = 'IGNORE';
1598
1599   local $FS::svc_Common::noexport_hack = 1;
1600   my $oldAutoCommit = $FS::UID::AutoCommit;
1601   local $FS::UID::AutoCommit = 0;
1602   my $dbh = dbh;
1603
1604   my $reset = 0;
1605   foreach my $field (keys %$valueref){
1606     $reset = 1 if $valueref->{$field};
1607     $self->setfield($field, $valueref->{$field});
1608     $self->setfield( $field.'_threshold',
1609                      int($self->getfield($field)
1610                          * ( $conf->exists('svc_acct-usage_threshold')
1611                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1612                              : 0.20
1613                            )
1614                        )
1615                      );
1616   }
1617   my $error = $self->replace;
1618   die $error if $error;
1619
1620   if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) {
1621     my $error = $self->cust_svc->cust_pkg->unsuspend;
1622     if ( $error ) {
1623       $dbh->rollback if $oldAutoCommit;
1624       return "Error unsuspending: $error";
1625     }
1626   }
1627
1628   warn "$me update successful; committing\n"
1629     if $DEBUG;
1630   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1631   '';
1632
1633 }
1634
1635
1636 =item recharge HASHREF
1637
1638   Increments usage columns by the amount specified in HASHREF as
1639   column=>amount pairs.
1640
1641 =cut
1642
1643 sub recharge {
1644   my ($self, $vhash) = @_;
1645
1646   if ( $DEBUG ) {
1647     warn "[$me] recharge called on $self: ". Dumper($self).
1648          "\nwith vhash: ". Dumper($vhash);
1649   }
1650
1651   my $oldAutoCommit = $FS::UID::AutoCommit;
1652   local $FS::UID::AutoCommit = 0;
1653   my $dbh = dbh;
1654   my $error = '';
1655
1656   foreach my $column (keys %$vhash){
1657     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1658   }
1659
1660   if ( $error ) {
1661     $dbh->rollback if $oldAutoCommit;
1662   }else{
1663     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1664   }
1665   return $error;
1666 }
1667
1668 =item is_rechargeable
1669
1670 Returns true if this svc_account can be "recharged" and false otherwise.
1671
1672 =cut
1673
1674 sub is_rechargable {
1675   my $self = shift;
1676   $self->seconds ne ''
1677     || $self->upbytes ne ''
1678     || $self->downbytes ne ''
1679     || $self->totalbytes ne '';
1680 }
1681
1682 =item seconds_since TIMESTAMP
1683
1684 Returns the number of seconds this account has been online since TIMESTAMP,
1685 according to the session monitor (see L<FS::Session>).
1686
1687 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1688 L<Time::Local> and L<Date::Parse> for conversion functions.
1689
1690 =cut
1691
1692 #note: POD here, implementation in FS::cust_svc
1693 sub seconds_since {
1694   my $self = shift;
1695   $self->cust_svc->seconds_since(@_);
1696 }
1697
1698 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1699
1700 Returns the numbers of seconds this account has been online between
1701 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1702 external SQL radacct table, specified via sqlradius export.  Sessions which
1703 started in the specified range but are still open are counted from session
1704 start to the end of the range (unless they are over 1 day old, in which case
1705 they are presumed missing their stop record and not counted).  Also, sessions
1706 which end in the range but started earlier are counted from the start of the
1707 range to session end.  Finally, sessions which start before the range but end
1708 after are counted for the entire range.
1709
1710 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1711 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1712 functions.
1713
1714 =cut
1715
1716 #note: POD here, implementation in FS::cust_svc
1717 sub seconds_since_sqlradacct {
1718   my $self = shift;
1719   $self->cust_svc->seconds_since_sqlradacct(@_);
1720 }
1721
1722 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1723
1724 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1725 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1726 TIMESTAMP_END (exclusive).
1727
1728 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1729 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1730 functions.
1731
1732 =cut
1733
1734 #note: POD here, implementation in FS::cust_svc
1735 sub attribute_since_sqlradacct {
1736   my $self = shift;
1737   $self->cust_svc->attribute_since_sqlradacct(@_);
1738 }
1739
1740 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1741
1742 Returns an array of hash references of this customers login history for the
1743 given time range.  (document this better)
1744
1745 =cut
1746
1747 sub get_session_history {
1748   my $self = shift;
1749   $self->cust_svc->get_session_history(@_);
1750 }
1751
1752 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1753
1754 =cut
1755
1756 sub get_cdrs {
1757   my($self, $start, $end, %opt ) = @_;
1758
1759   my $did = $self->username; #yup
1760
1761   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1762
1763   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1764
1765   #SELECT $for_update * FROM cdr
1766   #  WHERE calldate >= $start #need a conversion
1767   #    AND calldate <  $end   #ditto
1768   #    AND (    charged_party = "$did"
1769   #          OR charged_party = "$prefix$did" #if length($prefix);
1770   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1771   #               AND
1772   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1773   #             )
1774   #        )
1775   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1776
1777   my $charged_or_src;
1778   if ( length($prefix) ) {
1779     $charged_or_src =
1780       " AND (    charged_party = '$did'
1781               OR charged_party = '$prefix$did'
1782               OR ( ( charged_party IS NULL OR charged_party = '' )
1783                    AND
1784                    ( src = '$did' OR src = '$prefix$did' )
1785                  )
1786             )
1787       ";
1788   } else {
1789     $charged_or_src =
1790       " AND (    charged_party = '$did'
1791               OR ( ( charged_party IS NULL OR charged_party = '' )
1792                    AND
1793                    src = '$did'
1794                  )
1795             )
1796       ";
1797
1798   }
1799
1800   qsearch(
1801     'select'    => "$for_update *",
1802     'table'     => 'cdr',
1803     'hashref'   => {
1804                      #( freesidestatus IS NULL OR freesidestatus = '' )
1805                      'freesidestatus' => '',
1806                    },
1807     'extra_sql' => $charged_or_src,
1808
1809   );
1810
1811 }
1812
1813 =item radius_groups
1814
1815 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1816
1817 =cut
1818
1819 sub radius_groups {
1820   my $self = shift;
1821   if ( $self->usergroup ) {
1822     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1823       unless ref($self->usergroup) eq 'ARRAY';
1824     #when provisioning records, export callback runs in svc_Common.pm before
1825     #radius_usergroup records can be inserted...
1826     @{$self->usergroup};
1827   } else {
1828     map { $_->groupname }
1829       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1830   }
1831 }
1832
1833 =item clone_suspended
1834
1835 Constructor used by FS::part_export::_export_suspend fallback.  Document
1836 better.
1837
1838 =cut
1839
1840 sub clone_suspended {
1841   my $self = shift;
1842   my %hash = $self->hash;
1843   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1844   new FS::svc_acct \%hash;
1845 }
1846
1847 =item clone_kludge_unsuspend
1848
1849 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1850 better.
1851
1852 =cut
1853
1854 sub clone_kludge_unsuspend {
1855   my $self = shift;
1856   my %hash = $self->hash;
1857   $hash{_password} = '';
1858   new FS::svc_acct \%hash;
1859 }
1860
1861 =item check_password
1862
1863 Checks the supplied password against the (possibly encrypted) password in the
1864 database.  Returns true for a successful authentication, false for no match.
1865
1866 Currently supported encryptions are: classic DES crypt() and MD5
1867
1868 =cut
1869
1870 sub check_password {
1871   my($self, $check_password) = @_;
1872
1873   #remove old-style SUSPENDED kludge, they should be allowed to login to
1874   #self-service and pay up
1875   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1876
1877   #eventually should check a "password-encoding" field
1878   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1879     return 0;
1880   } elsif ( length($password) < 13 ) { #plaintext
1881     $check_password eq $password;
1882   } elsif ( length($password) == 13 ) { #traditional DES crypt
1883     crypt($check_password, $password) eq $password;
1884   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1885     unix_md5_crypt($check_password, $password) eq $password;
1886   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1887     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1888          $self->svcnum. "\n";
1889     0;
1890   } else {
1891     warn "Can't check password: Unrecognized encryption for svcnum ".
1892          $self->svcnum. "\n";
1893     0;
1894   }
1895
1896 }
1897
1898 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1899
1900 Returns an encrypted password, either by passing through an encrypted password
1901 in the database or by encrypting a plaintext password from the database.
1902
1903 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1904 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1905 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1906 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1907 encryption type is only used if the password is not already encrypted in the
1908 database.
1909
1910 =cut
1911
1912 sub crypt_password {
1913   my $self = shift;
1914   #eventually should check a "password-encoding" field
1915   if ( length($self->_password) == 13
1916        || $self->_password =~ /^\$(1|2a?)\$/
1917        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1918      )
1919   {
1920     $self->_password;
1921   } else {
1922     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1923     if ( $encryption eq 'crypt' ) {
1924       crypt(
1925         $self->_password,
1926         $saltset[int(rand(64))].$saltset[int(rand(64))]
1927       );
1928     } elsif ( $encryption eq 'md5' ) {
1929       unix_md5_crypt( $self->_password );
1930     } elsif ( $encryption eq 'blowfish' ) {
1931       croak "unknown encryption method $encryption";
1932     } else {
1933       croak "unknown encryption method $encryption";
1934     }
1935   }
1936 }
1937
1938 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
1939
1940 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
1941 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
1942 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
1943
1944 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
1945 to work the same as the B</crypt_password> method.
1946
1947 =cut
1948
1949 sub ldap_password {
1950   my $self = shift;
1951   #eventually should check a "password-encoding" field
1952   if ( length($self->_password) == 13 ) { #crypt
1953     return '{CRYPT}'. $self->_password;
1954   } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
1955     return '{MD5}'. $1;
1956   } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
1957     die "Blowfish encryption not supported in this context, svcnum ".
1958         $self->svcnum. "\n";
1959   } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
1960     return '{SSHA}'. $1;
1961   } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
1962     return '{NS-MTA-MD5}'. $1;
1963   } else { #plaintext
1964     return '{PLAIN}'. $self->_password;
1965     #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1966     #if ( $encryption eq 'crypt' ) {
1967     #  return '{CRYPT}'. crypt(
1968     #    $self->_password,
1969     #    $saltset[int(rand(64))].$saltset[int(rand(64))]
1970     #  );
1971     #} elsif ( $encryption eq 'md5' ) {
1972     #  unix_md5_crypt( $self->_password );
1973     #} elsif ( $encryption eq 'blowfish' ) {
1974     #  croak "unknown encryption method $encryption";
1975     #} else {
1976     #  croak "unknown encryption method $encryption";
1977     #}
1978   }
1979 }
1980
1981 =item domain_slash_username
1982
1983 Returns $domain/$username/
1984
1985 =cut
1986
1987 sub domain_slash_username {
1988   my $self = shift;
1989   $self->domain. '/'. $self->username. '/';
1990 }
1991
1992 =item virtual_maildir
1993
1994 Returns $domain/maildirs/$username/
1995
1996 =cut
1997
1998 sub virtual_maildir {
1999   my $self = shift;
2000   $self->domain. '/maildirs/'. $self->username. '/';
2001 }
2002
2003 =back
2004
2005 =head1 SUBROUTINES
2006
2007 =over 4
2008
2009 =item send_email
2010
2011 This is the FS::svc_acct job-queue-able version.  It still uses
2012 FS::Misc::send_email under-the-hood.
2013
2014 =cut
2015
2016 sub send_email {
2017   my %opt = @_;
2018
2019   eval "use FS::Misc qw(send_email)";
2020   die $@ if $@;
2021
2022   $opt{mimetype} ||= 'text/plain';
2023   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2024
2025   my $error = send_email(
2026     'from'         => $opt{from},
2027     'to'           => $opt{to},
2028     'subject'      => $opt{subject},
2029     'content-type' => $opt{mimetype},
2030     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2031   );
2032   die $error if $error;
2033 }
2034
2035 =item check_and_rebuild_fuzzyfiles
2036
2037 =cut
2038
2039 sub check_and_rebuild_fuzzyfiles {
2040   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2041   -e "$dir/svc_acct.username"
2042     or &rebuild_fuzzyfiles;
2043 }
2044
2045 =item rebuild_fuzzyfiles
2046
2047 =cut
2048
2049 sub rebuild_fuzzyfiles {
2050
2051   use Fcntl qw(:flock);
2052
2053   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2054
2055   #username
2056
2057   open(USERNAMELOCK,">>$dir/svc_acct.username")
2058     or die "can't open $dir/svc_acct.username: $!";
2059   flock(USERNAMELOCK,LOCK_EX)
2060     or die "can't lock $dir/svc_acct.username: $!";
2061
2062   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2063
2064   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2065     or die "can't open $dir/svc_acct.username.tmp: $!";
2066   print USERNAMECACHE join("\n", @all_username), "\n";
2067   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2068
2069   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2070   close USERNAMELOCK;
2071
2072 }
2073
2074 =item all_username
2075
2076 =cut
2077
2078 sub all_username {
2079   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2080   open(USERNAMECACHE,"<$dir/svc_acct.username")
2081     or die "can't open $dir/svc_acct.username: $!";
2082   my @array = map { chomp; $_; } <USERNAMECACHE>;
2083   close USERNAMECACHE;
2084   \@array;
2085 }
2086
2087 =item append_fuzzyfiles USERNAME
2088
2089 =cut
2090
2091 sub append_fuzzyfiles {
2092   my $username = shift;
2093
2094   &check_and_rebuild_fuzzyfiles;
2095
2096   use Fcntl qw(:flock);
2097
2098   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2099
2100   open(USERNAME,">>$dir/svc_acct.username")
2101     or die "can't open $dir/svc_acct.username: $!";
2102   flock(USERNAME,LOCK_EX)
2103     or die "can't lock $dir/svc_acct.username: $!";
2104
2105   print USERNAME "$username\n";
2106
2107   flock(USERNAME,LOCK_UN)
2108     or die "can't unlock $dir/svc_acct.username: $!";
2109   close USERNAME;
2110
2111   1;
2112 }
2113
2114
2115
2116 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2117
2118 =cut
2119
2120 sub radius_usergroup_selector {
2121   my $sel_groups = shift;
2122   my %sel_groups = map { $_=>1 } @$sel_groups;
2123
2124   my $selectname = shift || 'radius_usergroup';
2125
2126   my $dbh = dbh;
2127   my $sth = $dbh->prepare(
2128     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2129   ) or die $dbh->errstr;
2130   $sth->execute() or die $sth->errstr;
2131   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2132
2133   my $html = <<END;
2134     <SCRIPT>
2135     function ${selectname}_doadd(object) {
2136       var myvalue = object.${selectname}_add.value;
2137       var optionName = new Option(myvalue,myvalue,false,true);
2138       var length = object.$selectname.length;
2139       object.$selectname.options[length] = optionName;
2140       object.${selectname}_add.value = "";
2141     }
2142     </SCRIPT>
2143     <SELECT MULTIPLE NAME="$selectname">
2144 END
2145
2146   foreach my $group ( @all_groups ) {
2147     $html .= qq(<OPTION VALUE="$group");
2148     if ( $sel_groups{$group} ) {
2149       $html .= ' SELECTED';
2150       $sel_groups{$group} = 0;
2151     }
2152     $html .= ">$group</OPTION>\n";
2153   }
2154   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2155     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2156   };
2157   $html .= '</SELECT>';
2158
2159   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2160            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2161
2162   $html;
2163 }
2164
2165 =item reached_threshold
2166
2167 Performs some activities when svc_acct thresholds (such as number of seconds
2168 remaining) are reached.
2169
2170 =cut
2171
2172 sub reached_threshold {
2173   my %opt = @_;
2174
2175   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2176   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2177
2178   if ( $opt{'op'} eq '+' ){
2179     $svc_acct->setfield( $opt{'column'}.'_threshold',
2180                          int($svc_acct->getfield($opt{'column'})
2181                              * ( $conf->exists('svc_acct-usage_threshold')
2182                                  ? $conf->config('svc_acct-usage_threshold')/100
2183                                  : 0.80
2184                                )
2185                          )
2186                        );
2187     my $error = $svc_acct->replace;
2188     die $error if $error;
2189   }elsif ( $opt{'op'} eq '-' ){
2190
2191     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2192     return '' if ($threshold eq '' );
2193
2194     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2195     my $error = $svc_acct->replace;
2196     die $error if $error; # email next time, i guess
2197
2198     if ( $warning_template ) {
2199       eval "use FS::Misc qw(send_email)";
2200       die $@ if $@;
2201
2202       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2203       my $cust_main = $cust_pkg->cust_main;
2204
2205       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2206                                $cust_main->invoicing_list,
2207                                $svc_acct->email,
2208                                ($opt{'to'} ? $opt{'to'} : ())
2209                    );
2210
2211       my $mimetype = $warning_mimetype;
2212       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2213
2214       my $body       =  $warning_template->fill_in( HASH => {
2215                         'custnum'   => $cust_main->custnum,
2216                         'username'  => $svc_acct->username,
2217                         'password'  => $svc_acct->_password,
2218                         'first'     => $cust_main->first,
2219                         'last'      => $cust_main->getfield('last'),
2220                         'pkg'       => $cust_pkg->part_pkg->pkg,
2221                         'column'    => $opt{'column'},
2222                         'amount'    => $svc_acct->getfield($opt{'column'}),
2223                         'threshold' => $threshold,
2224                       } );
2225
2226
2227       my $error = send_email(
2228         'from'         => $warning_from,
2229         'to'           => $to,
2230         'subject'      => $warning_subject,
2231         'content-type' => $mimetype,
2232         'body'         => [ map "$_\n", split("\n", $body) ],
2233       );
2234       die $error if $error;
2235     }
2236   }else{
2237     die "unknown op: " . $opt{'op'};
2238   }
2239 }
2240
2241 =back
2242
2243 =head1 BUGS
2244
2245 The $recref stuff in sub check should be cleaned up.
2246
2247 The suspend, unsuspend and cancel methods update the database, but not the
2248 current object.  This is probably a bug as it's unexpected and
2249 counterintuitive.
2250
2251 radius_usergroup_selector?  putting web ui components in here?  they should
2252 probably live somewhere else...
2253
2254 insertion of RADIUS group stuff in insert could be done with child_objects now
2255 (would probably clean up export of them too)
2256
2257 =head1 SEE ALSO
2258
2259 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2260 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2261 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2262 L<freeside-queued>), L<FS::svc_acct_pop>,
2263 schema.html from the base documentation.
2264
2265 =cut
2266
2267 1;
2268