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