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