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