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