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