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 ". $self->username.
1267                ": conflicts with svcnum ". $dup_user->svcnum.
1268                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1269       }
1270     }
1271
1272     foreach my $dup_userdomain ( @dup_userdomain ) {
1273       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1274       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1275         return "duplicate username\@domain ". $self->email.
1276                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1277                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1278       }
1279     }
1280
1281     foreach my $dup_uid ( @dup_uid ) {
1282       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1283       if ( exists($conflict_user_svcpart{$dup_svcpart})
1284            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1285         return "duplicate uid ". $self->uid.
1286                ": conflicts with svcnum ". $dup_uid->svcnum.
1287                " via exportnum ".
1288                ( $conflict_user_svcpart{$dup_svcpart}
1289                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1290       }
1291     }
1292
1293   }
1294
1295   return '';
1296
1297 }
1298
1299 =item radius
1300
1301 Depriciated, use radius_reply instead.
1302
1303 =cut
1304
1305 sub radius {
1306   carp "FS::svc_acct::radius depriciated, use radius_reply";
1307   $_[0]->radius_reply;
1308 }
1309
1310 =item radius_reply
1311
1312 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1313 reply attributes of this record.
1314
1315 Note that this is now the preferred method for reading RADIUS attributes -
1316 accessing the columns directly is discouraged, as the column names are
1317 expected to change in the future.
1318
1319 =cut
1320
1321 sub radius_reply {
1322   my $self = shift;
1323
1324   return %{ $self->{'radius_reply'} }
1325     if exists $self->{'radius_reply'};
1326
1327   my %reply =
1328     map {
1329       /^(radius_(.*))$/;
1330       my($column, $attrib) = ($1, $2);
1331       #$attrib =~ s/_/\-/g;
1332       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1333     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1334
1335   if ( $self->slipip && $self->slipip ne '0e0' ) {
1336     $reply{$radius_ip} = $self->slipip;
1337   }
1338
1339   if ( $self->seconds !~ /^$/ ) {
1340     $reply{'Session-Timeout'} = $self->seconds;
1341   }
1342
1343   %reply;
1344 }
1345
1346 =item radius_check
1347
1348 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1349 check attributes of this record.
1350
1351 Note that this is now the preferred method for reading RADIUS attributes -
1352 accessing the columns directly is discouraged, as the column names are
1353 expected to change in the future.
1354
1355 =cut
1356
1357 sub radius_check {
1358   my $self = shift;
1359
1360   return %{ $self->{'radius_check'} }
1361     if exists $self->{'radius_check'};
1362
1363   my %check =
1364     map {
1365       /^(rc_(.*))$/;
1366       my($column, $attrib) = ($1, $2);
1367       #$attrib =~ s/_/\-/g;
1368       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1369     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1370
1371   my $password = $self->_password;
1372   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1373
1374   my $cust_svc = $self->cust_svc;
1375   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1376     unless $cust_svc;
1377   my $cust_pkg = $cust_svc->cust_pkg;
1378   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1379     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1380   }
1381
1382   %check;
1383
1384 }
1385
1386 =item snapshot
1387
1388 This method instructs the object to "snapshot" or freeze RADIUS check and
1389 reply attributes to the current values.
1390
1391 =cut
1392
1393 #bah, my english is too broken this morning
1394 #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
1395 #the FS::cust_pkg's replace method to trigger the correct export updates when
1396 #package dates change)
1397
1398 sub snapshot {
1399   my $self = shift;
1400
1401   $self->{$_} = { $self->$_() }
1402     foreach qw( radius_reply radius_check );
1403
1404 }
1405
1406 =item forget_snapshot
1407
1408 This methos instructs the object to forget any previously snapshotted
1409 RADIUS check and reply attributes.
1410
1411 =cut
1412
1413 sub forget_snapshot {
1414   my $self = shift;
1415
1416   delete $self->{$_}
1417     foreach qw( radius_reply radius_check );
1418
1419 }
1420
1421 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1422
1423 Returns the domain associated with this account.
1424
1425 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1426 history records.
1427
1428 =cut
1429
1430 sub domain {
1431   my $self = shift;
1432   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1433   my $svc_domain = $self->svc_domain(@_)
1434     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1435   $svc_domain->domain;
1436 }
1437
1438 =item svc_domain
1439
1440 Returns the FS::svc_domain record for this account's domain (see
1441 L<FS::svc_domain>).
1442
1443 =cut
1444
1445 # FS::h_svc_acct has a history-aware svc_domain override
1446
1447 sub svc_domain {
1448   my $self = shift;
1449   $self->{'_domsvc'}
1450     ? $self->{'_domsvc'}
1451     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1452 }
1453
1454 =item cust_svc
1455
1456 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1457
1458 =cut
1459
1460 #inherited from svc_Common
1461
1462 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1463
1464 Returns an email address associated with the account.
1465
1466 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1467 history records.
1468
1469 =cut
1470
1471 sub email {
1472   my $self = shift;
1473   $self->username. '@'. $self->domain(@_);
1474 }
1475
1476 =item acct_snarf
1477
1478 Returns an array of FS::acct_snarf records associated with the account.
1479 If the acct_snarf table does not exist or there are no associated records,
1480 an empty list is returned
1481
1482 =cut
1483
1484 sub acct_snarf {
1485   my $self = shift;
1486   return () unless dbdef->table('acct_snarf');
1487   eval "use FS::acct_snarf;";
1488   die $@ if $@;
1489   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1490 }
1491
1492 =item decrement_upbytes OCTETS
1493
1494 Decrements the I<upbytes> field of this record by the given amount.  If there
1495 is an error, returns the error, otherwise returns false.
1496
1497 =cut
1498
1499 sub decrement_upbytes {
1500   shift->_op_usage('-', 'upbytes', @_);
1501 }
1502
1503 =item increment_upbytes OCTETS
1504
1505 Increments the I<upbytes> field of this record by the given amount.  If there
1506 is an error, returns the error, otherwise returns false.
1507
1508 =cut
1509
1510 sub increment_upbytes {
1511   shift->_op_usage('+', 'upbytes', @_);
1512 }
1513
1514 =item decrement_downbytes OCTETS
1515
1516 Decrements the I<downbytes> field of this record by the given amount.  If there
1517 is an error, returns the error, otherwise returns false.
1518
1519 =cut
1520
1521 sub decrement_downbytes {
1522   shift->_op_usage('-', 'downbytes', @_);
1523 }
1524
1525 =item increment_downbytes OCTETS
1526
1527 Increments the I<downbytes> field of this record by the given amount.  If there
1528 is an error, returns the error, otherwise returns false.
1529
1530 =cut
1531
1532 sub increment_downbytes {
1533   shift->_op_usage('+', 'downbytes', @_);
1534 }
1535
1536 =item decrement_totalbytes OCTETS
1537
1538 Decrements the I<totalbytes> field of this record by the given amount.  If there
1539 is an error, returns the error, otherwise returns false.
1540
1541 =cut
1542
1543 sub decrement_totalbytes {
1544   shift->_op_usage('-', 'totalbytes', @_);
1545 }
1546
1547 =item increment_totalbytes OCTETS
1548
1549 Increments the I<totalbytes> field of this record by the given amount.  If there
1550 is an error, returns the error, otherwise returns false.
1551
1552 =cut
1553
1554 sub increment_totalbytes {
1555   shift->_op_usage('+', 'totalbytes', @_);
1556 }
1557
1558 =item decrement_seconds SECONDS
1559
1560 Decrements the I<seconds> field of this record by the given amount.  If there
1561 is an error, returns the error, otherwise returns false.
1562
1563 =cut
1564
1565 sub decrement_seconds {
1566   shift->_op_usage('-', 'seconds', @_);
1567 }
1568
1569 =item increment_seconds SECONDS
1570
1571 Increments the I<seconds> field of this record by the given amount.  If there
1572 is an error, returns the error, otherwise returns false.
1573
1574 =cut
1575
1576 sub increment_seconds {
1577   shift->_op_usage('+', 'seconds', @_);
1578 }
1579
1580
1581 my %op2action = (
1582   '-' => 'suspend',
1583   '+' => 'unsuspend',
1584 );
1585 my %op2condition = (
1586   '-' => sub { my($self, $column, $amount) = @_;
1587                $self->$column - $amount <= 0;
1588              },
1589   '+' => sub { my($self, $column, $amount) = @_;
1590                $self->$column + $amount > 0;
1591              },
1592 );
1593 my %op2warncondition = (
1594   '-' => sub { my($self, $column, $amount) = @_;
1595                my $threshold = $column . '_threshold';
1596                $self->$column - $amount <= $self->$threshold + 0;
1597              },
1598   '+' => sub { my($self, $column, $amount) = @_;
1599                $self->$column + $amount > 0;
1600              },
1601 );
1602
1603 sub _op_usage {
1604   my( $self, $op, $column, $amount ) = @_;
1605
1606   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1607        ' ('. $self->email. "): $op $amount\n"
1608     if $DEBUG;
1609
1610   return '' unless $amount;
1611
1612   local $SIG{HUP} = 'IGNORE';
1613   local $SIG{INT} = 'IGNORE';
1614   local $SIG{QUIT} = 'IGNORE';
1615   local $SIG{TERM} = 'IGNORE';
1616   local $SIG{TSTP} = 'IGNORE';
1617   local $SIG{PIPE} = 'IGNORE';
1618
1619   my $oldAutoCommit = $FS::UID::AutoCommit;
1620   local $FS::UID::AutoCommit = 0;
1621   my $dbh = dbh;
1622
1623   my $sql = "UPDATE svc_acct SET $column = ".
1624             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1625             " $op ? WHERE svcnum = ?";
1626   warn "$me $sql\n"
1627     if $DEBUG;
1628
1629   my $sth = $dbh->prepare( $sql )
1630     or die "Error preparing $sql: ". $dbh->errstr;
1631   my $rv = $sth->execute($amount, $self->svcnum);
1632   die "Error executing $sql: ". $sth->errstr
1633     unless defined($rv);
1634   die "Can't update $column for svcnum". $self->svcnum
1635     if $rv == 0;
1636
1637   my $action = $op2action{$op};
1638
1639   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1640         ( $action eq 'suspend'   && !$self->overlimit
1641        || $action eq 'unsuspend' &&  $self->overlimit )
1642      ) {
1643     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1644       if ($part_export->option('overlimit_groups')) {
1645         my ($new,$old);
1646         my $other = new FS::svc_acct $self->hashref;
1647         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1648                        ($self, $part_export->option('overlimit_groups'));
1649         $other->usergroup( $groups );
1650         if ($action eq 'suspend'){
1651           $new = $other; $old = $self;
1652         }else{
1653           $new = $self; $old = $other;
1654         }
1655         my $error = $part_export->export_replace($new, $old);
1656         $error ||= $self->overlimit($action);
1657         if ( $error ) {
1658           $dbh->rollback if $oldAutoCommit;
1659           return "Error replacing radius groups in export, ${op}: $error";
1660         }
1661       }
1662     }
1663   }
1664
1665   if ( $conf->exists("svc_acct-usage_$action")
1666        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1667     #my $error = $self->$action();
1668     my $error = $self->cust_svc->cust_pkg->$action();
1669     # $error ||= $self->overlimit($action);
1670     if ( $error ) {
1671       $dbh->rollback if $oldAutoCommit;
1672       return "Error ${action}ing: $error";
1673     }
1674   }
1675
1676   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1677     my $wqueue = new FS::queue {
1678       'svcnum' => $self->svcnum,
1679       'job'    => 'FS::svc_acct::reached_threshold',
1680     };
1681
1682     my $to = '';
1683     if ($op eq '-'){
1684       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1685     }
1686
1687     # x_threshold race
1688     my $error = $wqueue->insert(
1689       'svcnum' => $self->svcnum,
1690       'op'     => $op,
1691       'column' => $column,
1692       'to'     => $to,
1693     );
1694     if ( $error ) {
1695       $dbh->rollback if $oldAutoCommit;
1696       return "Error queuing threshold activity: $error";
1697     }
1698   }
1699
1700   warn "$me update successful; committing\n"
1701     if $DEBUG;
1702   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1703   '';
1704
1705 }
1706
1707 sub set_usage {
1708   my( $self, $valueref ) = @_;
1709
1710   warn "$me set_usage called for svcnum ". $self->svcnum.
1711        ' ('. $self->email. "): ".
1712        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1713     if $DEBUG;
1714
1715   local $SIG{HUP} = 'IGNORE';
1716   local $SIG{INT} = 'IGNORE';
1717   local $SIG{QUIT} = 'IGNORE';
1718   local $SIG{TERM} = 'IGNORE';
1719   local $SIG{TSTP} = 'IGNORE';
1720   local $SIG{PIPE} = 'IGNORE';
1721
1722   local $FS::svc_Common::noexport_hack = 1;
1723   my $oldAutoCommit = $FS::UID::AutoCommit;
1724   local $FS::UID::AutoCommit = 0;
1725   my $dbh = dbh;
1726
1727   my $reset = 0;
1728   my %handyhash = ();
1729   foreach my $field (keys %$valueref){
1730     $reset = 1 if $valueref->{$field};
1731     $self->setfield($field, $valueref->{$field});
1732     $self->setfield( $field.'_threshold',
1733                      int($self->getfield($field)
1734                          * ( $conf->exists('svc_acct-usage_threshold')
1735                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1736                              : 0.20
1737                            )
1738                        )
1739                      );
1740     $handyhash{$field} = $self->getfield($field);
1741     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1742   }
1743   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1744   #die $error if $error;         #services not explicity changed via the UI
1745
1746   my $sql = "UPDATE svc_acct SET " .
1747     join (',', map { "$_ =  ?" } (keys %handyhash) ).
1748     " WHERE svcnum = ?";
1749
1750   warn "$me $sql\n"
1751     if $DEBUG;
1752
1753   if (scalar(keys %handyhash)) {
1754     my $sth = $dbh->prepare( $sql )
1755       or die "Error preparing $sql: ". $dbh->errstr;
1756     my $rv = $sth->execute((values %handyhash), $self->svcnum);
1757     die "Error executing $sql: ". $sth->errstr
1758       unless defined($rv);
1759     die "Can't update usage for svcnum ". $self->svcnum
1760       if $rv == 0;
1761   }
1762
1763   if ( $reset ) {
1764     my $error;
1765
1766     if ($self->overlimit) {
1767       $error = $self->overlimit('unsuspend');
1768       foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1769         if ($part_export->option('overlimit_groups')) {
1770           my $old = new FS::svc_acct $self->hashref;
1771           my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1772                          ($self, $part_export->option('overlimit_groups'));
1773           $old->usergroup( $groups );
1774           $error ||= $part_export->export_replace($self, $old);
1775         }
1776       }
1777     }
1778
1779     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1780       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1781     }
1782     if ( $error ) {
1783       $dbh->rollback if $oldAutoCommit;
1784       return "Error unsuspending: $error";
1785     }
1786   }
1787
1788   warn "$me update successful; committing\n"
1789     if $DEBUG;
1790   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1791   '';
1792
1793 }
1794
1795
1796 =item recharge HASHREF
1797
1798   Increments usage columns by the amount specified in HASHREF as
1799   column=>amount pairs.
1800
1801 =cut
1802
1803 sub recharge {
1804   my ($self, $vhash) = @_;
1805
1806   if ( $DEBUG ) {
1807     warn "[$me] recharge called on $self: ". Dumper($self).
1808          "\nwith vhash: ". Dumper($vhash);
1809   }
1810
1811   my $oldAutoCommit = $FS::UID::AutoCommit;
1812   local $FS::UID::AutoCommit = 0;
1813   my $dbh = dbh;
1814   my $error = '';
1815
1816   foreach my $column (keys %$vhash){
1817     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1818   }
1819
1820   if ( $error ) {
1821     $dbh->rollback if $oldAutoCommit;
1822   }else{
1823     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1824   }
1825   return $error;
1826 }
1827
1828 =item is_rechargeable
1829
1830 Returns true if this svc_account can be "recharged" and false otherwise.
1831
1832 =cut
1833
1834 sub is_rechargable {
1835   my $self = shift;
1836   $self->seconds ne ''
1837     || $self->upbytes ne ''
1838     || $self->downbytes ne ''
1839     || $self->totalbytes ne '';
1840 }
1841
1842 =item seconds_since TIMESTAMP
1843
1844 Returns the number of seconds this account has been online since TIMESTAMP,
1845 according to the session monitor (see L<FS::Session>).
1846
1847 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1848 L<Time::Local> and L<Date::Parse> for conversion functions.
1849
1850 =cut
1851
1852 #note: POD here, implementation in FS::cust_svc
1853 sub seconds_since {
1854   my $self = shift;
1855   $self->cust_svc->seconds_since(@_);
1856 }
1857
1858 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1859
1860 Returns the numbers of seconds this account has been online between
1861 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1862 external SQL radacct table, specified via sqlradius export.  Sessions which
1863 started in the specified range but are still open are counted from session
1864 start to the end of the range (unless they are over 1 day old, in which case
1865 they are presumed missing their stop record and not counted).  Also, sessions
1866 which end in the range but started earlier are counted from the start of the
1867 range to session end.  Finally, sessions which start before the range but end
1868 after are counted for the entire range.
1869
1870 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1871 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1872 functions.
1873
1874 =cut
1875
1876 #note: POD here, implementation in FS::cust_svc
1877 sub seconds_since_sqlradacct {
1878   my $self = shift;
1879   $self->cust_svc->seconds_since_sqlradacct(@_);
1880 }
1881
1882 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1883
1884 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1885 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1886 TIMESTAMP_END (exclusive).
1887
1888 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1889 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1890 functions.
1891
1892 =cut
1893
1894 #note: POD here, implementation in FS::cust_svc
1895 sub attribute_since_sqlradacct {
1896   my $self = shift;
1897   $self->cust_svc->attribute_since_sqlradacct(@_);
1898 }
1899
1900 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1901
1902 Returns an array of hash references of this customers login history for the
1903 given time range.  (document this better)
1904
1905 =cut
1906
1907 sub get_session_history {
1908   my $self = shift;
1909   $self->cust_svc->get_session_history(@_);
1910 }
1911
1912 =item last_login_text
1913
1914 Returns text describing the time of last login.
1915
1916 =cut
1917
1918 sub last_login_text {
1919   my $self = shift;
1920   $self->last_login ? ctime($self->last_login) : 'unknown';
1921 }
1922
1923 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1924
1925 =cut
1926
1927 sub get_cdrs {
1928   my($self, $start, $end, %opt ) = @_;
1929
1930   my $did = $self->username; #yup
1931
1932   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1933
1934   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1935
1936   #SELECT $for_update * FROM cdr
1937   #  WHERE calldate >= $start #need a conversion
1938   #    AND calldate <  $end   #ditto
1939   #    AND (    charged_party = "$did"
1940   #          OR charged_party = "$prefix$did" #if length($prefix);
1941   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1942   #               AND
1943   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1944   #             )
1945   #        )
1946   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1947
1948   my $charged_or_src;
1949   if ( length($prefix) ) {
1950     $charged_or_src =
1951       " AND (    charged_party = '$did'
1952               OR charged_party = '$prefix$did'
1953               OR ( ( charged_party IS NULL OR charged_party = '' )
1954                    AND
1955                    ( src = '$did' OR src = '$prefix$did' )
1956                  )
1957             )
1958       ";
1959   } else {
1960     $charged_or_src =
1961       " AND (    charged_party = '$did'
1962               OR ( ( charged_party IS NULL OR charged_party = '' )
1963                    AND
1964                    src = '$did'
1965                  )
1966             )
1967       ";
1968
1969   }
1970
1971   qsearch(
1972     'select'    => "$for_update *",
1973     'table'     => 'cdr',
1974     'hashref'   => {
1975                      #( freesidestatus IS NULL OR freesidestatus = '' )
1976                      'freesidestatus' => '',
1977                    },
1978     'extra_sql' => $charged_or_src,
1979
1980   );
1981
1982 }
1983
1984 =item radius_groups
1985
1986 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1987
1988 =cut
1989
1990 sub radius_groups {
1991   my $self = shift;
1992   if ( $self->usergroup ) {
1993     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1994       unless ref($self->usergroup) eq 'ARRAY';
1995     #when provisioning records, export callback runs in svc_Common.pm before
1996     #radius_usergroup records can be inserted...
1997     @{$self->usergroup};
1998   } else {
1999     map { $_->groupname }
2000       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2001   }
2002 }
2003
2004 =item clone_suspended
2005
2006 Constructor used by FS::part_export::_export_suspend fallback.  Document
2007 better.
2008
2009 =cut
2010
2011 sub clone_suspended {
2012   my $self = shift;
2013   my %hash = $self->hash;
2014   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2015   new FS::svc_acct \%hash;
2016 }
2017
2018 =item clone_kludge_unsuspend
2019
2020 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2021 better.
2022
2023 =cut
2024
2025 sub clone_kludge_unsuspend {
2026   my $self = shift;
2027   my %hash = $self->hash;
2028   $hash{_password} = '';
2029   new FS::svc_acct \%hash;
2030 }
2031
2032 =item check_password
2033
2034 Checks the supplied password against the (possibly encrypted) password in the
2035 database.  Returns true for a successful authentication, false for no match.
2036
2037 Currently supported encryptions are: classic DES crypt() and MD5
2038
2039 =cut
2040
2041 sub check_password {
2042   my($self, $check_password) = @_;
2043
2044   #remove old-style SUSPENDED kludge, they should be allowed to login to
2045   #self-service and pay up
2046   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2047
2048   #eventually should check a "password-encoding" field
2049   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2050     return 0;
2051   } elsif ( length($password) < 13 ) { #plaintext
2052     $check_password eq $password;
2053   } elsif ( length($password) == 13 ) { #traditional DES crypt
2054     crypt($check_password, $password) eq $password;
2055   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2056     unix_md5_crypt($check_password, $password) eq $password;
2057   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2058     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
2059          $self->svcnum. "\n";
2060     0;
2061   } else {
2062     warn "Can't check password: Unrecognized encryption for svcnum ".
2063          $self->svcnum. "\n";
2064     0;
2065   }
2066
2067 }
2068
2069 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2070
2071 Returns an encrypted password, either by passing through an encrypted password
2072 in the database or by encrypting a plaintext password from the database.
2073
2074 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2075 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2076 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2077 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2078 encryption type is only used if the password is not already encrypted in the
2079 database.
2080
2081 =cut
2082
2083 sub crypt_password {
2084   my $self = shift;
2085   #eventually should check a "password-encoding" field
2086   if ( length($self->_password) == 13
2087        || $self->_password =~ /^\$(1|2a?)\$/
2088        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2089      )
2090   {
2091     $self->_password;
2092   } else {
2093     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2094     if ( $encryption eq 'crypt' ) {
2095       crypt(
2096         $self->_password,
2097         $saltset[int(rand(64))].$saltset[int(rand(64))]
2098       );
2099     } elsif ( $encryption eq 'md5' ) {
2100       unix_md5_crypt( $self->_password );
2101     } elsif ( $encryption eq 'blowfish' ) {
2102       croak "unknown encryption method $encryption";
2103     } else {
2104       croak "unknown encryption method $encryption";
2105     }
2106   }
2107 }
2108
2109 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2110
2111 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2112 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
2113 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
2114
2115 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2116 to work the same as the B</crypt_password> method.
2117
2118 =cut
2119
2120 sub ldap_password {
2121   my $self = shift;
2122   #eventually should check a "password-encoding" field
2123   if ( length($self->_password) == 13 ) { #crypt
2124     return '{CRYPT}'. $self->_password;
2125   } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2126     return '{MD5}'. $1;
2127   } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2128     warn "Blowfish encryption not supported in this context, svcnum ".
2129          $self->svcnum. "\n";
2130     return '{CRYPT}*'; #unsupported, should not auth
2131   } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2132     return '{SSHA}'. $1;
2133   } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2134     return '{NS-MTA-MD5}'. $1;
2135   } else { #plaintext
2136     return '{PLAIN}'. $self->_password;
2137     #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2138     #if ( $encryption eq 'crypt' ) {
2139     #  return '{CRYPT}'. crypt(
2140     #    $self->_password,
2141     #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2142     #  );
2143     #} elsif ( $encryption eq 'md5' ) {
2144     #  unix_md5_crypt( $self->_password );
2145     #} elsif ( $encryption eq 'blowfish' ) {
2146     #  croak "unknown encryption method $encryption";
2147     #} else {
2148     #  croak "unknown encryption method $encryption";
2149     #}
2150   }
2151 }
2152
2153 =item domain_slash_username
2154
2155 Returns $domain/$username/
2156
2157 =cut
2158
2159 sub domain_slash_username {
2160   my $self = shift;
2161   $self->domain. '/'. $self->username. '/';
2162 }
2163
2164 =item virtual_maildir
2165
2166 Returns $domain/maildirs/$username/
2167
2168 =cut
2169
2170 sub virtual_maildir {
2171   my $self = shift;
2172   $self->domain. '/maildirs/'. $self->username. '/';
2173 }
2174
2175 =back
2176
2177 =head1 SUBROUTINES
2178
2179 =over 4
2180
2181 =item send_email
2182
2183 This is the FS::svc_acct job-queue-able version.  It still uses
2184 FS::Misc::send_email under-the-hood.
2185
2186 =cut
2187
2188 sub send_email {
2189   my %opt = @_;
2190
2191   eval "use FS::Misc qw(send_email)";
2192   die $@ if $@;
2193
2194   $opt{mimetype} ||= 'text/plain';
2195   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2196
2197   my $error = send_email(
2198     'from'         => $opt{from},
2199     'to'           => $opt{to},
2200     'subject'      => $opt{subject},
2201     'content-type' => $opt{mimetype},
2202     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2203   );
2204   die $error if $error;
2205 }
2206
2207 =item check_and_rebuild_fuzzyfiles
2208
2209 =cut
2210
2211 sub check_and_rebuild_fuzzyfiles {
2212   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2213   -e "$dir/svc_acct.username"
2214     or &rebuild_fuzzyfiles;
2215 }
2216
2217 =item rebuild_fuzzyfiles
2218
2219 =cut
2220
2221 sub rebuild_fuzzyfiles {
2222
2223   use Fcntl qw(:flock);
2224
2225   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2226
2227   #username
2228
2229   open(USERNAMELOCK,">>$dir/svc_acct.username")
2230     or die "can't open $dir/svc_acct.username: $!";
2231   flock(USERNAMELOCK,LOCK_EX)
2232     or die "can't lock $dir/svc_acct.username: $!";
2233
2234   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2235
2236   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2237     or die "can't open $dir/svc_acct.username.tmp: $!";
2238   print USERNAMECACHE join("\n", @all_username), "\n";
2239   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2240
2241   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2242   close USERNAMELOCK;
2243
2244 }
2245
2246 =item all_username
2247
2248 =cut
2249
2250 sub all_username {
2251   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2252   open(USERNAMECACHE,"<$dir/svc_acct.username")
2253     or die "can't open $dir/svc_acct.username: $!";
2254   my @array = map { chomp; $_; } <USERNAMECACHE>;
2255   close USERNAMECACHE;
2256   \@array;
2257 }
2258
2259 =item append_fuzzyfiles USERNAME
2260
2261 =cut
2262
2263 sub append_fuzzyfiles {
2264   my $username = shift;
2265
2266   &check_and_rebuild_fuzzyfiles;
2267
2268   use Fcntl qw(:flock);
2269
2270   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2271
2272   open(USERNAME,">>$dir/svc_acct.username")
2273     or die "can't open $dir/svc_acct.username: $!";
2274   flock(USERNAME,LOCK_EX)
2275     or die "can't lock $dir/svc_acct.username: $!";
2276
2277   print USERNAME "$username\n";
2278
2279   flock(USERNAME,LOCK_UN)
2280     or die "can't unlock $dir/svc_acct.username: $!";
2281   close USERNAME;
2282
2283   1;
2284 }
2285
2286
2287
2288 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2289
2290 =cut
2291
2292 sub radius_usergroup_selector {
2293   my $sel_groups = shift;
2294   my %sel_groups = map { $_=>1 } @$sel_groups;
2295
2296   my $selectname = shift || 'radius_usergroup';
2297
2298   my $dbh = dbh;
2299   my $sth = $dbh->prepare(
2300     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2301   ) or die $dbh->errstr;
2302   $sth->execute() or die $sth->errstr;
2303   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2304
2305   my $html = <<END;
2306     <SCRIPT>
2307     function ${selectname}_doadd(object) {
2308       var myvalue = object.${selectname}_add.value;
2309       var optionName = new Option(myvalue,myvalue,false,true);
2310       var length = object.$selectname.length;
2311       object.$selectname.options[length] = optionName;
2312       object.${selectname}_add.value = "";
2313     }
2314     </SCRIPT>
2315     <SELECT MULTIPLE NAME="$selectname">
2316 END
2317
2318   foreach my $group ( @all_groups ) {
2319     $html .= qq(<OPTION VALUE="$group");
2320     if ( $sel_groups{$group} ) {
2321       $html .= ' SELECTED';
2322       $sel_groups{$group} = 0;
2323     }
2324     $html .= ">$group</OPTION>\n";
2325   }
2326   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2327     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2328   };
2329   $html .= '</SELECT>';
2330
2331   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2332            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2333
2334   $html;
2335 }
2336
2337 =item reached_threshold
2338
2339 Performs some activities when svc_acct thresholds (such as number of seconds
2340 remaining) are reached.
2341
2342 =cut
2343
2344 sub reached_threshold {
2345   my %opt = @_;
2346
2347   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2348   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2349
2350   if ( $opt{'op'} eq '+' ){
2351     $svc_acct->setfield( $opt{'column'}.'_threshold',
2352                          int($svc_acct->getfield($opt{'column'})
2353                              * ( $conf->exists('svc_acct-usage_threshold')
2354                                  ? $conf->config('svc_acct-usage_threshold')/100
2355                                  : 0.80
2356                                )
2357                          )
2358                        );
2359     my $error = $svc_acct->replace;
2360     die $error if $error;
2361   }elsif ( $opt{'op'} eq '-' ){
2362
2363     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2364     return '' if ($threshold eq '' );
2365
2366     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2367     my $error = $svc_acct->replace;
2368     die $error if $error; # email next time, i guess
2369
2370     if ( $warning_template ) {
2371       eval "use FS::Misc qw(send_email)";
2372       die $@ if $@;
2373
2374       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2375       my $cust_main = $cust_pkg->cust_main;
2376
2377       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2378                                $cust_main->invoicing_list,
2379                                ($opt{'to'} ? $opt{'to'} : ())
2380                    );
2381
2382       my $mimetype = $warning_mimetype;
2383       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2384
2385       my $body       =  $warning_template->fill_in( HASH => {
2386                         'custnum'   => $cust_main->custnum,
2387                         'username'  => $svc_acct->username,
2388                         'password'  => $svc_acct->_password,
2389                         'first'     => $cust_main->first,
2390                         'last'      => $cust_main->getfield('last'),
2391                         'pkg'       => $cust_pkg->part_pkg->pkg,
2392                         'column'    => $opt{'column'},
2393                         'amount'    => $opt{'column'} =~/bytes/
2394                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2395                                        : $svc_acct->getfield($opt{'column'}),
2396                         'threshold' => $opt{'column'} =~/bytes/
2397                                        ? FS::UI::bytecount::display_bytecount($threshold)
2398                                        : $threshold,
2399                       } );
2400
2401
2402       my $error = send_email(
2403         'from'         => $warning_from,
2404         'to'           => $to,
2405         'subject'      => $warning_subject,
2406         'content-type' => $mimetype,
2407         'body'         => [ map "$_\n", split("\n", $body) ],
2408       );
2409       die $error if $error;
2410     }
2411   }else{
2412     die "unknown op: " . $opt{'op'};
2413   }
2414 }
2415
2416 =back
2417
2418 =head1 BUGS
2419
2420 The $recref stuff in sub check should be cleaned up.
2421
2422 The suspend, unsuspend and cancel methods update the database, but not the
2423 current object.  This is probably a bug as it's unexpected and
2424 counterintuitive.
2425
2426 radius_usergroup_selector?  putting web ui components in here?  they should
2427 probably live somewhere else...
2428
2429 insertion of RADIUS group stuff in insert could be done with child_objects now
2430 (would probably clean up export of them too)
2431
2432 =head1 SEE ALSO
2433
2434 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2435 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2436 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2437 L<freeside-queued>), L<FS::svc_acct_pop>,
2438 schema.html from the base documentation.
2439
2440 =cut
2441
2442 =item domain_select_hash %OPTIONS
2443
2444 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
2445 may at present purchase.
2446
2447 Currently available options are: I<pkgnum> I<svcpart>
2448
2449 =cut
2450
2451 sub domain_select_hash {
2452   my ($self, %options) = @_;
2453   my %domains = ();
2454   my $part_svc;
2455   my $cust_pkg;
2456
2457   if (ref($self)) {
2458     $part_svc = $self->part_svc;
2459     $cust_pkg = $self->cust_svc->cust_pkg
2460       if $self->cust_svc;
2461   }
2462
2463   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2464     if $options{'svcpart'};
2465
2466   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2467     if $options{'pkgnum'};
2468
2469   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2470                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2471     %domains = map { $_->svcnum => $_->domain }
2472                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2473                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2474   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2475     %domains = map { $_->svcnum => $_->domain }
2476                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2477                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2478                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2479   }else{
2480     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2481   }
2482
2483   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2484     my $svc_domain = qsearchs('svc_domain',
2485       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2486     if ( $svc_domain ) {
2487       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
2488     }else{
2489       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2490            $part_svc->part_svc_column('domsvc')->columnvalue;
2491
2492     }
2493   }
2494
2495   (%domains);
2496 }
2497
2498 1;
2499