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