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