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