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