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