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 && $recref->{username} ne 'root';
 581
 582 #    $error = $self->ut_textn('finger');
 583 #    return $error if $error;
 584     $self->getfield('finger') =~
 585       /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\*\<\>]*)$/
 586         or return "Illegal finger: ". $self->getfield('finger');
 587     $self->setfield('finger', $1);
 588
 589     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 590       or return "Illegal directory";
 591     $recref->{dir} = $1;
 592     return "Illegal directory"
 593       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 594     return "Illegal directory"
 595       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 596     unless ( $recref->{dir} ) {
 597       $recref->{dir} = $dir_prefix . '/';
 598       if ( $dirhash > 0 ) {
 599         for my $h ( 1 .. $dirhash ) {
 600           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 601         }
 602       } elsif ( $dirhash < 0 ) {
 603         for my $h ( reverse $dirhash .. -1 ) {
 604           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 605         }
 606       }
 607       $recref->{dir} .= $recref->{username};
 608     ;
 609     }
 610
 611     unless ( $recref->{username} eq 'sync' ) {
 612       if ( grep $_ eq $recref->{shell}, @shells ) {
 613         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 614       } else {
 615         return "Illegal shell \`". $self->shell. "\'; ".
 616                $conf->dir. "/shells contains: @shells";
 617       }
 618     } else {
 619       $recref->{shell} = '/bin/sync';
 620     }
 621
 622     $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)";
 623     $recref->{quota} = $1;
 624
 625   } else {
 626     $recref->{gid} ne '' ?
 627       return "Can't have gid without uid" : ( $recref->{gid}='' );
 628     $recref->{finger} ne '' ?
 629       return "Can't have finger-name without uid" : ( $recref->{finger}='' );
 630     $recref->{dir} ne '' ?
 631       return "Can't have directory without uid" : ( $recref->{dir}='' );
 632     $recref->{shell} ne '' ?
 633       return "Can't have shell without uid" : ( $recref->{shell}='' );
 634     $recref->{quota} ne '' ?
 635       return "Can't have quota without uid" : ( $recref->{quota}='' );
 636   }
 637
 638   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 639     unless ( $recref->{slipip} eq '0e0' ) {
 640       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 641         or return "Illegal slipip". $self->slipip;
 642       $recref->{slipip} = $1;
 643     } else {
 644       $recref->{slipip} = '0e0';
 645     }
 646
 647   }
 648
 649   #arbitrary RADIUS stuff; allow ut_textn for now
 650   foreach ( grep /^radius_/, fields('svc_acct') ) {
 651     $self->ut_textn($_);
 652   }
 653
 654   #generate a password if it is blank
 655   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 656     unless ( $recref->{_password} );
 657
 658   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 659   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 660     $recref->{_password} = $1.$3;
 661     #uncomment this to encrypt password immediately upon entry, or run
 662     #bin/crypt_pw in cron to give new users a window during which their
 663     #password is available to techs, for faxing, etc.  (also be aware of
 664     #radius issues!)
 665     #$recref->{password} = $1.
 666     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 667     #;
 668   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$]{13,34})$/ ) {
 669     $recref->{_password} = $1.$3;
 670   } elsif ( $recref->{_password} eq '*' ) {
 671     $recref->{_password} = '*';
 672   } elsif ( $recref->{_password} eq '!!' ) {
 673     $recref->{_password} = '!!';
 674   } else {
 675     #return "Illegal password";
 676     return gettext('illegal_password'). ": ". $recref->{_password};
 677   }
 678
 679   ''; #no error
 680 }
 681
 682 =item radius
 683
 684 Depriciated, use radius_reply instead.
 685
 686 =cut
 687
 688 sub radius {
 689   carp "FS::svc_acct::radius depriciated, use radius_reply";
 690   $_[0]->radius_reply;
 691 }
 692
 693 =item radius_reply
 694
 695 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 696 reply attributes of this record.
 697
 698 Note that this is now the preferred method for reading RADIUS attributes -
 699 accessing the columns directly is discouraged, as the column names are
 700 expected to change in the future.
 701
 702 =cut
 703
 704 sub radius_reply {
 705   my $self = shift;
 706   my %reply =
 707     map {
 708       /^(radius_(.*))$/;
 709       my($column, $attrib) = ($1, $2);
 710       #$attrib =~ s/_/\-/g;
 711       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 712     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 713   if ( $self->ip && $self->ip ne '0e0' ) {
 714     $reply{'Framed-IP-Address'} = $self->ip;
 715   }
 716   %reply;
 717 }
 718
 719 =item radius_check
 720
 721 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 722 check attributes of this record.
 723
 724 Note that this is now the preferred method for reading RADIUS attributes -
 725 accessing the columns directly is discouraged, as the column names are
 726 expected to change in the future.
 727
 728 =cut
 729
 730 sub radius_check {
 731   my $self = shift;
 732   ( 'Password' => $self->_password,
 733     map {
 734       /^(rc_(.*))$/;
 735       my($column, $attrib) = ($1, $2);
 736       #$attrib =~ s/_/\-/g;
 737       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 738     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 739   );
 740 }
 741
 742 =item domain
 743
 744 Returns the domain associated with this account.
 745
 746 =cut
 747
 748 sub domain {
 749   my $self = shift;
 750   if ( $self->domsvc ) {
 751     #$self->svc_domain->domain;
 752     my $svc_domain = $self->svc_domain
 753       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 754     $svc_domain->domain;
 755   } else {
 756     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 757   }
 758 }
 759
 760 =item svc_domain
 761
 762 Returns the FS::svc_domain record for this account's domain (see
 763 L<FS::svc_domain>.
 764
 765 =cut
 766
 767 sub svc_domain {
 768   my $self = shift;
 769   $self->{'_domsvc'}
 770     ? $self->{'_domsvc'}
 771     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 772 }
 773
 774 =item cust_svc
 775
 776 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 777
 778 sub cust_svc {
 779   my $self = shift;
 780   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 781 }
 782
 783 =item email
 784
 785 Returns an email address associated with the account.
 786
 787 =cut
 788
 789 sub email {
 790   my $self = shift;
 791   $self->username. '@'. $self->domain;
 792 }
 793
 794 =item seconds_since TIMESTAMP
 795
 796 Returns the number of seconds this account has been online since TIMESTAMP.
 797 See L<FS::session>
 798
 799 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 800 L<Time::Local> and L<Date::Parse> for conversion functions.
 801
 802 =cut
 803
 804 #note: POD here, implementation in FS::cust_svc
 805 sub seconds_since {
 806   my $self = shift;
 807   $self->cust_svc->seconds_since(@_);
 808 }
 809
 810 =item radius_groups
 811
 812 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
 813
 814 =cut
 815
 816 sub radius_groups {
 817   my $self = shift;
 818   map { $_->groupname }
 819     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
 820 }
 821
 822 =back
 823
 824 =head1 SUBROUTINES
 825
 826 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
 827
 828 =cut
 829
 830 sub radius_usergroup_selector {
 831   my $sel_groups = shift;
 832   my %sel_groups = map { $_=>1 } @$sel_groups;
 833
 834   my $selectname = shift || 'radius_usergroup';
 835
 836   my $dbh = dbh;
 837   my $sth = $dbh->prepare(
 838     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
 839   ) or die $dbh->errstr;
 840   $sth->execute() or die $sth->errstr;
 841   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
 842
 843   my $html = <<END;
 844     <SCRIPT>
 845     function ${selectname}_doadd(object) {
 846       var myvalue = object.${selectname}_add.value;
 847       var optionName = new Option(myvalue,myvalue,false,true);
 848       var length = object.$selectname.length;
 849       object.$selectname.options[length] = optionName;
 850       object.${selectname}_add.value = "";
 851     }
 852     </SCRIPT>
 853     <SELECT MULTIPLE NAME="$selectname">
 854 END
 855
 856   foreach my $group ( @all_groups ) {
 857     $html .= '<OPTION';
 858     if ( $sel_groups{$group} ) {
 859       $html .= ' SELECTED';
 860       $sel_groups{$group} = 0;
 861     }
 862     $html .= ">$group</OPTION>\n";
 863   }
 864   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
 865     $html .= "<OPTION SELECTED>$group</OPTION>\n";
 866   };
 867   $html .= '</SELECT>';
 868
 869   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
 870            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
 871
 872   $html;
 873 }
 874
 875 =head1 BUGS
 876
 877 The $recref stuff in sub check should be cleaned up.
 878
 879 The suspend, unsuspend and cancel methods update the database, but not the
 880 current object.  This is probably a bug as it's unexpected and
 881 counterintuitive.
 882
 883 radius_usergroup_selector?  putting web ui components in here?  they should
 884 probably live somewhere else...
 885
 886 =head1 SEE ALSO
 887
 888 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
 889 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
 890 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
 891 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
 892 schema.html from the base documentation.
 893
 894 =cut
 895
 896 1;
 897