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