FS/FS/svc_acct.pm

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