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