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