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