FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $noexport_hack $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              $dirhash
  12              @saltset @pw_set );
  13 use Carp;
  14 use Fcntl qw(:flock);
  15 use FS::UID qw( datasrc );
  16 use FS::Conf;
  17 use FS::Record qw( qsearch qsearchs fields dbh );
  18 use FS::svc_Common;
  19 use Net::SSH;
  20 use FS::part_svc;
  21 use FS::svc_acct_pop;
  22 use FS::svc_acct_sm;
  23 use FS::cust_main_invoice;
  24 use FS::svc_domain;
  25 use FS::raddb;
  26 use FS::queue;
  27 use FS::radius_usergroup;
  28 use FS::Msgcat qw(gettext);
  29
  30 @ISA = qw( FS::svc_Common );
  31
  32 #ask FS::UID to run this stuff for us later
  33 $FS::UID::callback{'FS::svc_acct'} = sub {
  34   $conf = new FS::Conf;
  35   $dir_prefix = $conf->config('home');
  36   @shells = $conf->config('shells');
  37   $usernamemin = $conf->config('usernamemin') || 2;
  38   $usernamemax = $conf->config('usernamemax');
  39   $passwordmin = $conf->config('passwordmin') || 6;
  40   $passwordmax = $conf->config('passwordmax') || 8;
  41   $username_letter = $conf->exists('username-letter');
  42   $username_letterfirst = $conf->exists('username-letterfirst');
  43   $username_noperiod = $conf->exists('username-noperiod');
  44   $username_nounderscore = $conf->exists('username-nounderscore');
  45   $username_nodash = $conf->exists('username-nodash');
  46   $username_uppercase = $conf->exists('username-uppercase');
  47   $username_ampersand = $conf->exists('username-ampersand');
  48   $mydomain = $conf->config('domain');
  49
  50   $dirhash = $conf->config('dirhash') || 0;
  51 };
  52
  53 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  54 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  55
  56 sub _cache {
  57   my $self = shift;
  58   my ( $hashref, $cache ) = @_;
  59   if ( $hashref->{'svc_acct_svcnum'} ) {
  60     $self->{'_domsvc'} = FS::svc_domain->new( {
  61       'svcnum'   => $hashref->{'domsvc'},
  62       'domain'   => $hashref->{'svc_acct_domain'},
  63       'catchall' => $hashref->{'svc_acct_catchall'},
  64     } );
  65   }
  66 }
  67
  68 =head1 NAME
  69
  70 FS::svc_acct - Object methods for svc_acct records
  71
  72 =head1 SYNOPSIS
  73
  74   use FS::svc_acct;
  75
  76   $record = new FS::svc_acct \%hash;
  77   $record = new FS::svc_acct { 'column' => 'value' };
  78
  79   $error = $record->insert;
  80
  81   $error = $new_record->replace($old_record);
  82
  83   $error = $record->delete;
  84
  85   $error = $record->check;
  86
  87   $error = $record->suspend;
  88
  89   $error = $record->unsuspend;
  90
  91   $error = $record->cancel;
  92
  93   %hash = $record->radius;
  94
  95   %hash = $record->radius_reply;
  96
  97   %hash = $record->radius_check;
  98
  99   $domain = $record->domain;
 100
 101   $svc_domain = $record->svc_domain;
 102
 103   $email = $record->email;
 104
 105   $seconds_since = $record->seconds_since($timestamp);
 106
 107 =head1 DESCRIPTION
 108
 109 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 110 FS::svc_Common.  The following fields are currently supported:
 111
 112 =over 4
 113
 114 =item svcnum - primary key (assigned automatcially for new accounts)
 115
 116 =item username
 117
 118 =item _password - generated if blank
 119
 120 =item sec_phrase - security phrase
 121
 122 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 123
 124 =item uid
 125
 126 =item gid
 127
 128 =item finger - GECOS
 129
 130 =item dir - set automatically if blank (and uid is not)
 131
 132 =item shell
 133
 134 =item quota - (unimplementd)
 135
 136 =item slipip - IP address
 137
 138 =item seconds -
 139
 140 =item domsvc - svcnum from svc_domain
 141
 142 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 143
 144 =back
 145
 146 =head1 METHODS
 147
 148 =over 4
 149
 150 =item new HASHREF
 151
 152 Creates a new account.  To add the account to the database, see L<"insert">.
 153
 154 =cut
 155
 156 sub table { 'svc_acct'; }
 157
 158 =item insert
 159
 160 Adds this account to the database.  If there is an error, returns the error,
 161 otherwise returns false.
 162
 163 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 164 defined.  An FS::cust_svc record will be created and inserted.
 165
 166 The additional field I<usergroup> can optionally be defined; if so it should
 167 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 168 sqlradius export only)
 169
 170 (TODOC: L<FS::queue> and L<freeside-queued>)
 171
 172 (TODOC: new exports! $noexport_hack)
 173
 174 =cut
 175
 176 sub insert {
 177   my $self = shift;
 178   my $error;
 179
 180   local $SIG{HUP} = 'IGNORE';
 181   local $SIG{INT} = 'IGNORE';
 182   local $SIG{QUIT} = 'IGNORE';
 183   local $SIG{TERM} = 'IGNORE';
 184   local $SIG{TSTP} = 'IGNORE';
 185   local $SIG{PIPE} = 'IGNORE';
 186
 187   my $oldAutoCommit = $FS::UID::AutoCommit;
 188   local $FS::UID::AutoCommit = 0;
 189   my $dbh = dbh;
 190
 191   $error = $self->check;
 192   return $error if $error;
 193
 194   return gettext('username_in_use'). ": ". $self->username
 195     if qsearchs( 'svc_acct', { 'username' => $self->username,
 196                                'domsvc'   => $self->domsvc,
 197                              } );
 198
 199   if ( $self->svcnum ) {
 200     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 201     unless ( $cust_svc ) {
 202       $dbh->rollback if $oldAutoCommit;
 203       return "no cust_svc record found for svcnum ". $self->svcnum;
 204     }
 205     $self->pkgnum($cust_svc->pkgnum);
 206     $self->svcpart($cust_svc->svcpart);
 207   }
 208
 209   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 210   return "Unknown svcpart" unless $part_svc;
 211   return "uid in use"
 212     if $part_svc->part_svc_column('uid')->columnflag ne 'F'
 213       && qsearchs( 'svc_acct', { 'uid' => $self->uid } )
 214       && $self->username !~ /^(hyla)?fax$/
 215     ;
 216
 217   $error = $self->SUPER::insert;
 218   if ( $error ) {
 219     $dbh->rollback if $oldAutoCommit;
 220     return $error;
 221   }
 222
 223   if ( $self->usergroup ) {
 224     foreach my $groupname ( @{$self->usergroup} ) {
 225       my $radius_usergroup = new FS::radius_usergroup ( {
 226         svcnum    => $self->svcnum,
 227         groupname => $groupname,
 228       } );
 229       my $error = $radius_usergroup->insert;
 230       if ( $error ) {
 231         $dbh->rollback if $oldAutoCommit;
 232         return $error;
 233       }
 234     }
 235   }
 236
 237   #new-style exports!
 238   unless ( $noexport_hack ) {
 239     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
 240       my $error = $part_export->export_insert($self);
 241       if ( $error ) {
 242         $dbh->rollback if $oldAutoCommit;
 243         return "exporting to ". $part_export->exporttype.
 244                " (transaction rolled back): $error";
 245       }
 246     }
 247   }
 248
 249   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 250   ''; #no error
 251 }
 252
 253 =item delete
 254
 255 Deletes this account from the database.  If there is an error, returns the
 256 error, otherwise returns false.
 257
 258 The corresponding FS::cust_svc record will be deleted as well.
 259
 260 (TODOC: new exports! $noexport_hack)
 261
 262 =cut
 263
 264 sub delete {
 265   my $self = shift;
 266
 267   if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
 268     return "Can't delete an account which has (svc_acct_sm) mail aliases!"
 269       if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
 270   }
 271
 272   return "Can't delete an account which is a (svc_forward) source!"
 273     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 274
 275   return "Can't delete an account which is a (svc_forward) destination!"
 276     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 277
 278   return "Can't delete an account with (svc_www) web service!"
 279     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 280
 281   # what about records in session ? (they should refer to history table)
 282
 283   local $SIG{HUP} = 'IGNORE';
 284   local $SIG{INT} = 'IGNORE';
 285   local $SIG{QUIT} = 'IGNORE';
 286   local $SIG{TERM} = 'IGNORE';
 287   local $SIG{TSTP} = 'IGNORE';
 288   local $SIG{PIPE} = 'IGNORE';
 289
 290   my $oldAutoCommit = $FS::UID::AutoCommit;
 291   local $FS::UID::AutoCommit = 0;
 292   my $dbh = dbh;
 293
 294   foreach my $cust_main_invoice (
 295     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 296   ) {
 297     unless ( defined($cust_main_invoice) ) {
 298       warn "WARNING: something's wrong with qsearch";
 299       next;
 300     }
 301     my %hash = $cust_main_invoice->hash;
 302     $hash{'dest'} = $self->email;
 303     my $new = new FS::cust_main_invoice \%hash;
 304     my $error = $new->replace($cust_main_invoice);
 305     if ( $error ) {
 306       $dbh->rollback if $oldAutoCommit;
 307       return $error;
 308     }
 309   }
 310
 311   foreach my $svc_domain (
 312     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 313   ) {
 314     my %hash = new FS::svc_domain->hash;
 315     $hash{'catchall'} = '';
 316     my $new = new FS::svc_domain \%hash;
 317     my $error = $new->replace($svc_domain);
 318     if ( $error ) {
 319       $dbh->rollback if $oldAutoCommit;
 320       return $error;
 321     }
 322   }
 323
 324   foreach my $radius_usergroup (
 325     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 326   ) {
 327     my $error = $radius_usergroup->delete;
 328     if ( $error ) {
 329       $dbh->rollback if $oldAutoCommit;
 330       return $error;
 331     }
 332   }
 333
 334   my $part_svc = $self->cust_svc->part_svc;
 335
 336   my $error = $self->SUPER::delete;
 337   if ( $error ) {
 338     $dbh->rollback if $oldAutoCommit;
 339     return $error;
 340   }
 341
 342   #new-style exports!
 343   unless ( $noexport_hack ) {
 344     foreach my $part_export ( $part_svc->part_export ) {
 345       my $error = $part_export->export_delete($self);
 346       if ( $error ) {
 347         $dbh->rollback if $oldAutoCommit;
 348         return "exporting to ". $part_export->exporttype.
 349                " (transaction rolled back): $error";
 350       }
 351     }
 352   }
 353
 354   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 355   '';
 356 }
 357
 358 =item replace OLD_RECORD
 359
 360 Replaces OLD_RECORD with this one in the database.  If there is an error,
 361 returns the error, otherwise returns false.
 362
 363 The additional field I<usergroup> can optionally be defined; if so it should
 364 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 365 sqlradius export only)
 366
 367 =cut
 368
 369 sub replace {
 370   my ( $new, $old ) = ( shift, shift );
 371   my $error;
 372
 373   return "Username in use"
 374     if $old->username ne $new->username &&
 375       qsearchs( 'svc_acct', { 'username' => $new->username,
 376                                'domsvc'   => $new->domsvc,
 377                              } );
 378   {
 379     #no warnings 'numeric';  #alas, a 5.006-ism
 380     local($^W) = 0;
 381     return "Can't change uid!" if $old->uid != $new->uid;
 382   }
 383
 384   #change homdir when we change username
 385   $new->setfield('dir', '') if $old->username ne $new->username;
 386
 387   local $SIG{HUP} = 'IGNORE';
 388   local $SIG{INT} = 'IGNORE';
 389   local $SIG{QUIT} = 'IGNORE';
 390   local $SIG{TERM} = 'IGNORE';
 391   local $SIG{TSTP} = 'IGNORE';
 392   local $SIG{PIPE} = 'IGNORE';
 393
 394   my $oldAutoCommit = $FS::UID::AutoCommit;
 395   local $FS::UID::AutoCommit = 0;
 396   my $dbh = dbh;
 397
 398   $error = $new->SUPER::replace($old);
 399   if ( $error ) {
 400     $dbh->rollback if $oldAutoCommit;
 401     return $error if $error;
 402   }
 403
 404   $old->usergroup( [ $old->radius_groups ] );
 405   if ( $new->usergroup ) {
 406     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 407     my @newgroups = @{$new->usergroup};
 408     foreach my $oldgroup ( @{$old->usergroup} ) {
 409       if ( grep { $oldgroup eq $_ } @newgroups ) {
 410         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 411         next;
 412       }
 413       my $radius_usergroup = qsearchs('radius_usergroup', {
 414         svcnum    => $old->svcnum,
 415         groupname => $oldgroup,
 416       } );
 417       my $error = $radius_usergroup->delete;
 418       if ( $error ) {
 419         $dbh->rollback if $oldAutoCommit;
 420         return "error deleting radius_usergroup $oldgroup: $error";
 421       }
 422     }
 423
 424     foreach my $newgroup ( @newgroups ) {
 425       my $radius_usergroup = new FS::radius_usergroup ( {
 426         svcnum    => $new->svcnum,
 427         groupname => $newgroup,
 428       } );
 429       my $error = $radius_usergroup->insert;
 430       if ( $error ) {
 431         $dbh->rollback if $oldAutoCommit;
 432         return "error adding radius_usergroup $newgroup: $error";
 433       }
 434     }
 435
 436   }
 437
 438   #new-style exports!
 439   unless ( $noexport_hack ) {
 440     foreach my $part_export ( $new->cust_svc->part_svc->part_export ) {
 441       my $error = $part_export->export_replace($new,$old);
 442       if ( $error ) {
 443         $dbh->rollback if $oldAutoCommit;
 444         return "exporting to ". $part_export->exporttype.
 445                " (transaction rolled back): $error";
 446       }
 447     }
 448   }
 449
 450   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 451   ''; #no error
 452 }
 453
 454 =item suspend
 455
 456 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 457 error, returns the error, otherwise returns false.
 458
 459 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 460
 461 =cut
 462
 463 sub suspend {
 464   my $self = shift;
 465   my %hash = $self->hash;
 466   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 467            || $hash{_password} eq '*'
 468          ) {
 469     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 470     my $new = new FS::svc_acct ( \%hash );
 471     $new->replace($self);
 472   } else {
 473     ''; #no error (already suspended)
 474   }
 475 }
 476
 477 =item unsuspend
 478
 479 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 480 an error, returns the error, otherwise returns false.
 481
 482 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 483
 484 =cut
 485
 486 sub unsuspend {
 487   my $self = shift;
 488   my %hash = $self->hash;
 489   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 490     $hash{_password} = $1;
 491     my $new = new FS::svc_acct ( \%hash );
 492     $new->replace($self);
 493   } else {
 494     ''; #no error (already unsuspended)
 495   }
 496 }
 497
 498 =item cancel
 499
 500 Just returns false (no error) for now.
 501
 502 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 503
 504 =item check
 505
 506 Checks all fields to make sure this is a valid service.  If there is an error,
 507 returns the error, otherwise returns false.  Called by the insert and replace
 508 methods.
 509
 510 Sets any fixed values; see L<FS::part_svc>.
 511
 512 =cut
 513
 514 sub check {
 515   my $self = shift;
 516
 517   my($recref) = $self->hashref;
 518
 519   my $x = $self->setfixed;
 520   return $x unless ref($x);
 521   my $part_svc = $x;
 522
 523   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 524     $self->usergroup(
 525       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 526   }
 527
 528   my $error = $self->ut_numbern('svcnum')
 529               || $self->ut_number('domsvc')
 530               || $self->ut_textn('sec_phrase')
 531   ;
 532   return $error if $error;
 533
 534   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 535   if ( $username_uppercase ) {
 536     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 537       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 538     $recref->{username} = $1;
 539   } else {
 540     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 541       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 542     $recref->{username} = $1;
 543   }
 544
 545   if ( $username_letterfirst ) {
 546     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 547   } elsif ( $username_letter ) {
 548     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 549   }
 550   if ( $username_noperiod ) {
 551     $recref->{username} =~ /\./ and return gettext('illegal_username');
 552   }
 553   if ( $username_nounderscore ) {
 554     $recref->{username} =~ /_/ and return gettext('illegal_username');
 555   }
 556   if ( $username_nodash ) {
 557     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 558   }
 559   unless ( $username_ampersand ) {
 560     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 561   }
 562
 563   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 564   $recref->{popnum} = $1;
 565   return "Unknown popnum" unless
 566     ! $recref->{popnum} ||
 567     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 568
 569   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 570
 571     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 572     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 573
 574     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 575     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 576     #not all systems use gid=uid
 577     #you can set a fixed gid in part_svc
 578
 579     return "Only root can have uid 0"
 580       if $recref->{uid} == 0
 581          && $recref->{username} ne 'root'
 582          && $recref->{username} ne 'toor';
 583
 584 #    $error = $self->ut_textn('finger');
 585 #    return $error if $error;
 586     $self->getfield('finger') =~
 587       /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\*\<\>]*)$/
 588         or return "Illegal finger: ". $self->getfield('finger');
 589     $self->setfield('finger', $1);
 590
 591     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 592       or return "Illegal directory";
 593     $recref->{dir} = $1;
 594     return "Illegal directory"
 595       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 596     return "Illegal directory"
 597       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 598     unless ( $recref->{dir} ) {
 599       $recref->{dir} = $dir_prefix . '/';
 600       if ( $dirhash > 0 ) {
 601         for my $h ( 1 .. $dirhash ) {
 602           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 603         }
 604       } elsif ( $dirhash < 0 ) {
 605         for my $h ( reverse $dirhash .. -1 ) {
 606           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 607         }
 608       }
 609       $recref->{dir} .= $recref->{username};
 610     ;
 611     }
 612
 613     unless ( $recref->{username} eq 'sync' ) {
 614       if ( grep $_ eq $recref->{shell}, @shells ) {
 615         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 616       } else {
 617         return "Illegal shell \`". $self->shell. "\'; ".
 618                $conf->dir. "/shells contains: @shells";
 619       }
 620     } else {
 621       $recref->{shell} = '/bin/sync';
 622     }
 623
 624     $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)";
 625     $recref->{quota} = $1;
 626
 627   } else {
 628     $recref->{gid} ne '' ?
 629       return "Can't have gid without uid" : ( $recref->{gid}='' );
 630     $recref->{finger} ne '' ?
 631       return "Can't have finger-name without uid" : ( $recref->{finger}='' );
 632     $recref->{dir} ne '' ?
 633       return "Can't have directory without uid" : ( $recref->{dir}='' );
 634     $recref->{shell} ne '' ?
 635       return "Can't have shell without uid" : ( $recref->{shell}='' );
 636     $recref->{quota} ne '' ?
 637       return "Can't have quota without uid" : ( $recref->{quota}='' );
 638   }
 639
 640   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 641     unless ( $recref->{slipip} eq '0e0' ) {
 642       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 643         or return "Illegal slipip". $self->slipip;
 644       $recref->{slipip} = $1;
 645     } else {
 646       $recref->{slipip} = '0e0';
 647     }
 648
 649   }
 650
 651   #arbitrary RADIUS stuff; allow ut_textn for now
 652   foreach ( grep /^radius_/, fields('svc_acct') ) {
 653     $self->ut_textn($_);
 654   }
 655
 656   #generate a password if it is blank
 657   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 658     unless ( $recref->{_password} );
 659
 660   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 661   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 662     $recref->{_password} = $1.$3;
 663     #uncomment this to encrypt password immediately upon entry, or run
 664     #bin/crypt_pw in cron to give new users a window during which their
 665     #password is available to techs, for faxing, etc.  (also be aware of
 666     #radius issues!)
 667     #$recref->{password} = $1.
 668     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 669     #;
 670   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$]{13,34})$/ ) {
 671     $recref->{_password} = $1.$3;
 672   } elsif ( $recref->{_password} eq '*' ) {
 673     $recref->{_password} = '*';
 674   } elsif ( $recref->{_password} eq '!!' ) {
 675     $recref->{_password} = '!!';
 676   } else {
 677     #return "Illegal password";
 678     return gettext('illegal_password'). ": ". $recref->{_password};
 679   }
 680
 681   ''; #no error
 682 }
 683
 684 =item radius
 685
 686 Depriciated, use radius_reply instead.
 687
 688 =cut
 689
 690 sub radius {
 691   carp "FS::svc_acct::radius depriciated, use radius_reply";
 692   $_[0]->radius_reply;
 693 }
 694
 695 =item radius_reply
 696
 697 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 698 reply attributes of this record.
 699
 700 Note that this is now the preferred method for reading RADIUS attributes -
 701 accessing the columns directly is discouraged, as the column names are
 702 expected to change in the future.
 703
 704 =cut
 705
 706 sub radius_reply {
 707   my $self = shift;
 708   my %reply =
 709     map {
 710       /^(radius_(.*))$/;
 711       my($column, $attrib) = ($1, $2);
 712       #$attrib =~ s/_/\-/g;
 713       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 714     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 715   if ( $self->ip && $self->ip ne '0e0' ) {
 716     $reply{'Framed-IP-Address'} = $self->ip;
 717   }
 718   %reply;
 719 }
 720
 721 =item radius_check
 722
 723 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 724 check attributes of this record.
 725
 726 Note that this is now the preferred method for reading RADIUS attributes -
 727 accessing the columns directly is discouraged, as the column names are
 728 expected to change in the future.
 729
 730 =cut
 731
 732 sub radius_check {
 733   my $self = shift;
 734   ( 'Password' => $self->_password,
 735     map {
 736       /^(rc_(.*))$/;
 737       my($column, $attrib) = ($1, $2);
 738       #$attrib =~ s/_/\-/g;
 739       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 740     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 741   );
 742 }
 743
 744 =item domain
 745
 746 Returns the domain associated with this account.
 747
 748 =cut
 749
 750 sub domain {
 751   my $self = shift;
 752   if ( $self->domsvc ) {
 753     #$self->svc_domain->domain;
 754     my $svc_domain = $self->svc_domain
 755       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 756     $svc_domain->domain;
 757   } else {
 758     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 759   }
 760 }
 761
 762 =item svc_domain
 763
 764 Returns the FS::svc_domain record for this account's domain (see
 765 L<FS::svc_domain>.
 766
 767 =cut
 768
 769 sub svc_domain {
 770   my $self = shift;
 771   $self->{'_domsvc'}
 772     ? $self->{'_domsvc'}
 773     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 774 }
 775
 776 =item cust_svc
 777
 778 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 779
 780 sub cust_svc {
 781   my $self = shift;
 782   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 783 }
 784
 785 =item email
 786
 787 Returns an email address associated with the account.
 788
 789 =cut
 790
 791 sub email {
 792   my $self = shift;
 793   $self->username. '@'. $self->domain;
 794 }
 795
 796 =item seconds_since TIMESTAMP
 797
 798 Returns the number of seconds this account has been online since TIMESTAMP.
 799 See L<FS::session>
 800
 801 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 802 L<Time::Local> and L<Date::Parse> for conversion functions.
 803
 804 =cut
 805
 806 #note: POD here, implementation in FS::cust_svc
 807 sub seconds_since {
 808   my $self = shift;
 809   $self->cust_svc->seconds_since(@_);
 810 }
 811
 812 =item radius_groups
 813
 814 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
 815
 816 =cut
 817
 818 sub radius_groups {
 819   my $self = shift;
 820   map { $_->groupname }
 821     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
 822 }
 823
 824 =back
 825
 826 =head1 SUBROUTINES
 827
 828 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
 829
 830 =cut
 831
 832 sub radius_usergroup_selector {
 833   my $sel_groups = shift;
 834   my %sel_groups = map { $_=>1 } @$sel_groups;
 835
 836   my $selectname = shift || 'radius_usergroup';
 837
 838   my $dbh = dbh;
 839   my $sth = $dbh->prepare(
 840     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
 841   ) or die $dbh->errstr;
 842   $sth->execute() or die $sth->errstr;
 843   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
 844
 845   my $html = <<END;
 846     <SCRIPT>
 847     function ${selectname}_doadd(object) {
 848       var myvalue = object.${selectname}_add.value;
 849       var optionName = new Option(myvalue,myvalue,false,true);
 850       var length = object.$selectname.length;
 851       object.$selectname.options[length] = optionName;
 852       object.${selectname}_add.value = "";
 853     }
 854     </SCRIPT>
 855     <SELECT MULTIPLE NAME="$selectname">
 856 END
 857
 858   foreach my $group ( @all_groups ) {
 859     $html .= '<OPTION';
 860     if ( $sel_groups{$group} ) {
 861       $html .= ' SELECTED';
 862       $sel_groups{$group} = 0;
 863     }
 864     $html .= ">$group</OPTION>\n";
 865   }
 866   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
 867     $html .= "<OPTION SELECTED>$group</OPTION>\n";
 868   };
 869   $html .= '</SELECT>';
 870
 871   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
 872            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
 873
 874   $html;
 875 }
 876
 877 =head1 BUGS
 878
 879 The $recref stuff in sub check should be cleaned up.
 880
 881 The suspend, unsuspend and cancel methods update the database, but not the
 882 current object.  This is probably a bug as it's unexpected and
 883 counterintuitive.
 884
 885 radius_usergroup_selector?  putting web ui components in here?  they should
 886 probably live somewhere else...
 887
 888 =head1 SEE ALSO
 889
 890 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
 891 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
 892 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
 893 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
 894 schema.html from the base documentation.
 895
 896 =cut
 897
 898 1;
 899