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} ne 'root'
 702          && $recref->{username} ne 'toor';
 703
 704
 705     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 706       or return "Illegal directory: ". $recref->{dir};
 707     $recref->{dir} = $1;
 708     return "Illegal directory"
 709       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 710     return "Illegal directory"
 711       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 712     unless ( $recref->{dir} ) {
 713       $recref->{dir} = $dir_prefix . '/';
 714       if ( $dirhash > 0 ) {
 715         for my $h ( 1 .. $dirhash ) {
 716           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 717         }
 718       } elsif ( $dirhash < 0 ) {
 719         for my $h ( reverse $dirhash .. -1 ) {
 720           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 721         }
 722       }
 723       $recref->{dir} .= $recref->{username};
 724     ;
 725     }
 726
 727     unless ( $recref->{username} eq 'sync' ) {
 728       if ( grep $_ eq $recref->{shell}, @shells ) {
 729         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 730       } else {
 731         return "Illegal shell \`". $self->shell. "\'; ".
 732                $conf->dir. "/shells contains: @shells";
 733       }
 734     } else {
 735       $recref->{shell} = '/bin/sync';
 736     }
 737
 738   } else {
 739     $recref->{gid} ne '' ?
 740       return "Can't have gid without uid" : ( $recref->{gid}='' );
 741     $recref->{dir} ne '' ?
 742       return "Can't have directory without uid" : ( $recref->{dir}='' );
 743     $recref->{shell} ne '' ?
 744       return "Can't have shell without uid" : ( $recref->{shell}='' );
 745   }
 746
 747   #  $error = $self->ut_textn('finger');
 748   #  return $error if $error;
 749   if ( $self->getfield('finger') eq '' ) {
 750     my $cust_pkg = $self->svcnum
 751       ? $self->cust_svc->cust_pkg
 752       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
 753     if ( $cust_pkg ) {
 754       my $cust_main = $cust_pkg->cust_main;
 755       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
 756     }
 757   }
 758   $self->getfield('finger') =~
 759     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 760       or return "Illegal finger: ". $self->getfield('finger');
 761   $self->setfield('finger', $1);
 762
 763   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 764   $recref->{quota} = $1;
 765
 766   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 767     if ( $recref->{slipip} eq '' ) {
 768       $recref->{slipip} = '';
 769     } elsif ( $recref->{slipip} eq '0e0' ) {
 770       $recref->{slipip} = '0e0';
 771     } else {
 772       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 773         or return "Illegal slipip". $self->slipip;
 774       $recref->{slipip} = $1;
 775     }
 776
 777   }
 778
 779   #arbitrary RADIUS stuff; allow ut_textn for now
 780   foreach ( grep /^radius_/, fields('svc_acct') ) {
 781     $self->ut_textn($_);
 782   }
 783
 784   #generate a password if it is blank
 785   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 786     unless ( $recref->{_password} );
 787
 788   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 789   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 790     $recref->{_password} = $1.$3;
 791     #uncomment this to encrypt password immediately upon entry, or run
 792     #bin/crypt_pw in cron to give new users a window during which their
 793     #password is available to techs, for faxing, etc.  (also be aware of
 794     #radius issues!)
 795     #$recref->{password} = $1.
 796     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 797     #;
 798   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 799     $recref->{_password} = $1.$3;
 800   } elsif ( $recref->{_password} eq '*' ) {
 801     $recref->{_password} = '*';
 802   } elsif ( $recref->{_password} eq '!' ) {
 803     $recref->{_password} = '!';
 804   } elsif ( $recref->{_password} eq '!!' ) {
 805     $recref->{_password} = '!!';
 806   } else {
 807     #return "Illegal password";
 808     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 809            FS::Msgcat::_gettext('illegal_password_characters').
 810            ": ". $recref->{_password};
 811   }
 812
 813   ''; #no error
 814 }
 815
 816 =item _check_system
 817
 818 =cut
 819
 820 sub _check_system {
 821   my $self = shift;
 822   scalar( grep { $self->username eq $_ || $self->email eq $_ }
 823                $conf->config('system_usernames')
 824         );
 825 }
 826
 827 =item _check_duplicate
 828
 829 Internal function to check for duplicates usernames, username@domain pairs and
 830 uids.
 831
 832 If the I<global_unique-username> configuration value is set to B<username> or
 833 B<username@domain>, enforces global username or username@domain uniqueness.
 834
 835 In all cases, check for duplicate uids and usernames or username@domain pairs
 836 per export and with identical I<svcpart> values.
 837
 838 =cut
 839
 840 sub _check_duplicate {
 841   my $self = shift;
 842
 843   #this is Pg-specific.  what to do for mysql etc?
 844   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
 845   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
 846   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
 847     or die dbh->errstr;
 848   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
 849
 850   my $svcpart = $self->svcpart;
 851   my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
 852   unless ( $part_svc ) {
 853     return 'unknown svcpart '. $self->svcpart;
 854   }
 855
 856   my $global_unique = $conf->config('global_unique-username');
 857
 858   my @dup_user = grep { $svcpart != $_->svcpart }
 859                  qsearch( 'svc_acct', { 'username' => $self->username } );
 860   return gettext('username_in_use')
 861     if $global_unique eq 'username' && @dup_user;
 862
 863   my @dup_userdomain = grep { $svcpart != $_->svcpart }
 864                        qsearch( 'svc_acct', { 'username' => $self->username,
 865                                               'domsvc'   => $self->domsvc } );
 866   return gettext('username_in_use')
 867     if $global_unique eq 'username@domain' && @dup_userdomain;
 868
 869   my @dup_uid;
 870   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 871        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 872     @dup_uid = grep { $svcpart != $_->svcpart }
 873                qsearch( 'svc_acct', { 'uid' => $self->uid } );
 874   } else {
 875     @dup_uid = ();
 876   }
 877
 878   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 879     my $exports = FS::part_export::export_info('svc_acct');
 880     my %conflict_user_svcpart;
 881     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 882
 883     foreach my $part_export ( $part_svc->part_export ) {
 884
 885       #this will catch to the same exact export
 886       my @svcparts = map { $_->svcpart } $part_export->export_svc;
 887
 888       #this will catch to exports w/same exporthost+type ???
 889       #my @other_part_export = qsearch('part_export', {
 890       #  'machine'    => $part_export->machine,
 891       #  'exporttype' => $part_export->exporttype,
 892       #} );
 893       #foreach my $other_part_export ( @other_part_export ) {
 894       #  push @svcparts, map { $_->svcpart }
 895       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 896       #}
 897
 898       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 899       #silly kludge to avoid uninitialized value errors
 900       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 901                      ? $exports->{$part_export->exporttype}{'nodomain'}
 902                      : '';
 903       if ( $nodomain =~ /^Y/i ) {
 904         $conflict_user_svcpart{$_} = $part_export->exportnum
 905           foreach @svcparts;
 906       } else {
 907         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 908           foreach @svcparts;
 909       }
 910     }
 911
 912     foreach my $dup_user ( @dup_user ) {
 913       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 914       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 915         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 916                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 917       }
 918     }
 919
 920     foreach my $dup_userdomain ( @dup_userdomain ) {
 921       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 922       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 923         return "duplicate username\@domain: conflicts with svcnum ".
 924                $dup_userdomain->svcnum. " via exportnum ".
 925                $conflict_userdomain_svcpart{$dup_svcpart};
 926       }
 927     }
 928
 929     foreach my $dup_uid ( @dup_uid ) {
 930       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 931       if ( exists($conflict_user_svcpart{$dup_svcpart})
 932            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 933         return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
 934                "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 935                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 936       }
 937     }
 938
 939   }
 940
 941   return '';
 942
 943 }
 944
 945 =item radius
 946
 947 Depriciated, use radius_reply instead.
 948
 949 =cut
 950
 951 sub radius {
 952   carp "FS::svc_acct::radius depriciated, use radius_reply";
 953   $_[0]->radius_reply;
 954 }
 955
 956 =item radius_reply
 957
 958 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 959 reply attributes of this record.
 960
 961 Note that this is now the preferred method for reading RADIUS attributes -
 962 accessing the columns directly is discouraged, as the column names are
 963 expected to change in the future.
 964
 965 Internal function to check the username against the list of system usernames
 966 from the I<system_usernames> configuration value.  Returns true if the username
 967 is listed on the system username list.
 968
 969 =cut
 970
 971 sub radius_reply {
 972   my $self = shift;
 973   my %reply =
 974     map {
 975       /^(radius_(.*))$/;
 976       my($column, $attrib) = ($1, $2);
 977       #$attrib =~ s/_/\-/g;
 978       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 979     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 980   if ( $self->slipip && $self->slipip ne '0e0' ) {
 981     $reply{$radius_ip} = $self->slipip;
 982   }
 983   %reply;
 984 }
 985
 986 =item radius_check
 987
 988 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 989 check attributes of this record.
 990
 991 Note that this is now the preferred method for reading RADIUS attributes -
 992 accessing the columns directly is discouraged, as the column names are
 993 expected to change in the future.
 994
 995 =cut
 996
 997 sub radius_check {
 998   my $self = shift;
 999   my $password = $self->_password;
1000   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1001   ( $pw_attrib => $self->_password,
1002     map {
1003       /^(rc_(.*))$/;
1004       my($column, $attrib) = ($1, $2);
1005       #$attrib =~ s/_/\-/g;
1006       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1007     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1008   );
1009 }
1010
1011 =item domain
1012
1013 Returns the domain associated with this account.
1014
1015 =cut
1016
1017 sub domain {
1018   my $self = shift;
1019   if ( $self->domsvc ) {
1020     #$self->svc_domain->domain;
1021     my $svc_domain = $self->svc_domain
1022       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1023     $svc_domain->domain;
1024   } else {
1025     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
1026   }
1027 }
1028
1029 =item svc_domain
1030
1031 Returns the FS::svc_domain record for this account's domain (see
1032 L<FS::svc_domain>).
1033
1034 =cut
1035
1036 sub svc_domain {
1037   my $self = shift;
1038   $self->{'_domsvc'}
1039     ? $self->{'_domsvc'}
1040     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1041 }
1042
1043 =item cust_svc
1044
1045 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1046
1047 =cut
1048
1049 sub cust_svc {
1050   my $self = shift;
1051   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1052 }
1053
1054 =item email
1055
1056 Returns an email address associated with the account.
1057
1058 =cut
1059
1060 sub email {
1061   my $self = shift;
1062   $self->username. '@'. $self->domain;
1063 }
1064
1065 =item acct_snarf
1066
1067 Returns an array of FS::acct_snarf records associated with the account.
1068 If the acct_snarf table does not exist or there are no associated records,
1069 an empty list is returned
1070
1071 =cut
1072
1073 sub acct_snarf {
1074   my $self = shift;
1075   return () unless dbdef->table('acct_snarf');
1076   eval "use FS::acct_snarf;";
1077   die $@ if $@;
1078   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1079 }
1080
1081 =item seconds_since TIMESTAMP
1082
1083 Returns the number of seconds this account has been online since TIMESTAMP,
1084 according to the session monitor (see L<FS::Session>).
1085
1086 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1087 L<Time::Local> and L<Date::Parse> for conversion functions.
1088
1089 =cut
1090
1091 #note: POD here, implementation in FS::cust_svc
1092 sub seconds_since {
1093   my $self = shift;
1094   $self->cust_svc->seconds_since(@_);
1095 }
1096
1097 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1098
1099 Returns the numbers of seconds this account has been online between
1100 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1101 external SQL radacct table, specified via sqlradius export.  Sessions which
1102 started in the specified range but are still open are counted from session
1103 start to the end of the range (unless they are over 1 day old, in which case
1104 they are presumed missing their stop record and not counted).  Also, sessions
1105 which end in the range but started earlier are counted from the start of the
1106 range to session end.  Finally, sessions which start before the range but end
1107 after are counted for the entire range.
1108
1109 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1110 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1111 functions.
1112
1113 =cut
1114
1115 #note: POD here, implementation in FS::cust_svc
1116 sub seconds_since_sqlradacct {
1117   my $self = shift;
1118   $self->cust_svc->seconds_since_sqlradacct(@_);
1119 }
1120
1121 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1122
1123 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1124 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1125 TIMESTAMP_END (exclusive).
1126
1127 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1128 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1129 functions.
1130
1131 =cut
1132
1133 #note: POD here, implementation in FS::cust_svc
1134 sub attribute_since_sqlradacct {
1135   my $self = shift;
1136   $self->cust_svc->attribute_since_sqlradacct(@_);
1137 }
1138
1139 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1140
1141 Returns an array of hash references of this customers login history for the
1142 given time range.  (document this better)
1143
1144 =cut
1145
1146 sub get_session_history_sqlradacct {
1147   my $self = shift;
1148   $self->cust_svc->get_session_history_sqlradacct(@_);
1149 }
1150
1151 =item radius_groups
1152
1153 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1154
1155 =cut
1156
1157 sub radius_groups {
1158   my $self = shift;
1159   if ( $self->usergroup ) {
1160     #when provisioning records, export callback runs in svc_Common.pm before
1161     #radius_usergroup records can be inserted...
1162     @{$self->usergroup};
1163   } else {
1164     map { $_->groupname }
1165       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1166   }
1167 }
1168
1169 =item clone_suspended
1170
1171 Constructor used by FS::part_export::_export_suspend fallback.  Document
1172 better.
1173
1174 =cut
1175
1176 sub clone_suspended {
1177   my $self = shift;
1178   my %hash = $self->hash;
1179   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1180   new FS::svc_acct \%hash;
1181 }
1182
1183 =item clone_kludge_unsuspend
1184
1185 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1186 better.
1187
1188 =cut
1189
1190 sub clone_kludge_unsuspend {
1191   my $self = shift;
1192   my %hash = $self->hash;
1193   $hash{_password} = '';
1194   new FS::svc_acct \%hash;
1195 }
1196
1197 =item check_password
1198
1199 Checks the supplied password against the (possibly encrypted) password in the
1200 database.  Returns true for a sucessful authentication, false for no match.
1201
1202 Currently supported encryptions are: classic DES crypt() and MD5
1203
1204 =cut
1205
1206 sub check_password {
1207   my($self, $check_password) = @_;
1208
1209   #remove old-style SUSPENDED kludge, they should be allowed to login to
1210   #self-service and pay up
1211   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1212
1213   #eventually should check a "password-encoding" field
1214   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1215     return 0;
1216   } elsif ( length($password) < 13 ) { #plaintext
1217     $check_password eq $password;
1218   } elsif ( length($password) == 13 ) { #traditional DES crypt
1219     crypt($check_password, $password) eq $password;
1220   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1221     unix_md5_crypt($check_password, $password) eq $password;
1222   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1223     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1224          $self->svcnum. "\n";
1225     0;
1226   } else {
1227     warn "Can't check password: Unrecognized encryption for svcnum ".
1228          $self->svcnum. "\n";
1229     0;
1230   }
1231
1232 }
1233
1234 =back
1235
1236 =head1 SUBROUTINES
1237
1238 =over 4
1239
1240 =item send_email
1241
1242 =cut
1243
1244 sub send_email {
1245   my %opt = @_;
1246
1247   use Date::Format;
1248   use Mail::Internet 1.44;
1249   use Mail::Header;
1250
1251   $opt{mimetype} ||= 'text/plain';
1252   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1253
1254   $ENV{MAILADDRESS} = $opt{from};
1255   my $header = new Mail::Header ( [
1256     "From: $opt{from}",
1257     "To: $opt{to}",
1258     "Sender: $opt{from}",
1259     "Reply-To: $opt{from}",
1260     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1261     "Subject: $opt{subject}",
1262     "Content-Type: $opt{mimetype}",
1263   ] );
1264   my $message = new Mail::Internet (
1265     'Header' => $header,
1266     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1267   );
1268   $!=0;
1269   $message->smtpsend( Host => $smtpmachine )
1270     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1271       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1272 }
1273
1274 =item check_and_rebuild_fuzzyfiles
1275
1276 =cut
1277
1278 sub check_and_rebuild_fuzzyfiles {
1279   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1280   -e "$dir/svc_acct.username"
1281     or &rebuild_fuzzyfiles;
1282 }
1283
1284 =item rebuild_fuzzyfiles
1285
1286 =cut
1287
1288 sub rebuild_fuzzyfiles {
1289
1290   use Fcntl qw(:flock);
1291
1292   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1293
1294   #username
1295
1296   open(USERNAMELOCK,">>$dir/svc_acct.username")
1297     or die "can't open $dir/svc_acct.username: $!";
1298   flock(USERNAMELOCK,LOCK_EX)
1299     or die "can't lock $dir/svc_acct.username: $!";
1300
1301   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1302
1303   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1304     or die "can't open $dir/svc_acct.username.tmp: $!";
1305   print USERNAMECACHE join("\n", @all_username), "\n";
1306   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1307
1308   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1309   close USERNAMELOCK;
1310
1311 }
1312
1313 =item all_username
1314
1315 =cut
1316
1317 sub all_username {
1318   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1319   open(USERNAMECACHE,"<$dir/svc_acct.username")
1320     or die "can't open $dir/svc_acct.username: $!";
1321   my @array = map { chomp; $_; } <USERNAMECACHE>;
1322   close USERNAMECACHE;
1323   \@array;
1324 }
1325
1326 =item append_fuzzyfiles USERNAME
1327
1328 =cut
1329
1330 sub append_fuzzyfiles {
1331   my $username = shift;
1332
1333   &check_and_rebuild_fuzzyfiles;
1334
1335   use Fcntl qw(:flock);
1336
1337   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1338
1339   open(USERNAME,">>$dir/svc_acct.username")
1340     or die "can't open $dir/svc_acct.username: $!";
1341   flock(USERNAME,LOCK_EX)
1342     or die "can't lock $dir/svc_acct.username: $!";
1343
1344   print USERNAME "$username\n";
1345
1346   flock(USERNAME,LOCK_UN)
1347     or die "can't unlock $dir/svc_acct.username: $!";
1348   close USERNAME;
1349
1350   1;
1351 }
1352
1353
1354
1355 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1356
1357 =cut
1358
1359 sub radius_usergroup_selector {
1360   my $sel_groups = shift;
1361   my %sel_groups = map { $_=>1 } @$sel_groups;
1362
1363   my $selectname = shift || 'radius_usergroup';
1364
1365   my $dbh = dbh;
1366   my $sth = $dbh->prepare(
1367     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1368   ) or die $dbh->errstr;
1369   $sth->execute() or die $sth->errstr;
1370   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1371
1372   my $html = <<END;
1373     <SCRIPT>
1374     function ${selectname}_doadd(object) {
1375       var myvalue = object.${selectname}_add.value;
1376       var optionName = new Option(myvalue,myvalue,false,true);
1377       var length = object.$selectname.length;
1378       object.$selectname.options[length] = optionName;
1379       object.${selectname}_add.value = "";
1380     }
1381     </SCRIPT>
1382     <SELECT MULTIPLE NAME="$selectname">
1383 END
1384
1385   foreach my $group ( @all_groups ) {
1386     $html .= '<OPTION';
1387     if ( $sel_groups{$group} ) {
1388       $html .= ' SELECTED';
1389       $sel_groups{$group} = 0;
1390     }
1391     $html .= ">$group</OPTION>\n";
1392   }
1393   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1394     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1395   };
1396   $html .= '</SELECT>';
1397
1398   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1399            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1400
1401   $html;
1402 }
1403
1404 =back
1405
1406 =head1 BUGS
1407
1408 The $recref stuff in sub check should be cleaned up.
1409
1410 The suspend, unsuspend and cancel methods update the database, but not the
1411 current object.  This is probably a bug as it's unexpected and
1412 counterintuitive.
1413
1414 radius_usergroup_selector?  putting web ui components in here?  they should
1415 probably live somewhere else...
1416
1417 insertion of RADIUS group stuff in insert could be done with child_objects now
1418 (would probably clean up export of them too)
1419
1420 =head1 SEE ALSO
1421
1422 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1423 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1424 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1425 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1426 schema.html from the base documentation.
1427
1428 =cut
1429
1430 1;
1431