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