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   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1500     unless $cust_svc;
1501   my $cust_pkg = $cust_svc->cust_pkg;
1502   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1503     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1504   }
1505
1506   %check;
1507
1508 }
1509
1510 =item radius_password
1511
1512 Returns a key/value pair containing the RADIUS attribute name and value
1513 for the password.
1514
1515 =cut
1516
1517 sub radius_password {
1518   my $self = shift;
1519
1520   my($pw_attrib, $password);
1521   if ( $self->_password_encoding eq 'ldap' ) {
1522
1523     $pw_attrib = 'Password-With-Header';
1524     $password = $self->_password;
1525
1526   } elsif ( $self->_password_encoding eq 'crypt' ) {
1527
1528     $pw_attrib = 'Crypt-Password';
1529     $password = $self->_password;
1530
1531   } elsif ( $self->_password_encoding eq 'plain' ) {
1532
1533     $pw_attrib = $radius_password; #Cleartext-Password?  man rlm_pap
1534     $password = $self->_password;
1535
1536   } else {
1537
1538     $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1539     $password = $self->_password;
1540
1541   }
1542
1543   ($pw_attrib, $password);
1544
1545 }
1546
1547 =item snapshot
1548
1549 This method instructs the object to "snapshot" or freeze RADIUS check and
1550 reply attributes to the current values.
1551
1552 =cut
1553
1554 #bah, my english is too broken this morning
1555 #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
1556 #the FS::cust_pkg's replace method to trigger the correct export updates when
1557 #package dates change)
1558
1559 sub snapshot {
1560   my $self = shift;
1561
1562   $self->{$_} = { $self->$_() }
1563     foreach qw( radius_reply radius_check );
1564
1565 }
1566
1567 =item forget_snapshot
1568
1569 This methos instructs the object to forget any previously snapshotted
1570 RADIUS check and reply attributes.
1571
1572 =cut
1573
1574 sub forget_snapshot {
1575   my $self = shift;
1576
1577   delete $self->{$_}
1578     foreach qw( radius_reply radius_check );
1579
1580 }
1581
1582 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1583
1584 Returns the domain associated with this account.
1585
1586 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1587 history records.
1588
1589 =cut
1590
1591 sub domain {
1592   my $self = shift;
1593   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1594   my $svc_domain = $self->svc_domain(@_)
1595     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1596   $svc_domain->domain;
1597 }
1598
1599 =item svc_domain
1600
1601 Returns the FS::svc_domain record for this account's domain (see
1602 L<FS::svc_domain>).
1603
1604 =cut
1605
1606 # FS::h_svc_acct has a history-aware svc_domain override
1607
1608 sub svc_domain {
1609   my $self = shift;
1610   $self->{'_domsvc'}
1611     ? $self->{'_domsvc'}
1612     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1613 }
1614
1615 =item cust_svc
1616
1617 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1618
1619 =cut
1620
1621 #inherited from svc_Common
1622
1623 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1624
1625 Returns an email address associated with the account.
1626
1627 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1628 history records.
1629
1630 =cut
1631
1632 sub email {
1633   my $self = shift;
1634   $self->username. '@'. $self->domain(@_);
1635 }
1636
1637 =item acct_snarf
1638
1639 Returns an array of FS::acct_snarf records associated with the account.
1640 If the acct_snarf table does not exist or there are no associated records,
1641 an empty list is returned
1642
1643 =cut
1644
1645 sub acct_snarf {
1646   my $self = shift;
1647   return () unless dbdef->table('acct_snarf');
1648   eval "use FS::acct_snarf;";
1649   die $@ if $@;
1650   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1651 }
1652
1653 =item decrement_upbytes OCTETS
1654
1655 Decrements the I<upbytes> field of this record by the given amount.  If there
1656 is an error, returns the error, otherwise returns false.
1657
1658 =cut
1659
1660 sub decrement_upbytes {
1661   shift->_op_usage('-', 'upbytes', @_);
1662 }
1663
1664 =item increment_upbytes OCTETS
1665
1666 Increments the I<upbytes> field of this record by the given amount.  If there
1667 is an error, returns the error, otherwise returns false.
1668
1669 =cut
1670
1671 sub increment_upbytes {
1672   shift->_op_usage('+', 'upbytes', @_);
1673 }
1674
1675 =item decrement_downbytes OCTETS
1676
1677 Decrements the I<downbytes> field of this record by the given amount.  If there
1678 is an error, returns the error, otherwise returns false.
1679
1680 =cut
1681
1682 sub decrement_downbytes {
1683   shift->_op_usage('-', 'downbytes', @_);
1684 }
1685
1686 =item increment_downbytes OCTETS
1687
1688 Increments the I<downbytes> field of this record by the given amount.  If there
1689 is an error, returns the error, otherwise returns false.
1690
1691 =cut
1692
1693 sub increment_downbytes {
1694   shift->_op_usage('+', 'downbytes', @_);
1695 }
1696
1697 =item decrement_totalbytes OCTETS
1698
1699 Decrements the I<totalbytes> field of this record by the given amount.  If there
1700 is an error, returns the error, otherwise returns false.
1701
1702 =cut
1703
1704 sub decrement_totalbytes {
1705   shift->_op_usage('-', 'totalbytes', @_);
1706 }
1707
1708 =item increment_totalbytes OCTETS
1709
1710 Increments the I<totalbytes> field of this record by the given amount.  If there
1711 is an error, returns the error, otherwise returns false.
1712
1713 =cut
1714
1715 sub increment_totalbytes {
1716   shift->_op_usage('+', 'totalbytes', @_);
1717 }
1718
1719 =item decrement_seconds SECONDS
1720
1721 Decrements the I<seconds> field of this record by the given amount.  If there
1722 is an error, returns the error, otherwise returns false.
1723
1724 =cut
1725
1726 sub decrement_seconds {
1727   shift->_op_usage('-', 'seconds', @_);
1728 }
1729
1730 =item increment_seconds SECONDS
1731
1732 Increments the I<seconds> field of this record by the given amount.  If there
1733 is an error, returns the error, otherwise returns false.
1734
1735 =cut
1736
1737 sub increment_seconds {
1738   shift->_op_usage('+', 'seconds', @_);
1739 }
1740
1741
1742 my %op2action = (
1743   '-' => 'suspend',
1744   '+' => 'unsuspend',
1745 );
1746 my %op2condition = (
1747   '-' => sub { my($self, $column, $amount) = @_;
1748                $self->$column - $amount <= 0;
1749              },
1750   '+' => sub { my($self, $column, $amount) = @_;
1751                ($self->$column || 0) + $amount > 0;
1752              },
1753 );
1754 my %op2warncondition = (
1755   '-' => sub { my($self, $column, $amount) = @_;
1756                my $threshold = $column . '_threshold';
1757                $self->$column - $amount <= $self->$threshold + 0;
1758              },
1759   '+' => sub { my($self, $column, $amount) = @_;
1760                ($self->$column || 0) + $amount > 0;
1761              },
1762 );
1763
1764 sub _op_usage {
1765   my( $self, $op, $column, $amount ) = @_;
1766
1767   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1768        ' ('. $self->email. "): $op $amount\n"
1769     if $DEBUG;
1770
1771   return '' unless $amount;
1772
1773   local $SIG{HUP} = 'IGNORE';
1774   local $SIG{INT} = 'IGNORE';
1775   local $SIG{QUIT} = 'IGNORE';
1776   local $SIG{TERM} = 'IGNORE';
1777   local $SIG{TSTP} = 'IGNORE';
1778   local $SIG{PIPE} = 'IGNORE';
1779
1780   my $oldAutoCommit = $FS::UID::AutoCommit;
1781   local $FS::UID::AutoCommit = 0;
1782   my $dbh = dbh;
1783
1784   my $sql = "UPDATE svc_acct SET $column = ".
1785             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1786             " $op ? WHERE svcnum = ?";
1787   warn "$me $sql\n"
1788     if $DEBUG;
1789
1790   my $sth = $dbh->prepare( $sql )
1791     or die "Error preparing $sql: ". $dbh->errstr;
1792   my $rv = $sth->execute($amount, $self->svcnum);
1793   die "Error executing $sql: ". $sth->errstr
1794     unless defined($rv);
1795   die "Can't update $column for svcnum". $self->svcnum
1796     if $rv == 0;
1797
1798   #$self->snapshot; #not necessary, we retain the old values
1799   #create an object with the updated usage values
1800   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1801   #call exports
1802   my $error = $new->replace($self);
1803   if ( $error ) {
1804     $dbh->rollback if $oldAutoCommit;
1805     return "Error replacing: $error";
1806   }
1807
1808   #overlimit_action eq 'cancel' handling
1809   my $cust_pkg = $self->cust_svc->cust_pkg;
1810   if ( $cust_pkg
1811        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1812        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1813      )
1814   {
1815
1816     my $error = $cust_pkg->cancel; #XXX should have a reason
1817     if ( $error ) {
1818       $dbh->rollback if $oldAutoCommit;
1819       return "Error cancelling: $error";
1820     }
1821
1822     #nothing else is relevant if we're cancelling, so commit & return success
1823     warn "$me update successful; committing\n"
1824       if $DEBUG;
1825     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1826     return '';
1827
1828   }
1829
1830   my $action = $op2action{$op};
1831
1832   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1833         ( $action eq 'suspend'   && !$self->overlimit
1834        || $action eq 'unsuspend' &&  $self->overlimit )
1835      ) {
1836     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1837       if ($part_export->option('overlimit_groups')) {
1838         my ($new,$old);
1839         my $other = new FS::svc_acct $self->hashref;
1840         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1841                        ($self, $part_export->option('overlimit_groups'));
1842         $other->usergroup( $groups );
1843         if ($action eq 'suspend'){
1844           $new = $other; $old = $self;
1845         }else{
1846           $new = $self; $old = $other;
1847         }
1848         my $error = $part_export->export_replace($new, $old);
1849         $error ||= $self->overlimit($action);
1850         if ( $error ) {
1851           $dbh->rollback if $oldAutoCommit;
1852           return "Error replacing radius groups in export, ${op}: $error";
1853         }
1854       }
1855     }
1856   }
1857
1858   if ( $conf->exists("svc_acct-usage_$action")
1859        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1860     #my $error = $self->$action();
1861     my $error = $self->cust_svc->cust_pkg->$action();
1862     # $error ||= $self->overlimit($action);
1863     if ( $error ) {
1864       $dbh->rollback if $oldAutoCommit;
1865       return "Error ${action}ing: $error";
1866     }
1867   }
1868
1869   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1870     my $wqueue = new FS::queue {
1871       'svcnum' => $self->svcnum,
1872       'job'    => 'FS::svc_acct::reached_threshold',
1873     };
1874
1875     my $to = '';
1876     if ($op eq '-'){
1877       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1878     }
1879
1880     # x_threshold race
1881     my $error = $wqueue->insert(
1882       'svcnum' => $self->svcnum,
1883       'op'     => $op,
1884       'column' => $column,
1885       'to'     => $to,
1886     );
1887     if ( $error ) {
1888       $dbh->rollback if $oldAutoCommit;
1889       return "Error queuing threshold activity: $error";
1890     }
1891   }
1892
1893   warn "$me update successful; committing\n"
1894     if $DEBUG;
1895   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1896   '';
1897
1898 }
1899
1900 sub set_usage {
1901   my( $self, $valueref, %options ) = @_;
1902
1903   warn "$me set_usage called for svcnum ". $self->svcnum.
1904        ' ('. $self->email. "): ".
1905        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1906     if $DEBUG;
1907
1908   local $SIG{HUP} = 'IGNORE';
1909   local $SIG{INT} = 'IGNORE';
1910   local $SIG{QUIT} = 'IGNORE';
1911   local $SIG{TERM} = 'IGNORE';
1912   local $SIG{TSTP} = 'IGNORE';
1913   local $SIG{PIPE} = 'IGNORE';
1914
1915   local $FS::svc_Common::noexport_hack = 1;
1916   my $oldAutoCommit = $FS::UID::AutoCommit;
1917   local $FS::UID::AutoCommit = 0;
1918   my $dbh = dbh;
1919
1920   my $reset = 0;
1921   my %handyhash = ();
1922   if ( $options{null} ) {
1923     %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1924                    qw( seconds upbytes downbytes totalbytes )
1925                  );
1926   }
1927   foreach my $field (keys %$valueref){
1928     $reset = 1 if $valueref->{$field};
1929     $self->setfield($field, $valueref->{$field});
1930     $self->setfield( $field.'_threshold',
1931                      int($self->getfield($field)
1932                          * ( $conf->exists('svc_acct-usage_threshold')
1933                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1934                              : 0.20
1935                            )
1936                        )
1937                      );
1938     $handyhash{$field} = $self->getfield($field);
1939     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1940   }
1941   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1942   #die $error if $error;         #services not explicity changed via the UI
1943
1944   my $sql = "UPDATE svc_acct SET " .
1945     join (',', map { "$_ =  $handyhash{$_}" } (keys %handyhash) ).
1946     " WHERE svcnum = ". $self->svcnum;
1947
1948   warn "$me $sql\n"
1949     if $DEBUG;
1950
1951   if (scalar(keys %handyhash)) {
1952     my $sth = $dbh->prepare( $sql )
1953       or die "Error preparing $sql: ". $dbh->errstr;
1954     my $rv = $sth->execute();
1955     die "Error executing $sql: ". $sth->errstr
1956       unless defined($rv);
1957     die "Can't update usage for svcnum ". $self->svcnum
1958       if $rv == 0;
1959   }
1960
1961   #$self->snapshot; #not necessary, we retain the old values
1962   #create an object with the updated usage values
1963   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1964   #call exports
1965   my $error = $new->replace($self);
1966   if ( $error ) {
1967     $dbh->rollback if $oldAutoCommit;
1968     return "Error replacing: $error";
1969   }
1970
1971   if ( $reset ) {
1972     my $error;
1973
1974     if ($self->overlimit) {
1975       $error = $self->overlimit('unsuspend');
1976       foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1977         if ($part_export->option('overlimit_groups')) {
1978           my $old = new FS::svc_acct $self->hashref;
1979           my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1980                          ($self, $part_export->option('overlimit_groups'));
1981           $old->usergroup( $groups );
1982           $error ||= $part_export->export_replace($self, $old);
1983         }
1984       }
1985     }
1986
1987     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1988       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1989     }
1990     if ( $error ) {
1991       $dbh->rollback if $oldAutoCommit;
1992       return "Error unsuspending: $error";
1993     }
1994   }
1995
1996   warn "$me update successful; committing\n"
1997     if $DEBUG;
1998   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1999   '';
2000
2001 }
2002
2003
2004 =item recharge HASHREF
2005
2006   Increments usage columns by the amount specified in HASHREF as
2007   column=>amount pairs.
2008
2009 =cut
2010
2011 sub recharge {
2012   my ($self, $vhash) = @_;
2013
2014   if ( $DEBUG ) {
2015     warn "[$me] recharge called on $self: ". Dumper($self).
2016          "\nwith vhash: ". Dumper($vhash);
2017   }
2018
2019   my $oldAutoCommit = $FS::UID::AutoCommit;
2020   local $FS::UID::AutoCommit = 0;
2021   my $dbh = dbh;
2022   my $error = '';
2023
2024   foreach my $column (keys %$vhash){
2025     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2026   }
2027
2028   if ( $error ) {
2029     $dbh->rollback if $oldAutoCommit;
2030   }else{
2031     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2032   }
2033   return $error;
2034 }
2035
2036 =item is_rechargeable
2037
2038 Returns true if this svc_account can be "recharged" and false otherwise.
2039
2040 =cut
2041
2042 sub is_rechargable {
2043   my $self = shift;
2044   $self->seconds ne ''
2045     || $self->upbytes ne ''
2046     || $self->downbytes ne ''
2047     || $self->totalbytes ne '';
2048 }
2049
2050 =item seconds_since TIMESTAMP
2051
2052 Returns the number of seconds this account has been online since TIMESTAMP,
2053 according to the session monitor (see L<FS::Session>).
2054
2055 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2056 L<Time::Local> and L<Date::Parse> for conversion functions.
2057
2058 =cut
2059
2060 #note: POD here, implementation in FS::cust_svc
2061 sub seconds_since {
2062   my $self = shift;
2063   $self->cust_svc->seconds_since(@_);
2064 }
2065
2066 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2067
2068 Returns the numbers of seconds this account has been online between
2069 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2070 external SQL radacct table, specified via sqlradius export.  Sessions which
2071 started in the specified range but are still open are counted from session
2072 start to the end of the range (unless they are over 1 day old, in which case
2073 they are presumed missing their stop record and not counted).  Also, sessions
2074 which end in the range but started earlier are counted from the start of the
2075 range to session end.  Finally, sessions which start before the range but end
2076 after are counted for the entire range.
2077
2078 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2079 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2080 functions.
2081
2082 =cut
2083
2084 #note: POD here, implementation in FS::cust_svc
2085 sub seconds_since_sqlradacct {
2086   my $self = shift;
2087   $self->cust_svc->seconds_since_sqlradacct(@_);
2088 }
2089
2090 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2091
2092 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2093 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2094 TIMESTAMP_END (exclusive).
2095
2096 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2097 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2098 functions.
2099
2100 =cut
2101
2102 #note: POD here, implementation in FS::cust_svc
2103 sub attribute_since_sqlradacct {
2104   my $self = shift;
2105   $self->cust_svc->attribute_since_sqlradacct(@_);
2106 }
2107
2108 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2109
2110 Returns an array of hash references of this customers login history for the
2111 given time range.  (document this better)
2112
2113 =cut
2114
2115 sub get_session_history {
2116   my $self = shift;
2117   $self->cust_svc->get_session_history(@_);
2118 }
2119
2120 =item last_login_text
2121
2122 Returns text describing the time of last login.
2123
2124 =cut
2125
2126 sub last_login_text {
2127   my $self = shift;
2128   $self->last_login ? ctime($self->last_login) : 'unknown';
2129 }
2130
2131 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2132
2133 =cut
2134
2135 sub get_cdrs {
2136   my($self, $start, $end, %opt ) = @_;
2137
2138   my $did = $self->username; #yup
2139
2140   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2141
2142   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2143
2144   #SELECT $for_update * FROM cdr
2145   #  WHERE calldate >= $start #need a conversion
2146   #    AND calldate <  $end   #ditto
2147   #    AND (    charged_party = "$did"
2148   #          OR charged_party = "$prefix$did" #if length($prefix);
2149   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2150   #               AND
2151   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2152   #             )
2153   #        )
2154   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2155
2156   my $charged_or_src;
2157   if ( length($prefix) ) {
2158     $charged_or_src =
2159       " AND (    charged_party = '$did'
2160               OR charged_party = '$prefix$did'
2161               OR ( ( charged_party IS NULL OR charged_party = '' )
2162                    AND
2163                    ( src = '$did' OR src = '$prefix$did' )
2164                  )
2165             )
2166       ";
2167   } else {
2168     $charged_or_src =
2169       " AND (    charged_party = '$did'
2170               OR ( ( charged_party IS NULL OR charged_party = '' )
2171                    AND
2172                    src = '$did'
2173                  )
2174             )
2175       ";
2176
2177   }
2178
2179   qsearch(
2180     'select'    => "$for_update *",
2181     'table'     => 'cdr',
2182     'hashref'   => {
2183                      #( freesidestatus IS NULL OR freesidestatus = '' )
2184                      'freesidestatus' => '',
2185                    },
2186     'extra_sql' => $charged_or_src,
2187
2188   );
2189
2190 }
2191
2192 =item radius_groups
2193
2194 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2195
2196 =cut
2197
2198 sub radius_groups {
2199   my $self = shift;
2200   if ( $self->usergroup ) {
2201     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2202       unless ref($self->usergroup) eq 'ARRAY';
2203     #when provisioning records, export callback runs in svc_Common.pm before
2204     #radius_usergroup records can be inserted...
2205     @{$self->usergroup};
2206   } else {
2207     map { $_->groupname }
2208       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2209   }
2210 }
2211
2212 =item clone_suspended
2213
2214 Constructor used by FS::part_export::_export_suspend fallback.  Document
2215 better.
2216
2217 =cut
2218
2219 sub clone_suspended {
2220   my $self = shift;
2221   my %hash = $self->hash;
2222   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2223   new FS::svc_acct \%hash;
2224 }
2225
2226 =item clone_kludge_unsuspend
2227
2228 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2229 better.
2230
2231 =cut
2232
2233 sub clone_kludge_unsuspend {
2234   my $self = shift;
2235   my %hash = $self->hash;
2236   $hash{_password} = '';
2237   new FS::svc_acct \%hash;
2238 }
2239
2240 =item check_password
2241
2242 Checks the supplied password against the (possibly encrypted) password in the
2243 database.  Returns true for a successful authentication, false for no match.
2244
2245 Currently supported encryptions are: classic DES crypt() and MD5
2246
2247 =cut
2248
2249 sub check_password {
2250   my($self, $check_password) = @_;
2251
2252   #remove old-style SUSPENDED kludge, they should be allowed to login to
2253   #self-service and pay up
2254   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2255
2256   if ( $self->_password_encoding eq 'ldap' ) {
2257
2258     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2259     return $auth->match($check_password);
2260
2261   } elsif ( $self->_password_encoding eq 'crypt' ) {
2262
2263     my $auth = from_crypt Authen::Passphrase $self->_password;
2264     return $auth->match($check_password);
2265
2266   } elsif ( $self->_password_encoding eq 'plain' ) {
2267
2268     return $check_password eq $password;
2269
2270   } else {
2271
2272     #XXX this could be replaced with Authen::Passphrase stuff
2273
2274     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2275       return 0;
2276     } elsif ( length($password) < 13 ) { #plaintext
2277       $check_password eq $password;
2278     } elsif ( length($password) == 13 ) { #traditional DES crypt
2279       crypt($check_password, $password) eq $password;
2280     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2281       unix_md5_crypt($check_password, $password) eq $password;
2282     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2283       warn "Can't check password: Blowfish encryption not yet supported, ".
2284            "svcnum ".  $self->svcnum. "\n";
2285       0;
2286     } else {
2287       warn "Can't check password: Unrecognized encryption for svcnum ".
2288            $self->svcnum. "\n";
2289       0;
2290     }
2291
2292   }
2293
2294 }
2295
2296 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2297
2298 Returns an encrypted password, either by passing through an encrypted password
2299 in the database or by encrypting a plaintext password from the database.
2300
2301 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2302 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2303 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2304 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2305 encryption type is only used if the password is not already encrypted in the
2306 database.
2307
2308 =cut
2309
2310 sub crypt_password {
2311   my $self = shift;
2312
2313   if ( $self->_password_encoding eq 'ldap' ) {
2314
2315     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2316       my $plain = $2;
2317
2318       #XXX this could be replaced with Authen::Passphrase stuff
2319
2320       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2321       if ( $encryption eq 'crypt' ) {
2322         crypt(
2323           $self->_password,
2324           $saltset[int(rand(64))].$saltset[int(rand(64))]
2325         );
2326       } elsif ( $encryption eq 'md5' ) {
2327         unix_md5_crypt( $self->_password );
2328       } elsif ( $encryption eq 'blowfish' ) {
2329         croak "unknown encryption method $encryption";
2330       } else {
2331         croak "unknown encryption method $encryption";
2332       }
2333
2334     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2335       $1;
2336     }
2337
2338   } elsif ( $self->_password_encoding eq 'crypt' ) {
2339
2340     return $self->_password;
2341
2342   } elsif ( $self->_password_encoding eq 'plain' ) {
2343
2344     #XXX this could be replaced with Authen::Passphrase stuff
2345
2346     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2347     if ( $encryption eq 'crypt' ) {
2348       crypt(
2349         $self->_password,
2350         $saltset[int(rand(64))].$saltset[int(rand(64))]
2351       );
2352     } elsif ( $encryption eq 'md5' ) {
2353       unix_md5_crypt( $self->_password );
2354     } elsif ( $encryption eq 'blowfish' ) {
2355       croak "unknown encryption method $encryption";
2356     } else {
2357       croak "unknown encryption method $encryption";
2358     }
2359
2360   } else {
2361
2362     if ( length($self->_password) == 13
2363          || $self->_password =~ /^\$(1|2a?)\$/
2364          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2365        )
2366     {
2367       $self->_password;
2368     } else {
2369
2370       #XXX this could be replaced with Authen::Passphrase stuff
2371
2372       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2373       if ( $encryption eq 'crypt' ) {
2374         crypt(
2375           $self->_password,
2376           $saltset[int(rand(64))].$saltset[int(rand(64))]
2377         );
2378       } elsif ( $encryption eq 'md5' ) {
2379         unix_md5_crypt( $self->_password );
2380       } elsif ( $encryption eq 'blowfish' ) {
2381         croak "unknown encryption method $encryption";
2382       } else {
2383         croak "unknown encryption method $encryption";
2384       }
2385
2386     }
2387
2388   }
2389
2390 }
2391
2392 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2393
2394 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2395 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2396 "{MD5}5426824942db4253f87a1009fd5d2d4".
2397
2398 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2399 to work the same as the B</crypt_password> method.
2400
2401 =cut
2402
2403 sub ldap_password {
2404   my $self = shift;
2405   #eventually should check a "password-encoding" field
2406
2407   if ( $self->_password_encoding eq 'ldap' ) {
2408
2409     return $self->_password;
2410
2411   } elsif ( $self->_password_encoding eq 'crypt' ) {
2412
2413     if ( length($self->_password) == 13 ) { #crypt
2414       return '{CRYPT}'. $self->_password;
2415     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2416       return '{MD5}'. $1;
2417     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2418     #  die "Blowfish encryption not supported in this context, svcnum ".
2419     #      $self->svcnum. "\n";
2420     } else {
2421       warn "encryption method not (yet?) supported in LDAP context";
2422       return '{CRYPT}*'; #unsupported, should not auth
2423     }
2424
2425   } elsif ( $self->_password_encoding eq 'plain' ) {
2426
2427     return '{PLAIN}'. $self->_password;
2428
2429     #return '{CLEARTEXT}'. $self->_password; #?
2430
2431   } else {
2432
2433     if ( length($self->_password) == 13 ) { #crypt
2434       return '{CRYPT}'. $self->_password;
2435     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2436       return '{MD5}'. $1;
2437     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2438       warn "Blowfish encryption not supported in this context, svcnum ".
2439           $self->svcnum. "\n";
2440       return '{CRYPT}*';
2441
2442     #are these two necessary anymore?
2443     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2444       return '{SSHA}'. $1;
2445     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2446       return '{NS-MTA-MD5}'. $1;
2447
2448     } else { #plaintext
2449       return '{PLAIN}'. $self->_password;
2450
2451       #return '{CLEARTEXT}'. $self->_password; #?
2452
2453       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2454       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2455       #if ( $encryption eq 'crypt' ) {
2456       #  return '{CRYPT}'. crypt(
2457       #    $self->_password,
2458       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2459       #  );
2460       #} elsif ( $encryption eq 'md5' ) {
2461       #  unix_md5_crypt( $self->_password );
2462       #} elsif ( $encryption eq 'blowfish' ) {
2463       #  croak "unknown encryption method $encryption";
2464       #} else {
2465       #  croak "unknown encryption method $encryption";
2466       #}
2467     }
2468
2469   }
2470
2471 }
2472
2473 =item domain_slash_username
2474
2475 Returns $domain/$username/
2476
2477 =cut
2478
2479 sub domain_slash_username {
2480   my $self = shift;
2481   $self->domain. '/'. $self->username. '/';
2482 }
2483
2484 =item virtual_maildir
2485
2486 Returns $domain/maildirs/$username/
2487
2488 =cut
2489
2490 sub virtual_maildir {
2491   my $self = shift;
2492   $self->domain. '/maildirs/'. $self->username. '/';
2493 }
2494
2495 =back
2496
2497 =head1 SUBROUTINES
2498
2499 =over 4
2500
2501 =item send_email
2502
2503 This is the FS::svc_acct job-queue-able version.  It still uses
2504 FS::Misc::send_email under-the-hood.
2505
2506 =cut
2507
2508 sub send_email {
2509   my %opt = @_;
2510
2511   eval "use FS::Misc qw(send_email)";
2512   die $@ if $@;
2513
2514   $opt{mimetype} ||= 'text/plain';
2515   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2516
2517   my $error = send_email(
2518     'from'         => $opt{from},
2519     'to'           => $opt{to},
2520     'subject'      => $opt{subject},
2521     'content-type' => $opt{mimetype},
2522     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2523   );
2524   die $error if $error;
2525 }
2526
2527 =item check_and_rebuild_fuzzyfiles
2528
2529 =cut
2530
2531 sub check_and_rebuild_fuzzyfiles {
2532   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2533   -e "$dir/svc_acct.username"
2534     or &rebuild_fuzzyfiles;
2535 }
2536
2537 =item rebuild_fuzzyfiles
2538
2539 =cut
2540
2541 sub rebuild_fuzzyfiles {
2542
2543   use Fcntl qw(:flock);
2544
2545   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2546
2547   #username
2548
2549   open(USERNAMELOCK,">>$dir/svc_acct.username")
2550     or die "can't open $dir/svc_acct.username: $!";
2551   flock(USERNAMELOCK,LOCK_EX)
2552     or die "can't lock $dir/svc_acct.username: $!";
2553
2554   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2555
2556   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2557     or die "can't open $dir/svc_acct.username.tmp: $!";
2558   print USERNAMECACHE join("\n", @all_username), "\n";
2559   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2560
2561   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2562   close USERNAMELOCK;
2563
2564 }
2565
2566 =item all_username
2567
2568 =cut
2569
2570 sub all_username {
2571   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2572   open(USERNAMECACHE,"<$dir/svc_acct.username")
2573     or die "can't open $dir/svc_acct.username: $!";
2574   my @array = map { chomp; $_; } <USERNAMECACHE>;
2575   close USERNAMECACHE;
2576   \@array;
2577 }
2578
2579 =item append_fuzzyfiles USERNAME
2580
2581 =cut
2582
2583 sub append_fuzzyfiles {
2584   my $username = shift;
2585
2586   &check_and_rebuild_fuzzyfiles;
2587
2588   use Fcntl qw(:flock);
2589
2590   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2591
2592   open(USERNAME,">>$dir/svc_acct.username")
2593     or die "can't open $dir/svc_acct.username: $!";
2594   flock(USERNAME,LOCK_EX)
2595     or die "can't lock $dir/svc_acct.username: $!";
2596
2597   print USERNAME "$username\n";
2598
2599   flock(USERNAME,LOCK_UN)
2600     or die "can't unlock $dir/svc_acct.username: $!";
2601   close USERNAME;
2602
2603   1;
2604 }
2605
2606
2607
2608 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2609
2610 =cut
2611
2612 sub radius_usergroup_selector {
2613   my $sel_groups = shift;
2614   my %sel_groups = map { $_=>1 } @$sel_groups;
2615
2616   my $selectname = shift || 'radius_usergroup';
2617
2618   my $dbh = dbh;
2619   my $sth = $dbh->prepare(
2620     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2621   ) or die $dbh->errstr;
2622   $sth->execute() or die $sth->errstr;
2623   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2624
2625   my $html = <<END;
2626     <SCRIPT>
2627     function ${selectname}_doadd(object) {
2628       var myvalue = object.${selectname}_add.value;
2629       var optionName = new Option(myvalue,myvalue,false,true);
2630       var length = object.$selectname.length;
2631       object.$selectname.options[length] = optionName;
2632       object.${selectname}_add.value = "";
2633     }
2634     </SCRIPT>
2635     <SELECT MULTIPLE NAME="$selectname">
2636 END
2637
2638   foreach my $group ( @all_groups ) {
2639     $html .= qq(<OPTION VALUE="$group");
2640     if ( $sel_groups{$group} ) {
2641       $html .= ' SELECTED';
2642       $sel_groups{$group} = 0;
2643     }
2644     $html .= ">$group</OPTION>\n";
2645   }
2646   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2647     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2648   };
2649   $html .= '</SELECT>';
2650
2651   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2652            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2653
2654   $html;
2655 }
2656
2657 =item reached_threshold
2658
2659 Performs some activities when svc_acct thresholds (such as number of seconds
2660 remaining) are reached.
2661
2662 =cut
2663
2664 sub reached_threshold {
2665   my %opt = @_;
2666
2667   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2668   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2669
2670   if ( $opt{'op'} eq '+' ){
2671     $svc_acct->setfield( $opt{'column'}.'_threshold',
2672                          int($svc_acct->getfield($opt{'column'})
2673                              * ( $conf->exists('svc_acct-usage_threshold')
2674                                  ? $conf->config('svc_acct-usage_threshold')/100
2675                                  : 0.80
2676                                )
2677                          )
2678                        );
2679     my $error = $svc_acct->replace;
2680     die $error if $error;
2681   }elsif ( $opt{'op'} eq '-' ){
2682
2683     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2684     return '' if ($threshold eq '' );
2685
2686     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2687     my $error = $svc_acct->replace;
2688     die $error if $error; # email next time, i guess
2689
2690     if ( $warning_template ) {
2691       eval "use FS::Misc qw(send_email)";
2692       die $@ if $@;
2693
2694       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2695       my $cust_main = $cust_pkg->cust_main;
2696
2697       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2698                                $cust_main->invoicing_list,
2699                                ($opt{'to'} ? $opt{'to'} : ())
2700                    );
2701
2702       my $mimetype = $warning_mimetype;
2703       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2704
2705       my $body       =  $warning_template->fill_in( HASH => {
2706                         'custnum'   => $cust_main->custnum,
2707                         'username'  => $svc_acct->username,
2708                         'password'  => $svc_acct->_password,
2709                         'first'     => $cust_main->first,
2710                         'last'      => $cust_main->getfield('last'),
2711                         'pkg'       => $cust_pkg->part_pkg->pkg,
2712                         'column'    => $opt{'column'},
2713                         'amount'    => $opt{'column'} =~/bytes/
2714                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2715                                        : $svc_acct->getfield($opt{'column'}),
2716                         'threshold' => $opt{'column'} =~/bytes/
2717                                        ? FS::UI::bytecount::display_bytecount($threshold)
2718                                        : $threshold,
2719                       } );
2720
2721
2722       my $error = send_email(
2723         'from'         => $warning_from,
2724         'to'           => $to,
2725         'subject'      => $warning_subject,
2726         'content-type' => $mimetype,
2727         'body'         => [ map "$_\n", split("\n", $body) ],
2728       );
2729       die $error if $error;
2730     }
2731   }else{
2732     die "unknown op: " . $opt{'op'};
2733   }
2734 }
2735
2736 =back
2737
2738 =head1 BUGS
2739
2740 The $recref stuff in sub check should be cleaned up.
2741
2742 The suspend, unsuspend and cancel methods update the database, but not the
2743 current object.  This is probably a bug as it's unexpected and
2744 counterintuitive.
2745
2746 radius_usergroup_selector?  putting web ui components in here?  they should
2747 probably live somewhere else...
2748
2749 insertion of RADIUS group stuff in insert could be done with child_objects now
2750 (would probably clean up export of them too)
2751
2752 _op_usage and set_usage bypass the history... maybe they shouldn't
2753
2754 =head1 SEE ALSO
2755
2756 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2757 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2758 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2759 L<freeside-queued>), L<FS::svc_acct_pop>,
2760 schema.html from the base documentation.
2761
2762 =cut
2763
2764 =item domain_select_hash %OPTIONS
2765
2766 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
2767 may at present purchase.
2768
2769 Currently available options are: I<pkgnum> I<svcpart>
2770
2771 =cut
2772
2773 sub domain_select_hash {
2774   my ($self, %options) = @_;
2775   my %domains = ();
2776   my $part_svc;
2777   my $cust_pkg;
2778
2779   if (ref($self)) {
2780     $part_svc = $self->part_svc;
2781     $cust_pkg = $self->cust_svc->cust_pkg
2782       if $self->cust_svc;
2783   }
2784
2785   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2786     if $options{'svcpart'};
2787
2788   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2789     if $options{'pkgnum'};
2790
2791   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2792                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2793     %domains = map { $_->svcnum => $_->domain }
2794                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2795                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2796   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2797     %domains = map { $_->svcnum => $_->domain }
2798                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2799                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2800                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2801   }else{
2802     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2803   }
2804
2805   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2806     my $svc_domain = qsearchs('svc_domain',
2807       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2808     if ( $svc_domain ) {
2809       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
2810     }else{
2811       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2812            $part_svc->part_svc_column('domsvc')->columnvalue;
2813
2814     }
2815   }
2816
2817   (%domains);
2818 }
2819
2820 1;
2821