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