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