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