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