FS/FS/svc_acct.pm

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