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