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
1742     my $error = $self->_op_overlimit($action);
1743     if ( $error ) {
1744       $dbh->rollback if $oldAutoCommit;
1745       return $error;
1746     }
1747
1748   }
1749
1750   if ( $conf->exists("svc_acct-usage_$action")
1751        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1752     #my $error = $self->$action();
1753     my $error = $self->cust_svc->cust_pkg->$action();
1754     # $error ||= $self->overlimit($action);
1755     if ( $error ) {
1756       $dbh->rollback if $oldAutoCommit;
1757       return "Error ${action}ing: $error";
1758     }
1759   }
1760
1761   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1762     my $wqueue = new FS::queue {
1763       'svcnum' => $self->svcnum,
1764       'job'    => 'FS::svc_acct::reached_threshold',
1765     };
1766
1767     my $to = '';
1768     if ($op eq '-'){
1769       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1770     }
1771
1772     # x_threshold race
1773     my $error = $wqueue->insert(
1774       'svcnum' => $self->svcnum,
1775       'op'     => $op,
1776       'column' => $column,
1777       'to'     => $to,
1778     );
1779     if ( $error ) {
1780       $dbh->rollback if $oldAutoCommit;
1781       return "Error queuing threshold activity: $error";
1782     }
1783   }
1784
1785   warn "$me update successful; committing\n"
1786     if $DEBUG;
1787   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1788   '';
1789
1790 }
1791
1792 sub _op_overlimit {
1793   my( $self, $action ) = @_;
1794
1795   local $SIG{HUP} = 'IGNORE';
1796   local $SIG{INT} = 'IGNORE';
1797   local $SIG{QUIT} = 'IGNORE';
1798   local $SIG{TERM} = 'IGNORE';
1799   local $SIG{TSTP} = 'IGNORE';
1800   local $SIG{PIPE} = 'IGNORE';
1801
1802   my $oldAutoCommit = $FS::UID::AutoCommit;
1803   local $FS::UID::AutoCommit = 0;
1804   my $dbh = dbh;
1805
1806   my $cust_pkg = $self->cust_svc->cust_pkg;
1807
1808   my $conf_overlimit = $conf->config('overlimit_groups');
1809
1810   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1811
1812     my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
1813     next unless $groups;
1814
1815     my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
1816
1817     my $other = new FS::svc_acct $self->hashref;
1818     $other->usergroup( $gref );
1819
1820     my($new,$old);
1821     if ($action eq 'suspend') {
1822       $new = $other;
1823       $old = $self;
1824     } else { # $action eq 'unsuspend'
1825       $new = $self;
1826       $old = $other;
1827     }
1828
1829     my $error = $part_export->export_replace($new, $old)
1830                 || $self->overlimit($action);
1831
1832     if ( $error ) {
1833       $dbh->rollback if $oldAutoCommit;
1834       return "Error replacing radius groups: $error";
1835     }
1836
1837   }
1838
1839   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1840   '';
1841
1842 }
1843
1844 sub set_usage {
1845   my( $self, $valueref, %options ) = @_;
1846
1847   warn "$me set_usage called for svcnum ". $self->svcnum.
1848        ' ('. $self->email. "): ".
1849        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1850     if $DEBUG;
1851
1852   local $SIG{HUP} = 'IGNORE';
1853   local $SIG{INT} = 'IGNORE';
1854   local $SIG{QUIT} = 'IGNORE';
1855   local $SIG{TERM} = 'IGNORE';
1856   local $SIG{TSTP} = 'IGNORE';
1857   local $SIG{PIPE} = 'IGNORE';
1858
1859   local $FS::svc_Common::noexport_hack = 1;
1860   my $oldAutoCommit = $FS::UID::AutoCommit;
1861   local $FS::UID::AutoCommit = 0;
1862   my $dbh = dbh;
1863
1864   my $reset = 0;
1865   my %handyhash = ();
1866   if ( $options{null} ) {
1867     %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1868                    qw( seconds upbytes downbytes totalbytes )
1869                  );
1870   }
1871   foreach my $field (keys %$valueref){
1872     $reset = 1 if $valueref->{$field};
1873     $self->setfield($field, $valueref->{$field});
1874     $self->setfield( $field.'_threshold',
1875                      int($self->getfield($field)
1876                          * ( $conf->exists('svc_acct-usage_threshold')
1877                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1878                              : 0.20
1879                            )
1880                        )
1881                      );
1882     $handyhash{$field} = $self->getfield($field);
1883     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1884   }
1885   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1886   #die $error if $error;         #services not explicity changed via the UI
1887
1888   my $sql = "UPDATE svc_acct SET " .
1889     join (',', map { "$_ =  $handyhash{$_}" } (keys %handyhash) ).
1890     " WHERE svcnum = ". $self->svcnum;
1891
1892   warn "$me $sql\n"
1893     if $DEBUG;
1894
1895   if (scalar(keys %handyhash)) {
1896     my $sth = $dbh->prepare( $sql )
1897       or die "Error preparing $sql: ". $dbh->errstr;
1898     my $rv = $sth->execute();
1899     die "Error executing $sql: ". $sth->errstr
1900       unless defined($rv);
1901     die "Can't update usage for svcnum ". $self->svcnum
1902       if $rv == 0;
1903   }
1904
1905   #$self->snapshot; #not necessary, we retain the old values
1906   #create an object with the updated usage values
1907   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1908   #call exports
1909   my $error = $new->replace($self);
1910   if ( $error ) {
1911     $dbh->rollback if $oldAutoCommit;
1912     return "Error replacing: $error";
1913   }
1914
1915   if ( $reset ) {
1916
1917     my $error = '';
1918
1919     $error = $self->_op_overlimit('unsuspend')
1920       if $self->overlimit;;
1921
1922     $error ||= $self->cust_svc->cust_pkg->unsuspend
1923       if $conf->exists("svc_acct-usage_unsuspend");
1924
1925     if ( $error ) {
1926       $dbh->rollback if $oldAutoCommit;
1927       return "Error unsuspending: $error";
1928     }
1929
1930   }
1931
1932   warn "$me update successful; committing\n"
1933     if $DEBUG;
1934   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1935   '';
1936
1937 }
1938
1939
1940 =item recharge HASHREF
1941
1942   Increments usage columns by the amount specified in HASHREF as
1943   column=>amount pairs.
1944
1945 =cut
1946
1947 sub recharge {
1948   my ($self, $vhash) = @_;
1949
1950   if ( $DEBUG ) {
1951     warn "[$me] recharge called on $self: ". Dumper($self).
1952          "\nwith vhash: ". Dumper($vhash);
1953   }
1954
1955   my $oldAutoCommit = $FS::UID::AutoCommit;
1956   local $FS::UID::AutoCommit = 0;
1957   my $dbh = dbh;
1958   my $error = '';
1959
1960   foreach my $column (keys %$vhash){
1961     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1962   }
1963
1964   if ( $error ) {
1965     $dbh->rollback if $oldAutoCommit;
1966   }else{
1967     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1968   }
1969   return $error;
1970 }
1971
1972 =item is_rechargeable
1973
1974 Returns true if this svc_account can be "recharged" and false otherwise.
1975
1976 =cut
1977
1978 sub is_rechargable {
1979   my $self = shift;
1980   $self->seconds ne ''
1981     || $self->upbytes ne ''
1982     || $self->downbytes ne ''
1983     || $self->totalbytes ne '';
1984 }
1985
1986 =item seconds_since TIMESTAMP
1987
1988 Returns the number of seconds this account has been online since TIMESTAMP,
1989 according to the session monitor (see L<FS::Session>).
1990
1991 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1992 L<Time::Local> and L<Date::Parse> for conversion functions.
1993
1994 =cut
1995
1996 #note: POD here, implementation in FS::cust_svc
1997 sub seconds_since {
1998   my $self = shift;
1999   $self->cust_svc->seconds_since(@_);
2000 }
2001
2002 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2003
2004 Returns the numbers of seconds this account has been online between
2005 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2006 external SQL radacct table, specified via sqlradius export.  Sessions which
2007 started in the specified range but are still open are counted from session
2008 start to the end of the range (unless they are over 1 day old, in which case
2009 they are presumed missing their stop record and not counted).  Also, sessions
2010 which end in the range but started earlier are counted from the start of the
2011 range to session end.  Finally, sessions which start before the range but end
2012 after are counted for the entire range.
2013
2014 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2015 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2016 functions.
2017
2018 =cut
2019
2020 #note: POD here, implementation in FS::cust_svc
2021 sub seconds_since_sqlradacct {
2022   my $self = shift;
2023   $self->cust_svc->seconds_since_sqlradacct(@_);
2024 }
2025
2026 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2027
2028 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2029 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2030 TIMESTAMP_END (exclusive).
2031
2032 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2033 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2034 functions.
2035
2036 =cut
2037
2038 #note: POD here, implementation in FS::cust_svc
2039 sub attribute_since_sqlradacct {
2040   my $self = shift;
2041   $self->cust_svc->attribute_since_sqlradacct(@_);
2042 }
2043
2044 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2045
2046 Returns an array of hash references of this customers login history for the
2047 given time range.  (document this better)
2048
2049 =cut
2050
2051 sub get_session_history {
2052   my $self = shift;
2053   $self->cust_svc->get_session_history(@_);
2054 }
2055
2056 =item last_login_text
2057
2058 Returns text describing the time of last login.
2059
2060 =cut
2061
2062 sub last_login_text {
2063   my $self = shift;
2064   $self->last_login ? ctime($self->last_login) : 'unknown';
2065 }
2066
2067 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2068
2069 =cut
2070
2071 sub get_cdrs {
2072   my($self, $start, $end, %opt ) = @_;
2073
2074   my $did = $self->username; #yup
2075
2076   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2077
2078   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2079
2080   #SELECT $for_update * FROM cdr
2081   #  WHERE calldate >= $start #need a conversion
2082   #    AND calldate <  $end   #ditto
2083   #    AND (    charged_party = "$did"
2084   #          OR charged_party = "$prefix$did" #if length($prefix);
2085   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2086   #               AND
2087   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2088   #             )
2089   #        )
2090   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2091
2092   my $charged_or_src;
2093   if ( length($prefix) ) {
2094     $charged_or_src =
2095       " AND (    charged_party = '$did'
2096               OR charged_party = '$prefix$did'
2097               OR ( ( charged_party IS NULL OR charged_party = '' )
2098                    AND
2099                    ( src = '$did' OR src = '$prefix$did' )
2100                  )
2101             )
2102       ";
2103   } else {
2104     $charged_or_src =
2105       " AND (    charged_party = '$did'
2106               OR ( ( charged_party IS NULL OR charged_party = '' )
2107                    AND
2108                    src = '$did'
2109                  )
2110             )
2111       ";
2112
2113   }
2114
2115   qsearch(
2116     'select'    => "$for_update *",
2117     'table'     => 'cdr',
2118     'hashref'   => {
2119                      #( freesidestatus IS NULL OR freesidestatus = '' )
2120                      'freesidestatus' => '',
2121                    },
2122     'extra_sql' => $charged_or_src,
2123
2124   );
2125
2126 }
2127
2128 =item radius_groups
2129
2130 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2131
2132 =cut
2133
2134 sub radius_groups {
2135   my $self = shift;
2136   if ( $self->usergroup ) {
2137     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2138       unless ref($self->usergroup) eq 'ARRAY';
2139     #when provisioning records, export callback runs in svc_Common.pm before
2140     #radius_usergroup records can be inserted...
2141     @{$self->usergroup};
2142   } else {
2143     map { $_->groupname }
2144       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2145   }
2146 }
2147
2148 =item clone_suspended
2149
2150 Constructor used by FS::part_export::_export_suspend fallback.  Document
2151 better.
2152
2153 =cut
2154
2155 sub clone_suspended {
2156   my $self = shift;
2157   my %hash = $self->hash;
2158   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2159   new FS::svc_acct \%hash;
2160 }
2161
2162 =item clone_kludge_unsuspend
2163
2164 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2165 better.
2166
2167 =cut
2168
2169 sub clone_kludge_unsuspend {
2170   my $self = shift;
2171   my %hash = $self->hash;
2172   $hash{_password} = '';
2173   new FS::svc_acct \%hash;
2174 }
2175
2176 =item check_password
2177
2178 Checks the supplied password against the (possibly encrypted) password in the
2179 database.  Returns true for a successful authentication, false for no match.
2180
2181 Currently supported encryptions are: classic DES crypt() and MD5
2182
2183 =cut
2184
2185 sub check_password {
2186   my($self, $check_password) = @_;
2187
2188   #remove old-style SUSPENDED kludge, they should be allowed to login to
2189   #self-service and pay up
2190   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2191
2192   #eventually should check a "password-encoding" field
2193   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2194     return 0;
2195   } elsif ( length($password) < 13 ) { #plaintext
2196     $check_password eq $password;
2197   } elsif ( length($password) == 13 ) { #traditional DES crypt
2198     crypt($check_password, $password) eq $password;
2199   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2200     unix_md5_crypt($check_password, $password) eq $password;
2201   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2202     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
2203          $self->svcnum. "\n";
2204     0;
2205   } else {
2206     warn "Can't check password: Unrecognized encryption for svcnum ".
2207          $self->svcnum. "\n";
2208     0;
2209   }
2210
2211 }
2212
2213 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2214
2215 Returns an encrypted password, either by passing through an encrypted password
2216 in the database or by encrypting a plaintext password from the database.
2217
2218 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2219 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2220 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2221 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2222 encryption type is only used if the password is not already encrypted in the
2223 database.
2224
2225 =cut
2226
2227 sub crypt_password {
2228   my $self = shift;
2229   #eventually should check a "password-encoding" field
2230   if ( length($self->_password) == 13
2231        || $self->_password =~ /^\$(1|2a?)\$/
2232        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2233      )
2234   {
2235     $self->_password;
2236   } else {
2237     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2238     if ( $encryption eq 'crypt' ) {
2239       crypt(
2240         $self->_password,
2241         $saltset[int(rand(64))].$saltset[int(rand(64))]
2242       );
2243     } elsif ( $encryption eq 'md5' ) {
2244       unix_md5_crypt( $self->_password );
2245     } elsif ( $encryption eq 'blowfish' ) {
2246       croak "unknown encryption method $encryption";
2247     } else {
2248       croak "unknown encryption method $encryption";
2249     }
2250   }
2251 }
2252
2253 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2254
2255 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2256 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
2257 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
2258
2259 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2260 to work the same as the B</crypt_password> method.
2261
2262 =cut
2263
2264 sub ldap_password {
2265   my $self = shift;
2266   #eventually should check a "password-encoding" field
2267   if ( length($self->_password) == 13 ) { #crypt
2268     return '{CRYPT}'. $self->_password;
2269   } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2270     return '{MD5}'. $1;
2271   } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2272     warn "Blowfish encryption not supported in this context, svcnum ".
2273          $self->svcnum. "\n";
2274     return '{CRYPT}*'; #unsupported, should not auth
2275   } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2276     return '{SSHA}'. $1;
2277   } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2278     return '{NS-MTA-MD5}'. $1;
2279   } else { #plaintext
2280     return '{PLAIN}'. $self->_password;
2281     #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2282     #if ( $encryption eq 'crypt' ) {
2283     #  return '{CRYPT}'. crypt(
2284     #    $self->_password,
2285     #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2286     #  );
2287     #} elsif ( $encryption eq 'md5' ) {
2288     #  unix_md5_crypt( $self->_password );
2289     #} elsif ( $encryption eq 'blowfish' ) {
2290     #  croak "unknown encryption method $encryption";
2291     #} else {
2292     #  croak "unknown encryption method $encryption";
2293     #}
2294   }
2295 }
2296
2297 =item domain_slash_username
2298
2299 Returns $domain/$username/
2300
2301 =cut
2302
2303 sub domain_slash_username {
2304   my $self = shift;
2305   $self->domain. '/'. $self->username. '/';
2306 }
2307
2308 =item virtual_maildir
2309
2310 Returns $domain/maildirs/$username/
2311
2312 =cut
2313
2314 sub virtual_maildir {
2315   my $self = shift;
2316   $self->domain. '/maildirs/'. $self->username. '/';
2317 }
2318
2319 =back
2320
2321 =head1 SUBROUTINES
2322
2323 =over 4
2324
2325 =item send_email
2326
2327 This is the FS::svc_acct job-queue-able version.  It still uses
2328 FS::Misc::send_email under-the-hood.
2329
2330 =cut
2331
2332 sub send_email {
2333   my %opt = @_;
2334
2335   eval "use FS::Misc qw(send_email)";
2336   die $@ if $@;
2337
2338   $opt{mimetype} ||= 'text/plain';
2339   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2340
2341   my $error = send_email(
2342     'from'         => $opt{from},
2343     'to'           => $opt{to},
2344     'subject'      => $opt{subject},
2345     'content-type' => $opt{mimetype},
2346     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2347   );
2348   die $error if $error;
2349 }
2350
2351 =item check_and_rebuild_fuzzyfiles
2352
2353 =cut
2354
2355 sub check_and_rebuild_fuzzyfiles {
2356   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2357   -e "$dir/svc_acct.username"
2358     or &rebuild_fuzzyfiles;
2359 }
2360
2361 =item rebuild_fuzzyfiles
2362
2363 =cut
2364
2365 sub rebuild_fuzzyfiles {
2366
2367   use Fcntl qw(:flock);
2368
2369   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2370
2371   #username
2372
2373   open(USERNAMELOCK,">>$dir/svc_acct.username")
2374     or die "can't open $dir/svc_acct.username: $!";
2375   flock(USERNAMELOCK,LOCK_EX)
2376     or die "can't lock $dir/svc_acct.username: $!";
2377
2378   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2379
2380   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2381     or die "can't open $dir/svc_acct.username.tmp: $!";
2382   print USERNAMECACHE join("\n", @all_username), "\n";
2383   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2384
2385   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2386   close USERNAMELOCK;
2387
2388 }
2389
2390 =item all_username
2391
2392 =cut
2393
2394 sub all_username {
2395   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2396   open(USERNAMECACHE,"<$dir/svc_acct.username")
2397     or die "can't open $dir/svc_acct.username: $!";
2398   my @array = map { chomp; $_; } <USERNAMECACHE>;
2399   close USERNAMECACHE;
2400   \@array;
2401 }
2402
2403 =item append_fuzzyfiles USERNAME
2404
2405 =cut
2406
2407 sub append_fuzzyfiles {
2408   my $username = shift;
2409
2410   &check_and_rebuild_fuzzyfiles;
2411
2412   use Fcntl qw(:flock);
2413
2414   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2415
2416   open(USERNAME,">>$dir/svc_acct.username")
2417     or die "can't open $dir/svc_acct.username: $!";
2418   flock(USERNAME,LOCK_EX)
2419     or die "can't lock $dir/svc_acct.username: $!";
2420
2421   print USERNAME "$username\n";
2422
2423   flock(USERNAME,LOCK_UN)
2424     or die "can't unlock $dir/svc_acct.username: $!";
2425   close USERNAME;
2426
2427   1;
2428 }
2429
2430
2431
2432 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2433
2434 =cut
2435
2436 sub radius_usergroup_selector {
2437   my $sel_groups = shift;
2438   my %sel_groups = map { $_=>1 } @$sel_groups;
2439
2440   my $selectname = shift || 'radius_usergroup';
2441
2442   my $dbh = dbh;
2443   my $sth = $dbh->prepare(
2444     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2445   ) or die $dbh->errstr;
2446   $sth->execute() or die $sth->errstr;
2447   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2448
2449   my $html = <<END;
2450     <SCRIPT>
2451     function ${selectname}_doadd(object) {
2452       var myvalue = object.${selectname}_add.value;
2453       var optionName = new Option(myvalue,myvalue,false,true);
2454       var length = object.$selectname.length;
2455       object.$selectname.options[length] = optionName;
2456       object.${selectname}_add.value = "";
2457     }
2458     </SCRIPT>
2459     <SELECT MULTIPLE NAME="$selectname">
2460 END
2461
2462   foreach my $group ( @all_groups ) {
2463     $html .= qq(<OPTION VALUE="$group");
2464     if ( $sel_groups{$group} ) {
2465       $html .= ' SELECTED';
2466       $sel_groups{$group} = 0;
2467     }
2468     $html .= ">$group</OPTION>\n";
2469   }
2470   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2471     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2472   };
2473   $html .= '</SELECT>';
2474
2475   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2476            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2477
2478   $html;
2479 }
2480
2481 =item reached_threshold
2482
2483 Performs some activities when svc_acct thresholds (such as number of seconds
2484 remaining) are reached.
2485
2486 =cut
2487
2488 sub reached_threshold {
2489   my %opt = @_;
2490
2491   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2492   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2493
2494   if ( $opt{'op'} eq '+' ){
2495     $svc_acct->setfield( $opt{'column'}.'_threshold',
2496                          int($svc_acct->getfield($opt{'column'})
2497                              * ( $conf->exists('svc_acct-usage_threshold')
2498                                  ? $conf->config('svc_acct-usage_threshold')/100
2499                                  : 0.80
2500                                )
2501                          )
2502                        );
2503     my $error = $svc_acct->replace;
2504     die $error if $error;
2505   }elsif ( $opt{'op'} eq '-' ){
2506
2507     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2508     return '' if ($threshold eq '' );
2509
2510     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2511     my $error = $svc_acct->replace;
2512     die $error if $error; # email next time, i guess
2513
2514     if ( $warning_template ) {
2515       eval "use FS::Misc qw(send_email)";
2516       die $@ if $@;
2517
2518       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2519       my $cust_main = $cust_pkg->cust_main;
2520
2521       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2522                                $cust_main->invoicing_list,
2523                                ($opt{'to'} ? $opt{'to'} : ())
2524                    );
2525
2526       my $mimetype = $warning_mimetype;
2527       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2528
2529       my $body       =  $warning_template->fill_in( HASH => {
2530                         'custnum'   => $cust_main->custnum,
2531                         'username'  => $svc_acct->username,
2532                         'password'  => $svc_acct->_password,
2533                         'first'     => $cust_main->first,
2534                         'last'      => $cust_main->getfield('last'),
2535                         'pkg'       => $cust_pkg->part_pkg->pkg,
2536                         'column'    => $opt{'column'},
2537                         'amount'    => $opt{'column'} =~/bytes/
2538                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2539                                        : $svc_acct->getfield($opt{'column'}),
2540                         'threshold' => $opt{'column'} =~/bytes/
2541                                        ? FS::UI::bytecount::display_bytecount($threshold)
2542                                        : $threshold,
2543                       } );
2544
2545
2546       my $error = send_email(
2547         'from'         => $warning_from,
2548         'to'           => $to,
2549         'subject'      => $warning_subject,
2550         'content-type' => $mimetype,
2551         'body'         => [ map "$_\n", split("\n", $body) ],
2552       );
2553       die $error if $error;
2554     }
2555   }else{
2556     die "unknown op: " . $opt{'op'};
2557   }
2558 }
2559
2560 =back
2561
2562 =head1 BUGS
2563
2564 The $recref stuff in sub check should be cleaned up.
2565
2566 The suspend, unsuspend and cancel methods update the database, but not the
2567 current object.  This is probably a bug as it's unexpected and
2568 counterintuitive.
2569
2570 radius_usergroup_selector?  putting web ui components in here?  they should
2571 probably live somewhere else...
2572
2573 insertion of RADIUS group stuff in insert could be done with child_objects now
2574 (would probably clean up export of them too)
2575
2576 _op_usage and set_usage bypass the history... maybe they shouldn't
2577
2578 =head1 SEE ALSO
2579
2580 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2581 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2582 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2583 L<freeside-queued>), L<FS::svc_acct_pop>,
2584 schema.html from the base documentation.
2585
2586 =cut
2587
2588 =item domain_select_hash %OPTIONS
2589
2590 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
2591 may at present purchase.
2592
2593 Currently available options are: I<pkgnum> I<svcpart>
2594
2595 =cut
2596
2597 sub domain_select_hash {
2598   my ($self, %options) = @_;
2599   my %domains = ();
2600   my $part_svc;
2601   my $cust_pkg;
2602
2603   if (ref($self)) {
2604     $part_svc = $self->part_svc;
2605     $cust_pkg = $self->cust_svc->cust_pkg
2606       if $self->cust_svc;
2607   }
2608
2609   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2610     if $options{'svcpart'};
2611
2612   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2613     if $options{'pkgnum'};
2614
2615   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2616                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2617     %domains = map { $_->svcnum => $_->domain }
2618                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2619                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2620   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2621     %domains = map { $_->svcnum => $_->domain }
2622                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2623                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2624                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2625   }else{
2626     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2627   }
2628
2629   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2630     my $svc_domain = qsearchs('svc_domain',
2631       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2632     if ( $svc_domain ) {
2633       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
2634     }else{
2635       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2636            $part_svc->part_svc_column('domsvc')->columnvalue;
2637
2638     }
2639   }
2640
2641   (%domains);
2642 }
2643
2644 1;
2645