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