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
1844     my $error = $self->_op_overlimit($action);
1845     if ( $error ) {
1846       $dbh->rollback if $oldAutoCommit;
1847       return $error;
1848     }
1849
1850   }
1851
1852   if ( $conf->exists("svc_acct-usage_$action")
1853        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1854     #my $error = $self->$action();
1855     my $error = $self->cust_svc->cust_pkg->$action();
1856     # $error ||= $self->overlimit($action);
1857     if ( $error ) {
1858       $dbh->rollback if $oldAutoCommit;
1859       return "Error ${action}ing: $error";
1860     }
1861   }
1862
1863   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1864     my $wqueue = new FS::queue {
1865       'svcnum' => $self->svcnum,
1866       'job'    => 'FS::svc_acct::reached_threshold',
1867     };
1868
1869     my $to = '';
1870     if ($op eq '-'){
1871       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1872     }
1873
1874     # x_threshold race
1875     my $error = $wqueue->insert(
1876       'svcnum' => $self->svcnum,
1877       'op'     => $op,
1878       'column' => $column,
1879       'to'     => $to,
1880     );
1881     if ( $error ) {
1882       $dbh->rollback if $oldAutoCommit;
1883       return "Error queuing threshold activity: $error";
1884     }
1885   }
1886
1887   warn "$me update successful; committing\n"
1888     if $DEBUG;
1889   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1890   '';
1891
1892 }
1893
1894 sub _op_overlimit {
1895   my( $self, $action ) = @_;
1896
1897   local $SIG{HUP} = 'IGNORE';
1898   local $SIG{INT} = 'IGNORE';
1899   local $SIG{QUIT} = 'IGNORE';
1900   local $SIG{TERM} = 'IGNORE';
1901   local $SIG{TSTP} = 'IGNORE';
1902   local $SIG{PIPE} = 'IGNORE';
1903
1904   my $oldAutoCommit = $FS::UID::AutoCommit;
1905   local $FS::UID::AutoCommit = 0;
1906   my $dbh = dbh;
1907
1908   my $cust_pkg = $self->cust_svc->cust_pkg;
1909
1910   my $conf_overlimit =
1911     $cust_pkg
1912       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
1913       : $conf->config('overlimit_groups');
1914
1915   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1916
1917     my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
1918     next unless $groups;
1919
1920     my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
1921
1922     my $other = new FS::svc_acct $self->hashref;
1923     $other->usergroup( $gref );
1924
1925     my($new,$old);
1926     if ($action eq 'suspend') {
1927       $new = $other;
1928       $old = $self;
1929     } else { # $action eq 'unsuspend'
1930       $new = $self;
1931       $old = $other;
1932     }
1933
1934     my $error = $part_export->export_replace($new, $old)
1935                 || $self->overlimit($action);
1936
1937     if ( $error ) {
1938       $dbh->rollback if $oldAutoCommit;
1939       return "Error replacing radius groups: $error";
1940     }
1941
1942   }
1943
1944   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1945   '';
1946
1947 }
1948
1949 sub set_usage {
1950   my( $self, $valueref, %options ) = @_;
1951
1952   warn "$me set_usage called for svcnum ". $self->svcnum.
1953        ' ('. $self->email. "): ".
1954        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1955     if $DEBUG;
1956
1957   local $SIG{HUP} = 'IGNORE';
1958   local $SIG{INT} = 'IGNORE';
1959   local $SIG{QUIT} = 'IGNORE';
1960   local $SIG{TERM} = 'IGNORE';
1961   local $SIG{TSTP} = 'IGNORE';
1962   local $SIG{PIPE} = 'IGNORE';
1963
1964   local $FS::svc_Common::noexport_hack = 1;
1965   my $oldAutoCommit = $FS::UID::AutoCommit;
1966   local $FS::UID::AutoCommit = 0;
1967   my $dbh = dbh;
1968
1969   my $reset = 0;
1970   my %handyhash = ();
1971   if ( $options{null} ) {
1972     %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1973                    qw( seconds upbytes downbytes totalbytes )
1974                  );
1975   }
1976   foreach my $field (keys %$valueref){
1977     $reset = 1 if $valueref->{$field};
1978     $self->setfield($field, $valueref->{$field});
1979     $self->setfield( $field.'_threshold',
1980                      int($self->getfield($field)
1981                          * ( $conf->exists('svc_acct-usage_threshold')
1982                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1983                              : 0.20
1984                            )
1985                        )
1986                      );
1987     $handyhash{$field} = $self->getfield($field);
1988     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1989   }
1990   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1991   #die $error if $error;         #services not explicity changed via the UI
1992
1993   my $sql = "UPDATE svc_acct SET " .
1994     join (',', map { "$_ =  $handyhash{$_}" } (keys %handyhash) ).
1995     " WHERE svcnum = ". $self->svcnum;
1996
1997   warn "$me $sql\n"
1998     if $DEBUG;
1999
2000   if (scalar(keys %handyhash)) {
2001     my $sth = $dbh->prepare( $sql )
2002       or die "Error preparing $sql: ". $dbh->errstr;
2003     my $rv = $sth->execute();
2004     die "Error executing $sql: ". $sth->errstr
2005       unless defined($rv);
2006     die "Can't update usage for svcnum ". $self->svcnum
2007       if $rv == 0;
2008   }
2009
2010   #$self->snapshot; #not necessary, we retain the old values
2011   #create an object with the updated usage values
2012   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2013   #call exports
2014   my $error = $new->replace($self);
2015   if ( $error ) {
2016     $dbh->rollback if $oldAutoCommit;
2017     return "Error replacing: $error";
2018   }
2019
2020   if ( $reset ) {
2021
2022     my $error = '';
2023
2024     $error = $self->_op_overlimit('unsuspend')
2025       if $self->overlimit;;
2026
2027     $error ||= $self->cust_svc->cust_pkg->unsuspend
2028       if $conf->exists("svc_acct-usage_unsuspend");
2029
2030     if ( $error ) {
2031       $dbh->rollback if $oldAutoCommit;
2032       return "Error unsuspending: $error";
2033     }
2034
2035   }
2036
2037   warn "$me update successful; committing\n"
2038     if $DEBUG;
2039   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2040   '';
2041
2042 }
2043
2044
2045 =item recharge HASHREF
2046
2047   Increments usage columns by the amount specified in HASHREF as
2048   column=>amount pairs.
2049
2050 =cut
2051
2052 sub recharge {
2053   my ($self, $vhash) = @_;
2054
2055   if ( $DEBUG ) {
2056     warn "[$me] recharge called on $self: ". Dumper($self).
2057          "\nwith vhash: ". Dumper($vhash);
2058   }
2059
2060   my $oldAutoCommit = $FS::UID::AutoCommit;
2061   local $FS::UID::AutoCommit = 0;
2062   my $dbh = dbh;
2063   my $error = '';
2064
2065   foreach my $column (keys %$vhash){
2066     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2067   }
2068
2069   if ( $error ) {
2070     $dbh->rollback if $oldAutoCommit;
2071   }else{
2072     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2073   }
2074   return $error;
2075 }
2076
2077 =item is_rechargeable
2078
2079 Returns true if this svc_account can be "recharged" and false otherwise.
2080
2081 =cut
2082
2083 sub is_rechargable {
2084   my $self = shift;
2085   $self->seconds ne ''
2086     || $self->upbytes ne ''
2087     || $self->downbytes ne ''
2088     || $self->totalbytes ne '';
2089 }
2090
2091 =item seconds_since TIMESTAMP
2092
2093 Returns the number of seconds this account has been online since TIMESTAMP,
2094 according to the session monitor (see L<FS::Session>).
2095
2096 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2097 L<Time::Local> and L<Date::Parse> for conversion functions.
2098
2099 =cut
2100
2101 #note: POD here, implementation in FS::cust_svc
2102 sub seconds_since {
2103   my $self = shift;
2104   $self->cust_svc->seconds_since(@_);
2105 }
2106
2107 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2108
2109 Returns the numbers of seconds this account has been online between
2110 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2111 external SQL radacct table, specified via sqlradius export.  Sessions which
2112 started in the specified range but are still open are counted from session
2113 start to the end of the range (unless they are over 1 day old, in which case
2114 they are presumed missing their stop record and not counted).  Also, sessions
2115 which end in the range but started earlier are counted from the start of the
2116 range to session end.  Finally, sessions which start before the range but end
2117 after are counted for the entire range.
2118
2119 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2120 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2121 functions.
2122
2123 =cut
2124
2125 #note: POD here, implementation in FS::cust_svc
2126 sub seconds_since_sqlradacct {
2127   my $self = shift;
2128   $self->cust_svc->seconds_since_sqlradacct(@_);
2129 }
2130
2131 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2132
2133 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2134 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2135 TIMESTAMP_END (exclusive).
2136
2137 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2138 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2139 functions.
2140
2141 =cut
2142
2143 #note: POD here, implementation in FS::cust_svc
2144 sub attribute_since_sqlradacct {
2145   my $self = shift;
2146   $self->cust_svc->attribute_since_sqlradacct(@_);
2147 }
2148
2149 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2150
2151 Returns an array of hash references of this customers login history for the
2152 given time range.  (document this better)
2153
2154 =cut
2155
2156 sub get_session_history {
2157   my $self = shift;
2158   $self->cust_svc->get_session_history(@_);
2159 }
2160
2161 =item last_login_text
2162
2163 Returns text describing the time of last login.
2164
2165 =cut
2166
2167 sub last_login_text {
2168   my $self = shift;
2169   $self->last_login ? ctime($self->last_login) : 'unknown';
2170 }
2171
2172 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2173
2174 =cut
2175
2176 sub get_cdrs {
2177   my($self, $start, $end, %opt ) = @_;
2178
2179   my $did = $self->username; #yup
2180
2181   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2182
2183   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2184
2185   #SELECT $for_update * FROM cdr
2186   #  WHERE calldate >= $start #need a conversion
2187   #    AND calldate <  $end   #ditto
2188   #    AND (    charged_party = "$did"
2189   #          OR charged_party = "$prefix$did" #if length($prefix);
2190   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2191   #               AND
2192   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2193   #             )
2194   #        )
2195   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2196
2197   my $charged_or_src;
2198   if ( length($prefix) ) {
2199     $charged_or_src =
2200       " AND (    charged_party = '$did'
2201               OR charged_party = '$prefix$did'
2202               OR ( ( charged_party IS NULL OR charged_party = '' )
2203                    AND
2204                    ( src = '$did' OR src = '$prefix$did' )
2205                  )
2206             )
2207       ";
2208   } else {
2209     $charged_or_src =
2210       " AND (    charged_party = '$did'
2211               OR ( ( charged_party IS NULL OR charged_party = '' )
2212                    AND
2213                    src = '$did'
2214                  )
2215             )
2216       ";
2217
2218   }
2219
2220   qsearch(
2221     'select'    => "$for_update *",
2222     'table'     => 'cdr',
2223     'hashref'   => {
2224                      #( freesidestatus IS NULL OR freesidestatus = '' )
2225                      'freesidestatus' => '',
2226                    },
2227     'extra_sql' => $charged_or_src,
2228
2229   );
2230
2231 }
2232
2233 =item radius_groups
2234
2235 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2236
2237 =cut
2238
2239 sub radius_groups {
2240   my $self = shift;
2241   if ( $self->usergroup ) {
2242     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2243       unless ref($self->usergroup) eq 'ARRAY';
2244     #when provisioning records, export callback runs in svc_Common.pm before
2245     #radius_usergroup records can be inserted...
2246     @{$self->usergroup};
2247   } else {
2248     map { $_->groupname }
2249       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2250   }
2251 }
2252
2253 =item clone_suspended
2254
2255 Constructor used by FS::part_export::_export_suspend fallback.  Document
2256 better.
2257
2258 =cut
2259
2260 sub clone_suspended {
2261   my $self = shift;
2262   my %hash = $self->hash;
2263   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2264   new FS::svc_acct \%hash;
2265 }
2266
2267 =item clone_kludge_unsuspend
2268
2269 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2270 better.
2271
2272 =cut
2273
2274 sub clone_kludge_unsuspend {
2275   my $self = shift;
2276   my %hash = $self->hash;
2277   $hash{_password} = '';
2278   new FS::svc_acct \%hash;
2279 }
2280
2281 =item check_password
2282
2283 Checks the supplied password against the (possibly encrypted) password in the
2284 database.  Returns true for a successful authentication, false for no match.
2285
2286 Currently supported encryptions are: classic DES crypt() and MD5
2287
2288 =cut
2289
2290 sub check_password {
2291   my($self, $check_password) = @_;
2292
2293   #remove old-style SUSPENDED kludge, they should be allowed to login to
2294   #self-service and pay up
2295   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2296
2297   if ( $self->_password_encoding eq 'ldap' ) {
2298
2299     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2300     return $auth->match($check_password);
2301
2302   } elsif ( $self->_password_encoding eq 'crypt' ) {
2303
2304     my $auth = from_crypt Authen::Passphrase $self->_password;
2305     return $auth->match($check_password);
2306
2307   } elsif ( $self->_password_encoding eq 'plain' ) {
2308
2309     return $check_password eq $password;
2310
2311   } else {
2312
2313     #XXX this could be replaced with Authen::Passphrase stuff
2314
2315     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2316       return 0;
2317     } elsif ( length($password) < 13 ) { #plaintext
2318       $check_password eq $password;
2319     } elsif ( length($password) == 13 ) { #traditional DES crypt
2320       crypt($check_password, $password) eq $password;
2321     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2322       unix_md5_crypt($check_password, $password) eq $password;
2323     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2324       warn "Can't check password: Blowfish encryption not yet supported, ".
2325            "svcnum ".  $self->svcnum. "\n";
2326       0;
2327     } else {
2328       warn "Can't check password: Unrecognized encryption for svcnum ".
2329            $self->svcnum. "\n";
2330       0;
2331     }
2332
2333   }
2334
2335 }
2336
2337 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2338
2339 Returns an encrypted password, either by passing through an encrypted password
2340 in the database or by encrypting a plaintext password from the database.
2341
2342 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2343 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2344 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2345 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2346 encryption type is only used if the password is not already encrypted in the
2347 database.
2348
2349 =cut
2350
2351 sub crypt_password {
2352   my $self = shift;
2353
2354   if ( $self->_password_encoding eq 'ldap' ) {
2355
2356     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2357       my $plain = $2;
2358
2359       #XXX this could be replaced with Authen::Passphrase stuff
2360
2361       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2362       if ( $encryption eq 'crypt' ) {
2363         crypt(
2364           $self->_password,
2365           $saltset[int(rand(64))].$saltset[int(rand(64))]
2366         );
2367       } elsif ( $encryption eq 'md5' ) {
2368         unix_md5_crypt( $self->_password );
2369       } elsif ( $encryption eq 'blowfish' ) {
2370         croak "unknown encryption method $encryption";
2371       } else {
2372         croak "unknown encryption method $encryption";
2373       }
2374
2375     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2376       $1;
2377     }
2378
2379   } elsif ( $self->_password_encoding eq 'crypt' ) {
2380
2381     return $self->_password;
2382
2383   } elsif ( $self->_password_encoding eq 'plain' ) {
2384
2385     #XXX this could be replaced with Authen::Passphrase stuff
2386
2387     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2388     if ( $encryption eq 'crypt' ) {
2389       crypt(
2390         $self->_password,
2391         $saltset[int(rand(64))].$saltset[int(rand(64))]
2392       );
2393     } elsif ( $encryption eq 'md5' ) {
2394       unix_md5_crypt( $self->_password );
2395     } elsif ( $encryption eq 'blowfish' ) {
2396       croak "unknown encryption method $encryption";
2397     } else {
2398       croak "unknown encryption method $encryption";
2399     }
2400
2401   } else {
2402
2403     if ( length($self->_password) == 13
2404          || $self->_password =~ /^\$(1|2a?)\$/
2405          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2406        )
2407     {
2408       $self->_password;
2409     } else {
2410
2411       #XXX this could be replaced with Authen::Passphrase stuff
2412
2413       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2414       if ( $encryption eq 'crypt' ) {
2415         crypt(
2416           $self->_password,
2417           $saltset[int(rand(64))].$saltset[int(rand(64))]
2418         );
2419       } elsif ( $encryption eq 'md5' ) {
2420         unix_md5_crypt( $self->_password );
2421       } elsif ( $encryption eq 'blowfish' ) {
2422         croak "unknown encryption method $encryption";
2423       } else {
2424         croak "unknown encryption method $encryption";
2425       }
2426
2427     }
2428
2429   }
2430
2431 }
2432
2433 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2434
2435 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2436 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2437 "{MD5}5426824942db4253f87a1009fd5d2d4".
2438
2439 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2440 to work the same as the B</crypt_password> method.
2441
2442 =cut
2443
2444 sub ldap_password {
2445   my $self = shift;
2446   #eventually should check a "password-encoding" field
2447
2448   if ( $self->_password_encoding eq 'ldap' ) {
2449
2450     return $self->_password;
2451
2452   } elsif ( $self->_password_encoding eq 'crypt' ) {
2453
2454     if ( length($self->_password) == 13 ) { #crypt
2455       return '{CRYPT}'. $self->_password;
2456     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2457       return '{MD5}'. $1;
2458     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2459     #  die "Blowfish encryption not supported in this context, svcnum ".
2460     #      $self->svcnum. "\n";
2461     } else {
2462       warn "encryption method not (yet?) supported in LDAP context";
2463       return '{CRYPT}*'; #unsupported, should not auth
2464     }
2465
2466   } elsif ( $self->_password_encoding eq 'plain' ) {
2467
2468     return '{PLAIN}'. $self->_password;
2469
2470     #return '{CLEARTEXT}'. $self->_password; #?
2471
2472   } else {
2473
2474     if ( length($self->_password) == 13 ) { #crypt
2475       return '{CRYPT}'. $self->_password;
2476     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2477       return '{MD5}'. $1;
2478     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2479       warn "Blowfish encryption not supported in this context, svcnum ".
2480           $self->svcnum. "\n";
2481       return '{CRYPT}*';
2482
2483     #are these two necessary anymore?
2484     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2485       return '{SSHA}'. $1;
2486     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2487       return '{NS-MTA-MD5}'. $1;
2488
2489     } else { #plaintext
2490       return '{PLAIN}'. $self->_password;
2491
2492       #return '{CLEARTEXT}'. $self->_password; #?
2493
2494       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2495       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2496       #if ( $encryption eq 'crypt' ) {
2497       #  return '{CRYPT}'. crypt(
2498       #    $self->_password,
2499       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2500       #  );
2501       #} elsif ( $encryption eq 'md5' ) {
2502       #  unix_md5_crypt( $self->_password );
2503       #} elsif ( $encryption eq 'blowfish' ) {
2504       #  croak "unknown encryption method $encryption";
2505       #} else {
2506       #  croak "unknown encryption method $encryption";
2507       #}
2508     }
2509
2510   }
2511
2512 }
2513
2514 =item domain_slash_username
2515
2516 Returns $domain/$username/
2517
2518 =cut
2519
2520 sub domain_slash_username {
2521   my $self = shift;
2522   $self->domain. '/'. $self->username. '/';
2523 }
2524
2525 =item virtual_maildir
2526
2527 Returns $domain/maildirs/$username/
2528
2529 =cut
2530
2531 sub virtual_maildir {
2532   my $self = shift;
2533   $self->domain. '/maildirs/'. $self->username. '/';
2534 }
2535
2536 =back
2537
2538 =head1 CLASS METHODS
2539
2540 =over 4
2541
2542 =item search HASHREF
2543
2544 Class method which returns a qsearch hash expression to search for parameters
2545 specified in HASHREF.  Valid parameters are
2546
2547 =over 4
2548
2549 =item domain
2550
2551 =item domsvc
2552
2553 =item unlinked
2554
2555 =item agentnum
2556
2557 =item pkgpart
2558
2559 Arrayref of pkgparts
2560
2561 =item pkgpart
2562
2563 =item where
2564
2565 Arrayref of additional WHERE clauses, will be ANDed together.
2566
2567 =item order_by
2568
2569 =item cust_fields
2570
2571 =back
2572
2573 =cut
2574
2575 sub search {
2576   my ($class, $params) = @_;
2577
2578   my @where = ();
2579
2580   # domain
2581   if ( $params->{'domain'} ) {
2582     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2583     #preserve previous behavior & bubble up an error if $svc_domain not found?
2584     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2585   }
2586
2587   # domsvc
2588   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2589     push @where, "domsvc = $1";
2590   }
2591
2592   #unlinked
2593   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2594
2595   #agentnum
2596   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2597     push @where, "agentnum = $1";
2598   }
2599
2600   #custnum
2601   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2602     push @where, "custnum = $1";
2603   }
2604
2605   #pkgpart
2606   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2607     #XXX untaint or sql quote
2608     push @where,
2609       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2610   }
2611
2612   # popnum
2613   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2614     push @where, "popnum = $1";
2615   }
2616
2617   # svcpart
2618   if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2619     push @where, "svcpart = $1";
2620   }
2621
2622
2623   # here is the agent virtualization
2624   #if ($params->{CurrentUser}) {
2625   #  my $access_user =
2626   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2627   #
2628   #  if ($access_user) {
2629   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2630   #  }else{
2631   #    push @where, "1=0";
2632   #  }
2633   #} else {
2634     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2635                    'table'      => 'cust_main',
2636                    'null_right' => 'View/link unlinked services',
2637                  );
2638   #}
2639
2640   push @where, @{ $params->{'where'} } if $params->{'where'};
2641
2642   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2643
2644   my $addl_from = ' LEFT JOIN cust_svc  USING ( svcnum  ) '.
2645                   ' LEFT JOIN part_svc  USING ( svcpart ) '.
2646                   ' LEFT JOIN cust_pkg  USING ( pkgnum  ) '.
2647                   ' LEFT JOIN cust_main USING ( custnum ) ';
2648
2649   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2650   #if ( keys %svc_acct ) {
2651   #  $count_query .= ' WHERE '.
2652   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2653   #                                      keys %svc_acct
2654   #                        );
2655   #}
2656
2657   my $sql_query = {
2658     'table'       => 'svc_acct',
2659     'hashref'     => {}, # \%svc_acct,
2660     'select'      => join(', ',
2661                        'svc_acct.*',
2662                        'part_svc.svc',
2663                        'cust_main.custnum',
2664                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2665                      ),
2666     'addl_from'   => $addl_from,
2667     'extra_sql'   => $extra_sql,
2668     'order_by'    => $params->{'order_by'},
2669     'count_query' => $count_query,
2670   };
2671
2672 }
2673
2674 =back
2675
2676 =head1 SUBROUTINES
2677
2678 =over 4
2679
2680 =item send_email
2681
2682 This is the FS::svc_acct job-queue-able version.  It still uses
2683 FS::Misc::send_email under-the-hood.
2684
2685 =cut
2686
2687 sub send_email {
2688   my %opt = @_;
2689
2690   eval "use FS::Misc qw(send_email)";
2691   die $@ if $@;
2692
2693   $opt{mimetype} ||= 'text/plain';
2694   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2695
2696   my $error = send_email(
2697     'from'         => $opt{from},
2698     'to'           => $opt{to},
2699     'subject'      => $opt{subject},
2700     'content-type' => $opt{mimetype},
2701     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2702   );
2703   die $error if $error;
2704 }
2705
2706 =item check_and_rebuild_fuzzyfiles
2707
2708 =cut
2709
2710 sub check_and_rebuild_fuzzyfiles {
2711   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2712   -e "$dir/svc_acct.username"
2713     or &rebuild_fuzzyfiles;
2714 }
2715
2716 =item rebuild_fuzzyfiles
2717
2718 =cut
2719
2720 sub rebuild_fuzzyfiles {
2721
2722   use Fcntl qw(:flock);
2723
2724   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2725
2726   #username
2727
2728   open(USERNAMELOCK,">>$dir/svc_acct.username")
2729     or die "can't open $dir/svc_acct.username: $!";
2730   flock(USERNAMELOCK,LOCK_EX)
2731     or die "can't lock $dir/svc_acct.username: $!";
2732
2733   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2734
2735   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2736     or die "can't open $dir/svc_acct.username.tmp: $!";
2737   print USERNAMECACHE join("\n", @all_username), "\n";
2738   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2739
2740   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2741   close USERNAMELOCK;
2742
2743 }
2744
2745 =item all_username
2746
2747 =cut
2748
2749 sub all_username {
2750   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2751   open(USERNAMECACHE,"<$dir/svc_acct.username")
2752     or die "can't open $dir/svc_acct.username: $!";
2753   my @array = map { chomp; $_; } <USERNAMECACHE>;
2754   close USERNAMECACHE;
2755   \@array;
2756 }
2757
2758 =item append_fuzzyfiles USERNAME
2759
2760 =cut
2761
2762 sub append_fuzzyfiles {
2763   my $username = shift;
2764
2765   &check_and_rebuild_fuzzyfiles;
2766
2767   use Fcntl qw(:flock);
2768
2769   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2770
2771   open(USERNAME,">>$dir/svc_acct.username")
2772     or die "can't open $dir/svc_acct.username: $!";
2773   flock(USERNAME,LOCK_EX)
2774     or die "can't lock $dir/svc_acct.username: $!";
2775
2776   print USERNAME "$username\n";
2777
2778   flock(USERNAME,LOCK_UN)
2779     or die "can't unlock $dir/svc_acct.username: $!";
2780   close USERNAME;
2781
2782   1;
2783 }
2784
2785
2786
2787 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2788
2789 =cut
2790
2791 sub radius_usergroup_selector {
2792   my $sel_groups = shift;
2793   my %sel_groups = map { $_=>1 } @$sel_groups;
2794
2795   my $selectname = shift || 'radius_usergroup';
2796
2797   my $dbh = dbh;
2798   my $sth = $dbh->prepare(
2799     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2800   ) or die $dbh->errstr;
2801   $sth->execute() or die $sth->errstr;
2802   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2803
2804   my $html = <<END;
2805     <SCRIPT>
2806     function ${selectname}_doadd(object) {
2807       var myvalue = object.${selectname}_add.value;
2808       var optionName = new Option(myvalue,myvalue,false,true);
2809       var length = object.$selectname.length;
2810       object.$selectname.options[length] = optionName;
2811       object.${selectname}_add.value = "";
2812     }
2813     </SCRIPT>
2814     <SELECT MULTIPLE NAME="$selectname">
2815 END
2816
2817   foreach my $group ( @all_groups ) {
2818     $html .= qq(<OPTION VALUE="$group");
2819     if ( $sel_groups{$group} ) {
2820       $html .= ' SELECTED';
2821       $sel_groups{$group} = 0;
2822     }
2823     $html .= ">$group</OPTION>\n";
2824   }
2825   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2826     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2827   };
2828   $html .= '</SELECT>';
2829
2830   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2831            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2832
2833   $html;
2834 }
2835
2836 =item reached_threshold
2837
2838 Performs some activities when svc_acct thresholds (such as number of seconds
2839 remaining) are reached.
2840
2841 =cut
2842
2843 sub reached_threshold {
2844   my %opt = @_;
2845
2846   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2847   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2848
2849   if ( $opt{'op'} eq '+' ){
2850     $svc_acct->setfield( $opt{'column'}.'_threshold',
2851                          int($svc_acct->getfield($opt{'column'})
2852                              * ( $conf->exists('svc_acct-usage_threshold')
2853                                  ? $conf->config('svc_acct-usage_threshold')/100
2854                                  : 0.80
2855                                )
2856                          )
2857                        );
2858     my $error = $svc_acct->replace;
2859     die $error if $error;
2860   }elsif ( $opt{'op'} eq '-' ){
2861
2862     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2863     return '' if ($threshold eq '' );
2864
2865     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2866     my $error = $svc_acct->replace;
2867     die $error if $error; # email next time, i guess
2868
2869     if ( $warning_template ) {
2870       eval "use FS::Misc qw(send_email)";
2871       die $@ if $@;
2872
2873       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2874       my $cust_main = $cust_pkg->cust_main;
2875
2876       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2877                                $cust_main->invoicing_list,
2878                                ($opt{'to'} ? $opt{'to'} : ())
2879                    );
2880
2881       my $mimetype = $warning_mimetype;
2882       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2883
2884       my $body       =  $warning_template->fill_in( HASH => {
2885                         'custnum'   => $cust_main->custnum,
2886                         'username'  => $svc_acct->username,
2887                         'password'  => $svc_acct->_password,
2888                         'first'     => $cust_main->first,
2889                         'last'      => $cust_main->getfield('last'),
2890                         'pkg'       => $cust_pkg->part_pkg->pkg,
2891                         'column'    => $opt{'column'},
2892                         'amount'    => $opt{'column'} =~/bytes/
2893                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2894                                        : $svc_acct->getfield($opt{'column'}),
2895                         'threshold' => $opt{'column'} =~/bytes/
2896                                        ? FS::UI::bytecount::display_bytecount($threshold)
2897                                        : $threshold,
2898                       } );
2899
2900
2901       my $error = send_email(
2902         'from'         => $warning_from,
2903         'to'           => $to,
2904         'subject'      => $warning_subject,
2905         'content-type' => $mimetype,
2906         'body'         => [ map "$_\n", split("\n", $body) ],
2907       );
2908       die $error if $error;
2909     }
2910   }else{
2911     die "unknown op: " . $opt{'op'};
2912   }
2913 }
2914
2915 =back
2916
2917 =head1 BUGS
2918
2919 The $recref stuff in sub check should be cleaned up.
2920
2921 The suspend, unsuspend and cancel methods update the database, but not the
2922 current object.  This is probably a bug as it's unexpected and
2923 counterintuitive.
2924
2925 radius_usergroup_selector?  putting web ui components in here?  they should
2926 probably live somewhere else...
2927
2928 insertion of RADIUS group stuff in insert could be done with child_objects now
2929 (would probably clean up export of them too)
2930
2931 _op_usage and set_usage bypass the history... maybe they shouldn't
2932
2933 =head1 SEE ALSO
2934
2935 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2936 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2937 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2938 L<freeside-queued>), L<FS::svc_acct_pop>,
2939 schema.html from the base documentation.
2940
2941 =cut
2942
2943 =item domain_select_hash %OPTIONS
2944
2945 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
2946 may at present purchase.
2947
2948 Currently available options are: I<pkgnum> I<svcpart>
2949
2950 =cut
2951
2952 sub domain_select_hash {
2953   my ($self, %options) = @_;
2954   my %domains = ();
2955   my $part_svc;
2956   my $cust_pkg;
2957
2958   if (ref($self)) {
2959     $part_svc = $self->part_svc;
2960     $cust_pkg = $self->cust_svc->cust_pkg
2961       if $self->cust_svc;
2962   }
2963
2964   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2965     if $options{'svcpart'};
2966
2967   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2968     if $options{'pkgnum'};
2969
2970   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2971                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2972     %domains = map { $_->svcnum => $_->domain }
2973                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2974                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2975   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2976     %domains = map { $_->svcnum => $_->domain }
2977                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2978                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2979                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2980   }else{
2981     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2982   }
2983
2984   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2985     my $svc_domain = qsearchs('svc_domain',
2986       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2987     if ( $svc_domain ) {
2988       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
2989     }else{
2990       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2991            $part_svc->part_svc_column('domsvc')->columnvalue;
2992
2993     }
2994   }
2995
2996   (%domains);
2997 }
2998
2999 1;
3000