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     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1586       if ($part_export->option('overlimit_groups')) {
1587         my ($new,$old);
1588         my $other = new FS::svc_acct $self->hashref;
1589         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1590                        ($self, $part_export->option('overlimit_groups'));
1591         $other->usergroup( $groups );
1592         if ($action eq 'suspend'){
1593           $new = $other; $old = $self;
1594         }else{
1595           $new = $self; $old = $other;
1596         }
1597         my $error = $part_export->export_replace($new, $old);
1598         $error ||= $self->overlimit($action);
1599         if ( $error ) {
1600           $dbh->rollback if $oldAutoCommit;
1601           return "Error replacing radius groups in export, ${op}: $error";
1602         }
1603       }
1604     }
1605   }
1606
1607   if ( $conf->exists("svc_acct-usage_$action")
1608        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1609     #my $error = $self->$action();
1610     my $error = $self->cust_svc->cust_pkg->$action();
1611     $error ||= $self->overlimit($action);
1612     if ( $error ) {
1613       $dbh->rollback if $oldAutoCommit;
1614       return "Error ${action}ing: $error";
1615     }
1616   }
1617
1618   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1619     my $wqueue = new FS::queue {
1620       'svcnum' => $self->svcnum,
1621       'job'    => 'FS::svc_acct::reached_threshold',
1622     };
1623
1624     my $to = '';
1625     if ($op eq '-'){
1626       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1627     }
1628
1629     # x_threshold race
1630     my $error = $wqueue->insert(
1631       'svcnum' => $self->svcnum,
1632       'op'     => $op,
1633       'column' => $column,
1634       'to'     => $to,
1635     );
1636     if ( $error ) {
1637       $dbh->rollback if $oldAutoCommit;
1638       return "Error queuing threshold activity: $error";
1639     }
1640   }
1641
1642   warn "$me update successful; committing\n"
1643     if $DEBUG;
1644   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1645   '';
1646
1647 }
1648
1649 sub set_usage {
1650   my( $self, $valueref ) = @_;
1651
1652   warn "$me set_usage called for svcnum ". $self->svcnum.
1653        ' ('. $self->email. "): ".
1654        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1655     if $DEBUG;
1656
1657   local $SIG{HUP} = 'IGNORE';
1658   local $SIG{INT} = 'IGNORE';
1659   local $SIG{QUIT} = 'IGNORE';
1660   local $SIG{TERM} = 'IGNORE';
1661   local $SIG{TSTP} = 'IGNORE';
1662   local $SIG{PIPE} = 'IGNORE';
1663
1664   local $FS::svc_Common::noexport_hack = 1;
1665   my $oldAutoCommit = $FS::UID::AutoCommit;
1666   local $FS::UID::AutoCommit = 0;
1667   my $dbh = dbh;
1668
1669   my $reset = 0;
1670   my %handyhash = ();
1671   foreach my $field (keys %$valueref){
1672     $reset = 1 if $valueref->{$field};
1673     $self->setfield($field, $valueref->{$field});
1674     $self->setfield( $field.'_threshold',
1675                      int($self->getfield($field)
1676                          * ( $conf->exists('svc_acct-usage_threshold')
1677                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1678                              : 0.20
1679                            )
1680                        )
1681                      );
1682     $handyhash{$field} = $self->getfield($field);
1683     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1684   }
1685   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1686   #die $error if $error;         #services not explicity changed via the UI
1687
1688   my $sql = "UPDATE svc_acct SET " .
1689     join (',', map { "$_ =  ?" } (keys %handyhash) ).
1690     " WHERE svcnum = ?";
1691
1692   warn "$me $sql\n"
1693     if $DEBUG;
1694
1695   if (scalar(keys %handyhash)) {
1696     my $sth = $dbh->prepare( $sql )
1697       or die "Error preparing $sql: ". $dbh->errstr;
1698     my $rv = $sth->execute((grep{$_} values %handyhash), $self->svcnum);
1699     die "Error executing $sql: ". $sth->errstr
1700       unless defined($rv);
1701     die "Can't update usage for svcnum ". $self->svcnum
1702       if $rv == 0;
1703   }
1704
1705   if ( $reset ) {
1706     my $error = $self->overlimit('unsuspend');
1707
1708     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1709       if ($part_export->option('overlimit_groups')) {
1710         my $old = new FS::svc_acct $self->hashref;
1711         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1712                        ($self, $part_export->option('overlimit_groups'));
1713         $old->usergroup( $groups );
1714         $error ||= $part_export->export_replace($self, $old);
1715       }
1716     }
1717
1718     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1719       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1720     }
1721     if ( $error ) {
1722       $dbh->rollback if $oldAutoCommit;
1723       return "Error unsuspending: $error";
1724     }
1725   }
1726
1727   warn "$me update successful; committing\n"
1728     if $DEBUG;
1729   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1730   '';
1731
1732 }
1733
1734
1735 =item recharge HASHREF
1736
1737   Increments usage columns by the amount specified in HASHREF as
1738   column=>amount pairs.
1739
1740 =cut
1741
1742 sub recharge {
1743   my ($self, $vhash) = @_;
1744
1745   if ( $DEBUG ) {
1746     warn "[$me] recharge called on $self: ". Dumper($self).
1747          "\nwith vhash: ". Dumper($vhash);
1748   }
1749
1750   my $oldAutoCommit = $FS::UID::AutoCommit;
1751   local $FS::UID::AutoCommit = 0;
1752   my $dbh = dbh;
1753   my $error = '';
1754
1755   foreach my $column (keys %$vhash){
1756     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1757   }
1758
1759   if ( $error ) {
1760     $dbh->rollback if $oldAutoCommit;
1761   }else{
1762     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1763   }
1764   return $error;
1765 }
1766
1767 =item is_rechargeable
1768
1769 Returns true if this svc_account can be "recharged" and false otherwise.
1770
1771 =cut
1772
1773 sub is_rechargable {
1774   my $self = shift;
1775   $self->seconds ne ''
1776     || $self->upbytes ne ''
1777     || $self->downbytes ne ''
1778     || $self->totalbytes ne '';
1779 }
1780
1781 =item seconds_since TIMESTAMP
1782
1783 Returns the number of seconds this account has been online since TIMESTAMP,
1784 according to the session monitor (see L<FS::Session>).
1785
1786 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1787 L<Time::Local> and L<Date::Parse> for conversion functions.
1788
1789 =cut
1790
1791 #note: POD here, implementation in FS::cust_svc
1792 sub seconds_since {
1793   my $self = shift;
1794   $self->cust_svc->seconds_since(@_);
1795 }
1796
1797 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1798
1799 Returns the numbers of seconds this account has been online between
1800 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1801 external SQL radacct table, specified via sqlradius export.  Sessions which
1802 started in the specified range but are still open are counted from session
1803 start to the end of the range (unless they are over 1 day old, in which case
1804 they are presumed missing their stop record and not counted).  Also, sessions
1805 which end in the range but started earlier are counted from the start of the
1806 range to session end.  Finally, sessions which start before the range but end
1807 after are counted for the entire range.
1808
1809 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1810 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1811 functions.
1812
1813 =cut
1814
1815 #note: POD here, implementation in FS::cust_svc
1816 sub seconds_since_sqlradacct {
1817   my $self = shift;
1818   $self->cust_svc->seconds_since_sqlradacct(@_);
1819 }
1820
1821 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1822
1823 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1824 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1825 TIMESTAMP_END (exclusive).
1826
1827 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1828 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1829 functions.
1830
1831 =cut
1832
1833 #note: POD here, implementation in FS::cust_svc
1834 sub attribute_since_sqlradacct {
1835   my $self = shift;
1836   $self->cust_svc->attribute_since_sqlradacct(@_);
1837 }
1838
1839 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1840
1841 Returns an array of hash references of this customers login history for the
1842 given time range.  (document this better)
1843
1844 =cut
1845
1846 sub get_session_history {
1847   my $self = shift;
1848   $self->cust_svc->get_session_history(@_);
1849 }
1850
1851 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1852
1853 =cut
1854
1855 sub get_cdrs {
1856   my($self, $start, $end, %opt ) = @_;
1857
1858   my $did = $self->username; #yup
1859
1860   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1861
1862   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1863
1864   #SELECT $for_update * FROM cdr
1865   #  WHERE calldate >= $start #need a conversion
1866   #    AND calldate <  $end   #ditto
1867   #    AND (    charged_party = "$did"
1868   #          OR charged_party = "$prefix$did" #if length($prefix);
1869   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1870   #               AND
1871   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1872   #             )
1873   #        )
1874   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1875
1876   my $charged_or_src;
1877   if ( length($prefix) ) {
1878     $charged_or_src =
1879       " AND (    charged_party = '$did'
1880               OR charged_party = '$prefix$did'
1881               OR ( ( charged_party IS NULL OR charged_party = '' )
1882                    AND
1883                    ( src = '$did' OR src = '$prefix$did' )
1884                  )
1885             )
1886       ";
1887   } else {
1888     $charged_or_src =
1889       " AND (    charged_party = '$did'
1890               OR ( ( charged_party IS NULL OR charged_party = '' )
1891                    AND
1892                    src = '$did'
1893                  )
1894             )
1895       ";
1896
1897   }
1898
1899   qsearch(
1900     'select'    => "$for_update *",
1901     'table'     => 'cdr',
1902     'hashref'   => {
1903                      #( freesidestatus IS NULL OR freesidestatus = '' )
1904                      'freesidestatus' => '',
1905                    },
1906     'extra_sql' => $charged_or_src,
1907
1908   );
1909
1910 }
1911
1912 =item radius_groups
1913
1914 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1915
1916 =cut
1917
1918 sub radius_groups {
1919   my $self = shift;
1920   if ( $self->usergroup ) {
1921     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1922       unless ref($self->usergroup) eq 'ARRAY';
1923     #when provisioning records, export callback runs in svc_Common.pm before
1924     #radius_usergroup records can be inserted...
1925     @{$self->usergroup};
1926   } else {
1927     map { $_->groupname }
1928       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1929   }
1930 }
1931
1932 =item clone_suspended
1933
1934 Constructor used by FS::part_export::_export_suspend fallback.  Document
1935 better.
1936
1937 =cut
1938
1939 sub clone_suspended {
1940   my $self = shift;
1941   my %hash = $self->hash;
1942   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1943   new FS::svc_acct \%hash;
1944 }
1945
1946 =item clone_kludge_unsuspend
1947
1948 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1949 better.
1950
1951 =cut
1952
1953 sub clone_kludge_unsuspend {
1954   my $self = shift;
1955   my %hash = $self->hash;
1956   $hash{_password} = '';
1957   new FS::svc_acct \%hash;
1958 }
1959
1960 =item check_password
1961
1962 Checks the supplied password against the (possibly encrypted) password in the
1963 database.  Returns true for a successful authentication, false for no match.
1964
1965 Currently supported encryptions are: classic DES crypt() and MD5
1966
1967 =cut
1968
1969 sub check_password {
1970   my($self, $check_password) = @_;
1971
1972   #remove old-style SUSPENDED kludge, they should be allowed to login to
1973   #self-service and pay up
1974   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1975
1976   #eventually should check a "password-encoding" field
1977   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1978     return 0;
1979   } elsif ( length($password) < 13 ) { #plaintext
1980     $check_password eq $password;
1981   } elsif ( length($password) == 13 ) { #traditional DES crypt
1982     crypt($check_password, $password) eq $password;
1983   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1984     unix_md5_crypt($check_password, $password) eq $password;
1985   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1986     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1987          $self->svcnum. "\n";
1988     0;
1989   } else {
1990     warn "Can't check password: Unrecognized encryption for svcnum ".
1991          $self->svcnum. "\n";
1992     0;
1993   }
1994
1995 }
1996
1997 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1998
1999 Returns an encrypted password, either by passing through an encrypted password
2000 in the database or by encrypting a plaintext password from the database.
2001
2002 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2003 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2004 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2005 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2006 encryption type is only used if the password is not already encrypted in the
2007 database.
2008
2009 =cut
2010
2011 sub crypt_password {
2012   my $self = shift;
2013   #eventually should check a "password-encoding" field
2014   if ( length($self->_password) == 13
2015        || $self->_password =~ /^\$(1|2a?)\$/
2016        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2017      )
2018   {
2019     $self->_password;
2020   } else {
2021     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2022     if ( $encryption eq 'crypt' ) {
2023       crypt(
2024         $self->_password,
2025         $saltset[int(rand(64))].$saltset[int(rand(64))]
2026       );
2027     } elsif ( $encryption eq 'md5' ) {
2028       unix_md5_crypt( $self->_password );
2029     } elsif ( $encryption eq 'blowfish' ) {
2030       croak "unknown encryption method $encryption";
2031     } else {
2032       croak "unknown encryption method $encryption";
2033     }
2034   }
2035 }
2036
2037 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2038
2039 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2040 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
2041 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
2042
2043 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2044 to work the same as the B</crypt_password> method.
2045
2046 =cut
2047
2048 sub ldap_password {
2049   my $self = shift;
2050   #eventually should check a "password-encoding" field
2051   if ( length($self->_password) == 13 ) { #crypt
2052     return '{CRYPT}'. $self->_password;
2053   } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2054     return '{MD5}'. $1;
2055   } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2056     die "Blowfish encryption not supported in this context, svcnum ".
2057         $self->svcnum. "\n";
2058   } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2059     return '{SSHA}'. $1;
2060   } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2061     return '{NS-MTA-MD5}'. $1;
2062   } else { #plaintext
2063     return '{PLAIN}'. $self->_password;
2064     #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2065     #if ( $encryption eq 'crypt' ) {
2066     #  return '{CRYPT}'. crypt(
2067     #    $self->_password,
2068     #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2069     #  );
2070     #} elsif ( $encryption eq 'md5' ) {
2071     #  unix_md5_crypt( $self->_password );
2072     #} elsif ( $encryption eq 'blowfish' ) {
2073     #  croak "unknown encryption method $encryption";
2074     #} else {
2075     #  croak "unknown encryption method $encryption";
2076     #}
2077   }
2078 }
2079
2080 =item domain_slash_username
2081
2082 Returns $domain/$username/
2083
2084 =cut
2085
2086 sub domain_slash_username {
2087   my $self = shift;
2088   $self->domain. '/'. $self->username. '/';
2089 }
2090
2091 =item virtual_maildir
2092
2093 Returns $domain/maildirs/$username/
2094
2095 =cut
2096
2097 sub virtual_maildir {
2098   my $self = shift;
2099   $self->domain. '/maildirs/'. $self->username. '/';
2100 }
2101
2102 =back
2103
2104 =head1 SUBROUTINES
2105
2106 =over 4
2107
2108 =item send_email
2109
2110 This is the FS::svc_acct job-queue-able version.  It still uses
2111 FS::Misc::send_email under-the-hood.
2112
2113 =cut
2114
2115 sub send_email {
2116   my %opt = @_;
2117
2118   eval "use FS::Misc qw(send_email)";
2119   die $@ if $@;
2120
2121   $opt{mimetype} ||= 'text/plain';
2122   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2123
2124   my $error = send_email(
2125     'from'         => $opt{from},
2126     'to'           => $opt{to},
2127     'subject'      => $opt{subject},
2128     'content-type' => $opt{mimetype},
2129     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2130   );
2131   die $error if $error;
2132 }
2133
2134 =item check_and_rebuild_fuzzyfiles
2135
2136 =cut
2137
2138 sub check_and_rebuild_fuzzyfiles {
2139   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2140   -e "$dir/svc_acct.username"
2141     or &rebuild_fuzzyfiles;
2142 }
2143
2144 =item rebuild_fuzzyfiles
2145
2146 =cut
2147
2148 sub rebuild_fuzzyfiles {
2149
2150   use Fcntl qw(:flock);
2151
2152   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2153
2154   #username
2155
2156   open(USERNAMELOCK,">>$dir/svc_acct.username")
2157     or die "can't open $dir/svc_acct.username: $!";
2158   flock(USERNAMELOCK,LOCK_EX)
2159     or die "can't lock $dir/svc_acct.username: $!";
2160
2161   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2162
2163   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2164     or die "can't open $dir/svc_acct.username.tmp: $!";
2165   print USERNAMECACHE join("\n", @all_username), "\n";
2166   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2167
2168   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2169   close USERNAMELOCK;
2170
2171 }
2172
2173 =item all_username
2174
2175 =cut
2176
2177 sub all_username {
2178   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2179   open(USERNAMECACHE,"<$dir/svc_acct.username")
2180     or die "can't open $dir/svc_acct.username: $!";
2181   my @array = map { chomp; $_; } <USERNAMECACHE>;
2182   close USERNAMECACHE;
2183   \@array;
2184 }
2185
2186 =item append_fuzzyfiles USERNAME
2187
2188 =cut
2189
2190 sub append_fuzzyfiles {
2191   my $username = shift;
2192
2193   &check_and_rebuild_fuzzyfiles;
2194
2195   use Fcntl qw(:flock);
2196
2197   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2198
2199   open(USERNAME,">>$dir/svc_acct.username")
2200     or die "can't open $dir/svc_acct.username: $!";
2201   flock(USERNAME,LOCK_EX)
2202     or die "can't lock $dir/svc_acct.username: $!";
2203
2204   print USERNAME "$username\n";
2205
2206   flock(USERNAME,LOCK_UN)
2207     or die "can't unlock $dir/svc_acct.username: $!";
2208   close USERNAME;
2209
2210   1;
2211 }
2212
2213
2214
2215 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2216
2217 =cut
2218
2219 sub radius_usergroup_selector {
2220   my $sel_groups = shift;
2221   my %sel_groups = map { $_=>1 } @$sel_groups;
2222
2223   my $selectname = shift || 'radius_usergroup';
2224
2225   my $dbh = dbh;
2226   my $sth = $dbh->prepare(
2227     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2228   ) or die $dbh->errstr;
2229   $sth->execute() or die $sth->errstr;
2230   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2231
2232   my $html = <<END;
2233     <SCRIPT>
2234     function ${selectname}_doadd(object) {
2235       var myvalue = object.${selectname}_add.value;
2236       var optionName = new Option(myvalue,myvalue,false,true);
2237       var length = object.$selectname.length;
2238       object.$selectname.options[length] = optionName;
2239       object.${selectname}_add.value = "";
2240     }
2241     </SCRIPT>
2242     <SELECT MULTIPLE NAME="$selectname">
2243 END
2244
2245   foreach my $group ( @all_groups ) {
2246     $html .= qq(<OPTION VALUE="$group");
2247     if ( $sel_groups{$group} ) {
2248       $html .= ' SELECTED';
2249       $sel_groups{$group} = 0;
2250     }
2251     $html .= ">$group</OPTION>\n";
2252   }
2253   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2254     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2255   };
2256   $html .= '</SELECT>';
2257
2258   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2259            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2260
2261   $html;
2262 }
2263
2264 =item reached_threshold
2265
2266 Performs some activities when svc_acct thresholds (such as number of seconds
2267 remaining) are reached.
2268
2269 =cut
2270
2271 sub reached_threshold {
2272   my %opt = @_;
2273
2274   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2275   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2276
2277   if ( $opt{'op'} eq '+' ){
2278     $svc_acct->setfield( $opt{'column'}.'_threshold',
2279                          int($svc_acct->getfield($opt{'column'})
2280                              * ( $conf->exists('svc_acct-usage_threshold')
2281                                  ? $conf->config('svc_acct-usage_threshold')/100
2282                                  : 0.80
2283                                )
2284                          )
2285                        );
2286     my $error = $svc_acct->replace;
2287     die $error if $error;
2288   }elsif ( $opt{'op'} eq '-' ){
2289
2290     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2291     return '' if ($threshold eq '' );
2292
2293     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2294     my $error = $svc_acct->replace;
2295     die $error if $error; # email next time, i guess
2296
2297     if ( $warning_template ) {
2298       eval "use FS::Misc qw(send_email)";
2299       die $@ if $@;
2300
2301       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2302       my $cust_main = $cust_pkg->cust_main;
2303
2304       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2305                                $cust_main->invoicing_list,
2306                                ($opt{'to'} ? $opt{'to'} : ())
2307                    );
2308
2309       my $mimetype = $warning_mimetype;
2310       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2311
2312       my $body       =  $warning_template->fill_in( HASH => {
2313                         'custnum'   => $cust_main->custnum,
2314                         'username'  => $svc_acct->username,
2315                         'password'  => $svc_acct->_password,
2316                         'first'     => $cust_main->first,
2317                         'last'      => $cust_main->getfield('last'),
2318                         'pkg'       => $cust_pkg->part_pkg->pkg,
2319                         'column'    => $opt{'column'},
2320                         'amount'    => $svc_acct->getfield($opt{'column'}),
2321                         'threshold' => $threshold,
2322                       } );
2323
2324
2325       my $error = send_email(
2326         'from'         => $warning_from,
2327         'to'           => $to,
2328         'subject'      => $warning_subject,
2329         'content-type' => $mimetype,
2330         'body'         => [ map "$_\n", split("\n", $body) ],
2331       );
2332       die $error if $error;
2333     }
2334   }else{
2335     die "unknown op: " . $opt{'op'};
2336   }
2337 }
2338
2339 =back
2340
2341 =head1 BUGS
2342
2343 The $recref stuff in sub check should be cleaned up.
2344
2345 The suspend, unsuspend and cancel methods update the database, but not the
2346 current object.  This is probably a bug as it's unexpected and
2347 counterintuitive.
2348
2349 radius_usergroup_selector?  putting web ui components in here?  they should
2350 probably live somewhere else...
2351
2352 insertion of RADIUS group stuff in insert could be done with child_objects now
2353 (would probably clean up export of them too)
2354
2355 =head1 SEE ALSO
2356
2357 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2358 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2359 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2360 L<freeside-queued>), L<FS::svc_acct_pop>,
2361 schema.html from the base documentation.
2362
2363 =cut
2364
2365 1;
2366