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