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