FS/FS/svc_acct.pm

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