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