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