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