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