FS/FS/svc_acct.pm

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