FS/FS/svc_acct.pm

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