FS/FS/svc_acct.pm

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