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     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1951       if ($part_export->option('overlimit_groups')) {
1952         my ($new,$old);
1953         my $other = new FS::svc_acct $self->hashref;
1954         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1955                        ($self, $part_export->option('overlimit_groups'));
1956         $other->usergroup( $groups );
1957         if ($action eq 'suspend'){
1958           $new = $other; $old = $self;
1959         }else{
1960           $new = $self; $old = $other;
1961         }
1962         my $error = $part_export->export_replace($new, $old);
1963         $error ||= $self->overlimit($action);
1964         if ( $error ) {
1965           $dbh->rollback if $oldAutoCommit;
1966           return "Error replacing radius groups in export, ${op}: $error";
1967         }
1968       }
1969     }
1970   }
1971
1972   if ( $conf->exists("svc_acct-usage_$action")
1973        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1974     #my $error = $self->$action();
1975     my $error = $self->cust_svc->cust_pkg->$action();
1976     # $error ||= $self->overlimit($action);
1977     if ( $error ) {
1978       $dbh->rollback if $oldAutoCommit;
1979       return "Error ${action}ing: $error";
1980     }
1981   }
1982
1983   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1984     my $wqueue = new FS::queue {
1985       'svcnum' => $self->svcnum,
1986       'job'    => 'FS::svc_acct::reached_threshold',
1987     };
1988
1989     my $to = '';
1990     if ($op eq '-'){
1991       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1992     }
1993
1994     # x_threshold race
1995     my $error = $wqueue->insert(
1996       'svcnum' => $self->svcnum,
1997       'op'     => $op,
1998       'column' => $column,
1999       'to'     => $to,
2000     );
2001     if ( $error ) {
2002       $dbh->rollback if $oldAutoCommit;
2003       return "Error queuing threshold activity: $error";
2004     }
2005   }
2006
2007   warn "$me update successful; committing\n"
2008     if $DEBUG;
2009   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2010   '';
2011
2012 }
2013
2014 sub set_usage {
2015   my( $self, $valueref, %options ) = @_;
2016
2017   warn "$me set_usage called for svcnum ". $self->svcnum.
2018        ' ('. $self->email. "): ".
2019        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2020     if $DEBUG;
2021
2022   local $SIG{HUP} = 'IGNORE';
2023   local $SIG{INT} = 'IGNORE';
2024   local $SIG{QUIT} = 'IGNORE';
2025   local $SIG{TERM} = 'IGNORE';
2026   local $SIG{TSTP} = 'IGNORE';
2027   local $SIG{PIPE} = 'IGNORE';
2028
2029   local $FS::svc_Common::noexport_hack = 1;
2030   my $oldAutoCommit = $FS::UID::AutoCommit;
2031   local $FS::UID::AutoCommit = 0;
2032   my $dbh = dbh;
2033
2034   my $reset = 0;
2035   my %handyhash = ();
2036   if ( $options{null} ) {
2037     %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2038                    qw( seconds upbytes downbytes totalbytes )
2039                  );
2040   }
2041   foreach my $field (keys %$valueref){
2042     $reset = 1 if $valueref->{$field};
2043     $self->setfield($field, $valueref->{$field});
2044     $self->setfield( $field.'_threshold',
2045                      int($self->getfield($field)
2046                          * ( $conf->exists('svc_acct-usage_threshold')
2047                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2048                              : 0.20
2049                            )
2050                        )
2051                      );
2052     $handyhash{$field} = $self->getfield($field);
2053     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2054   }
2055   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2056   #die $error if $error;         #services not explicity changed via the UI
2057
2058   my $sql = "UPDATE svc_acct SET " .
2059     join (',', map { "$_ =  $handyhash{$_}" } (keys %handyhash) ).
2060     " WHERE svcnum = ". $self->svcnum;
2061
2062   warn "$me $sql\n"
2063     if $DEBUG;
2064
2065   if (scalar(keys %handyhash)) {
2066     my $sth = $dbh->prepare( $sql )
2067       or die "Error preparing $sql: ". $dbh->errstr;
2068     my $rv = $sth->execute();
2069     die "Error executing $sql: ". $sth->errstr
2070       unless defined($rv);
2071     die "Can't update usage for svcnum ". $self->svcnum
2072       if $rv == 0;
2073   }
2074
2075   #$self->snapshot; #not necessary, we retain the old values
2076   #create an object with the updated usage values
2077   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2078   #call exports
2079   my $error = $new->replace($self);
2080   if ( $error ) {
2081     $dbh->rollback if $oldAutoCommit;
2082     return "Error replacing: $error";
2083   }
2084
2085   if ( $reset ) {
2086     my $error;
2087
2088     if ($self->overlimit) {
2089       $error = $self->overlimit('unsuspend');
2090       foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2091         if ($part_export->option('overlimit_groups')) {
2092           my $old = new FS::svc_acct $self->hashref;
2093           my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
2094                          ($self, $part_export->option('overlimit_groups'));
2095           $old->usergroup( $groups );
2096           $error ||= $part_export->export_replace($self, $old);
2097         }
2098       }
2099     }
2100
2101     if ( $conf->exists("svc_acct-usage_unsuspend")) {
2102       $error ||= $self->cust_svc->cust_pkg->unsuspend;
2103     }
2104     if ( $error ) {
2105       $dbh->rollback if $oldAutoCommit;
2106       return "Error unsuspending: $error";
2107     }
2108   }
2109
2110   warn "$me update successful; committing\n"
2111     if $DEBUG;
2112   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2113   '';
2114
2115 }
2116
2117
2118 =item recharge HASHREF
2119
2120   Increments usage columns by the amount specified in HASHREF as
2121   column=>amount pairs.
2122
2123 =cut
2124
2125 sub recharge {
2126   my ($self, $vhash) = @_;
2127
2128   if ( $DEBUG ) {
2129     warn "[$me] recharge called on $self: ". Dumper($self).
2130          "\nwith vhash: ". Dumper($vhash);
2131   }
2132
2133   my $oldAutoCommit = $FS::UID::AutoCommit;
2134   local $FS::UID::AutoCommit = 0;
2135   my $dbh = dbh;
2136   my $error = '';
2137
2138   foreach my $column (keys %$vhash){
2139     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2140   }
2141
2142   if ( $error ) {
2143     $dbh->rollback if $oldAutoCommit;
2144   }else{
2145     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2146   }
2147   return $error;
2148 }
2149
2150 =item is_rechargeable
2151
2152 Returns true if this svc_account can be "recharged" and false otherwise.
2153
2154 =cut
2155
2156 sub is_rechargable {
2157   my $self = shift;
2158   $self->seconds ne ''
2159     || $self->upbytes ne ''
2160     || $self->downbytes ne ''
2161     || $self->totalbytes ne '';
2162 }
2163
2164 =item seconds_since TIMESTAMP
2165
2166 Returns the number of seconds this account has been online since TIMESTAMP,
2167 according to the session monitor (see L<FS::Session>).
2168
2169 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2170 L<Time::Local> and L<Date::Parse> for conversion functions.
2171
2172 =cut
2173
2174 #note: POD here, implementation in FS::cust_svc
2175 sub seconds_since {
2176   my $self = shift;
2177   $self->cust_svc->seconds_since(@_);
2178 }
2179
2180 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2181
2182 Returns the numbers of seconds this account has been online between
2183 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2184 external SQL radacct table, specified via sqlradius export.  Sessions which
2185 started in the specified range but are still open are counted from session
2186 start to the end of the range (unless they are over 1 day old, in which case
2187 they are presumed missing their stop record and not counted).  Also, sessions
2188 which end in the range but started earlier are counted from the start of the
2189 range to session end.  Finally, sessions which start before the range but end
2190 after are counted for the entire range.
2191
2192 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2193 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2194 functions.
2195
2196 =cut
2197
2198 #note: POD here, implementation in FS::cust_svc
2199 sub seconds_since_sqlradacct {
2200   my $self = shift;
2201   $self->cust_svc->seconds_since_sqlradacct(@_);
2202 }
2203
2204 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2205
2206 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2207 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2208 TIMESTAMP_END (exclusive).
2209
2210 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2211 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2212 functions.
2213
2214 =cut
2215
2216 #note: POD here, implementation in FS::cust_svc
2217 sub attribute_since_sqlradacct {
2218   my $self = shift;
2219   $self->cust_svc->attribute_since_sqlradacct(@_);
2220 }
2221
2222 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2223
2224 Returns an array of hash references of this customers login history for the
2225 given time range.  (document this better)
2226
2227 =cut
2228
2229 sub get_session_history {
2230   my $self = shift;
2231   $self->cust_svc->get_session_history(@_);
2232 }
2233
2234 =item last_login_text
2235
2236 Returns text describing the time of last login.
2237
2238 =cut
2239
2240 sub last_login_text {
2241   my $self = shift;
2242   $self->last_login ? ctime($self->last_login) : 'unknown';
2243 }
2244
2245 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2246
2247 =cut
2248
2249 sub get_cdrs {
2250   my($self, $start, $end, %opt ) = @_;
2251
2252   my $did = $self->username; #yup
2253
2254   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2255
2256   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2257
2258   #SELECT $for_update * FROM cdr
2259   #  WHERE calldate >= $start #need a conversion
2260   #    AND calldate <  $end   #ditto
2261   #    AND (    charged_party = "$did"
2262   #          OR charged_party = "$prefix$did" #if length($prefix);
2263   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2264   #               AND
2265   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2266   #             )
2267   #        )
2268   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2269
2270   my $charged_or_src;
2271   if ( length($prefix) ) {
2272     $charged_or_src =
2273       " AND (    charged_party = '$did'
2274               OR charged_party = '$prefix$did'
2275               OR ( ( charged_party IS NULL OR charged_party = '' )
2276                    AND
2277                    ( src = '$did' OR src = '$prefix$did' )
2278                  )
2279             )
2280       ";
2281   } else {
2282     $charged_or_src =
2283       " AND (    charged_party = '$did'
2284               OR ( ( charged_party IS NULL OR charged_party = '' )
2285                    AND
2286                    src = '$did'
2287                  )
2288             )
2289       ";
2290
2291   }
2292
2293   qsearch(
2294     'select'    => "$for_update *",
2295     'table'     => 'cdr',
2296     'hashref'   => {
2297                      #( freesidestatus IS NULL OR freesidestatus = '' )
2298                      'freesidestatus' => '',
2299                    },
2300     'extra_sql' => $charged_or_src,
2301
2302   );
2303
2304 }
2305
2306 =item radius_groups
2307
2308 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2309
2310 =cut
2311
2312 sub radius_groups {
2313   my $self = shift;
2314   if ( $self->usergroup ) {
2315     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2316       unless ref($self->usergroup) eq 'ARRAY';
2317     #when provisioning records, export callback runs in svc_Common.pm before
2318     #radius_usergroup records can be inserted...
2319     @{$self->usergroup};
2320   } else {
2321     map { $_->groupname }
2322       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2323   }
2324 }
2325
2326 =item clone_suspended
2327
2328 Constructor used by FS::part_export::_export_suspend fallback.  Document
2329 better.
2330
2331 =cut
2332
2333 sub clone_suspended {
2334   my $self = shift;
2335   my %hash = $self->hash;
2336   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2337   new FS::svc_acct \%hash;
2338 }
2339
2340 =item clone_kludge_unsuspend
2341
2342 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2343 better.
2344
2345 =cut
2346
2347 sub clone_kludge_unsuspend {
2348   my $self = shift;
2349   my %hash = $self->hash;
2350   $hash{_password} = '';
2351   new FS::svc_acct \%hash;
2352 }
2353
2354 =item check_password
2355
2356 Checks the supplied password against the (possibly encrypted) password in the
2357 database.  Returns true for a successful authentication, false for no match.
2358
2359 Currently supported encryptions are: classic DES crypt() and MD5
2360
2361 =cut
2362
2363 sub check_password {
2364   my($self, $check_password) = @_;
2365
2366   #remove old-style SUSPENDED kludge, they should be allowed to login to
2367   #self-service and pay up
2368   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2369
2370   if ( $self->_password_encoding eq 'ldap' ) {
2371
2372     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2373     return $auth->match($check_password);
2374
2375   } elsif ( $self->_password_encoding eq 'crypt' ) {
2376
2377     my $auth = from_crypt Authen::Passphrase $self->_password;
2378     return $auth->match($check_password);
2379
2380   } elsif ( $self->_password_encoding eq 'plain' ) {
2381
2382     return $check_password eq $password;
2383
2384   } else {
2385
2386     #XXX this could be replaced with Authen::Passphrase stuff
2387
2388     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2389       return 0;
2390     } elsif ( length($password) < 13 ) { #plaintext
2391       $check_password eq $password;
2392     } elsif ( length($password) == 13 ) { #traditional DES crypt
2393       crypt($check_password, $password) eq $password;
2394     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2395       unix_md5_crypt($check_password, $password) eq $password;
2396     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2397       warn "Can't check password: Blowfish encryption not yet supported, ".
2398            "svcnum ".  $self->svcnum. "\n";
2399       0;
2400     } else {
2401       warn "Can't check password: Unrecognized encryption for svcnum ".
2402            $self->svcnum. "\n";
2403       0;
2404     }
2405
2406   }
2407
2408 }
2409
2410 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2411
2412 Returns an encrypted password, either by passing through an encrypted password
2413 in the database or by encrypting a plaintext password from the database.
2414
2415 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2416 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2417 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2418 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2419 encryption type is only used if the password is not already encrypted in the
2420 database.
2421
2422 =cut
2423
2424 sub crypt_password {
2425   my $self = shift;
2426
2427   if ( $self->_password_encoding eq 'ldap' ) {
2428
2429     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2430       my $plain = $2;
2431
2432       #XXX this could be replaced with Authen::Passphrase stuff
2433
2434       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2435       if ( $encryption eq 'crypt' ) {
2436         crypt(
2437           $self->_password,
2438           $saltset[int(rand(64))].$saltset[int(rand(64))]
2439         );
2440       } elsif ( $encryption eq 'md5' ) {
2441         unix_md5_crypt( $self->_password );
2442       } elsif ( $encryption eq 'blowfish' ) {
2443         croak "unknown encryption method $encryption";
2444       } else {
2445         croak "unknown encryption method $encryption";
2446       }
2447
2448     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2449       $1;
2450     }
2451
2452   } elsif ( $self->_password_encoding eq 'crypt' ) {
2453
2454     return $self->_password;
2455
2456   } elsif ( $self->_password_encoding eq 'plain' ) {
2457
2458     #XXX this could be replaced with Authen::Passphrase stuff
2459
2460     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2461     if ( $encryption eq 'crypt' ) {
2462       crypt(
2463         $self->_password,
2464         $saltset[int(rand(64))].$saltset[int(rand(64))]
2465       );
2466     } elsif ( $encryption eq 'md5' ) {
2467       unix_md5_crypt( $self->_password );
2468     } elsif ( $encryption eq 'blowfish' ) {
2469       croak "unknown encryption method $encryption";
2470     } else {
2471       croak "unknown encryption method $encryption";
2472     }
2473
2474   } else {
2475
2476     if ( length($self->_password) == 13
2477          || $self->_password =~ /^\$(1|2a?)\$/
2478          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2479        )
2480     {
2481       $self->_password;
2482     } else {
2483
2484       #XXX this could be replaced with Authen::Passphrase stuff
2485
2486       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2487       if ( $encryption eq 'crypt' ) {
2488         crypt(
2489           $self->_password,
2490           $saltset[int(rand(64))].$saltset[int(rand(64))]
2491         );
2492       } elsif ( $encryption eq 'md5' ) {
2493         unix_md5_crypt( $self->_password );
2494       } elsif ( $encryption eq 'blowfish' ) {
2495         croak "unknown encryption method $encryption";
2496       } else {
2497         croak "unknown encryption method $encryption";
2498       }
2499
2500     }
2501
2502   }
2503
2504 }
2505
2506 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2507
2508 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2509 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2510 "{MD5}5426824942db4253f87a1009fd5d2d4".
2511
2512 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2513 to work the same as the B</crypt_password> method.
2514
2515 =cut
2516
2517 sub ldap_password {
2518   my $self = shift;
2519   #eventually should check a "password-encoding" field
2520
2521   if ( $self->_password_encoding eq 'ldap' ) {
2522
2523     return $self->_password;
2524
2525   } elsif ( $self->_password_encoding eq 'crypt' ) {
2526
2527     if ( length($self->_password) == 13 ) { #crypt
2528       return '{CRYPT}'. $self->_password;
2529     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2530       return '{MD5}'. $1;
2531     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2532     #  die "Blowfish encryption not supported in this context, svcnum ".
2533     #      $self->svcnum. "\n";
2534     } else {
2535       warn "encryption method not (yet?) supported in LDAP context";
2536       return '{CRYPT}*'; #unsupported, should not auth
2537     }
2538
2539   } elsif ( $self->_password_encoding eq 'plain' ) {
2540
2541     return '{PLAIN}'. $self->_password;
2542
2543     #return '{CLEARTEXT}'. $self->_password; #?
2544
2545   } else {
2546
2547     if ( length($self->_password) == 13 ) { #crypt
2548       return '{CRYPT}'. $self->_password;
2549     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2550       return '{MD5}'. $1;
2551     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2552       warn "Blowfish encryption not supported in this context, svcnum ".
2553           $self->svcnum. "\n";
2554       return '{CRYPT}*';
2555
2556     #are these two necessary anymore?
2557     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2558       return '{SSHA}'. $1;
2559     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2560       return '{NS-MTA-MD5}'. $1;
2561
2562     } else { #plaintext
2563       return '{PLAIN}'. $self->_password;
2564
2565       #return '{CLEARTEXT}'. $self->_password; #?
2566
2567       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2568       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2569       #if ( $encryption eq 'crypt' ) {
2570       #  return '{CRYPT}'. crypt(
2571       #    $self->_password,
2572       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2573       #  );
2574       #} elsif ( $encryption eq 'md5' ) {
2575       #  unix_md5_crypt( $self->_password );
2576       #} elsif ( $encryption eq 'blowfish' ) {
2577       #  croak "unknown encryption method $encryption";
2578       #} else {
2579       #  croak "unknown encryption method $encryption";
2580       #}
2581     }
2582
2583   }
2584
2585 }
2586
2587 =item domain_slash_username
2588
2589 Returns $domain/$username/
2590
2591 =cut
2592
2593 sub domain_slash_username {
2594   my $self = shift;
2595   $self->domain. '/'. $self->username. '/';
2596 }
2597
2598 =item virtual_maildir
2599
2600 Returns $domain/maildirs/$username/
2601
2602 =cut
2603
2604 sub virtual_maildir {
2605   my $self = shift;
2606   $self->domain. '/maildirs/'. $self->username. '/';
2607 }
2608
2609 =back
2610
2611 =head1 CLASS METHODS
2612
2613 =over 4
2614
2615 =item search HASHREF
2616
2617 Class method which returns a qsearch hash expression to search for parameters
2618 specified in HASHREF.  Valid parameters are
2619
2620 =over 4
2621
2622 =item domain
2623
2624 =item domsvc
2625
2626 =item unlinked
2627
2628 =item agentnum
2629
2630 =item pkgpart
2631
2632 Arrayref of pkgparts
2633
2634 =item pkgpart
2635
2636 =item where
2637
2638 Arrayref of additional WHERE clauses, will be ANDed together.
2639
2640 =item order_by
2641
2642 =item cust_fields
2643
2644 =back
2645
2646 =cut
2647
2648 sub search {
2649   my ($class, $params) = @_;
2650
2651   my @where = ();
2652
2653   # domain
2654   if ( $params->{'domain'} ) {
2655     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2656     #preserve previous behavior & bubble up an error if $svc_domain not found?
2657     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2658   }
2659
2660   # domsvc
2661   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2662     push @where, "domsvc = $1";
2663   }
2664
2665   #unlinked
2666   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2667
2668   #agentnum
2669   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2670     push @where, "agentnum = $1";
2671   }
2672
2673   #custnum
2674   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2675     push @where, "custnum = $1";
2676   }
2677
2678   #pkgpart
2679   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2680     #XXX untaint or sql quote
2681     push @where,
2682       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2683   }
2684
2685   # popnum
2686   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2687     push @where, "popnum = $1";
2688   }
2689
2690   # svcpart
2691   if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2692     push @where, "svcpart = $1";
2693   }
2694
2695
2696   # here is the agent virtualization
2697   #if ($params->{CurrentUser}) {
2698   #  my $access_user =
2699   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2700   #
2701   #  if ($access_user) {
2702   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2703   #  }else{
2704   #    push @where, "1=0";
2705   #  }
2706   #} else {
2707     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2708                    'table'      => 'cust_main',
2709                    'null_right' => 'View/link unlinked services',
2710                  );
2711   #}
2712
2713   push @where, @{ $params->{'where'} } if $params->{'where'};
2714
2715   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2716
2717   my $addl_from = ' LEFT JOIN cust_svc  USING ( svcnum  ) '.
2718                   ' LEFT JOIN part_svc  USING ( svcpart ) '.
2719                   ' LEFT JOIN cust_pkg  USING ( pkgnum  ) '.
2720                   ' LEFT JOIN cust_main USING ( custnum ) ';
2721
2722   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2723   #if ( keys %svc_acct ) {
2724   #  $count_query .= ' WHERE '.
2725   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2726   #                                      keys %svc_acct
2727   #                        );
2728   #}
2729
2730   my $sql_query = {
2731     'table'       => 'svc_acct',
2732     'hashref'     => {}, # \%svc_acct,
2733     'select'      => join(', ',
2734                        'svc_acct.*',
2735                        'part_svc.svc',
2736                        'cust_main.custnum',
2737                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2738                      ),
2739     'addl_from'   => $addl_from,
2740     'extra_sql'   => $extra_sql,
2741     'order_by'    => $params->{'order_by'},
2742     'count_query' => $count_query,
2743   };
2744
2745 }
2746
2747 =back
2748
2749 =head1 SUBROUTINES
2750
2751 =over 4
2752
2753 =item send_email
2754
2755 This is the FS::svc_acct job-queue-able version.  It still uses
2756 FS::Misc::send_email under-the-hood.
2757
2758 =cut
2759
2760 sub send_email {
2761   my %opt = @_;
2762
2763   eval "use FS::Misc qw(send_email)";
2764   die $@ if $@;
2765
2766   $opt{mimetype} ||= 'text/plain';
2767   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2768
2769   my $error = send_email(
2770     'from'         => $opt{from},
2771     'to'           => $opt{to},
2772     'subject'      => $opt{subject},
2773     'content-type' => $opt{mimetype},
2774     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2775   );
2776   die $error if $error;
2777 }
2778
2779 =item check_and_rebuild_fuzzyfiles
2780
2781 =cut
2782
2783 sub check_and_rebuild_fuzzyfiles {
2784   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2785   -e "$dir/svc_acct.username"
2786     or &rebuild_fuzzyfiles;
2787 }
2788
2789 =item rebuild_fuzzyfiles
2790
2791 =cut
2792
2793 sub rebuild_fuzzyfiles {
2794
2795   use Fcntl qw(:flock);
2796
2797   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2798
2799   #username
2800
2801   open(USERNAMELOCK,">>$dir/svc_acct.username")
2802     or die "can't open $dir/svc_acct.username: $!";
2803   flock(USERNAMELOCK,LOCK_EX)
2804     or die "can't lock $dir/svc_acct.username: $!";
2805
2806   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2807
2808   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2809     or die "can't open $dir/svc_acct.username.tmp: $!";
2810   print USERNAMECACHE join("\n", @all_username), "\n";
2811   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2812
2813   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2814   close USERNAMELOCK;
2815
2816 }
2817
2818 =item all_username
2819
2820 =cut
2821
2822 sub all_username {
2823   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2824   open(USERNAMECACHE,"<$dir/svc_acct.username")
2825     or die "can't open $dir/svc_acct.username: $!";
2826   my @array = map { chomp; $_; } <USERNAMECACHE>;
2827   close USERNAMECACHE;
2828   \@array;
2829 }
2830
2831 =item append_fuzzyfiles USERNAME
2832
2833 =cut
2834
2835 sub append_fuzzyfiles {
2836   my $username = shift;
2837
2838   &check_and_rebuild_fuzzyfiles;
2839
2840   use Fcntl qw(:flock);
2841
2842   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2843
2844   open(USERNAME,">>$dir/svc_acct.username")
2845     or die "can't open $dir/svc_acct.username: $!";
2846   flock(USERNAME,LOCK_EX)
2847     or die "can't lock $dir/svc_acct.username: $!";
2848
2849   print USERNAME "$username\n";
2850
2851   flock(USERNAME,LOCK_UN)
2852     or die "can't unlock $dir/svc_acct.username: $!";
2853   close USERNAME;
2854
2855   1;
2856 }
2857
2858
2859
2860 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2861
2862 =cut
2863
2864 sub radius_usergroup_selector {
2865   my $sel_groups = shift;
2866   my %sel_groups = map { $_=>1 } @$sel_groups;
2867
2868   my $selectname = shift || 'radius_usergroup';
2869
2870   my $dbh = dbh;
2871   my $sth = $dbh->prepare(
2872     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2873   ) or die $dbh->errstr;
2874   $sth->execute() or die $sth->errstr;
2875   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2876
2877   my $html = <<END;
2878     <SCRIPT>
2879     function ${selectname}_doadd(object) {
2880       var myvalue = object.${selectname}_add.value;
2881       var optionName = new Option(myvalue,myvalue,false,true);
2882       var length = object.$selectname.length;
2883       object.$selectname.options[length] = optionName;
2884       object.${selectname}_add.value = "";
2885     }
2886     </SCRIPT>
2887     <SELECT MULTIPLE NAME="$selectname">
2888 END
2889
2890   foreach my $group ( @all_groups ) {
2891     $html .= qq(<OPTION VALUE="$group");
2892     if ( $sel_groups{$group} ) {
2893       $html .= ' SELECTED';
2894       $sel_groups{$group} = 0;
2895     }
2896     $html .= ">$group</OPTION>\n";
2897   }
2898   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2899     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2900   };
2901   $html .= '</SELECT>';
2902
2903   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2904            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2905
2906   $html;
2907 }
2908
2909 =item reached_threshold
2910
2911 Performs some activities when svc_acct thresholds (such as number of seconds
2912 remaining) are reached.
2913
2914 =cut
2915
2916 sub reached_threshold {
2917   my %opt = @_;
2918
2919   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2920   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2921
2922   if ( $opt{'op'} eq '+' ){
2923     $svc_acct->setfield( $opt{'column'}.'_threshold',
2924                          int($svc_acct->getfield($opt{'column'})
2925                              * ( $conf->exists('svc_acct-usage_threshold')
2926                                  ? $conf->config('svc_acct-usage_threshold')/100
2927                                  : 0.80
2928                                )
2929                          )
2930                        );
2931     my $error = $svc_acct->replace;
2932     die $error if $error;
2933   }elsif ( $opt{'op'} eq '-' ){
2934
2935     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2936     return '' if ($threshold eq '' );
2937
2938     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2939     my $error = $svc_acct->replace;
2940     die $error if $error; # email next time, i guess
2941
2942     if ( $warning_template ) {
2943       eval "use FS::Misc qw(send_email)";
2944       die $@ if $@;
2945
2946       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2947       my $cust_main = $cust_pkg->cust_main;
2948
2949       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2950                                $cust_main->invoicing_list,
2951                                ($opt{'to'} ? $opt{'to'} : ())
2952                    );
2953
2954       my $mimetype = $warning_mimetype;
2955       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2956
2957       my $body       =  $warning_template->fill_in( HASH => {
2958                         'custnum'   => $cust_main->custnum,
2959                         'username'  => $svc_acct->username,
2960                         'password'  => $svc_acct->_password,
2961                         'first'     => $cust_main->first,
2962                         'last'      => $cust_main->getfield('last'),
2963                         'pkg'       => $cust_pkg->part_pkg->pkg,
2964                         'column'    => $opt{'column'},
2965                         'amount'    => $opt{'column'} =~/bytes/
2966                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2967                                        : $svc_acct->getfield($opt{'column'}),
2968                         'threshold' => $opt{'column'} =~/bytes/
2969                                        ? FS::UI::bytecount::display_bytecount($threshold)
2970                                        : $threshold,
2971                       } );
2972
2973
2974       my $error = send_email(
2975         'from'         => $warning_from,
2976         'to'           => $to,
2977         'subject'      => $warning_subject,
2978         'content-type' => $mimetype,
2979         'body'         => [ map "$_\n", split("\n", $body) ],
2980       );
2981       die $error if $error;
2982     }
2983   }else{
2984     die "unknown op: " . $opt{'op'};
2985   }
2986 }
2987
2988 =back
2989
2990 =head1 BUGS
2991
2992 The $recref stuff in sub check should be cleaned up.
2993
2994 The suspend, unsuspend and cancel methods update the database, but not the
2995 current object.  This is probably a bug as it's unexpected and
2996 counterintuitive.
2997
2998 radius_usergroup_selector?  putting web ui components in here?  they should
2999 probably live somewhere else...
3000
3001 insertion of RADIUS group stuff in insert could be done with child_objects now
3002 (would probably clean up export of them too)
3003
3004 _op_usage and set_usage bypass the history... maybe they shouldn't
3005
3006 =head1 SEE ALSO
3007
3008 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3009 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3010 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3011 L<freeside-queued>), L<FS::svc_acct_pop>,
3012 schema.html from the base documentation.
3013
3014 =cut
3015
3016 =item domain_select_hash %OPTIONS
3017
3018 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
3019 may at present purchase.
3020
3021 Currently available options are: I<pkgnum> I<svcpart>
3022
3023 =cut
3024
3025 sub domain_select_hash {
3026   my ($self, %options) = @_;
3027   my %domains = ();
3028   my $part_svc;
3029   my $cust_pkg;
3030
3031   if (ref($self)) {
3032     $part_svc = $self->part_svc;
3033     $cust_pkg = $self->cust_svc->cust_pkg
3034       if $self->cust_svc;
3035   }
3036
3037   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
3038     if $options{'svcpart'};
3039
3040   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
3041     if $options{'pkgnum'};
3042
3043   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
3044                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
3045     %domains = map { $_->svcnum => $_->domain }
3046                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
3047                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
3048   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
3049     %domains = map { $_->svcnum => $_->domain }
3050                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
3051                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
3052                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
3053   }else{
3054     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
3055   }
3056
3057   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
3058     my $svc_domain = qsearchs('svc_domain',
3059       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
3060     if ( $svc_domain ) {
3061       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
3062     }else{
3063       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
3064            $part_svc->part_svc_column('domsvc')->columnvalue;
3065
3066     }
3067   }
3068
3069   (%domains);
3070 }
3071
3072 1;
3073