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