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