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     $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     $self->set_password($recref->{_password});
1193   }
1194
1195   # Next, check _password to ensure compliance with the encoding.
1196   if ( $recref->{_password_encoding} eq 'ldap' ) {
1197
1198     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1199       $recref->{_password} = uc($1).$2;
1200     } else {
1201       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1202     }
1203
1204   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1205
1206     if ( $recref->{_password} =~
1207            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1208            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1209        ) {
1210
1211       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1212
1213     } else {
1214       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1215     }
1216
1217   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1218     # Password randomization is now in set_password.
1219     # Strip whitespace characters, check length requirements, etc.
1220     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1221       $recref->{_password} = $1;
1222     } else {
1223       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1224              FS::Msgcat::_gettext('illegal_password_characters').
1225              ": ". $recref->{_password};
1226     }
1227
1228     if ( $password_noampersand ) {
1229       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1230     }
1231     if ( $password_noexclamation ) {
1232       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1233     }
1234   }
1235   elsif ( $recref->{_password_encoding} eq 'legacy' ) {
1236     # this happens when set_password fails
1237     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1238            FS::Msgcat::_gettext('illegal_password_characters').
1239            ": ". $recref->{_password};
1240   }
1241   $self->SUPER::check;
1242
1243 }
1244
1245
1246 sub _password_encryption {
1247   my $self = shift;
1248   my $encoding = lc($self->_password_encoding);
1249   return if !$encoding;
1250   return 'plain' if $encoding eq 'plain';
1251   if($encoding eq 'crypt') {
1252     my $pass = $self->_password;
1253     $pass =~ s/^\*SUSPENDED\* //;
1254     $pass =~ s/^!!?//;
1255     return 'md5' if $pass =~ /^\$1\$/;
1256     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1257     return 'des' if length($pass) == 13;
1258     return;
1259   }
1260   if($encoding eq 'ldap') {
1261     uc($self->_password) =~ /^\{([\w-]+)\}/;
1262     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1263     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1264     return 'md5' if $1 eq 'MD5';
1265     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1266
1267     return;
1268   }
1269   return;
1270 }
1271
1272 sub get_cleartext_password {
1273   my $self = shift;
1274   if($self->_password_encryption eq 'plain') {
1275     if($self->_password_encoding eq 'ldap') {
1276       $self->_password =~ /\{\w+\}(.*)$/;
1277       return $1;
1278     }
1279     else {
1280       return $self->_password;
1281     }
1282   }
1283   return;
1284 }
1285
1286
1287 =item set_password
1288
1289 Set the cleartext password for the account.  If _password_encoding is set, the
1290 new password will be encoded according to the existing method (including
1291 encryption mode, if it can be determined).  Otherwise,
1292 config('default-password-encoding') is used.
1293
1294 If no password is supplied (or a zero-length password when minimum password length
1295 is >0), one will be generated randomly.
1296
1297 =cut
1298
1299 sub set_password {
1300   my $self = shift;
1301   my $pass = shift;
1302   my ($encoding, $encryption);
1303
1304
1305   if($self->_password_encoding) {
1306     $encoding = $self->_password_encoding;
1307     # identify existing encryption method, try to use it.
1308     $encryption = $self->_password_encryption;
1309     if(!$encryption) {
1310       # use the system default
1311       undef $encoding;
1312     }
1313   }
1314
1315   if(!$encoding) {
1316     # set encoding to system default
1317     ($encoding, $encryption) = split(/-/, lc($conf->config('default-password-encoding')));
1318     $encoding ||= 'legacy';
1319     $self->_password_encoding($encoding);
1320   }
1321
1322   if($encoding eq 'legacy') {
1323     # The legacy behavior from check():
1324     # If the password is blank, randomize it and set encoding to 'plain'.
1325     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1326       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1327       $self->_password_encoding('plain');
1328     }
1329     else {
1330       # Prefix + valid-length password
1331       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1332         $pass = $1.$3;
1333         $self->_password_encoding('plain');
1334       }
1335       # Prefix + crypt string
1336       elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1337         $pass = $1.$3;
1338         $self->_password_encoding('crypt');
1339       }
1340       # Various disabled crypt passwords
1341       elsif ( $pass eq '*' or
1342               $pass eq '!' or
1343               $pass eq '!!' ) {
1344         $self->_password_encoding('crypt');
1345       }
1346       else {
1347         # do nothing; check() will recognize this as an error
1348       }
1349    }
1350   }
1351   elsif($encoding eq 'crypt') {
1352     if($encryption eq 'md5') {
1353       $pass = unix_md5_crypt($pass);
1354     }
1355     elsif($encryption eq 'des') {
1356       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1357     }
1358   }
1359   elsif($encoding eq 'ldap') {
1360     if($encryption eq 'md5') {
1361       $pass = md5_base64($pass);
1362     }
1363     elsif($encryption eq 'sha1') {
1364       $pass = sha1_base64($pass);
1365     }
1366     elsif($encryption eq 'crypt') {
1367       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1368     }
1369     # else $encryption eq 'plain', do nothing
1370     $pass = '{'.uc($encryption).'}'.$pass;
1371   }
1372   # else encoding eq 'plain'
1373
1374   $self->_password($pass);
1375   return;
1376 }
1377
1378 =item _check_system
1379
1380 Internal function to check the username against the list of system usernames
1381 from the I<system_usernames> configuration value.  Returns true if the username
1382 is listed on the system username list.
1383
1384 =cut
1385
1386 sub _check_system {
1387   my $self = shift;
1388   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1389                $conf->config('system_usernames')
1390         );
1391 }
1392
1393 =item _check_duplicate
1394
1395 Internal method to check for duplicates usernames, username@domain pairs and
1396 uids.
1397
1398 If the I<global_unique-username> configuration value is set to B<username> or
1399 B<username@domain>, enforces global username or username@domain uniqueness.
1400
1401 In all cases, check for duplicate uids and usernames or username@domain pairs
1402 per export and with identical I<svcpart> values.
1403
1404 =cut
1405
1406 sub _check_duplicate {
1407   my $self = shift;
1408
1409   my $global_unique = $conf->config('global_unique-username') || 'none';
1410   return '' if $global_unique eq 'disabled';
1411
1412   $self->lock_table;
1413
1414   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1415   unless ( $part_svc ) {
1416     return 'unknown svcpart '. $self->svcpart;
1417   }
1418
1419   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1420                  qsearch( 'svc_acct', { 'username' => $self->username } );
1421   return gettext('username_in_use')
1422     if $global_unique eq 'username' && @dup_user;
1423
1424   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1425                        qsearch( 'svc_acct', { 'username' => $self->username,
1426                                               'domsvc'   => $self->domsvc } );
1427   return gettext('username_in_use')
1428     if $global_unique eq 'username@domain' && @dup_userdomain;
1429
1430   my @dup_uid;
1431   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1432        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1433     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1434                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1435   } else {
1436     @dup_uid = ();
1437   }
1438
1439   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1440     my $exports = FS::part_export::export_info('svc_acct');
1441     my %conflict_user_svcpart;
1442     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1443
1444     foreach my $part_export ( $part_svc->part_export ) {
1445
1446       #this will catch to the same exact export
1447       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1448
1449       #this will catch to exports w/same exporthost+type ???
1450       #my @other_part_export = qsearch('part_export', {
1451       #  'machine'    => $part_export->machine,
1452       #  'exporttype' => $part_export->exporttype,
1453       #} );
1454       #foreach my $other_part_export ( @other_part_export ) {
1455       #  push @svcparts, map { $_->svcpart }
1456       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1457       #}
1458
1459       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1460       #silly kludge to avoid uninitialized value errors
1461       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1462                      ? $exports->{$part_export->exporttype}{'nodomain'}
1463                      : '';
1464       if ( $nodomain =~ /^Y/i ) {
1465         $conflict_user_svcpart{$_} = $part_export->exportnum
1466           foreach @svcparts;
1467       } else {
1468         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1469           foreach @svcparts;
1470       }
1471     }
1472
1473     foreach my $dup_user ( @dup_user ) {
1474       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1475       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1476         return "duplicate username ". $self->username.
1477                ": conflicts with svcnum ". $dup_user->svcnum.
1478                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1479       }
1480     }
1481
1482     foreach my $dup_userdomain ( @dup_userdomain ) {
1483       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1484       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1485         return "duplicate username\@domain ". $self->email.
1486                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1487                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1488       }
1489     }
1490
1491     foreach my $dup_uid ( @dup_uid ) {
1492       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1493       if ( exists($conflict_user_svcpart{$dup_svcpart})
1494            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1495         return "duplicate uid ". $self->uid.
1496                ": conflicts with svcnum ". $dup_uid->svcnum.
1497                " via exportnum ".
1498                ( $conflict_user_svcpart{$dup_svcpart}
1499                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1500       }
1501     }
1502
1503   }
1504
1505   return '';
1506
1507 }
1508
1509 =item radius
1510
1511 Depriciated, use radius_reply instead.
1512
1513 =cut
1514
1515 sub radius {
1516   carp "FS::svc_acct::radius depriciated, use radius_reply";
1517   $_[0]->radius_reply;
1518 }
1519
1520 =item radius_reply
1521
1522 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1523 reply attributes of this record.
1524
1525 Note that this is now the preferred method for reading RADIUS attributes -
1526 accessing the columns directly is discouraged, as the column names are
1527 expected to change in the future.
1528
1529 =cut
1530
1531 sub radius_reply {
1532   my $self = shift;
1533
1534   return %{ $self->{'radius_reply'} }
1535     if exists $self->{'radius_reply'};
1536
1537   my %reply =
1538     map {
1539       /^(radius_(.*))$/;
1540       my($column, $attrib) = ($1, $2);
1541       #$attrib =~ s/_/\-/g;
1542       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1543     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1544
1545   if ( $self->slipip && $self->slipip ne '0e0' ) {
1546     $reply{$radius_ip} = $self->slipip;
1547   }
1548
1549   if ( $self->seconds !~ /^$/ ) {
1550     $reply{'Session-Timeout'} = $self->seconds;
1551   }
1552
1553   if ( $conf->exists('radius-chillispot-max') ) {
1554     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1555
1556     #hmm.  just because sqlradius.pm says so?
1557     my %whatis = (
1558       'input'  => 'up',
1559       'output' => 'down',
1560       'total'  => 'total',
1561     );
1562
1563     foreach my $what (qw( input output total )) {
1564       my $is = $whatis{$what}.'bytes';
1565       if ( $self->$is() =~ /\d/ ) {
1566         my $big = new Math::BigInt $self->$is();
1567         $big = new Math::BigInt '0' if $big->is_neg();
1568         my $att = "Chillispot-Max-\u$what";
1569         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1570         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1571       }
1572     }
1573
1574   }
1575
1576   %reply;
1577 }
1578
1579 =item radius_check
1580
1581 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1582 check attributes of this record.
1583
1584 Note that this is now the preferred method for reading RADIUS attributes -
1585 accessing the columns directly is discouraged, as the column names are
1586 expected to change in the future.
1587
1588 =cut
1589
1590 sub radius_check {
1591   my $self = shift;
1592
1593   return %{ $self->{'radius_check'} }
1594     if exists $self->{'radius_check'};
1595
1596   my %check =
1597     map {
1598       /^(rc_(.*))$/;
1599       my($column, $attrib) = ($1, $2);
1600       #$attrib =~ s/_/\-/g;
1601       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1602     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1603
1604
1605   my($pw_attrib, $password) = $self->radius_password;
1606   $check{$pw_attrib} = $password;
1607
1608   my $cust_svc = $self->cust_svc;
1609   if ( $cust_svc ) {
1610     my $cust_pkg = $cust_svc->cust_pkg;
1611     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1612       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1613     }
1614   } else {
1615     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1616          "; can't set Expiration\n"
1617       unless $cust_svc;
1618   }
1619
1620   %check;
1621
1622 }
1623
1624 =item radius_password
1625
1626 Returns a key/value pair containing the RADIUS attribute name and value
1627 for the password.
1628
1629 =cut
1630
1631 sub radius_password {
1632   my $self = shift;
1633
1634   my($pw_attrib, $password);
1635   if ( $self->_password_encoding eq 'ldap' ) {
1636
1637     $pw_attrib = 'Password-With-Header';
1638     $password = $self->_password;
1639
1640   } elsif ( $self->_password_encoding eq 'crypt' ) {
1641
1642     $pw_attrib = 'Crypt-Password';
1643     $password = $self->_password;
1644
1645   } elsif ( $self->_password_encoding eq 'plain' ) {
1646
1647     $pw_attrib = $radius_password; #Cleartext-Password?  man rlm_pap
1648     $password = $self->_password;
1649
1650   } else {
1651
1652     $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1653     $password = $self->_password;
1654
1655   }
1656
1657   ($pw_attrib, $password);
1658
1659 }
1660
1661 =item snapshot
1662
1663 This method instructs the object to "snapshot" or freeze RADIUS check and
1664 reply attributes to the current values.
1665
1666 =cut
1667
1668 #bah, my english is too broken this morning
1669 #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
1670 #the FS::cust_pkg's replace method to trigger the correct export updates when
1671 #package dates change)
1672
1673 sub snapshot {
1674   my $self = shift;
1675
1676   $self->{$_} = { $self->$_() }
1677     foreach qw( radius_reply radius_check );
1678
1679 }
1680
1681 =item forget_snapshot
1682
1683 This methos instructs the object to forget any previously snapshotted
1684 RADIUS check and reply attributes.
1685
1686 =cut
1687
1688 sub forget_snapshot {
1689   my $self = shift;
1690
1691   delete $self->{$_}
1692     foreach qw( radius_reply radius_check );
1693
1694 }
1695
1696 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1697
1698 Returns the domain associated with this account.
1699
1700 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1701 history records.
1702
1703 =cut
1704
1705 sub domain {
1706   my $self = shift;
1707   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1708   my $svc_domain = $self->svc_domain(@_)
1709     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1710   $svc_domain->domain;
1711 }
1712
1713 =item svc_domain
1714
1715 Returns the FS::svc_domain record for this account's domain (see
1716 L<FS::svc_domain>).
1717
1718 =cut
1719
1720 # FS::h_svc_acct has a history-aware svc_domain override
1721
1722 sub svc_domain {
1723   my $self = shift;
1724   $self->{'_domsvc'}
1725     ? $self->{'_domsvc'}
1726     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1727 }
1728
1729 =item cust_svc
1730
1731 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1732
1733 =cut
1734
1735 #inherited from svc_Common
1736
1737 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1738
1739 Returns an email address associated with the account.
1740
1741 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1742 history records.
1743
1744 =cut
1745
1746 sub email {
1747   my $self = shift;
1748   $self->username. '@'. $self->domain(@_);
1749 }
1750
1751 =item acct_snarf
1752
1753 Returns an array of FS::acct_snarf records associated with the account.
1754 If the acct_snarf table does not exist or there are no associated records,
1755 an empty list is returned
1756
1757 =cut
1758
1759 sub acct_snarf {
1760   my $self = shift;
1761   return () unless dbdef->table('acct_snarf');
1762   eval "use FS::acct_snarf;";
1763   die $@ if $@;
1764   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1765 }
1766
1767 =item decrement_upbytes OCTETS
1768
1769 Decrements the I<upbytes> field of this record by the given amount.  If there
1770 is an error, returns the error, otherwise returns false.
1771
1772 =cut
1773
1774 sub decrement_upbytes {
1775   shift->_op_usage('-', 'upbytes', @_);
1776 }
1777
1778 =item increment_upbytes OCTETS
1779
1780 Increments the I<upbytes> field of this record by the given amount.  If there
1781 is an error, returns the error, otherwise returns false.
1782
1783 =cut
1784
1785 sub increment_upbytes {
1786   shift->_op_usage('+', 'upbytes', @_);
1787 }
1788
1789 =item decrement_downbytes OCTETS
1790
1791 Decrements the I<downbytes> field of this record by the given amount.  If there
1792 is an error, returns the error, otherwise returns false.
1793
1794 =cut
1795
1796 sub decrement_downbytes {
1797   shift->_op_usage('-', 'downbytes', @_);
1798 }
1799
1800 =item increment_downbytes OCTETS
1801
1802 Increments the I<downbytes> field of this record by the given amount.  If there
1803 is an error, returns the error, otherwise returns false.
1804
1805 =cut
1806
1807 sub increment_downbytes {
1808   shift->_op_usage('+', 'downbytes', @_);
1809 }
1810
1811 =item decrement_totalbytes OCTETS
1812
1813 Decrements the I<totalbytes> field of this record by the given amount.  If there
1814 is an error, returns the error, otherwise returns false.
1815
1816 =cut
1817
1818 sub decrement_totalbytes {
1819   shift->_op_usage('-', 'totalbytes', @_);
1820 }
1821
1822 =item increment_totalbytes OCTETS
1823
1824 Increments the I<totalbytes> field of this record by the given amount.  If there
1825 is an error, returns the error, otherwise returns false.
1826
1827 =cut
1828
1829 sub increment_totalbytes {
1830   shift->_op_usage('+', 'totalbytes', @_);
1831 }
1832
1833 =item decrement_seconds SECONDS
1834
1835 Decrements the I<seconds> field of this record by the given amount.  If there
1836 is an error, returns the error, otherwise returns false.
1837
1838 =cut
1839
1840 sub decrement_seconds {
1841   shift->_op_usage('-', 'seconds', @_);
1842 }
1843
1844 =item increment_seconds SECONDS
1845
1846 Increments the I<seconds> field of this record by the given amount.  If there
1847 is an error, returns the error, otherwise returns false.
1848
1849 =cut
1850
1851 sub increment_seconds {
1852   shift->_op_usage('+', 'seconds', @_);
1853 }
1854
1855
1856 my %op2action = (
1857   '-' => 'suspend',
1858   '+' => 'unsuspend',
1859 );
1860 my %op2condition = (
1861   '-' => sub { my($self, $column, $amount) = @_;
1862                $self->$column - $amount <= 0;
1863              },
1864   '+' => sub { my($self, $column, $amount) = @_;
1865                ($self->$column || 0) + $amount > 0;
1866              },
1867 );
1868 my %op2warncondition = (
1869   '-' => sub { my($self, $column, $amount) = @_;
1870                my $threshold = $column . '_threshold';
1871                $self->$column - $amount <= $self->$threshold + 0;
1872              },
1873   '+' => sub { my($self, $column, $amount) = @_;
1874                ($self->$column || 0) + $amount > 0;
1875              },
1876 );
1877
1878 sub _op_usage {
1879   my( $self, $op, $column, $amount ) = @_;
1880
1881   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1882        ' ('. $self->email. "): $op $amount\n"
1883     if $DEBUG;
1884
1885   return '' unless $amount;
1886
1887   local $SIG{HUP} = 'IGNORE';
1888   local $SIG{INT} = 'IGNORE';
1889   local $SIG{QUIT} = 'IGNORE';
1890   local $SIG{TERM} = 'IGNORE';
1891   local $SIG{TSTP} = 'IGNORE';
1892   local $SIG{PIPE} = 'IGNORE';
1893
1894   my $oldAutoCommit = $FS::UID::AutoCommit;
1895   local $FS::UID::AutoCommit = 0;
1896   my $dbh = dbh;
1897
1898   my $sql = "UPDATE svc_acct SET $column = ".
1899             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1900             " $op ? WHERE svcnum = ?";
1901   warn "$me $sql\n"
1902     if $DEBUG;
1903
1904   my $sth = $dbh->prepare( $sql )
1905     or die "Error preparing $sql: ". $dbh->errstr;
1906   my $rv = $sth->execute($amount, $self->svcnum);
1907   die "Error executing $sql: ". $sth->errstr
1908     unless defined($rv);
1909   die "Can't update $column for svcnum". $self->svcnum
1910     if $rv == 0;
1911
1912   #$self->snapshot; #not necessary, we retain the old values
1913   #create an object with the updated usage values
1914   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1915   #call exports
1916   my $error = $new->replace($self);
1917   if ( $error ) {
1918     $dbh->rollback if $oldAutoCommit;
1919     return "Error replacing: $error";
1920   }
1921
1922   #overlimit_action eq 'cancel' handling
1923   my $cust_pkg = $self->cust_svc->cust_pkg;
1924   if ( $cust_pkg
1925        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1926        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1927      )
1928   {
1929
1930     my $error = $cust_pkg->cancel; #XXX should have a reason
1931     if ( $error ) {
1932       $dbh->rollback if $oldAutoCommit;
1933       return "Error cancelling: $error";
1934     }
1935
1936     #nothing else is relevant if we're cancelling, so commit & return success
1937     warn "$me update successful; committing\n"
1938       if $DEBUG;
1939     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1940     return '';
1941
1942   }
1943
1944   my $action = $op2action{$op};
1945
1946   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1947         ( $action eq 'suspend'   && !$self->overlimit
1948        || $action eq 'unsuspend' &&  $self->overlimit )
1949      ) {
1950
1951     my $error = $self->_op_overlimit($action);
1952     if ( $error ) {
1953       $dbh->rollback if $oldAutoCommit;
1954       return $error;
1955     }
1956
1957   }
1958
1959   if ( $conf->exists("svc_acct-usage_$action")
1960        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1961     #my $error = $self->$action();
1962     my $error = $self->cust_svc->cust_pkg->$action();
1963     # $error ||= $self->overlimit($action);
1964     if ( $error ) {
1965       $dbh->rollback if $oldAutoCommit;
1966       return "Error ${action}ing: $error";
1967     }
1968   }
1969
1970   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1971     my $wqueue = new FS::queue {
1972       'svcnum' => $self->svcnum,
1973       'job'    => 'FS::svc_acct::reached_threshold',
1974     };
1975
1976     my $to = '';
1977     if ($op eq '-'){
1978       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1979     }
1980
1981     # x_threshold race
1982     my $error = $wqueue->insert(
1983       'svcnum' => $self->svcnum,
1984       'op'     => $op,
1985       'column' => $column,
1986       'to'     => $to,
1987     );
1988     if ( $error ) {
1989       $dbh->rollback if $oldAutoCommit;
1990       return "Error queuing threshold activity: $error";
1991     }
1992   }
1993
1994   warn "$me update successful; committing\n"
1995     if $DEBUG;
1996   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1997   '';
1998
1999 }
2000
2001 sub _op_overlimit {
2002   my( $self, $action ) = @_;
2003
2004   local $SIG{HUP} = 'IGNORE';
2005   local $SIG{INT} = 'IGNORE';
2006   local $SIG{QUIT} = 'IGNORE';
2007   local $SIG{TERM} = 'IGNORE';
2008   local $SIG{TSTP} = 'IGNORE';
2009   local $SIG{PIPE} = 'IGNORE';
2010
2011   my $oldAutoCommit = $FS::UID::AutoCommit;
2012   local $FS::UID::AutoCommit = 0;
2013   my $dbh = dbh;
2014
2015   my $cust_pkg = $self->cust_svc->cust_pkg;
2016
2017   my $conf_overlimit =
2018     $cust_pkg
2019       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2020       : $conf->config('overlimit_groups');
2021
2022   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2023
2024     my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2025     next unless $groups;
2026
2027     my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2028
2029     my $other = new FS::svc_acct $self->hashref;
2030     $other->usergroup( $gref );
2031
2032     my($new,$old);
2033     if ($action eq 'suspend') {
2034       $new = $other;
2035       $old = $self;
2036     } else { # $action eq 'unsuspend'
2037       $new = $self;
2038       $old = $other;
2039     }
2040
2041     my $error = $part_export->export_replace($new, $old)
2042                 || $self->overlimit($action);
2043
2044     if ( $error ) {
2045       $dbh->rollback if $oldAutoCommit;
2046       return "Error replacing radius groups: $error";
2047     }
2048
2049   }
2050
2051   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2052   '';
2053
2054 }
2055
2056 sub set_usage {
2057   my( $self, $valueref, %options ) = @_;
2058
2059   warn "$me set_usage called for svcnum ". $self->svcnum.
2060        ' ('. $self->email. "): ".
2061        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2062     if $DEBUG;
2063
2064   local $SIG{HUP} = 'IGNORE';
2065   local $SIG{INT} = 'IGNORE';
2066   local $SIG{QUIT} = 'IGNORE';
2067   local $SIG{TERM} = 'IGNORE';
2068   local $SIG{TSTP} = 'IGNORE';
2069   local $SIG{PIPE} = 'IGNORE';
2070
2071   local $FS::svc_Common::noexport_hack = 1;
2072   my $oldAutoCommit = $FS::UID::AutoCommit;
2073   local $FS::UID::AutoCommit = 0;
2074   my $dbh = dbh;
2075
2076   my $reset = 0;
2077   my %handyhash = ();
2078   if ( $options{null} ) {
2079     %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2080                    qw( seconds upbytes downbytes totalbytes )
2081                  );
2082   }
2083   foreach my $field (keys %$valueref){
2084     $reset = 1 if $valueref->{$field};
2085     $self->setfield($field, $valueref->{$field});
2086     $self->setfield( $field.'_threshold',
2087                      int($self->getfield($field)
2088                          * ( $conf->exists('svc_acct-usage_threshold')
2089                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2090                              : 0.20
2091                            )
2092                        )
2093                      );
2094     $handyhash{$field} = $self->getfield($field);
2095     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2096   }
2097   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2098   #die $error if $error;         #services not explicity changed via the UI
2099
2100   my $sql = "UPDATE svc_acct SET " .
2101     join (',', map { "$_ =  $handyhash{$_}" } (keys %handyhash) ).
2102     " WHERE svcnum = ". $self->svcnum;
2103
2104   warn "$me $sql\n"
2105     if $DEBUG;
2106
2107   if (scalar(keys %handyhash)) {
2108     my $sth = $dbh->prepare( $sql )
2109       or die "Error preparing $sql: ". $dbh->errstr;
2110     my $rv = $sth->execute();
2111     die "Error executing $sql: ". $sth->errstr
2112       unless defined($rv);
2113     die "Can't update usage for svcnum ". $self->svcnum
2114       if $rv == 0;
2115   }
2116
2117   #$self->snapshot; #not necessary, we retain the old values
2118   #create an object with the updated usage values
2119   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2120   #call exports
2121   my $error = $new->replace($self);
2122   if ( $error ) {
2123     $dbh->rollback if $oldAutoCommit;
2124     return "Error replacing: $error";
2125   }
2126
2127   if ( $reset ) {
2128
2129     my $error = '';
2130
2131     $error = $self->_op_overlimit('unsuspend')
2132       if $self->overlimit;;
2133
2134     $error ||= $self->cust_svc->cust_pkg->unsuspend
2135       if $conf->exists("svc_acct-usage_unsuspend");
2136
2137     if ( $error ) {
2138       $dbh->rollback if $oldAutoCommit;
2139       return "Error unsuspending: $error";
2140     }
2141
2142   }
2143
2144   warn "$me update successful; committing\n"
2145     if $DEBUG;
2146   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2147   '';
2148
2149 }
2150
2151
2152 =item recharge HASHREF
2153
2154   Increments usage columns by the amount specified in HASHREF as
2155   column=>amount pairs.
2156
2157 =cut
2158
2159 sub recharge {
2160   my ($self, $vhash) = @_;
2161
2162   if ( $DEBUG ) {
2163     warn "[$me] recharge called on $self: ". Dumper($self).
2164          "\nwith vhash: ". Dumper($vhash);
2165   }
2166
2167   my $oldAutoCommit = $FS::UID::AutoCommit;
2168   local $FS::UID::AutoCommit = 0;
2169   my $dbh = dbh;
2170   my $error = '';
2171
2172   foreach my $column (keys %$vhash){
2173     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2174   }
2175
2176   if ( $error ) {
2177     $dbh->rollback if $oldAutoCommit;
2178   }else{
2179     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2180   }
2181   return $error;
2182 }
2183
2184 =item is_rechargeable
2185
2186 Returns true if this svc_account can be "recharged" and false otherwise.
2187
2188 =cut
2189
2190 sub is_rechargable {
2191   my $self = shift;
2192   $self->seconds ne ''
2193     || $self->upbytes ne ''
2194     || $self->downbytes ne ''
2195     || $self->totalbytes ne '';
2196 }
2197
2198 =item seconds_since TIMESTAMP
2199
2200 Returns the number of seconds this account has been online since TIMESTAMP,
2201 according to the session monitor (see L<FS::Session>).
2202
2203 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2204 L<Time::Local> and L<Date::Parse> for conversion functions.
2205
2206 =cut
2207
2208 #note: POD here, implementation in FS::cust_svc
2209 sub seconds_since {
2210   my $self = shift;
2211   $self->cust_svc->seconds_since(@_);
2212 }
2213
2214 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2215
2216 Returns the numbers of seconds this account has been online between
2217 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2218 external SQL radacct table, specified via sqlradius export.  Sessions which
2219 started in the specified range but are still open are counted from session
2220 start to the end of the range (unless they are over 1 day old, in which case
2221 they are presumed missing their stop record and not counted).  Also, sessions
2222 which end in the range but started earlier are counted from the start of the
2223 range to session end.  Finally, sessions which start before the range but end
2224 after are counted for the entire range.
2225
2226 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2227 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2228 functions.
2229
2230 =cut
2231
2232 #note: POD here, implementation in FS::cust_svc
2233 sub seconds_since_sqlradacct {
2234   my $self = shift;
2235   $self->cust_svc->seconds_since_sqlradacct(@_);
2236 }
2237
2238 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2239
2240 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2241 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2242 TIMESTAMP_END (exclusive).
2243
2244 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2245 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2246 functions.
2247
2248 =cut
2249
2250 #note: POD here, implementation in FS::cust_svc
2251 sub attribute_since_sqlradacct {
2252   my $self = shift;
2253   $self->cust_svc->attribute_since_sqlradacct(@_);
2254 }
2255
2256 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2257
2258 Returns an array of hash references of this customers login history for the
2259 given time range.  (document this better)
2260
2261 =cut
2262
2263 sub get_session_history {
2264   my $self = shift;
2265   $self->cust_svc->get_session_history(@_);
2266 }
2267
2268 =item last_login_text
2269
2270 Returns text describing the time of last login.
2271
2272 =cut
2273
2274 sub last_login_text {
2275   my $self = shift;
2276   $self->last_login ? ctime($self->last_login) : 'unknown';
2277 }
2278
2279 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2280
2281 =cut
2282
2283 sub get_cdrs {
2284   my($self, $start, $end, %opt ) = @_;
2285
2286   my $did = $self->username; #yup
2287
2288   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2289
2290   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2291
2292   #SELECT $for_update * FROM cdr
2293   #  WHERE calldate >= $start #need a conversion
2294   #    AND calldate <  $end   #ditto
2295   #    AND (    charged_party = "$did"
2296   #          OR charged_party = "$prefix$did" #if length($prefix);
2297   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2298   #               AND
2299   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2300   #             )
2301   #        )
2302   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2303
2304   my $charged_or_src;
2305   if ( length($prefix) ) {
2306     $charged_or_src =
2307       " AND (    charged_party = '$did'
2308               OR charged_party = '$prefix$did'
2309               OR ( ( charged_party IS NULL OR charged_party = '' )
2310                    AND
2311                    ( src = '$did' OR src = '$prefix$did' )
2312                  )
2313             )
2314       ";
2315   } else {
2316     $charged_or_src =
2317       " AND (    charged_party = '$did'
2318               OR ( ( charged_party IS NULL OR charged_party = '' )
2319                    AND
2320                    src = '$did'
2321                  )
2322             )
2323       ";
2324
2325   }
2326
2327   qsearch(
2328     'select'    => "$for_update *",
2329     'table'     => 'cdr',
2330     'hashref'   => {
2331                      #( freesidestatus IS NULL OR freesidestatus = '' )
2332                      'freesidestatus' => '',
2333                    },
2334     'extra_sql' => $charged_or_src,
2335
2336   );
2337
2338 }
2339
2340 =item radius_groups
2341
2342 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2343
2344 =cut
2345
2346 sub radius_groups {
2347   my $self = shift;
2348   if ( $self->usergroup ) {
2349     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2350       unless ref($self->usergroup) eq 'ARRAY';
2351     #when provisioning records, export callback runs in svc_Common.pm before
2352     #radius_usergroup records can be inserted...
2353     @{$self->usergroup};
2354   } else {
2355     map { $_->groupname }
2356       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2357   }
2358 }
2359
2360 =item clone_suspended
2361
2362 Constructor used by FS::part_export::_export_suspend fallback.  Document
2363 better.
2364
2365 =cut
2366
2367 sub clone_suspended {
2368   my $self = shift;
2369   my %hash = $self->hash;
2370   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2371   new FS::svc_acct \%hash;
2372 }
2373
2374 =item clone_kludge_unsuspend
2375
2376 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2377 better.
2378
2379 =cut
2380
2381 sub clone_kludge_unsuspend {
2382   my $self = shift;
2383   my %hash = $self->hash;
2384   $hash{_password} = '';
2385   new FS::svc_acct \%hash;
2386 }
2387
2388 =item check_password
2389
2390 Checks the supplied password against the (possibly encrypted) password in the
2391 database.  Returns true for a successful authentication, false for no match.
2392
2393 Currently supported encryptions are: classic DES crypt() and MD5
2394
2395 =cut
2396
2397 sub check_password {
2398   my($self, $check_password) = @_;
2399
2400   #remove old-style SUSPENDED kludge, they should be allowed to login to
2401   #self-service and pay up
2402   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2403
2404   if ( $self->_password_encoding eq 'ldap' ) {
2405
2406     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2407     return $auth->match($check_password);
2408
2409   } elsif ( $self->_password_encoding eq 'crypt' ) {
2410
2411     my $auth = from_crypt Authen::Passphrase $self->_password;
2412     return $auth->match($check_password);
2413
2414   } elsif ( $self->_password_encoding eq 'plain' ) {
2415
2416     return $check_password eq $password;
2417
2418   } else {
2419
2420     #XXX this could be replaced with Authen::Passphrase stuff
2421
2422     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2423       return 0;
2424     } elsif ( length($password) < 13 ) { #plaintext
2425       $check_password eq $password;
2426     } elsif ( length($password) == 13 ) { #traditional DES crypt
2427       crypt($check_password, $password) eq $password;
2428     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2429       unix_md5_crypt($check_password, $password) eq $password;
2430     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2431       warn "Can't check password: Blowfish encryption not yet supported, ".
2432            "svcnum ".  $self->svcnum. "\n";
2433       0;
2434     } else {
2435       warn "Can't check password: Unrecognized encryption for svcnum ".
2436            $self->svcnum. "\n";
2437       0;
2438     }
2439
2440   }
2441
2442 }
2443
2444 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2445
2446 Returns an encrypted password, either by passing through an encrypted password
2447 in the database or by encrypting a plaintext password from the database.
2448
2449 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2450 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2451 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2452 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2453 encryption type is only used if the password is not already encrypted in the
2454 database.
2455
2456 =cut
2457
2458 sub crypt_password {
2459   my $self = shift;
2460
2461   if ( $self->_password_encoding eq 'ldap' ) {
2462
2463     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2464       my $plain = $2;
2465
2466       #XXX this could be replaced with Authen::Passphrase stuff
2467
2468       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2469       if ( $encryption eq 'crypt' ) {
2470         crypt(
2471           $self->_password,
2472           $saltset[int(rand(64))].$saltset[int(rand(64))]
2473         );
2474       } elsif ( $encryption eq 'md5' ) {
2475         unix_md5_crypt( $self->_password );
2476       } elsif ( $encryption eq 'blowfish' ) {
2477         croak "unknown encryption method $encryption";
2478       } else {
2479         croak "unknown encryption method $encryption";
2480       }
2481
2482     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2483       $1;
2484     }
2485
2486   } elsif ( $self->_password_encoding eq 'crypt' ) {
2487
2488     return $self->_password;
2489
2490   } elsif ( $self->_password_encoding eq 'plain' ) {
2491
2492     #XXX this could be replaced with Authen::Passphrase stuff
2493
2494     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2495     if ( $encryption eq 'crypt' ) {
2496       crypt(
2497         $self->_password,
2498         $saltset[int(rand(64))].$saltset[int(rand(64))]
2499       );
2500     } elsif ( $encryption eq 'md5' ) {
2501       unix_md5_crypt( $self->_password );
2502     } elsif ( $encryption eq 'blowfish' ) {
2503       croak "unknown encryption method $encryption";
2504     } else {
2505       croak "unknown encryption method $encryption";
2506     }
2507
2508   } else {
2509
2510     if ( length($self->_password) == 13
2511          || $self->_password =~ /^\$(1|2a?)\$/
2512          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2513        )
2514     {
2515       $self->_password;
2516     } else {
2517
2518       #XXX this could be replaced with Authen::Passphrase stuff
2519
2520       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2521       if ( $encryption eq 'crypt' ) {
2522         crypt(
2523           $self->_password,
2524           $saltset[int(rand(64))].$saltset[int(rand(64))]
2525         );
2526       } elsif ( $encryption eq 'md5' ) {
2527         unix_md5_crypt( $self->_password );
2528       } elsif ( $encryption eq 'blowfish' ) {
2529         croak "unknown encryption method $encryption";
2530       } else {
2531         croak "unknown encryption method $encryption";
2532       }
2533
2534     }
2535
2536   }
2537
2538 }
2539
2540 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2541
2542 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2543 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2544 "{MD5}5426824942db4253f87a1009fd5d2d4".
2545
2546 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2547 to work the same as the B</crypt_password> method.
2548
2549 =cut
2550
2551 sub ldap_password {
2552   my $self = shift;
2553   #eventually should check a "password-encoding" field
2554
2555   if ( $self->_password_encoding eq 'ldap' ) {
2556
2557     return $self->_password;
2558
2559   } elsif ( $self->_password_encoding eq 'crypt' ) {
2560
2561     if ( length($self->_password) == 13 ) { #crypt
2562       return '{CRYPT}'. $self->_password;
2563     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2564       return '{MD5}'. $1;
2565     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2566     #  die "Blowfish encryption not supported in this context, svcnum ".
2567     #      $self->svcnum. "\n";
2568     } else {
2569       warn "encryption method not (yet?) supported in LDAP context";
2570       return '{CRYPT}*'; #unsupported, should not auth
2571     }
2572
2573   } elsif ( $self->_password_encoding eq 'plain' ) {
2574
2575     return '{PLAIN}'. $self->_password;
2576
2577     #return '{CLEARTEXT}'. $self->_password; #?
2578
2579   } else {
2580
2581     if ( length($self->_password) == 13 ) { #crypt
2582       return '{CRYPT}'. $self->_password;
2583     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2584       return '{MD5}'. $1;
2585     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2586       warn "Blowfish encryption not supported in this context, svcnum ".
2587           $self->svcnum. "\n";
2588       return '{CRYPT}*';
2589
2590     #are these two necessary anymore?
2591     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2592       return '{SSHA}'. $1;
2593     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2594       return '{NS-MTA-MD5}'. $1;
2595
2596     } else { #plaintext
2597       return '{PLAIN}'. $self->_password;
2598
2599       #return '{CLEARTEXT}'. $self->_password; #?
2600
2601       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2602       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2603       #if ( $encryption eq 'crypt' ) {
2604       #  return '{CRYPT}'. crypt(
2605       #    $self->_password,
2606       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2607       #  );
2608       #} elsif ( $encryption eq 'md5' ) {
2609       #  unix_md5_crypt( $self->_password );
2610       #} elsif ( $encryption eq 'blowfish' ) {
2611       #  croak "unknown encryption method $encryption";
2612       #} else {
2613       #  croak "unknown encryption method $encryption";
2614       #}
2615     }
2616
2617   }
2618
2619 }
2620
2621 =item domain_slash_username
2622
2623 Returns $domain/$username/
2624
2625 =cut
2626
2627 sub domain_slash_username {
2628   my $self = shift;
2629   $self->domain. '/'. $self->username. '/';
2630 }
2631
2632 =item virtual_maildir
2633
2634 Returns $domain/maildirs/$username/
2635
2636 =cut
2637
2638 sub virtual_maildir {
2639   my $self = shift;
2640   $self->domain. '/maildirs/'. $self->username. '/';
2641 }
2642
2643 =back
2644
2645 =head1 CLASS METHODS
2646
2647 =over 4
2648
2649 =item search HASHREF
2650
2651 Class method which returns a qsearch hash expression to search for parameters
2652 specified in HASHREF.  Valid parameters are
2653
2654 =over 4
2655
2656 =item domain
2657
2658 =item domsvc
2659
2660 =item unlinked
2661
2662 =item agentnum
2663
2664 =item pkgpart
2665
2666 Arrayref of pkgparts
2667
2668 =item pkgpart
2669
2670 =item where
2671
2672 Arrayref of additional WHERE clauses, will be ANDed together.
2673
2674 =item order_by
2675
2676 =item cust_fields
2677
2678 =back
2679
2680 =cut
2681
2682 sub search {
2683   my ($class, $params) = @_;
2684
2685   my @where = ();
2686
2687   # domain
2688   if ( $params->{'domain'} ) {
2689     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2690     #preserve previous behavior & bubble up an error if $svc_domain not found?
2691     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2692   }
2693
2694   # domsvc
2695   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2696     push @where, "domsvc = $1";
2697   }
2698
2699   #unlinked
2700   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2701
2702   #agentnum
2703   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2704     push @where, "agentnum = $1";
2705   }
2706
2707   #custnum
2708   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2709     push @where, "custnum = $1";
2710   }
2711
2712   #pkgpart
2713   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2714     #XXX untaint or sql quote
2715     push @where,
2716       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2717   }
2718
2719   # popnum
2720   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2721     push @where, "popnum = $1";
2722   }
2723
2724   # svcpart
2725   if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2726     push @where, "svcpart = $1";
2727   }
2728
2729
2730   # here is the agent virtualization
2731   #if ($params->{CurrentUser}) {
2732   #  my $access_user =
2733   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2734   #
2735   #  if ($access_user) {
2736   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2737   #  }else{
2738   #    push @where, "1=0";
2739   #  }
2740   #} else {
2741     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2742                    'table'      => 'cust_main',
2743                    'null_right' => 'View/link unlinked services',
2744                  );
2745   #}
2746
2747   push @where, @{ $params->{'where'} } if $params->{'where'};
2748
2749   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2750
2751   my $addl_from = ' LEFT JOIN cust_svc  USING ( svcnum  ) '.
2752                   ' LEFT JOIN part_svc  USING ( svcpart ) '.
2753                   ' LEFT JOIN cust_pkg  USING ( pkgnum  ) '.
2754                   ' LEFT JOIN cust_main USING ( custnum ) ';
2755
2756   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2757   #if ( keys %svc_acct ) {
2758   #  $count_query .= ' WHERE '.
2759   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2760   #                                      keys %svc_acct
2761   #                        );
2762   #}
2763
2764   my $sql_query = {
2765     'table'       => 'svc_acct',
2766     'hashref'     => {}, # \%svc_acct,
2767     'select'      => join(', ',
2768                        'svc_acct.*',
2769                        'part_svc.svc',
2770                        'cust_main.custnum',
2771                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2772                      ),
2773     'addl_from'   => $addl_from,
2774     'extra_sql'   => $extra_sql,
2775     'order_by'    => $params->{'order_by'},
2776     'count_query' => $count_query,
2777   };
2778
2779 }
2780
2781 =back
2782
2783 =head1 SUBROUTINES
2784
2785 =over 4
2786
2787 =item send_email
2788
2789 This is the FS::svc_acct job-queue-able version.  It still uses
2790 FS::Misc::send_email under-the-hood.
2791
2792 =cut
2793
2794 sub send_email {
2795   my %opt = @_;
2796
2797   eval "use FS::Misc qw(send_email)";
2798   die $@ if $@;
2799
2800   $opt{mimetype} ||= 'text/plain';
2801   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2802
2803   my $error = send_email(
2804     'from'         => $opt{from},
2805     'to'           => $opt{to},
2806     'subject'      => $opt{subject},
2807     'content-type' => $opt{mimetype},
2808     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2809   );
2810   die $error if $error;
2811 }
2812
2813 =item check_and_rebuild_fuzzyfiles
2814
2815 =cut
2816
2817 sub check_and_rebuild_fuzzyfiles {
2818   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2819   -e "$dir/svc_acct.username"
2820     or &rebuild_fuzzyfiles;
2821 }
2822
2823 =item rebuild_fuzzyfiles
2824
2825 =cut
2826
2827 sub rebuild_fuzzyfiles {
2828
2829   use Fcntl qw(:flock);
2830
2831   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2832
2833   #username
2834
2835   open(USERNAMELOCK,">>$dir/svc_acct.username")
2836     or die "can't open $dir/svc_acct.username: $!";
2837   flock(USERNAMELOCK,LOCK_EX)
2838     or die "can't lock $dir/svc_acct.username: $!";
2839
2840   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2841
2842   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2843     or die "can't open $dir/svc_acct.username.tmp: $!";
2844   print USERNAMECACHE join("\n", @all_username), "\n";
2845   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2846
2847   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2848   close USERNAMELOCK;
2849
2850 }
2851
2852 =item all_username
2853
2854 =cut
2855
2856 sub all_username {
2857   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2858   open(USERNAMECACHE,"<$dir/svc_acct.username")
2859     or die "can't open $dir/svc_acct.username: $!";
2860   my @array = map { chomp; $_; } <USERNAMECACHE>;
2861   close USERNAMECACHE;
2862   \@array;
2863 }
2864
2865 =item append_fuzzyfiles USERNAME
2866
2867 =cut
2868
2869 sub append_fuzzyfiles {
2870   my $username = shift;
2871
2872   &check_and_rebuild_fuzzyfiles;
2873
2874   use Fcntl qw(:flock);
2875
2876   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2877
2878   open(USERNAME,">>$dir/svc_acct.username")
2879     or die "can't open $dir/svc_acct.username: $!";
2880   flock(USERNAME,LOCK_EX)
2881     or die "can't lock $dir/svc_acct.username: $!";
2882
2883   print USERNAME "$username\n";
2884
2885   flock(USERNAME,LOCK_UN)
2886     or die "can't unlock $dir/svc_acct.username: $!";
2887   close USERNAME;
2888
2889   1;
2890 }
2891
2892
2893
2894 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2895
2896 =cut
2897
2898 sub radius_usergroup_selector {
2899   my $sel_groups = shift;
2900   my %sel_groups = map { $_=>1 } @$sel_groups;
2901
2902   my $selectname = shift || 'radius_usergroup';
2903
2904   my $dbh = dbh;
2905   my $sth = $dbh->prepare(
2906     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2907   ) or die $dbh->errstr;
2908   $sth->execute() or die $sth->errstr;
2909   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2910
2911   my $html = <<END;
2912     <SCRIPT>
2913     function ${selectname}_doadd(object) {
2914       var myvalue = object.${selectname}_add.value;
2915       var optionName = new Option(myvalue,myvalue,false,true);
2916       var length = object.$selectname.length;
2917       object.$selectname.options[length] = optionName;
2918       object.${selectname}_add.value = "";
2919     }
2920     </SCRIPT>
2921     <SELECT MULTIPLE NAME="$selectname">
2922 END
2923
2924   foreach my $group ( @all_groups ) {
2925     $html .= qq(<OPTION VALUE="$group");
2926     if ( $sel_groups{$group} ) {
2927       $html .= ' SELECTED';
2928       $sel_groups{$group} = 0;
2929     }
2930     $html .= ">$group</OPTION>\n";
2931   }
2932   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2933     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2934   };
2935   $html .= '</SELECT>';
2936
2937   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2938            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2939
2940   $html;
2941 }
2942
2943 =item reached_threshold
2944
2945 Performs some activities when svc_acct thresholds (such as number of seconds
2946 remaining) are reached.
2947
2948 =cut
2949
2950 sub reached_threshold {
2951   my %opt = @_;
2952
2953   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2954   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2955
2956   if ( $opt{'op'} eq '+' ){
2957     $svc_acct->setfield( $opt{'column'}.'_threshold',
2958                          int($svc_acct->getfield($opt{'column'})
2959                              * ( $conf->exists('svc_acct-usage_threshold')
2960                                  ? $conf->config('svc_acct-usage_threshold')/100
2961                                  : 0.80
2962                                )
2963                          )
2964                        );
2965     my $error = $svc_acct->replace;
2966     die $error if $error;
2967   }elsif ( $opt{'op'} eq '-' ){
2968
2969     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2970     return '' if ($threshold eq '' );
2971
2972     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2973     my $error = $svc_acct->replace;
2974     die $error if $error; # email next time, i guess
2975
2976     if ( $warning_template ) {
2977       eval "use FS::Misc qw(send_email)";
2978       die $@ if $@;
2979
2980       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2981       my $cust_main = $cust_pkg->cust_main;
2982
2983       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2984                                $cust_main->invoicing_list,
2985                                ($opt{'to'} ? $opt{'to'} : ())
2986                    );
2987
2988       my $mimetype = $warning_mimetype;
2989       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2990
2991       my $body       =  $warning_template->fill_in( HASH => {
2992                         'custnum'   => $cust_main->custnum,
2993                         'username'  => $svc_acct->username,
2994                         'password'  => $svc_acct->_password,
2995                         'first'     => $cust_main->first,
2996                         'last'      => $cust_main->getfield('last'),
2997                         'pkg'       => $cust_pkg->part_pkg->pkg,
2998                         'column'    => $opt{'column'},
2999                         'amount'    => $opt{'column'} =~/bytes/
3000                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3001                                        : $svc_acct->getfield($opt{'column'}),
3002                         'threshold' => $opt{'column'} =~/bytes/
3003                                        ? FS::UI::bytecount::display_bytecount($threshold)
3004                                        : $threshold,
3005                       } );
3006
3007
3008       my $error = send_email(
3009         'from'         => $warning_from,
3010         'to'           => $to,
3011         'subject'      => $warning_subject,
3012         'content-type' => $mimetype,
3013         'body'         => [ map "$_\n", split("\n", $body) ],
3014       );
3015       die $error if $error;
3016     }
3017   }else{
3018     die "unknown op: " . $opt{'op'};
3019   }
3020 }
3021
3022 =back
3023
3024 =head1 BUGS
3025
3026 The $recref stuff in sub check should be cleaned up.
3027
3028 The suspend, unsuspend and cancel methods update the database, but not the
3029 current object.  This is probably a bug as it's unexpected and
3030 counterintuitive.
3031
3032 radius_usergroup_selector?  putting web ui components in here?  they should
3033 probably live somewhere else...
3034
3035 insertion of RADIUS group stuff in insert could be done with child_objects now
3036 (would probably clean up export of them too)
3037
3038 _op_usage and set_usage bypass the history... maybe they shouldn't
3039
3040 =head1 SEE ALSO
3041
3042 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3043 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3044 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3045 L<freeside-queued>), L<FS::svc_acct_pop>,
3046 schema.html from the base documentation.
3047
3048 =cut
3049
3050 =item domain_select_hash %OPTIONS
3051
3052 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
3053 may at present purchase.
3054
3055 Currently available options are: I<pkgnum> I<svcpart>
3056
3057 =cut
3058
3059 sub domain_select_hash {
3060   my ($self, %options) = @_;
3061   my %domains = ();
3062   my $part_svc;
3063   my $cust_pkg;
3064
3065   if (ref($self)) {
3066     $part_svc = $self->part_svc;
3067     $cust_pkg = $self->cust_svc->cust_pkg
3068       if $self->cust_svc;
3069   }
3070
3071   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
3072     if $options{'svcpart'};
3073
3074   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
3075     if $options{'pkgnum'};
3076
3077   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
3078                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
3079     %domains = map { $_->svcnum => $_->domain }
3080                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
3081                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
3082   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
3083     %domains = map { $_->svcnum => $_->domain }
3084                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
3085                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
3086                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
3087   }else{
3088     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
3089   }
3090
3091   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
3092     my $svc_domain = qsearchs('svc_domain',
3093       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
3094     if ( $svc_domain ) {
3095       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
3096     }else{
3097       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
3098            $part_svc->part_svc_column('domsvc')->columnvalue;
3099
3100     }
3101   }
3102
3103   (%domains);
3104 }
3105
3106 1;
3107