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