FS/FS/svc_acct.pm

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