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