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