FS/FS/svc_acct.pm

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