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 $username_colon
  10              $password_noampersand $password_noexclamation
  11              $warning_template $warning_from $warning_subject $warning_mimetype
  12              $warning_cc
  13              $smtpmachine
  14              $radius_password $radius_ip
  15              $dirhash
  16              @saltset @pw_set );
  17 use Scalar::Util qw( blessed );
  18 use Math::BigInt;
  19 use Carp;
  20 use Fcntl qw(:flock);
  21 use Date::Format;
  22 use Crypt::PasswdMD5 1.2;
  23 use Digest::SHA1 'sha1_base64';
  24 use Digest::MD5 'md5_base64';
  25 use Data::Dumper;
  26 use Text::Template;
  27 use Authen::Passphrase;
  28 use FS::UID qw( datasrc driver_name );
  29 use FS::Conf;
  30 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  31 use FS::Msgcat qw(gettext);
  32 use FS::UI::bytecount;
  33 use FS::UI::Web;
  34 use FS::part_pkg;
  35 use FS::svc_Common;
  36 use FS::cust_svc;
  37 use FS::part_svc;
  38 use FS::svc_acct_pop;
  39 use FS::cust_main_invoice;
  40 use FS::svc_domain;
  41 use FS::raddb;
  42 use FS::queue;
  43 use FS::radius_usergroup;
  44 use FS::export_svc;
  45 use FS::part_export;
  46 use FS::svc_forward;
  47 use FS::svc_www;
  48 use FS::cdr;
  49
  50 @ISA = qw( FS::svc_Common );
  51
  52 $DEBUG = 0;
  53 $me = '[FS::svc_acct]';
  54
  55 #ask FS::UID to run this stuff for us later
  56 FS::UID->install_callback( sub {
  57   $conf = new FS::Conf;
  58   $dir_prefix = $conf->config('home');
  59   @shells = $conf->config('shells');
  60   $usernamemin = $conf->config('usernamemin') || 2;
  61   $usernamemax = $conf->config('usernamemax');
  62   $passwordmin = $conf->config('passwordmin'); # || 6;
  63   #blank->6, keep 0
  64   $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
  65                    ? $passwordmin
  66                    : 6;
  67   $passwordmax = $conf->config('passwordmax') || 8;
  68   $username_letter = $conf->exists('username-letter');
  69   $username_letterfirst = $conf->exists('username-letterfirst');
  70   $username_noperiod = $conf->exists('username-noperiod');
  71   $username_nounderscore = $conf->exists('username-nounderscore');
  72   $username_nodash = $conf->exists('username-nodash');
  73   $username_uppercase = $conf->exists('username-uppercase');
  74   $username_ampersand = $conf->exists('username-ampersand');
  75   $username_percent = $conf->exists('username-percent');
  76   $username_colon = $conf->exists('username-colon');
  77   $password_noampersand = $conf->exists('password-noexclamation');
  78   $password_noexclamation = $conf->exists('password-noexclamation');
  79   $dirhash = $conf->config('dirhash') || 0;
  80   if ( $conf->exists('warning_email') ) {
  81     $warning_template = new Text::Template (
  82       TYPE   => 'ARRAY',
  83       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  84     ) or warn "can't create warning email template: $Text::Template::ERROR";
  85     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  86     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  87     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  88     $warning_cc = $conf->config('warning_email-cc');
  89   } else {
  90     $warning_template = '';
  91     $warning_from = '';
  92     $warning_subject = '';
  93     $warning_mimetype = '';
  94     $warning_cc = '';
  95   }
  96   $smtpmachine = $conf->config('smtpmachine');
  97   $radius_password = $conf->config('radius-password') || 'Password';
  98   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  99   @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
 100 }
 101 );
 102
 103 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
 104 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
 105
 106 sub _cache {
 107   my $self = shift;
 108   my ( $hashref, $cache ) = @_;
 109   if ( $hashref->{'svc_acct_svcnum'} ) {
 110     $self->{'_domsvc'} = FS::svc_domain->new( {
 111       'svcnum'   => $hashref->{'domsvc'},
 112       'domain'   => $hashref->{'svc_acct_domain'},
 113       'catchall' => $hashref->{'svc_acct_catchall'},
 114     } );
 115   }
 116 }
 117
 118 =head1 NAME
 119
 120 FS::svc_acct - Object methods for svc_acct records
 121
 122 =head1 SYNOPSIS
 123
 124   use FS::svc_acct;
 125
 126   $record = new FS::svc_acct \%hash;
 127   $record = new FS::svc_acct { 'column' => 'value' };
 128
 129   $error = $record->insert;
 130
 131   $error = $new_record->replace($old_record);
 132
 133   $error = $record->delete;
 134
 135   $error = $record->check;
 136
 137   $error = $record->suspend;
 138
 139   $error = $record->unsuspend;
 140
 141   $error = $record->cancel;
 142
 143   %hash = $record->radius;
 144
 145   %hash = $record->radius_reply;
 146
 147   %hash = $record->radius_check;
 148
 149   $domain = $record->domain;
 150
 151   $svc_domain = $record->svc_domain;
 152
 153   $email = $record->email;
 154
 155   $seconds_since = $record->seconds_since($timestamp);
 156
 157 =head1 DESCRIPTION
 158
 159 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 160 FS::svc_Common.  The following fields are currently supported:
 161
 162 =over 4
 163
 164 =item svcnum - primary key (assigned automatcially for new accounts)
 165
 166 =item username
 167
 168 =item _password - generated if blank
 169
 170 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
 171
 172 =item sec_phrase - security phrase
 173
 174 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 175
 176 =item uid
 177
 178 =item gid
 179
 180 =item finger - GECOS
 181
 182 =item dir - set automatically if blank (and uid is not)
 183
 184 =item shell
 185
 186 =item quota - (unimplementd)
 187
 188 =item slipip - IP address
 189
 190 =item seconds -
 191
 192 =item upbytes -
 193
 194 =item downbytes -
 195
 196 =item totalbytes -
 197
 198 =item domsvc - svcnum from svc_domain
 199
 200 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 201
 202 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 203
 204 =back
 205
 206 =head1 METHODS
 207
 208 =over 4
 209
 210 =item new HASHREF
 211
 212 Creates a new account.  To add the account to the database, see L<"insert">.
 213
 214 =cut
 215
 216 sub table_info {
 217   {
 218     'name'   => 'Account',
 219     'longname_plural' => 'Access accounts and mailboxes',
 220     'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
 221     'display_weight' => 10,
 222     'cancel_weight'  => 50,
 223     'fields' => {
 224         'dir'       => 'Home directory',
 225         'uid'       => {
 226                          label    => 'UID',
 227                          def_info => 'set to fixed and blank for no UIDs',
 228                          type     => 'text',
 229                        },
 230         'slipip'    => 'IP address',
 231     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 232         'popnum'    => {
 233                          label => 'Access number',
 234                          type => 'select',
 235                          select_table => 'svc_acct_pop',
 236                          select_key   => 'popnum',
 237                          select_label => 'city',
 238                          disable_select => 1,
 239                        },
 240         'username'  => {
 241                          label => 'Username',
 242                          type => 'text',
 243                          disable_default => 1,
 244                          disable_fixed => 1,
 245                          disable_select => 1,
 246                        },
 247         'quota'     => {
 248                          label => 'Quota',
 249                          type => 'text',
 250                          disable_inventory => 1,
 251                          disable_select => 1,
 252                        },
 253         '_password' => 'Password',
 254         'gid'       => {
 255                          label    => 'GID',
 256                          def_info => 'when blank, defaults to UID',
 257                          type     => 'text',
 258                        },
 259         'shell'     => {
 260                          label    => 'Shell',
 261                          def_info => 'set to blank for no shell tracking',
 262                          type     => 'select',
 263                          #select_list => [ $conf->config('shells') ],
 264                          select_list => [ $conf ? $conf->config('shells') : () ],
 265                          disable_inventory => 1,
 266                          disable_select => 1,
 267                        },
 268         'finger'    => 'Real name', # (GECOS)',
 269         'domsvc'    => {
 270                          label     => 'Domain',
 271                          type      => 'select',
 272                          select_table => 'svc_domain',
 273                          select_key   => 'svcnum',
 274                          select_label => 'domain',
 275                          disable_inventory => 1,
 276
 277                        },
 278         'usergroup' => {
 279                          label => 'RADIUS groups',
 280                          type  => 'radius_usergroup_selector',
 281                          disable_inventory => 1,
 282                          disable_select => 1,
 283                        },
 284         'seconds'   => { label => 'Seconds',
 285                          label_sort => 'with Time Remaining',
 286                          type  => 'text',
 287                          disable_inventory => 1,
 288                          disable_select => 1,
 289                          disable_part_svc_column => 1,
 290                        },
 291         'upbytes'   => { label => 'Upload',
 292                          type  => 'text',
 293                          disable_inventory => 1,
 294                          disable_select => 1,
 295                          'format' => \&FS::UI::bytecount::display_bytecount,
 296                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 297                          disable_part_svc_column => 1,
 298                        },
 299         'downbytes' => { label => 'Download',
 300                          type  => 'text',
 301                          disable_inventory => 1,
 302                          disable_select => 1,
 303                          'format' => \&FS::UI::bytecount::display_bytecount,
 304                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 305                          disable_part_svc_column => 1,
 306                        },
 307         'totalbytes'=> { label => 'Total up and download',
 308                          type  => 'text',
 309                          disable_inventory => 1,
 310                          disable_select => 1,
 311                          'format' => \&FS::UI::bytecount::display_bytecount,
 312                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 313                          disable_part_svc_column => 1,
 314                        },
 315         'seconds_threshold'   => { label => 'Seconds threshold',
 316                                    type  => 'text',
 317                                    disable_inventory => 1,
 318                                    disable_select => 1,
 319                                    disable_part_svc_column => 1,
 320                                  },
 321         'upbytes_threshold'   => { label => 'Upload threshold',
 322                                    type  => 'text',
 323                                    disable_inventory => 1,
 324                                    disable_select => 1,
 325                                    'format' => \&FS::UI::bytecount::display_bytecount,
 326                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 327                                    disable_part_svc_column => 1,
 328                                  },
 329         'downbytes_threshold' => { label => 'Download threshold',
 330                                    type  => 'text',
 331                                    disable_inventory => 1,
 332                                    disable_select => 1,
 333                                    'format' => \&FS::UI::bytecount::display_bytecount,
 334                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 335                                    disable_part_svc_column => 1,
 336                                  },
 337         'totalbytes_threshold'=> { label => 'Total up and download threshold',
 338                                    type  => 'text',
 339                                    disable_inventory => 1,
 340                                    disable_select => 1,
 341                                    'format' => \&FS::UI::bytecount::display_bytecount,
 342                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 343                                    disable_part_svc_column => 1,
 344                                  },
 345         'last_login'=>           {
 346                                    label     => 'Last login',
 347                                    type      => 'disabled',
 348                                  },
 349         'last_logout'=>          {
 350                                    label     => 'Last logout',
 351                                    type      => 'disabled',
 352                                  },
 353     },
 354   };
 355 }
 356
 357 sub table { 'svc_acct'; }
 358
 359 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
 360
 361 sub _fieldhandlers {
 362   {
 363     #false laziness with edit/svc_acct.cgi
 364     'usergroup' => sub {
 365                          my( $self, $groups ) = @_;
 366                          if ( ref($groups) eq 'ARRAY' ) {
 367                            $groups;
 368                          } elsif ( length($groups) ) {
 369                            [ split(/\s*,\s*/, $groups) ];
 370                          } else {
 371                            [];
 372                          }
 373                        },
 374   };
 375 }
 376
 377 sub last_login {
 378   shift->_lastlog('in', @_);
 379 }
 380
 381 sub last_logout {
 382   shift->_lastlog('out', @_);
 383 }
 384
 385 sub _lastlog {
 386   my( $self, $op, $time ) = @_;
 387
 388   if ( defined($time) ) {
 389     warn "$me last_log$op called on svcnum ". $self->svcnum.
 390          ' ('. $self->email. "): $time\n"
 391       if $DEBUG;
 392
 393     my $dbh = dbh;
 394
 395     my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
 396     warn "$me $sql\n"
 397       if $DEBUG;
 398
 399     my $sth = $dbh->prepare( $sql )
 400       or die "Error preparing $sql: ". $dbh->errstr;
 401     my $rv = $sth->execute($time, $self->svcnum);
 402     die "Error executing $sql: ". $sth->errstr
 403       unless defined($rv);
 404     die "Can't update last_log$op for svcnum". $self->svcnum
 405       if $rv == 0;
 406
 407     $self->{'Hash'}->{"last_log$op"} = $time;
 408   }else{
 409     $self->getfield("last_log$op");
 410   }
 411 }
 412
 413 =item search_sql STRING
 414
 415 Class method which returns an SQL fragment to search for the given string.
 416
 417 =cut
 418
 419 sub search_sql {
 420   my( $class, $string ) = @_;
 421   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 422     my( $username, $domain ) = ( $1, $2 );
 423     my $q_username = dbh->quote($username);
 424     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 425     if ( @svc_domain ) {
 426       "svc_acct.username = $q_username AND ( ".
 427         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 428       " )";
 429     } else {
 430       '1 = 0'; #false
 431     }
 432   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 433     ' ( '.
 434       $class->search_sql_field('slipip',   $string ).
 435     ' OR '.
 436       $class->search_sql_field('username', $string ).
 437     ' ) ';
 438   } else {
 439     ' ( '.
 440       $class->search_sql_field('username', $string).
 441       ( $string =~ /^\d+$/
 442           ? 'OR '. $class->search_sql_field('svcnum', $string)
 443           : ''
 444       ).
 445     ' ) ';
 446   }
 447 }
 448
 449 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 450
 451 Returns the "username@domain" string for this account.
 452
 453 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 454 history records.
 455
 456 =cut
 457
 458 sub label {
 459   my $self = shift;
 460   $self->email(@_);
 461 }
 462
 463 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 464
 465 Returns a longer string label for this acccount ("Real Name <username@domain>"
 466 if available, or "username@domain").
 467
 468 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 469 history records.
 470
 471 =cut
 472
 473 sub label_long {
 474   my $self = shift;
 475   my $label = $self->label(@_);
 476   my $finger = $self->finger;
 477   return $label unless $finger =~ /\S/;
 478   my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
 479   $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
 480   "$finger <$label>";
 481 }
 482
 483 =item insert [ , OPTION => VALUE ... ]
 484
 485 Adds this account to the database.  If there is an error, returns the error,
 486 otherwise returns false.
 487
 488 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 489 defined.  An FS::cust_svc record will be created and inserted.
 490
 491 The additional field I<usergroup> can optionally be defined; if so it should
 492 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 493
 494 The additional field I<child_objects> can optionally be defined; if so it
 495 should contain an arrayref of FS::tablename objects.  They will have their
 496 svcnum fields set and will be inserted after this record, but before any
 497 exports are run.  Each element of the array can also optionally be a
 498 two-element array reference containing the child object and the name of an
 499 alternate field to be filled in with the newly-inserted svcnum, for example
 500 C<[ $svc_forward, 'srcsvc' ]>
 501
 502 Currently available options are: I<depend_jobnum>
 503
 504 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 505 jobnums), all provisioning jobs will have a dependancy on the supplied
 506 jobnum(s) (they will not run until the specific job(s) complete(s)).
 507
 508 (TODOC: L<FS::queue> and L<freeside-queued>)
 509
 510 (TODOC: new exports!)
 511
 512 =cut
 513
 514 sub insert {
 515   my $self = shift;
 516   my %options = @_;
 517
 518   if ( $DEBUG ) {
 519     warn "[$me] insert called on $self: ". Dumper($self).
 520          "\nwith options: ". Dumper(%options);
 521   }
 522
 523   local $SIG{HUP} = 'IGNORE';
 524   local $SIG{INT} = 'IGNORE';
 525   local $SIG{QUIT} = 'IGNORE';
 526   local $SIG{TERM} = 'IGNORE';
 527   local $SIG{TSTP} = 'IGNORE';
 528   local $SIG{PIPE} = 'IGNORE';
 529
 530   my $oldAutoCommit = $FS::UID::AutoCommit;
 531   local $FS::UID::AutoCommit = 0;
 532   my $dbh = dbh;
 533
 534   my @jobnums;
 535   my $error = $self->SUPER::insert(
 536     'jobnums'       => \@jobnums,
 537     'child_objects' => $self->child_objects,
 538     %options,
 539   );
 540   if ( $error ) {
 541     $dbh->rollback if $oldAutoCommit;
 542     return $error;
 543   }
 544
 545   if ( $self->usergroup ) {
 546     foreach my $groupname ( @{$self->usergroup} ) {
 547       my $radius_usergroup = new FS::radius_usergroup ( {
 548         svcnum    => $self->svcnum,
 549         groupname => $groupname,
 550       } );
 551       my $error = $radius_usergroup->insert;
 552       if ( $error ) {
 553         $dbh->rollback if $oldAutoCommit;
 554         return $error;
 555       }
 556     }
 557   }
 558
 559   unless ( $skip_fuzzyfiles ) {
 560     $error = $self->queue_fuzzyfiles_update;
 561     if ( $error ) {
 562       $dbh->rollback if $oldAutoCommit;
 563       return "updating fuzzy search cache: $error";
 564     }
 565   }
 566
 567   my $cust_pkg = $self->cust_svc->cust_pkg;
 568
 569   if ( $cust_pkg ) {
 570     my $cust_main = $cust_pkg->cust_main;
 571     my $agentnum = $cust_main->agentnum;
 572
 573     if (   $conf->exists('emailinvoiceautoalways')
 574         || $conf->exists('emailinvoiceauto')
 575         && ! $cust_main->invoicing_list_emailonly
 576        ) {
 577       my @invoicing_list = $cust_main->invoicing_list;
 578       push @invoicing_list, $self->email;
 579       $cust_main->invoicing_list(\@invoicing_list);
 580     }
 581
 582     #welcome email
 583     my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
 584       = ('','','','','','');
 585
 586     if ( $conf->exists('welcome_email', $agentnum) ) {
 587       $welcome_template = new Text::Template (
 588         TYPE   => 'ARRAY',
 589         SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
 590       ) or warn "can't create welcome email template: $Text::Template::ERROR";
 591       $welcome_from = $conf->config('welcome_email-from', $agentnum);
 592         # || 'your-isp-is-dum'
 593       $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
 594         || 'Welcome';
 595       $welcome_subject_template = new Text::Template (
 596         TYPE   => 'STRING',
 597         SOURCE => $welcome_subject,
 598       ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
 599       $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
 600         || 'text/plain';
 601     }
 602     if ( $welcome_template && $cust_pkg ) {
 603       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 604       if ( $to ) {
 605
 606         my %hash = (
 607                      'custnum'  => $self->custnum,
 608                      'username' => $self->username,
 609                      'password' => $self->_password,
 610                      'first'    => $cust_main->first,
 611                      'last'     => $cust_main->getfield('last'),
 612                      'pkg'      => $cust_pkg->part_pkg->pkg,
 613                    );
 614         my $wqueue = new FS::queue {
 615           'svcnum' => $self->svcnum,
 616           'job'    => 'FS::svc_acct::send_email'
 617         };
 618         my $error = $wqueue->insert(
 619           'to'       => $to,
 620           'from'     => $welcome_from,
 621           'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 622           'mimetype' => $welcome_mimetype,
 623           'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 624         );
 625         if ( $error ) {
 626           $dbh->rollback if $oldAutoCommit;
 627           return "error queuing welcome email: $error";
 628         }
 629
 630         if ( $options{'depend_jobnum'} ) {
 631           warn "$me depend_jobnum found; adding to welcome email dependancies"
 632             if $DEBUG;
 633           if ( ref($options{'depend_jobnum'}) ) {
 634             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 635                  "to welcome email dependancies"
 636               if $DEBUG;
 637             push @jobnums, @{ $options{'depend_jobnum'} };
 638           } else {
 639             warn "$me adding job $options{'depend_jobnum'} ".
 640                  "to welcome email dependancies"
 641               if $DEBUG;
 642             push @jobnums, $options{'depend_jobnum'};
 643           }
 644         }
 645
 646         foreach my $jobnum ( @jobnums ) {
 647           my $error = $wqueue->depend_insert($jobnum);
 648           if ( $error ) {
 649             $dbh->rollback if $oldAutoCommit;
 650             return "error queuing welcome email job dependancy: $error";
 651           }
 652         }
 653
 654       }
 655
 656     }
 657
 658   } # if ( $cust_pkg )
 659
 660   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 661   ''; #no error
 662 }
 663
 664 # set usage fields and thresholds if unset but set in a package def
 665 sub preinsert_hook_first {
 666   my $self = shift;
 667
 668   return '' unless $self->pkgnum;
 669
 670   my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 671   my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
 672   return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
 673
 674   my %values = $part_pkg->usage_valuehash;
 675   my $multiplier = $conf->exists('svc_acct-usage_threshold')
 676                      ? 1 - $conf->config('svc_acct-usage_threshold')/100
 677                      : 0.20; #doesn't matter
 678
 679   foreach ( keys %values ) {
 680     next if $self->getfield($_);
 681     $self->setfield( $_, $values{$_} );
 682     $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
 683       if $conf->exists('svc_acct-usage_threshold');
 684   }
 685
 686   ''; #no error
 687 }
 688
 689 =item delete
 690
 691 Deletes this account from the database.  If there is an error, returns the
 692 error, otherwise returns false.
 693
 694 The corresponding FS::cust_svc record will be deleted as well.
 695
 696 (TODOC: new exports!)
 697
 698 =cut
 699
 700 sub delete {
 701   my $self = shift;
 702
 703   return "can't delete system account" if $self->_check_system;
 704
 705   return "Can't delete an account which is a (svc_forward) source!"
 706     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 707
 708   return "Can't delete an account which is a (svc_forward) destination!"
 709     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 710
 711   return "Can't delete an account with (svc_www) web service!"
 712     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 713
 714   # what about records in session ? (they should refer to history table)
 715
 716   local $SIG{HUP} = 'IGNORE';
 717   local $SIG{INT} = 'IGNORE';
 718   local $SIG{QUIT} = 'IGNORE';
 719   local $SIG{TERM} = 'IGNORE';
 720   local $SIG{TSTP} = 'IGNORE';
 721   local $SIG{PIPE} = 'IGNORE';
 722
 723   my $oldAutoCommit = $FS::UID::AutoCommit;
 724   local $FS::UID::AutoCommit = 0;
 725   my $dbh = dbh;
 726
 727   foreach my $cust_main_invoice (
 728     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 729   ) {
 730     unless ( defined($cust_main_invoice) ) {
 731       warn "WARNING: something's wrong with qsearch";
 732       next;
 733     }
 734     my %hash = $cust_main_invoice->hash;
 735     $hash{'dest'} = $self->email;
 736     my $new = new FS::cust_main_invoice \%hash;
 737     my $error = $new->replace($cust_main_invoice);
 738     if ( $error ) {
 739       $dbh->rollback if $oldAutoCommit;
 740       return $error;
 741     }
 742   }
 743
 744   foreach my $svc_domain (
 745     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 746   ) {
 747     my %hash = new FS::svc_domain->hash;
 748     $hash{'catchall'} = '';
 749     my $new = new FS::svc_domain \%hash;
 750     my $error = $new->replace($svc_domain);
 751     if ( $error ) {
 752       $dbh->rollback if $oldAutoCommit;
 753       return $error;
 754     }
 755   }
 756
 757   my $error = $self->SUPER::delete;
 758   if ( $error ) {
 759     $dbh->rollback if $oldAutoCommit;
 760     return $error;
 761   }
 762
 763   foreach my $radius_usergroup (
 764     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 765   ) {
 766     my $error = $radius_usergroup->delete;
 767     if ( $error ) {
 768       $dbh->rollback if $oldAutoCommit;
 769       return $error;
 770     }
 771   }
 772
 773   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 774   '';
 775 }
 776
 777 =item replace OLD_RECORD
 778
 779 Replaces OLD_RECORD with this one in the database.  If there is an error,
 780 returns the error, otherwise returns false.
 781
 782 The additional field I<usergroup> can optionally be defined; if so it should
 783 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 784
 785
 786 =cut
 787
 788 sub replace {
 789   my $new = shift;
 790
 791   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 792               ? shift
 793               : $new->replace_old;
 794
 795   warn "$me replacing $old with $new\n" if $DEBUG;
 796
 797   my $error;
 798
 799   return "can't modify system account" if $old->_check_system;
 800
 801   {
 802     #no warnings 'numeric';  #alas, a 5.006-ism
 803     local($^W) = 0;
 804
 805     foreach my $xid (qw( uid gid )) {
 806
 807       return "Can't change $xid!"
 808         if ! $conf->exists("svc_acct-edit_$xid")
 809            && $old->$xid() != $new->$xid()
 810            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 811     }
 812
 813   }
 814
 815   #change homdir when we change username
 816   $new->setfield('dir', '') if $old->username ne $new->username;
 817
 818   local $SIG{HUP} = 'IGNORE';
 819   local $SIG{INT} = 'IGNORE';
 820   local $SIG{QUIT} = 'IGNORE';
 821   local $SIG{TERM} = 'IGNORE';
 822   local $SIG{TSTP} = 'IGNORE';
 823   local $SIG{PIPE} = 'IGNORE';
 824
 825   my $oldAutoCommit = $FS::UID::AutoCommit;
 826   local $FS::UID::AutoCommit = 0;
 827   my $dbh = dbh;
 828
 829   # redundant, but so $new->usergroup gets set
 830   $error = $new->check;
 831   return $error if $error;
 832
 833   $old->usergroup( [ $old->radius_groups ] );
 834   if ( $DEBUG ) {
 835     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 836     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 837   }
 838   if ( $new->usergroup ) {
 839     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 840     my @newgroups = @{$new->usergroup};
 841     foreach my $oldgroup ( @{$old->usergroup} ) {
 842       if ( grep { $oldgroup eq $_ } @newgroups ) {
 843         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 844         next;
 845       }
 846       my $radius_usergroup = qsearchs('radius_usergroup', {
 847         svcnum    => $old->svcnum,
 848         groupname => $oldgroup,
 849       } );
 850       my $error = $radius_usergroup->delete;
 851       if ( $error ) {
 852         $dbh->rollback if $oldAutoCommit;
 853         return "error deleting radius_usergroup $oldgroup: $error";
 854       }
 855     }
 856
 857     foreach my $newgroup ( @newgroups ) {
 858       my $radius_usergroup = new FS::radius_usergroup ( {
 859         svcnum    => $new->svcnum,
 860         groupname => $newgroup,
 861       } );
 862       my $error = $radius_usergroup->insert;
 863       if ( $error ) {
 864         $dbh->rollback if $oldAutoCommit;
 865         return "error adding radius_usergroup $newgroup: $error";
 866       }
 867     }
 868
 869   }
 870
 871   $error = $new->SUPER::replace($old, @_);
 872   if ( $error ) {
 873     $dbh->rollback if $oldAutoCommit;
 874     return $error if $error;
 875   }
 876
 877   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 878     $error = $new->queue_fuzzyfiles_update;
 879     if ( $error ) {
 880       $dbh->rollback if $oldAutoCommit;
 881       return "updating fuzzy search cache: $error";
 882     }
 883   }
 884
 885   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 886   ''; #no error
 887 }
 888
 889 =item queue_fuzzyfiles_update
 890
 891 Used by insert & replace to update the fuzzy search cache
 892
 893 =cut
 894
 895 sub queue_fuzzyfiles_update {
 896   my $self = shift;
 897
 898   local $SIG{HUP} = 'IGNORE';
 899   local $SIG{INT} = 'IGNORE';
 900   local $SIG{QUIT} = 'IGNORE';
 901   local $SIG{TERM} = 'IGNORE';
 902   local $SIG{TSTP} = 'IGNORE';
 903   local $SIG{PIPE} = 'IGNORE';
 904
 905   my $oldAutoCommit = $FS::UID::AutoCommit;
 906   local $FS::UID::AutoCommit = 0;
 907   my $dbh = dbh;
 908
 909   my $queue = new FS::queue {
 910     'svcnum' => $self->svcnum,
 911     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 912   };
 913   my $error = $queue->insert($self->username);
 914   if ( $error ) {
 915     $dbh->rollback if $oldAutoCommit;
 916     return "queueing job (transaction rolled back): $error";
 917   }
 918
 919   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 920   '';
 921
 922 }
 923
 924
 925 =item suspend
 926
 927 Suspends this account by calling export-specific suspend hooks.  If there is
 928 an error, returns the error, otherwise returns false.
 929
 930 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 931
 932 =cut
 933
 934 sub suspend {
 935   my $self = shift;
 936   return "can't suspend system account" if $self->_check_system;
 937   $self->SUPER::suspend(@_);
 938 }
 939
 940 =item unsuspend
 941
 942 Unsuspends this account by by calling export-specific suspend hooks.  If there
 943 is an error, returns the error, otherwise returns false.
 944
 945 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 946
 947 =cut
 948
 949 sub unsuspend {
 950   my $self = shift;
 951   my %hash = $self->hash;
 952   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 953     $hash{_password} = $1;
 954     my $new = new FS::svc_acct ( \%hash );
 955     my $error = $new->replace($self);
 956     return $error if $error;
 957   }
 958
 959   $self->SUPER::unsuspend(@_);
 960 }
 961
 962 =item cancel
 963
 964 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 965
 966 If the B<auto_unset_catchall> configuration option is set, this method will
 967 automatically remove any references to the canceled service in the catchall
 968 field of svc_domain.  This allows packages that contain both a svc_domain and
 969 its catchall svc_acct to be canceled in one step.
 970
 971 =cut
 972
 973 sub cancel {
 974   # Only one thing to do at this level
 975   my $self = shift;
 976   foreach my $svc_domain (
 977       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 978     if($conf->exists('auto_unset_catchall')) {
 979       my %hash = $svc_domain->hash;
 980       $hash{catchall} = '';
 981       my $new = new FS::svc_domain ( \%hash );
 982       my $error = $new->replace($svc_domain);
 983       return $error if $error;
 984     } else {
 985       return "cannot unprovision svc_acct #".$self->svcnum.
 986           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 987     }
 988   }
 989
 990   $self->SUPER::cancel(@_);
 991 }
 992
 993
 994 =item check
 995
 996 Checks all fields to make sure this is a valid service.  If there is an error,
 997 returns the error, otherwise returns false.  Called by the insert and replace
 998 methods.
 999
1000 Sets any fixed values; see L<FS::part_svc>.
1001
1002 =cut
1003
1004 sub check {
1005   my $self = shift;
1006
1007   my($recref) = $self->hashref;
1008
1009   my $x = $self->setfixed( $self->_fieldhandlers );
1010   return $x unless ref($x);
1011   my $part_svc = $x;
1012
1013   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1014     $self->usergroup(
1015       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1016   }
1017
1018   my $error = $self->ut_numbern('svcnum')
1019               #|| $self->ut_number('domsvc')
1020               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1021               || $self->ut_textn('sec_phrase')
1022               || $self->ut_snumbern('seconds')
1023               || $self->ut_snumbern('upbytes')
1024               || $self->ut_snumbern('downbytes')
1025               || $self->ut_snumbern('totalbytes')
1026               || $self->ut_enum( '_password_encoding',
1027                                  [ '', qw( plain crypt ldap ) ]
1028                                )
1029   ;
1030   return $error if $error;
1031
1032   my $cust_pkg;
1033   local $username_letter = $username_letter;
1034   if ($self->svcnum) {
1035     my $cust_svc = $self->cust_svc
1036       or return "no cust_svc record found for svcnum ". $self->svcnum;
1037     my $cust_pkg = $cust_svc->cust_pkg;
1038   }
1039   if ($self->pkgnum) {
1040     $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1041   }
1042   if ($cust_pkg) {
1043     $username_letter =
1044       $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1045   }
1046
1047   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1048   if ( $username_uppercase ) {
1049     $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1050       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1051     $recref->{username} = $1;
1052   } else {
1053     $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1054       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1055     $recref->{username} = $1;
1056   }
1057
1058   if ( $username_letterfirst ) {
1059     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1060   } elsif ( $username_letter ) {
1061     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1062   }
1063   if ( $username_noperiod ) {
1064     $recref->{username} =~ /\./ and return gettext('illegal_username');
1065   }
1066   if ( $username_nounderscore ) {
1067     $recref->{username} =~ /_/ and return gettext('illegal_username');
1068   }
1069   if ( $username_nodash ) {
1070     $recref->{username} =~ /\-/ and return gettext('illegal_username');
1071   }
1072   unless ( $username_ampersand ) {
1073     $recref->{username} =~ /\&/ and return gettext('illegal_username');
1074   }
1075   unless ( $username_percent ) {
1076     $recref->{username} =~ /\%/ and return gettext('illegal_username');
1077   }
1078   unless ( $username_colon ) {
1079     $recref->{username} =~ /\:/ and return gettext('illegal_username');
1080   }
1081
1082   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1083   $recref->{popnum} = $1;
1084   return "Unknown popnum" unless
1085     ! $recref->{popnum} ||
1086     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1087
1088   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1089
1090     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1091     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1092
1093     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1094     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1095     #not all systems use gid=uid
1096     #you can set a fixed gid in part_svc
1097
1098     return "Only root can have uid 0"
1099       if $recref->{uid} == 0
1100          && $recref->{username} !~ /^(root|toor|smtp)$/;
1101
1102     unless ( $recref->{username} eq 'sync' ) {
1103       if ( grep $_ eq $recref->{shell}, @shells ) {
1104         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1105       } else {
1106         return "Illegal shell \`". $self->shell. "\'; ".
1107                "shells configuration value contains: @shells";
1108       }
1109     } else {
1110       $recref->{shell} = '/bin/sync';
1111     }
1112
1113   } else {
1114     $recref->{gid} ne '' ?
1115       return "Can't have gid without uid" : ( $recref->{gid}='' );
1116     #$recref->{dir} ne '' ?
1117     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1118     $recref->{shell} ne '' ?
1119       return "Can't have shell without uid" : ( $recref->{shell}='' );
1120   }
1121
1122   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1123
1124     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1125       or return "Illegal directory: ". $recref->{dir};
1126     $recref->{dir} = $1;
1127     return "Illegal directory"
1128       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1129     return "Illegal directory"
1130       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1131     unless ( $recref->{dir} ) {
1132       $recref->{dir} = $dir_prefix . '/';
1133       if ( $dirhash > 0 ) {
1134         for my $h ( 1 .. $dirhash ) {
1135           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1136         }
1137       } elsif ( $dirhash < 0 ) {
1138         for my $h ( reverse $dirhash .. -1 ) {
1139           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1140         }
1141       }
1142       $recref->{dir} .= $recref->{username};
1143     ;
1144     }
1145
1146   }
1147
1148   #  $error = $self->ut_textn('finger');
1149   #  return $error if $error;
1150   if ( $self->getfield('finger') eq '' ) {
1151     my $cust_pkg = $self->svcnum
1152       ? $self->cust_svc->cust_pkg
1153       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1154     if ( $cust_pkg ) {
1155       my $cust_main = $cust_pkg->cust_main;
1156       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1157     }
1158   }
1159   $self->getfield('finger') =~
1160     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1161       or return "Illegal finger: ". $self->getfield('finger');
1162   $self->setfield('finger', $1);
1163
1164   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1165   $recref->{quota} = $1;
1166
1167   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1168     if ( $recref->{slipip} eq '' ) {
1169       $recref->{slipip} = '';
1170     } elsif ( $recref->{slipip} eq '0e0' ) {
1171       $recref->{slipip} = '0e0';
1172     } else {
1173       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1174         or return "Illegal slipip: ". $self->slipip;
1175       $recref->{slipip} = $1;
1176     }
1177
1178   }
1179
1180   #arbitrary RADIUS stuff; allow ut_textn for now
1181   foreach ( grep /^radius_/, fields('svc_acct') ) {
1182     $self->ut_textn($_);
1183   }
1184
1185   # First, if _password is blank, generate one and set default encoding.
1186   if ( ! $recref->{_password} ) {
1187     $error = $self->set_password('');
1188   }
1189   # But if there's a _password but no encoding, assume it's plaintext and
1190   # set it to default encoding.
1191   elsif ( ! $recref->{_password_encoding} ) {
1192     $error = $self->set_password($recref->{_password});
1193   }
1194   return $error if $error;
1195
1196   # Next, check _password to ensure compliance with the encoding.
1197   if ( $recref->{_password_encoding} eq 'ldap' ) {
1198
1199     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1200       $recref->{_password} = uc($1).$2;
1201     } else {
1202       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1203     }
1204
1205   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1206
1207     if ( $recref->{_password} =~
1208            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1209            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1210        ) {
1211
1212       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1213
1214     } else {
1215       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1216     }
1217
1218   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1219     # Password randomization is now in set_password.
1220     # Strip whitespace characters, check length requirements, etc.
1221     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1222       $recref->{_password} = $1;
1223     } else {
1224       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1225              FS::Msgcat::_gettext('illegal_password_characters').
1226              ": ". $recref->{_password};
1227     }
1228
1229     if ( $password_noampersand ) {
1230       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1231     }
1232     if ( $password_noexclamation ) {
1233       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1234     }
1235   }
1236   else {
1237     return "invalid password encoding ('".$recref->{_password_encoding}."'";
1238   }
1239   $self->SUPER::check;
1240
1241 }
1242
1243
1244 sub _password_encryption {
1245   my $self = shift;
1246   my $encoding = lc($self->_password_encoding);
1247   return if !$encoding;
1248   return 'plain' if $encoding eq 'plain';
1249   if($encoding eq 'crypt') {
1250     my $pass = $self->_password;
1251     $pass =~ s/^\*SUSPENDED\* //;
1252     $pass =~ s/^!!?//;
1253     return 'md5' if $pass =~ /^\$1\$/;
1254     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1255     return 'des' if length($pass) == 13;
1256     return;
1257   }
1258   if($encoding eq 'ldap') {
1259     uc($self->_password) =~ /^\{([\w-]+)\}/;
1260     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1261     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1262     return 'md5' if $1 eq 'MD5';
1263     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1264
1265     return;
1266   }
1267   return;
1268 }
1269
1270 sub get_cleartext_password {
1271   my $self = shift;
1272   if($self->_password_encryption eq 'plain') {
1273     if($self->_password_encoding eq 'ldap') {
1274       $self->_password =~ /\{\w+\}(.*)$/;
1275       return $1;
1276     }
1277     else {
1278       return $self->_password;
1279     }
1280   }
1281   return;
1282 }
1283
1284
1285 =item set_password
1286
1287 Set the cleartext password for the account.  If _password_encoding is set, the
1288 new password will be encoded according to the existing method (including
1289 encryption mode, if it can be determined).  Otherwise,
1290 config('default-password-encoding') is used.
1291
1292 If no password is supplied (or a zero-length password when minimum password length
1293 is >0), one will be generated randomly.
1294
1295 =cut
1296
1297 sub set_password {
1298   my $self = shift;
1299   my $pass = shift;
1300   my ($encoding, $encryption);
1301   my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1302                 FS::Msgcat::_gettext('illegal_password_characters').
1303                 ": ". $pass;
1304
1305   if(($passwordmin and length($pass) < $passwordmin) or
1306      ($passwordmax and length($pass) > $passwordmax)) {
1307     return $failure;
1308   }
1309
1310   if($self->_password_encoding) {
1311     $encoding = $self->_password_encoding;
1312     # identify existing encryption method, try to use it.
1313     $encryption = $self->_password_encryption;
1314     if(!$encryption) {
1315       # use the system default
1316       undef $encoding;
1317     }
1318   }
1319
1320   if(!$encoding) {
1321     # set encoding to system default
1322     ($encoding, $encryption) = split(/-/, lc($conf->config('default-password-encoding')));
1323     $encoding ||= 'legacy';
1324     $self->_password_encoding($encoding);
1325   }
1326
1327   if($encoding eq 'legacy') {
1328     # The legacy behavior from check():
1329     # If the password is blank, randomize it and set encoding to 'plain'.
1330     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1331       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1332       $self->_password_encoding('plain');
1333     }
1334     else {
1335       # Prefix + valid-length password
1336       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1337         $pass = $1.$3;
1338         $self->_password_encoding('plain');
1339       }
1340       # Prefix + crypt string
1341       elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1342         $pass = $1.$3;
1343         $self->_password_encoding('crypt');
1344       }
1345       # Various disabled crypt passwords
1346       elsif ( $pass eq '*' or
1347               $pass eq '!' or
1348               $pass eq '!!' ) {
1349         $self->_password_encoding('crypt');
1350       }
1351       else {
1352         return $failure;
1353       }
1354    }
1355   }
1356   elsif($encoding eq 'crypt') {
1357     if($encryption eq 'md5') {
1358       $pass = unix_md5_crypt($pass);
1359     }
1360     elsif($encryption eq 'des') {
1361       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1362     }
1363   }
1364   elsif($encoding eq 'ldap') {
1365     if($encryption eq 'md5') {
1366       $pass = md5_base64($pass);
1367     }
1368     elsif($encryption eq 'sha1') {
1369       $pass = sha1_base64($pass);
1370     }
1371     elsif($encryption eq 'crypt') {
1372       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1373     }
1374     # else $encryption eq 'plain', do nothing
1375     $pass = '{'.uc($encryption).'}'.$pass;
1376   }
1377   # else encoding eq 'plain'
1378
1379   $self->_password($pass);
1380   return;
1381 }
1382
1383 =item _check_system
1384
1385 Internal function to check the username against the list of system usernames
1386 from the I<system_usernames> configuration value.  Returns true if the username
1387 is listed on the system username list.
1388
1389 =cut
1390
1391 sub _check_system {
1392   my $self = shift;
1393   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1394                $conf->config('system_usernames')
1395         );
1396 }
1397
1398 =item _check_duplicate
1399
1400 Internal method to check for duplicates usernames, username@domain pairs and
1401 uids.
1402
1403 If the I<global_unique-username> configuration value is set to B<username> or
1404 B<username@domain>, enforces global username or username@domain uniqueness.
1405
1406 In all cases, check for duplicate uids and usernames or username@domain pairs
1407 per export and with identical I<svcpart> values.
1408
1409 =cut
1410
1411 sub _check_duplicate {
1412   my $self = shift;
1413
1414   my $global_unique = $conf->config('global_unique-username') || 'none';
1415   return '' if $global_unique eq 'disabled';
1416
1417   $self->lock_table;
1418
1419   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1420   unless ( $part_svc ) {
1421     return 'unknown svcpart '. $self->svcpart;
1422   }
1423
1424   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1425                  qsearch( 'svc_acct', { 'username' => $self->username } );
1426   return gettext('username_in_use')
1427     if $global_unique eq 'username' && @dup_user;
1428
1429   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1430                        qsearch( 'svc_acct', { 'username' => $self->username,
1431                                               'domsvc'   => $self->domsvc } );
1432   return gettext('username_in_use')
1433     if $global_unique eq 'username@domain' && @dup_userdomain;
1434
1435   my @dup_uid;
1436   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1437        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1438     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1439                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1440   } else {
1441     @dup_uid = ();
1442   }
1443
1444   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1445     my $exports = FS::part_export::export_info('svc_acct');
1446     my %conflict_user_svcpart;
1447     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1448
1449     foreach my $part_export ( $part_svc->part_export ) {
1450
1451       #this will catch to the same exact export
1452       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1453
1454       #this will catch to exports w/same exporthost+type ???
1455       #my @other_part_export = qsearch('part_export', {
1456       #  'machine'    => $part_export->machine,
1457       #  'exporttype' => $part_export->exporttype,
1458       #} );
1459       #foreach my $other_part_export ( @other_part_export ) {
1460       #  push @svcparts, map { $_->svcpart }
1461       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1462       #}
1463
1464       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1465       #silly kludge to avoid uninitialized value errors
1466       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1467                      ? $exports->{$part_export->exporttype}{'nodomain'}
1468                      : '';
1469       if ( $nodomain =~ /^Y/i ) {
1470         $conflict_user_svcpart{$_} = $part_export->exportnum
1471           foreach @svcparts;
1472       } else {
1473         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1474           foreach @svcparts;
1475       }
1476     }
1477
1478     foreach my $dup_user ( @dup_user ) {
1479       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1480       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1481         return "duplicate username ". $self->username.
1482                ": conflicts with svcnum ". $dup_user->svcnum.
1483                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1484       }
1485     }
1486
1487     foreach my $dup_userdomain ( @dup_userdomain ) {
1488       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1489       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1490         return "duplicate username\@domain ". $self->email.
1491                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1492                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1493       }
1494     }
1495
1496     foreach my $dup_uid ( @dup_uid ) {
1497       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1498       if ( exists($conflict_user_svcpart{$dup_svcpart})
1499            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1500         return "duplicate uid ". $self->uid.
1501                ": conflicts with svcnum ". $dup_uid->svcnum.
1502                " via exportnum ".
1503                ( $conflict_user_svcpart{$dup_svcpart}
1504                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1505       }
1506     }
1507
1508   }
1509
1510   return '';
1511
1512 }
1513
1514 =item radius
1515
1516 Depriciated, use radius_reply instead.
1517
1518 =cut
1519
1520 sub radius {
1521   carp "FS::svc_acct::radius depriciated, use radius_reply";
1522   $_[0]->radius_reply;
1523 }
1524
1525 =item radius_reply
1526
1527 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1528 reply attributes of this record.
1529
1530 Note that this is now the preferred method for reading RADIUS attributes -
1531 accessing the columns directly is discouraged, as the column names are
1532 expected to change in the future.
1533
1534 =cut
1535
1536 sub radius_reply {
1537   my $self = shift;
1538
1539   return %{ $self->{'radius_reply'} }
1540     if exists $self->{'radius_reply'};
1541
1542   my %reply =
1543     map {
1544       /^(radius_(.*))$/;
1545       my($column, $attrib) = ($1, $2);
1546       #$attrib =~ s/_/\-/g;
1547       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1548     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1549
1550   if ( $self->slipip && $self->slipip ne '0e0' ) {
1551     $reply{$radius_ip} = $self->slipip;
1552   }
1553
1554   if ( $self->seconds !~ /^$/ ) {
1555     $reply{'Session-Timeout'} = $self->seconds;
1556   }
1557
1558   if ( $conf->exists('radius-chillispot-max') ) {
1559     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1560
1561     #hmm.  just because sqlradius.pm says so?
1562     my %whatis = (
1563       'input'  => 'up',
1564       'output' => 'down',
1565       'total'  => 'total',
1566     );
1567
1568     foreach my $what (qw( input output total )) {
1569       my $is = $whatis{$what}.'bytes';
1570       if ( $self->$is() =~ /\d/ ) {
1571         my $big = new Math::BigInt $self->$is();
1572         $big = new Math::BigInt '0' if $big->is_neg();
1573         my $att = "Chillispot-Max-\u$what";
1574         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1575         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1576       }
1577     }
1578
1579   }
1580
1581   %reply;
1582 }
1583
1584 =item radius_check
1585
1586 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1587 check attributes of this record.
1588
1589 Note that this is now the preferred method for reading RADIUS attributes -
1590 accessing the columns directly is discouraged, as the column names are
1591 expected to change in the future.
1592
1593 =cut
1594
1595 sub radius_check {
1596   my $self = shift;
1597
1598   return %{ $self->{'radius_check'} }
1599     if exists $self->{'radius_check'};
1600
1601   my %check =
1602     map {
1603       /^(rc_(.*))$/;
1604       my($column, $attrib) = ($1, $2);
1605       #$attrib =~ s/_/\-/g;
1606       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1607     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1608
1609
1610   my($pw_attrib, $password) = $self->radius_password;
1611   $check{$pw_attrib} = $password;
1612
1613   my $cust_svc = $self->cust_svc;
1614   if ( $cust_svc ) {
1615     my $cust_pkg = $cust_svc->cust_pkg;
1616     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1617       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1618     }
1619   } else {
1620     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1621          "; can't set Expiration\n"
1622       unless $cust_svc;
1623   }
1624
1625   %check;
1626
1627 }
1628
1629 =item radius_password
1630
1631 Returns a key/value pair containing the RADIUS attribute name and value
1632 for the password.
1633
1634 =cut
1635
1636 sub radius_password {
1637   my $self = shift;
1638
1639   my($pw_attrib, $password);
1640   if ( $self->_password_encoding eq 'ldap' ) {
1641
1642     $pw_attrib = 'Password-With-Header';
1643     $password = $self->_password;
1644
1645   } elsif ( $self->_password_encoding eq 'crypt' ) {
1646
1647     $pw_attrib = 'Crypt-Password';
1648     $password = $self->_password;
1649
1650   } elsif ( $self->_password_encoding eq 'plain' ) {
1651
1652     $pw_attrib = $radius_password; #Cleartext-Password?  man rlm_pap
1653     $password = $self->_password;
1654
1655   } else {
1656
1657     $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1658     $password = $self->_password;
1659
1660   }
1661
1662   ($pw_attrib, $password);
1663
1664 }
1665
1666 =item snapshot
1667
1668 This method instructs the object to "snapshot" or freeze RADIUS check and
1669 reply attributes to the current values.
1670
1671 =cut
1672
1673 #bah, my english is too broken this morning
1674 #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
1675 #the FS::cust_pkg's replace method to trigger the correct export updates when
1676 #package dates change)
1677
1678 sub snapshot {
1679   my $self = shift;
1680
1681   $self->{$_} = { $self->$_() }
1682     foreach qw( radius_reply radius_check );
1683
1684 }
1685
1686 =item forget_snapshot
1687
1688 This methos instructs the object to forget any previously snapshotted
1689 RADIUS check and reply attributes.
1690
1691 =cut
1692
1693 sub forget_snapshot {
1694   my $self = shift;
1695
1696   delete $self->{$_}
1697     foreach qw( radius_reply radius_check );
1698
1699 }
1700
1701 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1702
1703 Returns the domain associated with this account.
1704
1705 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1706 history records.
1707
1708 =cut
1709
1710 sub domain {
1711   my $self = shift;
1712   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1713   my $svc_domain = $self->svc_domain(@_)
1714     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1715   $svc_domain->domain;
1716 }
1717
1718 =item svc_domain
1719
1720 Returns the FS::svc_domain record for this account's domain (see
1721 L<FS::svc_domain>).
1722
1723 =cut
1724
1725 # FS::h_svc_acct has a history-aware svc_domain override
1726
1727 sub svc_domain {
1728   my $self = shift;
1729   $self->{'_domsvc'}
1730     ? $self->{'_domsvc'}
1731     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1732 }
1733
1734 =item cust_svc
1735
1736 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1737
1738 =cut
1739
1740 #inherited from svc_Common
1741
1742 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1743
1744 Returns an email address associated with the account.
1745
1746 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1747 history records.
1748
1749 =cut
1750
1751 sub email {
1752   my $self = shift;
1753   $self->username. '@'. $self->domain(@_);
1754 }
1755
1756 =item acct_snarf
1757
1758 Returns an array of FS::acct_snarf records associated with the account.
1759 If the acct_snarf table does not exist or there are no associated records,
1760 an empty list is returned
1761
1762 =cut
1763
1764 sub acct_snarf {
1765   my $self = shift;
1766   return () unless dbdef->table('acct_snarf');
1767   eval "use FS::acct_snarf;";
1768   die $@ if $@;
1769   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1770 }
1771
1772 =item decrement_upbytes OCTETS
1773
1774 Decrements the I<upbytes> field of this record by the given amount.  If there
1775 is an error, returns the error, otherwise returns false.
1776
1777 =cut
1778
1779 sub decrement_upbytes {
1780   shift->_op_usage('-', 'upbytes', @_);
1781 }
1782
1783 =item increment_upbytes OCTETS
1784
1785 Increments the I<upbytes> field of this record by the given amount.  If there
1786 is an error, returns the error, otherwise returns false.
1787
1788 =cut
1789
1790 sub increment_upbytes {
1791   shift->_op_usage('+', 'upbytes', @_);
1792 }
1793
1794 =item decrement_downbytes OCTETS
1795
1796 Decrements the I<downbytes> field of this record by the given amount.  If there
1797 is an error, returns the error, otherwise returns false.
1798
1799 =cut
1800
1801 sub decrement_downbytes {
1802   shift->_op_usage('-', 'downbytes', @_);
1803 }
1804
1805 =item increment_downbytes OCTETS
1806
1807 Increments the I<downbytes> field of this record by the given amount.  If there
1808 is an error, returns the error, otherwise returns false.
1809
1810 =cut
1811
1812 sub increment_downbytes {
1813   shift->_op_usage('+', 'downbytes', @_);
1814 }
1815
1816 =item decrement_totalbytes OCTETS
1817
1818 Decrements the I<totalbytes> field of this record by the given amount.  If there
1819 is an error, returns the error, otherwise returns false.
1820
1821 =cut
1822
1823 sub decrement_totalbytes {
1824   shift->_op_usage('-', 'totalbytes', @_);
1825 }
1826
1827 =item increment_totalbytes OCTETS
1828
1829 Increments the I<totalbytes> field of this record by the given amount.  If there
1830 is an error, returns the error, otherwise returns false.
1831
1832 =cut
1833
1834 sub increment_totalbytes {
1835   shift->_op_usage('+', 'totalbytes', @_);
1836 }
1837
1838 =item decrement_seconds SECONDS
1839
1840 Decrements the I<seconds> field of this record by the given amount.  If there
1841 is an error, returns the error, otherwise returns false.
1842
1843 =cut
1844
1845 sub decrement_seconds {
1846   shift->_op_usage('-', 'seconds', @_);
1847 }
1848
1849 =item increment_seconds SECONDS
1850
1851 Increments the I<seconds> field of this record by the given amount.  If there
1852 is an error, returns the error, otherwise returns false.
1853
1854 =cut
1855
1856 sub increment_seconds {
1857   shift->_op_usage('+', 'seconds', @_);
1858 }
1859
1860
1861 my %op2action = (
1862   '-' => 'suspend',
1863   '+' => 'unsuspend',
1864 );
1865 my %op2condition = (
1866   '-' => sub { my($self, $column, $amount) = @_;
1867                $self->$column - $amount <= 0;
1868              },
1869   '+' => sub { my($self, $column, $amount) = @_;
1870                ($self->$column || 0) + $amount > 0;
1871              },
1872 );
1873 my %op2warncondition = (
1874   '-' => sub { my($self, $column, $amount) = @_;
1875                my $threshold = $column . '_threshold';
1876                $self->$column - $amount <= $self->$threshold + 0;
1877              },
1878   '+' => sub { my($self, $column, $amount) = @_;
1879                ($self->$column || 0) + $amount > 0;
1880              },
1881 );
1882
1883 sub _op_usage {
1884   my( $self, $op, $column, $amount ) = @_;
1885
1886   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1887        ' ('. $self->email. "): $op $amount\n"
1888     if $DEBUG;
1889
1890   return '' unless $amount;
1891
1892   local $SIG{HUP} = 'IGNORE';
1893   local $SIG{INT} = 'IGNORE';
1894   local $SIG{QUIT} = 'IGNORE';
1895   local $SIG{TERM} = 'IGNORE';
1896   local $SIG{TSTP} = 'IGNORE';
1897   local $SIG{PIPE} = 'IGNORE';
1898
1899   my $oldAutoCommit = $FS::UID::AutoCommit;
1900   local $FS::UID::AutoCommit = 0;
1901   my $dbh = dbh;
1902
1903   my $sql = "UPDATE svc_acct SET $column = ".
1904             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1905             " $op ? WHERE svcnum = ?";
1906   warn "$me $sql\n"
1907     if $DEBUG;
1908
1909   my $sth = $dbh->prepare( $sql )
1910     or die "Error preparing $sql: ". $dbh->errstr;
1911   my $rv = $sth->execute($amount, $self->svcnum);
1912   die "Error executing $sql: ". $sth->errstr
1913     unless defined($rv);
1914   die "Can't update $column for svcnum". $self->svcnum
1915     if $rv == 0;
1916
1917   #$self->snapshot; #not necessary, we retain the old values
1918   #create an object with the updated usage values
1919   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1920   #call exports
1921   my $error = $new->replace($self);
1922   if ( $error ) {
1923     $dbh->rollback if $oldAutoCommit;
1924     return "Error replacing: $error";
1925   }
1926
1927   #overlimit_action eq 'cancel' handling
1928   my $cust_pkg = $self->cust_svc->cust_pkg;
1929   if ( $cust_pkg
1930        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1931        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1932      )
1933   {
1934
1935     my $error = $cust_pkg->cancel; #XXX should have a reason
1936     if ( $error ) {
1937       $dbh->rollback if $oldAutoCommit;
1938       return "Error cancelling: $error";
1939     }
1940
1941     #nothing else is relevant if we're cancelling, so commit & return success
1942     warn "$me update successful; committing\n"
1943       if $DEBUG;
1944     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1945     return '';
1946
1947   }
1948
1949   my $action = $op2action{$op};
1950
1951   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1952         ( $action eq 'suspend'   && !$self->overlimit
1953        || $action eq 'unsuspend' &&  $self->overlimit )
1954      ) {
1955
1956     my $error = $self->_op_overlimit($action);
1957     if ( $error ) {
1958       $dbh->rollback if $oldAutoCommit;
1959       return $error;
1960     }
1961
1962   }
1963
1964   if ( $conf->exists("svc_acct-usage_$action")
1965        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1966     #my $error = $self->$action();
1967     my $error = $self->cust_svc->cust_pkg->$action();
1968     # $error ||= $self->overlimit($action);
1969     if ( $error ) {
1970       $dbh->rollback if $oldAutoCommit;
1971       return "Error ${action}ing: $error";
1972     }
1973   }
1974
1975   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1976     my $wqueue = new FS::queue {
1977       'svcnum' => $self->svcnum,
1978       'job'    => 'FS::svc_acct::reached_threshold',
1979     };
1980
1981     my $to = '';
1982     if ($op eq '-'){
1983       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1984     }
1985
1986     # x_threshold race
1987     my $error = $wqueue->insert(
1988       'svcnum' => $self->svcnum,
1989       'op'     => $op,
1990       'column' => $column,
1991       'to'     => $to,
1992     );
1993     if ( $error ) {
1994       $dbh->rollback if $oldAutoCommit;
1995       return "Error queuing threshold activity: $error";
1996     }
1997   }
1998
1999   warn "$me update successful; committing\n"
2000     if $DEBUG;
2001   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2002   '';
2003
2004 }
2005
2006 sub _op_overlimit {
2007   my( $self, $action ) = @_;
2008
2009   local $SIG{HUP} = 'IGNORE';
2010   local $SIG{INT} = 'IGNORE';
2011   local $SIG{QUIT} = 'IGNORE';
2012   local $SIG{TERM} = 'IGNORE';
2013   local $SIG{TSTP} = 'IGNORE';
2014   local $SIG{PIPE} = 'IGNORE';
2015
2016   my $oldAutoCommit = $FS::UID::AutoCommit;
2017   local $FS::UID::AutoCommit = 0;
2018   my $dbh = dbh;
2019
2020   my $cust_pkg = $self->cust_svc->cust_pkg;
2021
2022   my $conf_overlimit =
2023     $cust_pkg
2024       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2025       : $conf->config('overlimit_groups');
2026
2027   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2028
2029     my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2030     next unless $groups;
2031
2032     my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2033
2034     my $other = new FS::svc_acct $self->hashref;
2035     $other->usergroup( $gref );
2036
2037     my($new,$old);
2038     if ($action eq 'suspend') {
2039       $new = $other;
2040       $old = $self;
2041     } else { # $action eq 'unsuspend'
2042       $new = $self;
2043       $old = $other;
2044     }
2045
2046     my $error = $part_export->export_replace($new, $old)
2047                 || $self->overlimit($action);
2048
2049     if ( $error ) {
2050       $dbh->rollback if $oldAutoCommit;
2051       return "Error replacing radius groups: $error";
2052     }
2053
2054   }
2055
2056   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2057   '';
2058
2059 }
2060
2061 sub set_usage {
2062   my( $self, $valueref, %options ) = @_;
2063
2064   warn "$me set_usage called for svcnum ". $self->svcnum.
2065        ' ('. $self->email. "): ".
2066        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2067     if $DEBUG;
2068
2069   local $SIG{HUP} = 'IGNORE';
2070   local $SIG{INT} = 'IGNORE';
2071   local $SIG{QUIT} = 'IGNORE';
2072   local $SIG{TERM} = 'IGNORE';
2073   local $SIG{TSTP} = 'IGNORE';
2074   local $SIG{PIPE} = 'IGNORE';
2075
2076   local $FS::svc_Common::noexport_hack = 1;
2077   my $oldAutoCommit = $FS::UID::AutoCommit;
2078   local $FS::UID::AutoCommit = 0;
2079   my $dbh = dbh;
2080
2081   my $reset = 0;
2082   my %handyhash = ();
2083   if ( $options{null} ) {
2084     %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2085                    qw( seconds upbytes downbytes totalbytes )
2086                  );
2087   }
2088   foreach my $field (keys %$valueref){
2089     $reset = 1 if $valueref->{$field};
2090     $self->setfield($field, $valueref->{$field});
2091     $self->setfield( $field.'_threshold',
2092                      int($self->getfield($field)
2093                          * ( $conf->exists('svc_acct-usage_threshold')
2094                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2095                              : 0.20
2096                            )
2097                        )
2098                      );
2099     $handyhash{$field} = $self->getfield($field);
2100     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2101   }
2102   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2103   #die $error if $error;         #services not explicity changed via the UI
2104
2105   my $sql = "UPDATE svc_acct SET " .
2106     join (',', map { "$_ =  $handyhash{$_}" } (keys %handyhash) ).
2107     " WHERE svcnum = ". $self->svcnum;
2108
2109   warn "$me $sql\n"
2110     if $DEBUG;
2111
2112   if (scalar(keys %handyhash)) {
2113     my $sth = $dbh->prepare( $sql )
2114       or die "Error preparing $sql: ". $dbh->errstr;
2115     my $rv = $sth->execute();
2116     die "Error executing $sql: ". $sth->errstr
2117       unless defined($rv);
2118     die "Can't update usage for svcnum ". $self->svcnum
2119       if $rv == 0;
2120   }
2121
2122   #$self->snapshot; #not necessary, we retain the old values
2123   #create an object with the updated usage values
2124   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2125   #call exports
2126   my $error = $new->replace($self);
2127   if ( $error ) {
2128     $dbh->rollback if $oldAutoCommit;
2129     return "Error replacing: $error";
2130   }
2131
2132   if ( $reset ) {
2133
2134     my $error = '';
2135
2136     $error = $self->_op_overlimit('unsuspend')
2137       if $self->overlimit;;
2138
2139     $error ||= $self->cust_svc->cust_pkg->unsuspend
2140       if $conf->exists("svc_acct-usage_unsuspend");
2141
2142     if ( $error ) {
2143       $dbh->rollback if $oldAutoCommit;
2144       return "Error unsuspending: $error";
2145     }
2146
2147   }
2148
2149   warn "$me update successful; committing\n"
2150     if $DEBUG;
2151   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2152   '';
2153
2154 }
2155
2156
2157 =item recharge HASHREF
2158
2159   Increments usage columns by the amount specified in HASHREF as
2160   column=>amount pairs.
2161
2162 =cut
2163
2164 sub recharge {
2165   my ($self, $vhash) = @_;
2166
2167   if ( $DEBUG ) {
2168     warn "[$me] recharge called on $self: ". Dumper($self).
2169          "\nwith vhash: ". Dumper($vhash);
2170   }
2171
2172   my $oldAutoCommit = $FS::UID::AutoCommit;
2173   local $FS::UID::AutoCommit = 0;
2174   my $dbh = dbh;
2175   my $error = '';
2176
2177   foreach my $column (keys %$vhash){
2178     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2179   }
2180
2181   if ( $error ) {
2182     $dbh->rollback if $oldAutoCommit;
2183   }else{
2184     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2185   }
2186   return $error;
2187 }
2188
2189 =item is_rechargeable
2190
2191 Returns true if this svc_account can be "recharged" and false otherwise.
2192
2193 =cut
2194
2195 sub is_rechargable {
2196   my $self = shift;
2197   $self->seconds ne ''
2198     || $self->upbytes ne ''
2199     || $self->downbytes ne ''
2200     || $self->totalbytes ne '';
2201 }
2202
2203 =item seconds_since TIMESTAMP
2204
2205 Returns the number of seconds this account has been online since TIMESTAMP,
2206 according to the session monitor (see L<FS::Session>).
2207
2208 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2209 L<Time::Local> and L<Date::Parse> for conversion functions.
2210
2211 =cut
2212
2213 #note: POD here, implementation in FS::cust_svc
2214 sub seconds_since {
2215   my $self = shift;
2216   $self->cust_svc->seconds_since(@_);
2217 }
2218
2219 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2220
2221 Returns the numbers of seconds this account has been online between
2222 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2223 external SQL radacct table, specified via sqlradius export.  Sessions which
2224 started in the specified range but are still open are counted from session
2225 start to the end of the range (unless they are over 1 day old, in which case
2226 they are presumed missing their stop record and not counted).  Also, sessions
2227 which end in the range but started earlier are counted from the start of the
2228 range to session end.  Finally, sessions which start before the range but end
2229 after are counted for the entire range.
2230
2231 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2232 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2233 functions.
2234
2235 =cut
2236
2237 #note: POD here, implementation in FS::cust_svc
2238 sub seconds_since_sqlradacct {
2239   my $self = shift;
2240   $self->cust_svc->seconds_since_sqlradacct(@_);
2241 }
2242
2243 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2244
2245 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2246 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2247 TIMESTAMP_END (exclusive).
2248
2249 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2250 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2251 functions.
2252
2253 =cut
2254
2255 #note: POD here, implementation in FS::cust_svc
2256 sub attribute_since_sqlradacct {
2257   my $self = shift;
2258   $self->cust_svc->attribute_since_sqlradacct(@_);
2259 }
2260
2261 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2262
2263 Returns an array of hash references of this customers login history for the
2264 given time range.  (document this better)
2265
2266 =cut
2267
2268 sub get_session_history {
2269   my $self = shift;
2270   $self->cust_svc->get_session_history(@_);
2271 }
2272
2273 =item last_login_text
2274
2275 Returns text describing the time of last login.
2276
2277 =cut
2278
2279 sub last_login_text {
2280   my $self = shift;
2281   $self->last_login ? ctime($self->last_login) : 'unknown';
2282 }
2283
2284 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2285
2286 =cut
2287
2288 sub get_cdrs {
2289   my($self, $start, $end, %opt ) = @_;
2290
2291   my $did = $self->username; #yup
2292
2293   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2294
2295   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2296
2297   #SELECT $for_update * FROM cdr
2298   #  WHERE calldate >= $start #need a conversion
2299   #    AND calldate <  $end   #ditto
2300   #    AND (    charged_party = "$did"
2301   #          OR charged_party = "$prefix$did" #if length($prefix);
2302   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2303   #               AND
2304   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2305   #             )
2306   #        )
2307   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2308
2309   my $charged_or_src;
2310   if ( length($prefix) ) {
2311     $charged_or_src =
2312       " AND (    charged_party = '$did'
2313               OR charged_party = '$prefix$did'
2314               OR ( ( charged_party IS NULL OR charged_party = '' )
2315                    AND
2316                    ( src = '$did' OR src = '$prefix$did' )
2317                  )
2318             )
2319       ";
2320   } else {
2321     $charged_or_src =
2322       " AND (    charged_party = '$did'
2323               OR ( ( charged_party IS NULL OR charged_party = '' )
2324                    AND
2325                    src = '$did'
2326                  )
2327             )
2328       ";
2329
2330   }
2331
2332   qsearch(
2333     'select'    => "$for_update *",
2334     'table'     => 'cdr',
2335     'hashref'   => {
2336                      #( freesidestatus IS NULL OR freesidestatus = '' )
2337                      'freesidestatus' => '',
2338                    },
2339     'extra_sql' => $charged_or_src,
2340
2341   );
2342
2343 }
2344
2345 =item radius_groups
2346
2347 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2348
2349 =cut
2350
2351 sub radius_groups {
2352   my $self = shift;
2353   if ( $self->usergroup ) {
2354     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2355       unless ref($self->usergroup) eq 'ARRAY';
2356     #when provisioning records, export callback runs in svc_Common.pm before
2357     #radius_usergroup records can be inserted...
2358     @{$self->usergroup};
2359   } else {
2360     map { $_->groupname }
2361       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2362   }
2363 }
2364
2365 =item clone_suspended
2366
2367 Constructor used by FS::part_export::_export_suspend fallback.  Document
2368 better.
2369
2370 =cut
2371
2372 sub clone_suspended {
2373   my $self = shift;
2374   my %hash = $self->hash;
2375   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2376   new FS::svc_acct \%hash;
2377 }
2378
2379 =item clone_kludge_unsuspend
2380
2381 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2382 better.
2383
2384 =cut
2385
2386 sub clone_kludge_unsuspend {
2387   my $self = shift;
2388   my %hash = $self->hash;
2389   $hash{_password} = '';
2390   new FS::svc_acct \%hash;
2391 }
2392
2393 =item check_password
2394
2395 Checks the supplied password against the (possibly encrypted) password in the
2396 database.  Returns true for a successful authentication, false for no match.
2397
2398 Currently supported encryptions are: classic DES crypt() and MD5
2399
2400 =cut
2401
2402 sub check_password {
2403   my($self, $check_password) = @_;
2404
2405   #remove old-style SUSPENDED kludge, they should be allowed to login to
2406   #self-service and pay up
2407   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2408
2409   if ( $self->_password_encoding eq 'ldap' ) {
2410
2411     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2412     return $auth->match($check_password);
2413
2414   } elsif ( $self->_password_encoding eq 'crypt' ) {
2415
2416     my $auth = from_crypt Authen::Passphrase $self->_password;
2417     return $auth->match($check_password);
2418
2419   } elsif ( $self->_password_encoding eq 'plain' ) {
2420
2421     return $check_password eq $password;
2422
2423   } else {
2424
2425     #XXX this could be replaced with Authen::Passphrase stuff
2426
2427     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2428       return 0;
2429     } elsif ( length($password) < 13 ) { #plaintext
2430       $check_password eq $password;
2431     } elsif ( length($password) == 13 ) { #traditional DES crypt
2432       crypt($check_password, $password) eq $password;
2433     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2434       unix_md5_crypt($check_password, $password) eq $password;
2435     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2436       warn "Can't check password: Blowfish encryption not yet supported, ".
2437            "svcnum ".  $self->svcnum. "\n";
2438       0;
2439     } else {
2440       warn "Can't check password: Unrecognized encryption for svcnum ".
2441            $self->svcnum. "\n";
2442       0;
2443     }
2444
2445   }
2446
2447 }
2448
2449 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2450
2451 Returns an encrypted password, either by passing through an encrypted password
2452 in the database or by encrypting a plaintext password from the database.
2453
2454 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2455 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2456 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2457 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2458 encryption type is only used if the password is not already encrypted in the
2459 database.
2460
2461 =cut
2462
2463 sub crypt_password {
2464   my $self = shift;
2465
2466   if ( $self->_password_encoding eq 'ldap' ) {
2467
2468     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2469       my $plain = $2;
2470
2471       #XXX this could be replaced with Authen::Passphrase stuff
2472
2473       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2474       if ( $encryption eq 'crypt' ) {
2475         crypt(
2476           $self->_password,
2477           $saltset[int(rand(64))].$saltset[int(rand(64))]
2478         );
2479       } elsif ( $encryption eq 'md5' ) {
2480         unix_md5_crypt( $self->_password );
2481       } elsif ( $encryption eq 'blowfish' ) {
2482         croak "unknown encryption method $encryption";
2483       } else {
2484         croak "unknown encryption method $encryption";
2485       }
2486
2487     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2488       $1;
2489     }
2490
2491   } elsif ( $self->_password_encoding eq 'crypt' ) {
2492
2493     return $self->_password;
2494
2495   } elsif ( $self->_password_encoding eq 'plain' ) {
2496
2497     #XXX this could be replaced with Authen::Passphrase stuff
2498
2499     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2500     if ( $encryption eq 'crypt' ) {
2501       crypt(
2502         $self->_password,
2503         $saltset[int(rand(64))].$saltset[int(rand(64))]
2504       );
2505     } elsif ( $encryption eq 'md5' ) {
2506       unix_md5_crypt( $self->_password );
2507     } elsif ( $encryption eq 'blowfish' ) {
2508       croak "unknown encryption method $encryption";
2509     } else {
2510       croak "unknown encryption method $encryption";
2511     }
2512
2513   } else {
2514
2515     if ( length($self->_password) == 13
2516          || $self->_password =~ /^\$(1|2a?)\$/
2517          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2518        )
2519     {
2520       $self->_password;
2521     } else {
2522
2523       #XXX this could be replaced with Authen::Passphrase stuff
2524
2525       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2526       if ( $encryption eq 'crypt' ) {
2527         crypt(
2528           $self->_password,
2529           $saltset[int(rand(64))].$saltset[int(rand(64))]
2530         );
2531       } elsif ( $encryption eq 'md5' ) {
2532         unix_md5_crypt( $self->_password );
2533       } elsif ( $encryption eq 'blowfish' ) {
2534         croak "unknown encryption method $encryption";
2535       } else {
2536         croak "unknown encryption method $encryption";
2537       }
2538
2539     }
2540
2541   }
2542
2543 }
2544
2545 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2546
2547 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2548 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2549 "{MD5}5426824942db4253f87a1009fd5d2d4".
2550
2551 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2552 to work the same as the B</crypt_password> method.
2553
2554 =cut
2555
2556 sub ldap_password {
2557   my $self = shift;
2558   #eventually should check a "password-encoding" field
2559
2560   if ( $self->_password_encoding eq 'ldap' ) {
2561
2562     return $self->_password;
2563
2564   } elsif ( $self->_password_encoding eq 'crypt' ) {
2565
2566     if ( length($self->_password) == 13 ) { #crypt
2567       return '{CRYPT}'. $self->_password;
2568     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2569       return '{MD5}'. $1;
2570     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2571     #  die "Blowfish encryption not supported in this context, svcnum ".
2572     #      $self->svcnum. "\n";
2573     } else {
2574       warn "encryption method not (yet?) supported in LDAP context";
2575       return '{CRYPT}*'; #unsupported, should not auth
2576     }
2577
2578   } elsif ( $self->_password_encoding eq 'plain' ) {
2579
2580     return '{PLAIN}'. $self->_password;
2581
2582     #return '{CLEARTEXT}'. $self->_password; #?
2583
2584   } else {
2585
2586     if ( length($self->_password) == 13 ) { #crypt
2587       return '{CRYPT}'. $self->_password;
2588     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2589       return '{MD5}'. $1;
2590     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2591       warn "Blowfish encryption not supported in this context, svcnum ".
2592           $self->svcnum. "\n";
2593       return '{CRYPT}*';
2594
2595     #are these two necessary anymore?
2596     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2597       return '{SSHA}'. $1;
2598     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2599       return '{NS-MTA-MD5}'. $1;
2600
2601     } else { #plaintext
2602       return '{PLAIN}'. $self->_password;
2603
2604       #return '{CLEARTEXT}'. $self->_password; #?
2605
2606       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2607       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2608       #if ( $encryption eq 'crypt' ) {
2609       #  return '{CRYPT}'. crypt(
2610       #    $self->_password,
2611       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2612       #  );
2613       #} elsif ( $encryption eq 'md5' ) {
2614       #  unix_md5_crypt( $self->_password );
2615       #} elsif ( $encryption eq 'blowfish' ) {
2616       #  croak "unknown encryption method $encryption";
2617       #} else {
2618       #  croak "unknown encryption method $encryption";
2619       #}
2620     }
2621
2622   }
2623
2624 }
2625
2626 =item domain_slash_username
2627
2628 Returns $domain/$username/
2629
2630 =cut
2631
2632 sub domain_slash_username {
2633   my $self = shift;
2634   $self->domain. '/'. $self->username. '/';
2635 }
2636
2637 =item virtual_maildir
2638
2639 Returns $domain/maildirs/$username/
2640
2641 =cut
2642
2643 sub virtual_maildir {
2644   my $self = shift;
2645   $self->domain. '/maildirs/'. $self->username. '/';
2646 }
2647
2648 =back
2649
2650 =head1 CLASS METHODS
2651
2652 =over 4
2653
2654 =item search HASHREF
2655
2656 Class method which returns a qsearch hash expression to search for parameters
2657 specified in HASHREF.  Valid parameters are
2658
2659 =over 4
2660
2661 =item domain
2662
2663 =item domsvc
2664
2665 =item unlinked
2666
2667 =item agentnum
2668
2669 =item pkgpart
2670
2671 Arrayref of pkgparts
2672
2673 =item pkgpart
2674
2675 =item where
2676
2677 Arrayref of additional WHERE clauses, will be ANDed together.
2678
2679 =item order_by
2680
2681 =item cust_fields
2682
2683 =back
2684
2685 =cut
2686
2687 sub search {
2688   my ($class, $params) = @_;
2689
2690   my @where = ();
2691
2692   # domain
2693   if ( $params->{'domain'} ) {
2694     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2695     #preserve previous behavior & bubble up an error if $svc_domain not found?
2696     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2697   }
2698
2699   # domsvc
2700   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2701     push @where, "domsvc = $1";
2702   }
2703
2704   #unlinked
2705   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2706
2707   #agentnum
2708   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2709     push @where, "agentnum = $1";
2710   }
2711
2712   #custnum
2713   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2714     push @where, "custnum = $1";
2715   }
2716
2717   #pkgpart
2718   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2719     #XXX untaint or sql quote
2720     push @where,
2721       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2722   }
2723
2724   # popnum
2725   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2726     push @where, "popnum = $1";
2727   }
2728
2729   # svcpart
2730   if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2731     push @where, "svcpart = $1";
2732   }
2733
2734
2735   # here is the agent virtualization
2736   #if ($params->{CurrentUser}) {
2737   #  my $access_user =
2738   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2739   #
2740   #  if ($access_user) {
2741   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2742   #  }else{
2743   #    push @where, "1=0";
2744   #  }
2745   #} else {
2746     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2747                    'table'      => 'cust_main',
2748                    'null_right' => 'View/link unlinked services',
2749                  );
2750   #}
2751
2752   push @where, @{ $params->{'where'} } if $params->{'where'};
2753
2754   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2755
2756   my $addl_from = ' LEFT JOIN cust_svc  USING ( svcnum  ) '.
2757                   ' LEFT JOIN part_svc  USING ( svcpart ) '.
2758                   ' LEFT JOIN cust_pkg  USING ( pkgnum  ) '.
2759                   ' LEFT JOIN cust_main USING ( custnum ) ';
2760
2761   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2762   #if ( keys %svc_acct ) {
2763   #  $count_query .= ' WHERE '.
2764   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2765   #                                      keys %svc_acct
2766   #                        );
2767   #}
2768
2769   my $sql_query = {
2770     'table'       => 'svc_acct',
2771     'hashref'     => {}, # \%svc_acct,
2772     'select'      => join(', ',
2773                        'svc_acct.*',
2774                        'part_svc.svc',
2775                        'cust_main.custnum',
2776                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2777                      ),
2778     'addl_from'   => $addl_from,
2779     'extra_sql'   => $extra_sql,
2780     'order_by'    => $params->{'order_by'},
2781     'count_query' => $count_query,
2782   };
2783
2784 }
2785
2786 =back
2787
2788 =head1 SUBROUTINES
2789
2790 =over 4
2791
2792 =item send_email
2793
2794 This is the FS::svc_acct job-queue-able version.  It still uses
2795 FS::Misc::send_email under-the-hood.
2796
2797 =cut
2798
2799 sub send_email {
2800   my %opt = @_;
2801
2802   eval "use FS::Misc qw(send_email)";
2803   die $@ if $@;
2804
2805   $opt{mimetype} ||= 'text/plain';
2806   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2807
2808   my $error = send_email(
2809     'from'         => $opt{from},
2810     'to'           => $opt{to},
2811     'subject'      => $opt{subject},
2812     'content-type' => $opt{mimetype},
2813     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2814   );
2815   die $error if $error;
2816 }
2817
2818 =item check_and_rebuild_fuzzyfiles
2819
2820 =cut
2821
2822 sub check_and_rebuild_fuzzyfiles {
2823   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2824   -e "$dir/svc_acct.username"
2825     or &rebuild_fuzzyfiles;
2826 }
2827
2828 =item rebuild_fuzzyfiles
2829
2830 =cut
2831
2832 sub rebuild_fuzzyfiles {
2833
2834   use Fcntl qw(:flock);
2835
2836   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2837
2838   #username
2839
2840   open(USERNAMELOCK,">>$dir/svc_acct.username")
2841     or die "can't open $dir/svc_acct.username: $!";
2842   flock(USERNAMELOCK,LOCK_EX)
2843     or die "can't lock $dir/svc_acct.username: $!";
2844
2845   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2846
2847   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2848     or die "can't open $dir/svc_acct.username.tmp: $!";
2849   print USERNAMECACHE join("\n", @all_username), "\n";
2850   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2851
2852   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2853   close USERNAMELOCK;
2854
2855 }
2856
2857 =item all_username
2858
2859 =cut
2860
2861 sub all_username {
2862   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2863   open(USERNAMECACHE,"<$dir/svc_acct.username")
2864     or die "can't open $dir/svc_acct.username: $!";
2865   my @array = map { chomp; $_; } <USERNAMECACHE>;
2866   close USERNAMECACHE;
2867   \@array;
2868 }
2869
2870 =item append_fuzzyfiles USERNAME
2871
2872 =cut
2873
2874 sub append_fuzzyfiles {
2875   my $username = shift;
2876
2877   &check_and_rebuild_fuzzyfiles;
2878
2879   use Fcntl qw(:flock);
2880
2881   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2882
2883   open(USERNAME,">>$dir/svc_acct.username")
2884     or die "can't open $dir/svc_acct.username: $!";
2885   flock(USERNAME,LOCK_EX)
2886     or die "can't lock $dir/svc_acct.username: $!";
2887
2888   print USERNAME "$username\n";
2889
2890   flock(USERNAME,LOCK_UN)
2891     or die "can't unlock $dir/svc_acct.username: $!";
2892   close USERNAME;
2893
2894   1;
2895 }
2896
2897
2898
2899 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2900
2901 =cut
2902
2903 sub radius_usergroup_selector {
2904   my $sel_groups = shift;
2905   my %sel_groups = map { $_=>1 } @$sel_groups;
2906
2907   my $selectname = shift || 'radius_usergroup';
2908
2909   my $dbh = dbh;
2910   my $sth = $dbh->prepare(
2911     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2912   ) or die $dbh->errstr;
2913   $sth->execute() or die $sth->errstr;
2914   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2915
2916   my $html = <<END;
2917     <SCRIPT>
2918     function ${selectname}_doadd(object) {
2919       var myvalue = object.${selectname}_add.value;
2920       var optionName = new Option(myvalue,myvalue,false,true);
2921       var length = object.$selectname.length;
2922       object.$selectname.options[length] = optionName;
2923       object.${selectname}_add.value = "";
2924     }
2925     </SCRIPT>
2926     <SELECT MULTIPLE NAME="$selectname">
2927 END
2928
2929   foreach my $group ( @all_groups ) {
2930     $html .= qq(<OPTION VALUE="$group");
2931     if ( $sel_groups{$group} ) {
2932       $html .= ' SELECTED';
2933       $sel_groups{$group} = 0;
2934     }
2935     $html .= ">$group</OPTION>\n";
2936   }
2937   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2938     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2939   };
2940   $html .= '</SELECT>';
2941
2942   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2943            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2944
2945   $html;
2946 }
2947
2948 =item reached_threshold
2949
2950 Performs some activities when svc_acct thresholds (such as number of seconds
2951 remaining) are reached.
2952
2953 =cut
2954
2955 sub reached_threshold {
2956   my %opt = @_;
2957
2958   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2959   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2960
2961   if ( $opt{'op'} eq '+' ){
2962     $svc_acct->setfield( $opt{'column'}.'_threshold',
2963                          int($svc_acct->getfield($opt{'column'})
2964                              * ( $conf->exists('svc_acct-usage_threshold')
2965                                  ? $conf->config('svc_acct-usage_threshold')/100
2966                                  : 0.80
2967                                )
2968                          )
2969                        );
2970     my $error = $svc_acct->replace;
2971     die $error if $error;
2972   }elsif ( $opt{'op'} eq '-' ){
2973
2974     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2975     return '' if ($threshold eq '' );
2976
2977     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2978     my $error = $svc_acct->replace;
2979     die $error if $error; # email next time, i guess
2980
2981     if ( $warning_template ) {
2982       eval "use FS::Misc qw(send_email)";
2983       die $@ if $@;
2984
2985       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2986       my $cust_main = $cust_pkg->cust_main;
2987
2988       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2989                                $cust_main->invoicing_list,
2990                                ($opt{'to'} ? $opt{'to'} : ())
2991                    );
2992
2993       my $mimetype = $warning_mimetype;
2994       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2995
2996       my $body       =  $warning_template->fill_in( HASH => {
2997                         'custnum'   => $cust_main->custnum,
2998                         'username'  => $svc_acct->username,
2999                         'password'  => $svc_acct->_password,
3000                         'first'     => $cust_main->first,
3001                         'last'      => $cust_main->getfield('last'),
3002                         'pkg'       => $cust_pkg->part_pkg->pkg,
3003                         'column'    => $opt{'column'},
3004                         'amount'    => $opt{'column'} =~/bytes/
3005                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3006                                        : $svc_acct->getfield($opt{'column'}),
3007                         'threshold' => $opt{'column'} =~/bytes/
3008                                        ? FS::UI::bytecount::display_bytecount($threshold)
3009                                        : $threshold,
3010                       } );
3011
3012
3013       my $error = send_email(
3014         'from'         => $warning_from,
3015         'to'           => $to,
3016         'subject'      => $warning_subject,
3017         'content-type' => $mimetype,
3018         'body'         => [ map "$_\n", split("\n", $body) ],
3019       );
3020       die $error if $error;
3021     }
3022   }else{
3023     die "unknown op: " . $opt{'op'};
3024   }
3025 }
3026
3027 =back
3028
3029 =head1 BUGS
3030
3031 The $recref stuff in sub check should be cleaned up.
3032
3033 The suspend, unsuspend and cancel methods update the database, but not the
3034 current object.  This is probably a bug as it's unexpected and
3035 counterintuitive.
3036
3037 radius_usergroup_selector?  putting web ui components in here?  they should
3038 probably live somewhere else...
3039
3040 insertion of RADIUS group stuff in insert could be done with child_objects now
3041 (would probably clean up export of them too)
3042
3043 _op_usage and set_usage bypass the history... maybe they shouldn't
3044
3045 =head1 SEE ALSO
3046
3047 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3048 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3049 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3050 L<freeside-queued>), L<FS::svc_acct_pop>,
3051 schema.html from the base documentation.
3052
3053 =cut
3054
3055 =item domain_select_hash %OPTIONS
3056
3057 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
3058 may at present purchase.
3059
3060 Currently available options are: I<pkgnum> I<svcpart>
3061
3062 =cut
3063
3064 sub domain_select_hash {
3065   my ($self, %options) = @_;
3066   my %domains = ();
3067   my $part_svc;
3068   my $cust_pkg;
3069
3070   if (ref($self)) {
3071     $part_svc = $self->part_svc;
3072     $cust_pkg = $self->cust_svc->cust_pkg
3073       if $self->cust_svc;
3074   }
3075
3076   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
3077     if $options{'svcpart'};
3078
3079   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
3080     if $options{'pkgnum'};
3081
3082   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
3083                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
3084     %domains = map { $_->svcnum => $_->domain }
3085                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
3086                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
3087   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
3088     %domains = map { $_->svcnum => $_->domain }
3089                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
3090                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
3091                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
3092   }else{
3093     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
3094   }
3095
3096   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
3097     my $svc_domain = qsearchs('svc_domain',
3098       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
3099     if ( $svc_domain ) {
3100       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
3101     }else{
3102       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
3103            $part_svc->part_svc_column('domsvc')->columnvalue;
3104
3105     }
3106   }
3107
3108   (%domains);
3109 }
3110
3111 1;
3112