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