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