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