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