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