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