FS/FS/svc_acct.pm

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