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
  10              $password_noampersand $password_noexclamation
  11              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
  12              $smtpmachine
  13              $radius_password $radius_ip
  14              $dirhash
  15              @saltset @pw_set );
  16 use Carp;
  17 use Fcntl qw(:flock);
  18 use Crypt::PasswdMD5 1.2;
  19 use FS::UID qw( datasrc );
  20 use FS::Conf;
  21 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  22 use FS::svc_Common;
  23 use FS::cust_svc;
  24 use FS::part_svc;
  25 use FS::svc_acct_pop;
  26 use FS::cust_main_invoice;
  27 use FS::svc_domain;
  28 use FS::raddb;
  29 use FS::queue;
  30 use FS::radius_usergroup;
  31 use FS::export_svc;
  32 use FS::part_export;
  33 use FS::Msgcat qw(gettext);
  34 use FS::svc_forward;
  35 use FS::svc_www;
  36
  37 @ISA = qw( FS::svc_Common );
  38
  39 $DEBUG = 0;
  40 #$DEBUG = 1;
  41 $me = '[FS::svc_acct]';
  42
  43 #ask FS::UID to run this stuff for us later
  44 $FS::UID::callback{'FS::svc_acct'} = sub {
  45   $conf = new FS::Conf;
  46   $dir_prefix = $conf->config('home');
  47   @shells = $conf->config('shells');
  48   $usernamemin = $conf->config('usernamemin') || 2;
  49   $usernamemax = $conf->config('usernamemax');
  50   $passwordmin = $conf->config('passwordmin') || 6;
  51   $passwordmax = $conf->config('passwordmax') || 8;
  52   $username_letter = $conf->exists('username-letter');
  53   $username_letterfirst = $conf->exists('username-letterfirst');
  54   $username_noperiod = $conf->exists('username-noperiod');
  55   $username_nounderscore = $conf->exists('username-nounderscore');
  56   $username_nodash = $conf->exists('username-nodash');
  57   $username_uppercase = $conf->exists('username-uppercase');
  58   $username_ampersand = $conf->exists('username-ampersand');
  59   $password_noampersand = $conf->exists('password-noexclamation');
  60   $password_noexclamation = $conf->exists('password-noexclamation');
  61   $dirhash = $conf->config('dirhash') || 0;
  62   if ( $conf->exists('welcome_email') ) {
  63     $welcome_template = new Text::Template (
  64       TYPE   => 'ARRAY',
  65       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  66     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  67     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  68     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  69     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  70   } else {
  71     $welcome_template = '';
  72     $welcome_from = '';
  73     $welcome_subject = '';
  74     $welcome_mimetype = '';
  75   }
  76   $smtpmachine = $conf->config('smtpmachine');
  77   $radius_password = $conf->config('radius-password') || 'Password';
  78   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  79 };
  80
  81 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  82 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  83
  84 sub _cache {
  85   my $self = shift;
  86   my ( $hashref, $cache ) = @_;
  87   if ( $hashref->{'svc_acct_svcnum'} ) {
  88     $self->{'_domsvc'} = FS::svc_domain->new( {
  89       'svcnum'   => $hashref->{'domsvc'},
  90       'domain'   => $hashref->{'svc_acct_domain'},
  91       'catchall' => $hashref->{'svc_acct_catchall'},
  92     } );
  93   }
  94 }
  95
  96 =head1 NAME
  97
  98 FS::svc_acct - Object methods for svc_acct records
  99
 100 =head1 SYNOPSIS
 101
 102   use FS::svc_acct;
 103
 104   $record = new FS::svc_acct \%hash;
 105   $record = new FS::svc_acct { 'column' => 'value' };
 106
 107   $error = $record->insert;
 108
 109   $error = $new_record->replace($old_record);
 110
 111   $error = $record->delete;
 112
 113   $error = $record->check;
 114
 115   $error = $record->suspend;
 116
 117   $error = $record->unsuspend;
 118
 119   $error = $record->cancel;
 120
 121   %hash = $record->radius;
 122
 123   %hash = $record->radius_reply;
 124
 125   %hash = $record->radius_check;
 126
 127   $domain = $record->domain;
 128
 129   $svc_domain = $record->svc_domain;
 130
 131   $email = $record->email;
 132
 133   $seconds_since = $record->seconds_since($timestamp);
 134
 135 =head1 DESCRIPTION
 136
 137 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 138 FS::svc_Common.  The following fields are currently supported:
 139
 140 =over 4
 141
 142 =item svcnum - primary key (assigned automatcially for new accounts)
 143
 144 =item username
 145
 146 =item _password - generated if blank
 147
 148 =item sec_phrase - security phrase
 149
 150 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 151
 152 =item uid
 153
 154 =item gid
 155
 156 =item finger - GECOS
 157
 158 =item dir - set automatically if blank (and uid is not)
 159
 160 =item shell
 161
 162 =item quota - (unimplementd)
 163
 164 =item slipip - IP address
 165
 166 =item seconds -
 167
 168 =item domsvc - svcnum from svc_domain
 169
 170 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 171
 172 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 173
 174 =back
 175
 176 =head1 METHODS
 177
 178 =over 4
 179
 180 =item new HASHREF
 181
 182 Creates a new account.  To add the account to the database, see L<"insert">.
 183
 184 =cut
 185
 186 sub table { 'svc_acct'; }
 187
 188 =item insert [ , OPTION => VALUE ... ]
 189
 190 Adds this account to the database.  If there is an error, returns the error,
 191 otherwise returns false.
 192
 193 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 194 defined.  An FS::cust_svc record will be created and inserted.
 195
 196 The additional field I<usergroup> can optionally be defined; if so it should
 197 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 198
 199 The additional field I<child_objects> can optionally be defined; if so it
 200 should contain an arrayref of FS::tablename objects.  They will have their
 201 svcnum fields set and will be inserted after this record, but before any
 202 exports are run.  Each element of the array can also optionally be a
 203 two-element array reference containing the child object and the name of an
 204 alternate field to be filled in with the newly-inserted svcnum, for example
 205 C<[ $svc_forward, 'srcsvc' ]>
 206
 207 Currently available options are: I<depend_jobnum>
 208
 209 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 210 jobnums), all provisioning jobs will have a dependancy on the supplied
 211 jobnum(s) (they will not run until the specific job(s) complete(s)).
 212
 213 (TODOC: L<FS::queue> and L<freeside-queued>)
 214
 215 (TODOC: new exports!)
 216
 217 =cut
 218
 219 sub insert {
 220   my $self = shift;
 221   my %options = @_;
 222   my $error;
 223
 224   local $SIG{HUP} = 'IGNORE';
 225   local $SIG{INT} = 'IGNORE';
 226   local $SIG{QUIT} = 'IGNORE';
 227   local $SIG{TERM} = 'IGNORE';
 228   local $SIG{TSTP} = 'IGNORE';
 229   local $SIG{PIPE} = 'IGNORE';
 230
 231   my $oldAutoCommit = $FS::UID::AutoCommit;
 232   local $FS::UID::AutoCommit = 0;
 233   my $dbh = dbh;
 234
 235   $error = $self->check;
 236   return $error if $error;
 237
 238   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 239     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 240     unless ( $cust_svc ) {
 241       $dbh->rollback if $oldAutoCommit;
 242       return "no cust_svc record found for svcnum ". $self->svcnum;
 243     }
 244     $self->pkgnum($cust_svc->pkgnum);
 245     $self->svcpart($cust_svc->svcpart);
 246   }
 247
 248   $error = $self->_check_duplicate;
 249   if ( $error ) {
 250     $dbh->rollback if $oldAutoCommit;
 251     return $error;
 252   }
 253
 254   my @jobnums;
 255   $error = $self->SUPER::insert(
 256     'jobnums'       => \@jobnums,
 257     'child_objects' => $self->child_objects,
 258     %options,
 259   );
 260   if ( $error ) {
 261     $dbh->rollback if $oldAutoCommit;
 262     return $error;
 263   }
 264
 265   if ( $self->usergroup ) {
 266     foreach my $groupname ( @{$self->usergroup} ) {
 267       my $radius_usergroup = new FS::radius_usergroup ( {
 268         svcnum    => $self->svcnum,
 269         groupname => $groupname,
 270       } );
 271       my $error = $radius_usergroup->insert;
 272       if ( $error ) {
 273         $dbh->rollback if $oldAutoCommit;
 274         return $error;
 275       }
 276     }
 277   }
 278
 279   unless ( $skip_fuzzyfiles ) {
 280     $error = $self->queue_fuzzyfiles_update;
 281     if ( $error ) {
 282       $dbh->rollback if $oldAutoCommit;
 283       return "updating fuzzy search cache: $error";
 284     }
 285   }
 286
 287   my $cust_pkg = $self->cust_svc->cust_pkg;
 288
 289   if ( $cust_pkg ) {
 290     my $cust_main = $cust_pkg->cust_main;
 291
 292     if ( $conf->exists('emailinvoiceauto') ) {
 293       my @invoicing_list = $cust_main->invoicing_list;
 294       push @invoicing_list, $self->email;
 295       $cust_main->invoicing_list(\@invoicing_list);
 296     }
 297
 298     #welcome email
 299     my $to = '';
 300     if ( $welcome_template && $cust_pkg ) {
 301       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 302       if ( $to ) {
 303         my $wqueue = new FS::queue {
 304           'svcnum' => $self->svcnum,
 305           'job'    => 'FS::svc_acct::send_email'
 306         };
 307         my $error = $wqueue->insert(
 308           'to'       => $to,
 309           'from'     => $welcome_from,
 310           'subject'  => $welcome_subject,
 311           'mimetype' => $welcome_mimetype,
 312           'body'     => $welcome_template->fill_in( HASH => {
 313                           'custnum'  => $self->custnum,
 314                           'username' => $self->username,
 315                           'password' => $self->_password,
 316                           'first'    => $cust_main->first,
 317                           'last'     => $cust_main->getfield('last'),
 318                           'pkg'      => $cust_pkg->part_pkg->pkg,
 319                         } ),
 320         );
 321         if ( $error ) {
 322           $dbh->rollback if $oldAutoCommit;
 323           return "error queuing welcome email: $error";
 324         }
 325
 326         if ( $options{'depend_jobnum'} ) {
 327           warn "$me depend_jobnum found; adding to welcome email dependancies"
 328             if $DEBUG;
 329           if ( ref($options{'depend_jobnum'}) ) {
 330             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 331                  "to welcome email dependancies"
 332               if $DEBUG;
 333             push @jobnums, @{ $options{'depend_jobnum'} };
 334           } else {
 335             warn "$me adding job $options{'depend_jobnum'} ".
 336                  "to welcome email dependancies"
 337               if $DEBUG;
 338             push @jobnums, $options{'depend_jobnum'};
 339           }
 340         }
 341
 342         foreach my $jobnum ( @jobnums ) {
 343           my $error = $wqueue->depend_insert($jobnum);
 344           if ( $error ) {
 345             $dbh->rollback if $oldAutoCommit;
 346             return "error queuing welcome email job dependancy: $error";
 347           }
 348         }
 349
 350       }
 351
 352     }
 353
 354   } # if ( $cust_pkg )
 355
 356   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 357   ''; #no error
 358 }
 359
 360 =item delete
 361
 362 Deletes this account from the database.  If there is an error, returns the
 363 error, otherwise returns false.
 364
 365 The corresponding FS::cust_svc record will be deleted as well.
 366
 367 (TODOC: new exports!)
 368
 369 =cut
 370
 371 sub delete {
 372   my $self = shift;
 373
 374   return "can't delete system account" if $self->_check_system;
 375
 376   return "Can't delete an account which is a (svc_forward) source!"
 377     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 378
 379   return "Can't delete an account which is a (svc_forward) destination!"
 380     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 381
 382   return "Can't delete an account with (svc_www) web service!"
 383     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 384
 385   # what about records in session ? (they should refer to history table)
 386
 387   local $SIG{HUP} = 'IGNORE';
 388   local $SIG{INT} = 'IGNORE';
 389   local $SIG{QUIT} = 'IGNORE';
 390   local $SIG{TERM} = 'IGNORE';
 391   local $SIG{TSTP} = 'IGNORE';
 392   local $SIG{PIPE} = 'IGNORE';
 393
 394   my $oldAutoCommit = $FS::UID::AutoCommit;
 395   local $FS::UID::AutoCommit = 0;
 396   my $dbh = dbh;
 397
 398   foreach my $cust_main_invoice (
 399     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 400   ) {
 401     unless ( defined($cust_main_invoice) ) {
 402       warn "WARNING: something's wrong with qsearch";
 403       next;
 404     }
 405     my %hash = $cust_main_invoice->hash;
 406     $hash{'dest'} = $self->email;
 407     my $new = new FS::cust_main_invoice \%hash;
 408     my $error = $new->replace($cust_main_invoice);
 409     if ( $error ) {
 410       $dbh->rollback if $oldAutoCommit;
 411       return $error;
 412     }
 413   }
 414
 415   foreach my $svc_domain (
 416     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 417   ) {
 418     my %hash = new FS::svc_domain->hash;
 419     $hash{'catchall'} = '';
 420     my $new = new FS::svc_domain \%hash;
 421     my $error = $new->replace($svc_domain);
 422     if ( $error ) {
 423       $dbh->rollback if $oldAutoCommit;
 424       return $error;
 425     }
 426   }
 427
 428   foreach my $radius_usergroup (
 429     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 430   ) {
 431     my $error = $radius_usergroup->delete;
 432     if ( $error ) {
 433       $dbh->rollback if $oldAutoCommit;
 434       return $error;
 435     }
 436   }
 437
 438   my $error = $self->SUPER::delete;
 439   if ( $error ) {
 440     $dbh->rollback if $oldAutoCommit;
 441     return $error;
 442   }
 443
 444   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 445   '';
 446 }
 447
 448 =item replace OLD_RECORD
 449
 450 Replaces OLD_RECORD with this one in the database.  If there is an error,
 451 returns the error, otherwise returns false.
 452
 453 The additional field I<usergroup> can optionally be defined; if so it should
 454 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 455
 456
 457 =cut
 458
 459 sub replace {
 460   my ( $new, $old ) = ( shift, shift );
 461   my $error;
 462   warn "$me replacing $old with $new\n" if $DEBUG;
 463
 464   return "can't modify system account" if $old->_check_system;
 465
 466   {
 467     #no warnings 'numeric';  #alas, a 5.006-ism
 468     local($^W) = 0;
 469     return "Can't change uid!" if $old->uid != $new->uid;
 470   }
 471
 472   #change homdir when we change username
 473   $new->setfield('dir', '') if $old->username ne $new->username;
 474
 475   local $SIG{HUP} = 'IGNORE';
 476   local $SIG{INT} = 'IGNORE';
 477   local $SIG{QUIT} = 'IGNORE';
 478   local $SIG{TERM} = 'IGNORE';
 479   local $SIG{TSTP} = 'IGNORE';
 480   local $SIG{PIPE} = 'IGNORE';
 481
 482   my $oldAutoCommit = $FS::UID::AutoCommit;
 483   local $FS::UID::AutoCommit = 0;
 484   my $dbh = dbh;
 485
 486   # redundant, but so $new->usergroup gets set
 487   $error = $new->check;
 488   return $error if $error;
 489
 490   $old->usergroup( [ $old->radius_groups ] );
 491   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 492   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 493   if ( $new->usergroup ) {
 494     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 495     my @newgroups = @{$new->usergroup};
 496     foreach my $oldgroup ( @{$old->usergroup} ) {
 497       if ( grep { $oldgroup eq $_ } @newgroups ) {
 498         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 499         next;
 500       }
 501       my $radius_usergroup = qsearchs('radius_usergroup', {
 502         svcnum    => $old->svcnum,
 503         groupname => $oldgroup,
 504       } );
 505       my $error = $radius_usergroup->delete;
 506       if ( $error ) {
 507         $dbh->rollback if $oldAutoCommit;
 508         return "error deleting radius_usergroup $oldgroup: $error";
 509       }
 510     }
 511
 512     foreach my $newgroup ( @newgroups ) {
 513       my $radius_usergroup = new FS::radius_usergroup ( {
 514         svcnum    => $new->svcnum,
 515         groupname => $newgroup,
 516       } );
 517       my $error = $radius_usergroup->insert;
 518       if ( $error ) {
 519         $dbh->rollback if $oldAutoCommit;
 520         return "error adding radius_usergroup $newgroup: $error";
 521       }
 522     }
 523
 524   }
 525
 526   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 527     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 528     $error = $new->_check_duplicate;
 529     if ( $error ) {
 530       $dbh->rollback if $oldAutoCommit;
 531       return $error;
 532     }
 533   }
 534
 535   $error = $new->SUPER::replace($old);
 536   if ( $error ) {
 537     $dbh->rollback if $oldAutoCommit;
 538     return $error if $error;
 539   }
 540
 541   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 542     $error = $new->queue_fuzzyfiles_update;
 543     if ( $error ) {
 544       $dbh->rollback if $oldAutoCommit;
 545       return "updating fuzzy search cache: $error";
 546     }
 547   }
 548
 549   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 550   ''; #no error
 551 }
 552
 553 =item queue_fuzzyfiles_update
 554
 555 Used by insert & replace to update the fuzzy search cache
 556
 557 =cut
 558
 559 sub queue_fuzzyfiles_update {
 560   my $self = shift;
 561
 562   local $SIG{HUP} = 'IGNORE';
 563   local $SIG{INT} = 'IGNORE';
 564   local $SIG{QUIT} = 'IGNORE';
 565   local $SIG{TERM} = 'IGNORE';
 566   local $SIG{TSTP} = 'IGNORE';
 567   local $SIG{PIPE} = 'IGNORE';
 568
 569   my $oldAutoCommit = $FS::UID::AutoCommit;
 570   local $FS::UID::AutoCommit = 0;
 571   my $dbh = dbh;
 572
 573   my $queue = new FS::queue {
 574     'svcnum' => $self->svcnum,
 575     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 576   };
 577   my $error = $queue->insert($self->username);
 578   if ( $error ) {
 579     $dbh->rollback if $oldAutoCommit;
 580     return "queueing job (transaction rolled back): $error";
 581   }
 582
 583   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 584   '';
 585
 586 }
 587
 588
 589 =item suspend
 590
 591 Suspends this account by calling export-specific suspend hooks.  If there is
 592 an error, returns the error, otherwise returns false.
 593
 594 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 595
 596 =cut
 597
 598 sub suspend {
 599   my $self = shift;
 600   return "can't suspend system account" if $self->_check_system;
 601   $self->SUPER::suspend;
 602 }
 603
 604 =item unsuspend
 605
 606 Unsuspends this account by by calling export-specific suspend hooks.  If there
 607 is an error, returns the error, otherwise returns false.
 608
 609 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 610
 611 =cut
 612
 613 sub unsuspend {
 614   my $self = shift;
 615   my %hash = $self->hash;
 616   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 617     $hash{_password} = $1;
 618     my $new = new FS::svc_acct ( \%hash );
 619     my $error = $new->replace($self);
 620     return $error if $error;
 621   }
 622
 623   $self->SUPER::unsuspend;
 624 }
 625
 626 =item cancel
 627
 628 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 629
 630 If the B<auto_unset_catchall> configuration option is set, this method will
 631 automatically remove any references to the canceled service in the catchall
 632 field of svc_domain.  This allows packages that contain both a svc_domain and
 633 its catchall svc_acct to be canceled in one step.
 634
 635 =cut
 636
 637 sub cancel {
 638   # Only one thing to do at this level
 639   my $self = shift;
 640   foreach my $svc_domain (
 641       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 642     if($conf->exists('auto_unset_catchall')) {
 643       my %hash = $svc_domain->hash;
 644       $hash{catchall} = '';
 645       my $new = new FS::svc_domain ( \%hash );
 646       my $error = $new->replace($svc_domain);
 647       return $error if $error;
 648     } else {
 649       return "cannot unprovision svc_acct #".$self->svcnum.
 650           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 651     }
 652   }
 653
 654   $self->SUPER::cancel;
 655 }
 656
 657
 658 =item check
 659
 660 Checks all fields to make sure this is a valid service.  If there is an error,
 661 returns the error, otherwise returns false.  Called by the insert and replace
 662 methods.
 663
 664 Sets any fixed values; see L<FS::part_svc>.
 665
 666 =cut
 667
 668 sub check {
 669   my $self = shift;
 670
 671   my($recref) = $self->hashref;
 672
 673   my $x = $self->setfixed;
 674   return $x unless ref($x);
 675   my $part_svc = $x;
 676
 677   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 678     $self->usergroup(
 679       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 680   }
 681
 682   my $error = $self->ut_numbern('svcnum')
 683               #|| $self->ut_number('domsvc')
 684               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 685               || $self->ut_textn('sec_phrase')
 686   ;
 687   return $error if $error;
 688
 689   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 690   if ( $username_uppercase ) {
 691     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 692       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 693     $recref->{username} = $1;
 694   } else {
 695     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 696       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 697     $recref->{username} = $1;
 698   }
 699
 700   if ( $username_letterfirst ) {
 701     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 702   } elsif ( $username_letter ) {
 703     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 704   }
 705   if ( $username_noperiod ) {
 706     $recref->{username} =~ /\./ and return gettext('illegal_username');
 707   }
 708   if ( $username_nounderscore ) {
 709     $recref->{username} =~ /_/ and return gettext('illegal_username');
 710   }
 711   if ( $username_nodash ) {
 712     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 713   }
 714   unless ( $username_ampersand ) {
 715     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 716   }
 717   if ( $password_noampersand ) {
 718     $recref->{_password} =~ /\&/ and return gettext('illegal_password');
 719   }
 720   if ( $password_noexclamation ) {
 721     $recref->{_password} =~ /\!/ and return gettext('illegal_password');
 722   }
 723
 724   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 725   $recref->{popnum} = $1;
 726   return "Unknown popnum" unless
 727     ! $recref->{popnum} ||
 728     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 729
 730   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 731
 732     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 733     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 734
 735     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 736     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 737     #not all systems use gid=uid
 738     #you can set a fixed gid in part_svc
 739
 740     return "Only root can have uid 0"
 741       if $recref->{uid} == 0
 742          && $recref->{username} !~ /^(root|toor|smtp)$/;
 743
 744     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 745       or return "Illegal directory: ". $recref->{dir};
 746     $recref->{dir} = $1;
 747     return "Illegal directory"
 748       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 749     return "Illegal directory"
 750       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 751     unless ( $recref->{dir} ) {
 752       $recref->{dir} = $dir_prefix . '/';
 753       if ( $dirhash > 0 ) {
 754         for my $h ( 1 .. $dirhash ) {
 755           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 756         }
 757       } elsif ( $dirhash < 0 ) {
 758         for my $h ( reverse $dirhash .. -1 ) {
 759           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 760         }
 761       }
 762       $recref->{dir} .= $recref->{username};
 763     ;
 764     }
 765
 766     unless ( $recref->{username} eq 'sync' ) {
 767       if ( grep $_ eq $recref->{shell}, @shells ) {
 768         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 769       } else {
 770         return "Illegal shell \`". $self->shell. "\'; ".
 771                $conf->dir. "/shells contains: @shells";
 772       }
 773     } else {
 774       $recref->{shell} = '/bin/sync';
 775     }
 776
 777   } else {
 778     $recref->{gid} ne '' ?
 779       return "Can't have gid without uid" : ( $recref->{gid}='' );
 780     $recref->{dir} ne '' ?
 781       return "Can't have directory without uid" : ( $recref->{dir}='' );
 782     $recref->{shell} ne '' ?
 783       return "Can't have shell without uid" : ( $recref->{shell}='' );
 784   }
 785
 786   #  $error = $self->ut_textn('finger');
 787   #  return $error if $error;
 788   if ( $self->getfield('finger') eq '' ) {
 789     my $cust_pkg = $self->svcnum
 790       ? $self->cust_svc->cust_pkg
 791       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
 792     if ( $cust_pkg ) {
 793       my $cust_main = $cust_pkg->cust_main;
 794       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
 795     }
 796   }
 797   $self->getfield('finger') =~
 798     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 799       or return "Illegal finger: ". $self->getfield('finger');
 800   $self->setfield('finger', $1);
 801
 802   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 803   $recref->{quota} = $1;
 804
 805   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 806     if ( $recref->{slipip} eq '' ) {
 807       $recref->{slipip} = '';
 808     } elsif ( $recref->{slipip} eq '0e0' ) {
 809       $recref->{slipip} = '0e0';
 810     } else {
 811       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 812         or return "Illegal slipip: ". $self->slipip;
 813       $recref->{slipip} = $1;
 814     }
 815
 816   }
 817
 818   #arbitrary RADIUS stuff; allow ut_textn for now
 819   foreach ( grep /^radius_/, fields('svc_acct') ) {
 820     $self->ut_textn($_);
 821   }
 822
 823   #generate a password if it is blank
 824   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 825     unless ( $recref->{_password} );
 826
 827   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 828   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 829     $recref->{_password} = $1.$3;
 830     #uncomment this to encrypt password immediately upon entry, or run
 831     #bin/crypt_pw in cron to give new users a window during which their
 832     #password is available to techs, for faxing, etc.  (also be aware of
 833     #radius issues!)
 834     #$recref->{password} = $1.
 835     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 836     #;
 837   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 838     $recref->{_password} = $1.$3;
 839   } elsif ( $recref->{_password} eq '*' ) {
 840     $recref->{_password} = '*';
 841   } elsif ( $recref->{_password} eq '!' ) {
 842     $recref->{_password} = '!';
 843   } elsif ( $recref->{_password} eq '!!' ) {
 844     $recref->{_password} = '!!';
 845   } else {
 846     #return "Illegal password";
 847     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 848            FS::Msgcat::_gettext('illegal_password_characters').
 849            ": ". $recref->{_password};
 850   }
 851
 852   $self->SUPER::check;
 853 }
 854
 855 =item _check_system
 856
 857 Internal function to check the username against the list of system usernames
 858 from the I<system_usernames> configuration value.  Returns true if the username
 859 is listed on the system username list.
 860
 861 =cut
 862
 863 sub _check_system {
 864   my $self = shift;
 865   scalar( grep { $self->username eq $_ || $self->email eq $_ }
 866                $conf->config('system_usernames')
 867         );
 868 }
 869
 870 =item _check_duplicate
 871
 872 Internal function to check for duplicates usernames, username@domain pairs and
 873 uids.
 874
 875 If the I<global_unique-username> configuration value is set to B<username> or
 876 B<username@domain>, enforces global username or username@domain uniqueness.
 877
 878 In all cases, check for duplicate uids and usernames or username@domain pairs
 879 per export and with identical I<svcpart> values.
 880
 881 =cut
 882
 883 sub _check_duplicate {
 884   my $self = shift;
 885
 886   #this is Pg-specific.  what to do for mysql etc?
 887   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
 888   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
 889   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
 890     or die dbh->errstr;
 891   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
 892
 893   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 894   unless ( $part_svc ) {
 895     return 'unknown svcpart '. $self->svcpart;
 896   }
 897
 898   my $global_unique = $conf->config('global_unique-username') || 'none';
 899
 900   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 901                  qsearch( 'svc_acct', { 'username' => $self->username } );
 902   return gettext('username_in_use')
 903     if $global_unique eq 'username' && @dup_user;
 904
 905   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 906                        qsearch( 'svc_acct', { 'username' => $self->username,
 907                                               'domsvc'   => $self->domsvc } );
 908   return gettext('username_in_use')
 909     if $global_unique eq 'username@domain' && @dup_userdomain;
 910
 911   my @dup_uid;
 912   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 913        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 914     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 915                qsearch( 'svc_acct', { 'uid' => $self->uid } );
 916   } else {
 917     @dup_uid = ();
 918   }
 919
 920   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 921     my $exports = FS::part_export::export_info('svc_acct');
 922     my %conflict_user_svcpart;
 923     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 924
 925     foreach my $part_export ( $part_svc->part_export ) {
 926
 927       #this will catch to the same exact export
 928       my @svcparts = map { $_->svcpart } $part_export->export_svc;
 929
 930       #this will catch to exports w/same exporthost+type ???
 931       #my @other_part_export = qsearch('part_export', {
 932       #  'machine'    => $part_export->machine,
 933       #  'exporttype' => $part_export->exporttype,
 934       #} );
 935       #foreach my $other_part_export ( @other_part_export ) {
 936       #  push @svcparts, map { $_->svcpart }
 937       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 938       #}
 939
 940       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 941       #silly kludge to avoid uninitialized value errors
 942       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 943                      ? $exports->{$part_export->exporttype}{'nodomain'}
 944                      : '';
 945       if ( $nodomain =~ /^Y/i ) {
 946         $conflict_user_svcpart{$_} = $part_export->exportnum
 947           foreach @svcparts;
 948       } else {
 949         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 950           foreach @svcparts;
 951       }
 952     }
 953
 954     foreach my $dup_user ( @dup_user ) {
 955       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 956       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 957         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 958                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 959       }
 960     }
 961
 962     foreach my $dup_userdomain ( @dup_userdomain ) {
 963       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 964       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 965         return "duplicate username\@domain: conflicts with svcnum ".
 966                $dup_userdomain->svcnum. " via exportnum ".
 967                $conflict_userdomain_svcpart{$dup_svcpart};
 968       }
 969     }
 970
 971     foreach my $dup_uid ( @dup_uid ) {
 972       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 973       if ( exists($conflict_user_svcpart{$dup_svcpart})
 974            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 975         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
 976                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 977                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 978       }
 979     }
 980
 981   }
 982
 983   return '';
 984
 985 }
 986
 987 =item radius
 988
 989 Depriciated, use radius_reply instead.
 990
 991 =cut
 992
 993 sub radius {
 994   carp "FS::svc_acct::radius depriciated, use radius_reply";
 995   $_[0]->radius_reply;
 996 }
 997
 998 =item radius_reply
 999
1000 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1001 reply attributes of this record.
1002
1003 Note that this is now the preferred method for reading RADIUS attributes -
1004 accessing the columns directly is discouraged, as the column names are
1005 expected to change in the future.
1006
1007 =cut
1008
1009 sub radius_reply {
1010   my $self = shift;
1011   my %reply =
1012     map {
1013       /^(radius_(.*))$/;
1014       my($column, $attrib) = ($1, $2);
1015       #$attrib =~ s/_/\-/g;
1016       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1017     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1018   if ( $self->slipip && $self->slipip ne '0e0' ) {
1019     $reply{$radius_ip} = $self->slipip;
1020   }
1021   if ( $self->seconds !~ /^$/ ) {
1022     $reply{'Session-Timeout'} = $self->seconds;
1023   }
1024   %reply;
1025 }
1026
1027 =item radius_check
1028
1029 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1030 check attributes of this record.
1031
1032 Note that this is now the preferred method for reading RADIUS attributes -
1033 accessing the columns directly is discouraged, as the column names are
1034 expected to change in the future.
1035
1036 =cut
1037
1038 sub radius_check {
1039   my $self = shift;
1040   my $password = $self->_password;
1041   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1042   ( $pw_attrib => $password,
1043     map {
1044       /^(rc_(.*))$/;
1045       my($column, $attrib) = ($1, $2);
1046       #$attrib =~ s/_/\-/g;
1047       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1048     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1049   );
1050 }
1051
1052 =item domain
1053
1054 Returns the domain associated with this account.
1055
1056 =cut
1057
1058 sub domain {
1059   my $self = shift;
1060   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1061   my $svc_domain = $self->svc_domain(@_)
1062     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1063   $svc_domain->domain;
1064 }
1065
1066 =item svc_domain
1067
1068 Returns the FS::svc_domain record for this account's domain (see
1069 L<FS::svc_domain>).
1070
1071 =cut
1072
1073 sub svc_domain {
1074   my $self = shift;
1075   $self->{'_domsvc'}
1076     ? $self->{'_domsvc'}
1077     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1078 }
1079
1080 =item cust_svc
1081
1082 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1083
1084 =cut
1085
1086 sub cust_svc {
1087   my $self = shift;
1088   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1089 }
1090
1091 =item email
1092
1093 Returns an email address associated with the account.
1094
1095 =cut
1096
1097 sub email {
1098   my $self = shift;
1099   $self->username. '@'. $self->domain(@_);
1100 }
1101
1102 =item acct_snarf
1103
1104 Returns an array of FS::acct_snarf records associated with the account.
1105 If the acct_snarf table does not exist or there are no associated records,
1106 an empty list is returned
1107
1108 =cut
1109
1110 sub acct_snarf {
1111   my $self = shift;
1112   return () unless dbdef->table('acct_snarf');
1113   eval "use FS::acct_snarf;";
1114   die $@ if $@;
1115   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1116 }
1117
1118 =item decrement_seconds SECONDS
1119
1120 Decrements the I<seconds> field of this record by the given amount.
1121
1122 =cut
1123
1124 sub decrement_seconds {
1125   my( $self, $seconds ) = @_;
1126
1127   local $SIG{HUP} = 'IGNORE';
1128   local $SIG{INT} = 'IGNORE';
1129   local $SIG{QUIT} = 'IGNORE';
1130   local $SIG{TERM} = 'IGNORE';
1131   local $SIG{TSTP} = 'IGNORE';
1132   local $SIG{PIPE} = 'IGNORE';
1133
1134   my $oldAutoCommit = $FS::UID::AutoCommit;
1135   local $FS::UID::AutoCommit = 0;
1136   my $dbh = dbh;
1137
1138   my $sth = dbh->prepare(
1139     'UPDATE svc_acct SET seconds = seconds - ? WHERE svcnum = ?'
1140   ) or die dbh->errstr;;
1141   $sth->execute($seconds, $self->svcnum) or die $sth->errstr;
1142   if ( $conf->exists('svc_acct-usage_suspend')
1143        && $self->seconds - $seconds <= 0       ) {
1144     #my $error = $self->suspend;
1145     my $error = $self->cust_svc->cust_pkg->suspend;
1146     die $error if $error;
1147   }
1148
1149   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1150
1151 }
1152
1153 =item seconds_since TIMESTAMP
1154
1155 Returns the number of seconds this account has been online since TIMESTAMP,
1156 according to the session monitor (see L<FS::Session>).
1157
1158 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1159 L<Time::Local> and L<Date::Parse> for conversion functions.
1160
1161 =cut
1162
1163 #note: POD here, implementation in FS::cust_svc
1164 sub seconds_since {
1165   my $self = shift;
1166   $self->cust_svc->seconds_since(@_);
1167 }
1168
1169 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1170
1171 Returns the numbers of seconds this account has been online between
1172 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1173 external SQL radacct table, specified via sqlradius export.  Sessions which
1174 started in the specified range but are still open are counted from session
1175 start to the end of the range (unless they are over 1 day old, in which case
1176 they are presumed missing their stop record and not counted).  Also, sessions
1177 which end in the range but started earlier are counted from the start of the
1178 range to session end.  Finally, sessions which start before the range but end
1179 after are counted for the entire range.
1180
1181 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1182 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1183 functions.
1184
1185 =cut
1186
1187 #note: POD here, implementation in FS::cust_svc
1188 sub seconds_since_sqlradacct {
1189   my $self = shift;
1190   $self->cust_svc->seconds_since_sqlradacct(@_);
1191 }
1192
1193 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1194
1195 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1196 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1197 TIMESTAMP_END (exclusive).
1198
1199 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1200 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1201 functions.
1202
1203 =cut
1204
1205 #note: POD here, implementation in FS::cust_svc
1206 sub attribute_since_sqlradacct {
1207   my $self = shift;
1208   $self->cust_svc->attribute_since_sqlradacct(@_);
1209 }
1210
1211 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1212
1213 Returns an array of hash references of this customers login history for the
1214 given time range.  (document this better)
1215
1216 =cut
1217
1218 sub get_session_history {
1219   my $self = shift;
1220   $self->cust_svc->get_session_history(@_);
1221 }
1222
1223 =item radius_groups
1224
1225 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1226
1227 =cut
1228
1229 sub radius_groups {
1230   my $self = shift;
1231   if ( $self->usergroup ) {
1232     #when provisioning records, export callback runs in svc_Common.pm before
1233     #radius_usergroup records can be inserted...
1234     @{$self->usergroup};
1235   } else {
1236     map { $_->groupname }
1237       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1238   }
1239 }
1240
1241 =item clone_suspended
1242
1243 Constructor used by FS::part_export::_export_suspend fallback.  Document
1244 better.
1245
1246 =cut
1247
1248 sub clone_suspended {
1249   my $self = shift;
1250   my %hash = $self->hash;
1251   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1252   new FS::svc_acct \%hash;
1253 }
1254
1255 =item clone_kludge_unsuspend
1256
1257 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1258 better.
1259
1260 =cut
1261
1262 sub clone_kludge_unsuspend {
1263   my $self = shift;
1264   my %hash = $self->hash;
1265   $hash{_password} = '';
1266   new FS::svc_acct \%hash;
1267 }
1268
1269 =item check_password
1270
1271 Checks the supplied password against the (possibly encrypted) password in the
1272 database.  Returns true for a sucessful authentication, false for no match.
1273
1274 Currently supported encryptions are: classic DES crypt() and MD5
1275
1276 =cut
1277
1278 sub check_password {
1279   my($self, $check_password) = @_;
1280
1281   #remove old-style SUSPENDED kludge, they should be allowed to login to
1282   #self-service and pay up
1283   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1284
1285   #eventually should check a "password-encoding" field
1286   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1287     return 0;
1288   } elsif ( length($password) < 13 ) { #plaintext
1289     $check_password eq $password;
1290   } elsif ( length($password) == 13 ) { #traditional DES crypt
1291     crypt($check_password, $password) eq $password;
1292   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1293     unix_md5_crypt($check_password, $password) eq $password;
1294   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1295     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1296          $self->svcnum. "\n";
1297     0;
1298   } else {
1299     warn "Can't check password: Unrecognized encryption for svcnum ".
1300          $self->svcnum. "\n";
1301     0;
1302   }
1303
1304 }
1305
1306 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1307
1308 Returns an encrypted password, either by passing through an encrypted password
1309 in the database or by encrypting a plaintext password from the database.
1310
1311 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1312 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1313 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1314 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1315 encryption type is only used if the password is not already encrypted in the
1316 database.
1317
1318 =cut
1319
1320 sub crypt_password {
1321   my $self = shift;
1322   #eventually should check a "password-encoding" field
1323   if ( length($self->_password) == 13
1324        || $self->_password =~ /^\$(1|2a?)\$/
1325        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1326      )
1327   {
1328     $self->_password;
1329   } else {
1330     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1331     if ( $encryption eq 'crypt' ) {
1332       crypt(
1333         $self->_password,
1334         $saltset[int(rand(64))].$saltset[int(rand(64))]
1335       );
1336     } elsif ( $encryption eq 'md5' ) {
1337       unix_md5_crypt( $self->_password );
1338     } elsif ( $encryption eq 'blowfish' ) {
1339       die "unknown encryption method $encryption";
1340     } else {
1341       die "unknown encryption method $encryption";
1342     }
1343   }
1344 }
1345
1346 =item virtual_maildir
1347
1348 Returns $domain/maildirs/$username/
1349
1350 =cut
1351
1352 sub virtual_maildir {
1353   my $self = shift;
1354   $self->domain. '/maildirs/'. $self->username. '/';
1355 }
1356
1357 =back
1358
1359 =head1 SUBROUTINES
1360
1361 =over 4
1362
1363 =item send_email
1364
1365 This is the FS::svc_acct job-queue-able version.  It still uses
1366 FS::Misc::send_email under-the-hood.
1367
1368 =cut
1369
1370 sub send_email {
1371   my %opt = @_;
1372
1373   eval "use FS::Misc qw(send_email)";
1374   die $@ if $@;
1375
1376   $opt{mimetype} ||= 'text/plain';
1377   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1378
1379   my $error = send_email(
1380     'from'         => $opt{from},
1381     'to'           => $opt{to},
1382     'subject'      => $opt{subject},
1383     'content-type' => $opt{mimetype},
1384     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1385   );
1386   die $error if $error;
1387 }
1388
1389 =item check_and_rebuild_fuzzyfiles
1390
1391 =cut
1392
1393 sub check_and_rebuild_fuzzyfiles {
1394   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1395   -e "$dir/svc_acct.username"
1396     or &rebuild_fuzzyfiles;
1397 }
1398
1399 =item rebuild_fuzzyfiles
1400
1401 =cut
1402
1403 sub rebuild_fuzzyfiles {
1404
1405   use Fcntl qw(:flock);
1406
1407   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1408
1409   #username
1410
1411   open(USERNAMELOCK,">>$dir/svc_acct.username")
1412     or die "can't open $dir/svc_acct.username: $!";
1413   flock(USERNAMELOCK,LOCK_EX)
1414     or die "can't lock $dir/svc_acct.username: $!";
1415
1416   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1417
1418   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1419     or die "can't open $dir/svc_acct.username.tmp: $!";
1420   print USERNAMECACHE join("\n", @all_username), "\n";
1421   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1422
1423   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1424   close USERNAMELOCK;
1425
1426 }
1427
1428 =item all_username
1429
1430 =cut
1431
1432 sub all_username {
1433   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1434   open(USERNAMECACHE,"<$dir/svc_acct.username")
1435     or die "can't open $dir/svc_acct.username: $!";
1436   my @array = map { chomp; $_; } <USERNAMECACHE>;
1437   close USERNAMECACHE;
1438   \@array;
1439 }
1440
1441 =item append_fuzzyfiles USERNAME
1442
1443 =cut
1444
1445 sub append_fuzzyfiles {
1446   my $username = shift;
1447
1448   &check_and_rebuild_fuzzyfiles;
1449
1450   use Fcntl qw(:flock);
1451
1452   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1453
1454   open(USERNAME,">>$dir/svc_acct.username")
1455     or die "can't open $dir/svc_acct.username: $!";
1456   flock(USERNAME,LOCK_EX)
1457     or die "can't lock $dir/svc_acct.username: $!";
1458
1459   print USERNAME "$username\n";
1460
1461   flock(USERNAME,LOCK_UN)
1462     or die "can't unlock $dir/svc_acct.username: $!";
1463   close USERNAME;
1464
1465   1;
1466 }
1467
1468
1469
1470 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1471
1472 =cut
1473
1474 sub radius_usergroup_selector {
1475   my $sel_groups = shift;
1476   my %sel_groups = map { $_=>1 } @$sel_groups;
1477
1478   my $selectname = shift || 'radius_usergroup';
1479
1480   my $dbh = dbh;
1481   my $sth = $dbh->prepare(
1482     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1483   ) or die $dbh->errstr;
1484   $sth->execute() or die $sth->errstr;
1485   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1486
1487   my $html = <<END;
1488     <SCRIPT>
1489     function ${selectname}_doadd(object) {
1490       var myvalue = object.${selectname}_add.value;
1491       var optionName = new Option(myvalue,myvalue,false,true);
1492       var length = object.$selectname.length;
1493       object.$selectname.options[length] = optionName;
1494       object.${selectname}_add.value = "";
1495     }
1496     </SCRIPT>
1497     <SELECT MULTIPLE NAME="$selectname">
1498 END
1499
1500   foreach my $group ( @all_groups ) {
1501     $html .= qq(<OPTION VALUE="$group");
1502     if ( $sel_groups{$group} ) {
1503       $html .= ' SELECTED';
1504       $sel_groups{$group} = 0;
1505     }
1506     $html .= ">$group</OPTION>\n";
1507   }
1508   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1509     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1510   };
1511   $html .= '</SELECT>';
1512
1513   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1514            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1515
1516   $html;
1517 }
1518
1519 =back
1520
1521 =head1 BUGS
1522
1523 The $recref stuff in sub check should be cleaned up.
1524
1525 The suspend, unsuspend and cancel methods update the database, but not the
1526 current object.  This is probably a bug as it's unexpected and
1527 counterintuitive.
1528
1529 radius_usergroup_selector?  putting web ui components in here?  they should
1530 probably live somewhere else...
1531
1532 insertion of RADIUS group stuff in insert could be done with child_objects now
1533 (would probably clean up export of them too)
1534
1535 =head1 SEE ALSO
1536
1537 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1538 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1539 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1540 L<freeside-queued>), L<FS::svc_acct_pop>,
1541 schema.html from the base documentation.
1542
1543 =cut
1544
1545 1;
1546