FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $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              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
  11              $smtpmachine
  12              $radius_password
  13              $dirhash
  14              @saltset @pw_set );
  15 use Carp;
  16 use Fcntl qw(:flock);
  17 use FS::UID qw( datasrc );
  18 use FS::Conf;
  19 use FS::Record qw( qsearch qsearchs fields dbh );
  20 use FS::svc_Common;
  21 use FS::cust_svc;
  22 use FS::part_svc;
  23 use FS::svc_acct_pop;
  24 use FS::cust_main_invoice;
  25 use FS::svc_domain;
  26 use FS::raddb;
  27 use FS::queue;
  28 use FS::radius_usergroup;
  29 use FS::export_svc;
  30 use FS::part_export;
  31 use FS::Msgcat qw(gettext);
  32
  33 @ISA = qw( FS::svc_Common );
  34
  35 $DEBUG = 0;
  36 $me = '[FS::svc_acct]';
  37
  38 #ask FS::UID to run this stuff for us later
  39 $FS::UID::callback{'FS::svc_acct'} = sub {
  40   $conf = new FS::Conf;
  41   $dir_prefix = $conf->config('home');
  42   @shells = $conf->config('shells');
  43   $usernamemin = $conf->config('usernamemin') || 2;
  44   $usernamemax = $conf->config('usernamemax');
  45   $passwordmin = $conf->config('passwordmin') || 6;
  46   $passwordmax = $conf->config('passwordmax') || 8;
  47   $username_letter = $conf->exists('username-letter');
  48   $username_letterfirst = $conf->exists('username-letterfirst');
  49   $username_noperiod = $conf->exists('username-noperiod');
  50   $username_nounderscore = $conf->exists('username-nounderscore');
  51   $username_nodash = $conf->exists('username-nodash');
  52   $username_uppercase = $conf->exists('username-uppercase');
  53   $username_ampersand = $conf->exists('username-ampersand');
  54   $dirhash = $conf->config('dirhash') || 0;
  55   if ( $conf->exists('welcome_email') ) {
  56     $welcome_template = new Text::Template (
  57       TYPE   => 'ARRAY',
  58       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  59     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  60     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  61     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  62     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  63   } else {
  64     $welcome_template = '';
  65   }
  66   $smtpmachine = $conf->config('smtpmachine');
  67   $radius_password = $conf->config('radius-password') || 'Password';
  68 };
  69
  70 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  71 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  72
  73 sub _cache {
  74   my $self = shift;
  75   my ( $hashref, $cache ) = @_;
  76   if ( $hashref->{'svc_acct_svcnum'} ) {
  77     $self->{'_domsvc'} = FS::svc_domain->new( {
  78       'svcnum'   => $hashref->{'domsvc'},
  79       'domain'   => $hashref->{'svc_acct_domain'},
  80       'catchall' => $hashref->{'svc_acct_catchall'},
  81     } );
  82   }
  83 }
  84
  85 =head1 NAME
  86
  87 FS::svc_acct - Object methods for svc_acct records
  88
  89 =head1 SYNOPSIS
  90
  91   use FS::svc_acct;
  92
  93   $record = new FS::svc_acct \%hash;
  94   $record = new FS::svc_acct { 'column' => 'value' };
  95
  96   $error = $record->insert;
  97
  98   $error = $new_record->replace($old_record);
  99
 100   $error = $record->delete;
 101
 102   $error = $record->check;
 103
 104   $error = $record->suspend;
 105
 106   $error = $record->unsuspend;
 107
 108   $error = $record->cancel;
 109
 110   %hash = $record->radius;
 111
 112   %hash = $record->radius_reply;
 113
 114   %hash = $record->radius_check;
 115
 116   $domain = $record->domain;
 117
 118   $svc_domain = $record->svc_domain;
 119
 120   $email = $record->email;
 121
 122   $seconds_since = $record->seconds_since($timestamp);
 123
 124 =head1 DESCRIPTION
 125
 126 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 127 FS::svc_Common.  The following fields are currently supported:
 128
 129 =over 4
 130
 131 =item svcnum - primary key (assigned automatcially for new accounts)
 132
 133 =item username
 134
 135 =item _password - generated if blank
 136
 137 =item sec_phrase - security phrase
 138
 139 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 140
 141 =item uid
 142
 143 =item gid
 144
 145 =item finger - GECOS
 146
 147 =item dir - set automatically if blank (and uid is not)
 148
 149 =item shell
 150
 151 =item quota - (unimplementd)
 152
 153 =item slipip - IP address
 154
 155 =item seconds -
 156
 157 =item domsvc - svcnum from svc_domain
 158
 159 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 160
 161 =back
 162
 163 =head1 METHODS
 164
 165 =over 4
 166
 167 =item new HASHREF
 168
 169 Creates a new account.  To add the account to the database, see L<"insert">.
 170
 171 =cut
 172
 173 sub table { 'svc_acct'; }
 174
 175 =item insert
 176
 177 Adds this account to the database.  If there is an error, returns the error,
 178 otherwise returns false.
 179
 180 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 181 defined.  An FS::cust_svc record will be created and inserted.
 182
 183 The additional field I<usergroup> can optionally be defined; if so it should
 184 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 185 sqlradius export only)
 186
 187 (TODOC: L<FS::queue> and L<freeside-queued>)
 188
 189 (TODOC: new exports! $noexport_hack)
 190
 191 =cut
 192
 193 sub insert {
 194   my $self = shift;
 195   my $error;
 196
 197   local $SIG{HUP} = 'IGNORE';
 198   local $SIG{INT} = 'IGNORE';
 199   local $SIG{QUIT} = 'IGNORE';
 200   local $SIG{TERM} = 'IGNORE';
 201   local $SIG{TSTP} = 'IGNORE';
 202   local $SIG{PIPE} = 'IGNORE';
 203
 204   my $oldAutoCommit = $FS::UID::AutoCommit;
 205   local $FS::UID::AutoCommit = 0;
 206   my $dbh = dbh;
 207
 208   $error = $self->check;
 209   return $error if $error;
 210
 211   #no, duplicate checking just got a whole lot more complicated
 212   #(perhaps keep this check with a config option to turn on?)
 213
 214   #return gettext('username_in_use'). ": ". $self->username
 215   #  if qsearchs( 'svc_acct', { 'username' => $self->username,
 216   #                             'domsvc'   => $self->domsvc,
 217   #                           } );
 218
 219   if ( $self->svcnum ) {
 220     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 221     unless ( $cust_svc ) {
 222       $dbh->rollback if $oldAutoCommit;
 223       return "no cust_svc record found for svcnum ". $self->svcnum;
 224     }
 225     $self->pkgnum($cust_svc->pkgnum);
 226     $self->svcpart($cust_svc->svcpart);
 227   }
 228
 229   #new duplicate username checking
 230
 231   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 232   unless ( $part_svc ) {
 233     $dbh->rollback if $oldAutoCommit;
 234     return 'unknown svcpart '. $self->svcpart;
 235   }
 236
 237   my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
 238   my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
 239                                               'domsvc'   => $self->domsvc } );
 240   my @dup_uid;
 241   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 242        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 243     @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
 244   } else {
 245     @dup_uid = ();
 246   }
 247
 248   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 249     my $exports = FS::part_export::export_info('svc_acct');
 250     my %conflict_user_svcpart;
 251     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 252
 253     foreach my $part_export ( $part_svc->part_export ) {
 254
 255       #this will catch to the same exact export
 256       my @svcparts = map { $_->svcpart }
 257         qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 258
 259       #this will catch to exports w/same exporthost+type ???
 260       #my @other_part_export = qsearch('part_export', {
 261       #  'machine'    => $part_export->machine,
 262       #  'exporttype' => $part_export->exporttype,
 263       #} );
 264       #foreach my $other_part_export ( @other_part_export ) {
 265       #  push @svcparts, map { $_->svcpart }
 266       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 267       #}
 268
 269       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 270       #silly kludge to avoid uninitialized value errors
 271       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 272                      ? $exports->{$part_export->exporttype}{'nodomain'}
 273                      : '';
 274       if ( $nodomain =~ /^Y/i ) {
 275         $conflict_user_svcpart{$_} = $part_export->exportnum
 276           foreach @svcparts;
 277       } else {
 278         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 279           foreach @svcparts;
 280       }
 281     }
 282
 283     foreach my $dup_user ( @dup_user ) {
 284       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 285       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 286         $dbh->rollback if $oldAutoCommit;
 287         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 288                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 289       }
 290     }
 291
 292     foreach my $dup_userdomain ( @dup_userdomain ) {
 293       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 294       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 295         $dbh->rollback if $oldAutoCommit;
 296         return "duplicate username\@domain: conflicts with svcnum ".
 297                $dup_userdomain->svcnum. " via exportnum ".
 298                $conflict_userdomain_svcpart{$dup_svcpart};
 299       }
 300     }
 301
 302     foreach my $dup_uid ( @dup_uid ) {
 303       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 304       if ( exists($conflict_user_svcpart{$dup_svcpart})
 305            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 306         $dbh->rollback if $oldAutoCommit;
 307         return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
 308                "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 309                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 310       }
 311     }
 312
 313   }
 314
 315   #see?  i told you it was more complicated
 316
 317   my @jobnums;
 318   $error = $self->SUPER::insert(\@jobnums);
 319   if ( $error ) {
 320     $dbh->rollback if $oldAutoCommit;
 321     return $error;
 322   }
 323
 324   if ( $self->usergroup ) {
 325     foreach my $groupname ( @{$self->usergroup} ) {
 326       my $radius_usergroup = new FS::radius_usergroup ( {
 327         svcnum    => $self->svcnum,
 328         groupname => $groupname,
 329       } );
 330       my $error = $radius_usergroup->insert;
 331       if ( $error ) {
 332         $dbh->rollback if $oldAutoCommit;
 333         return $error;
 334       }
 335     }
 336   }
 337
 338   #false laziness with sub replace (and cust_main)
 339   my $queue = new FS::queue {
 340     'svcnum' => $self->svcnum,
 341     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 342   };
 343   $error = $queue->insert($self->username);
 344   if ( $error ) {
 345     $dbh->rollback if $oldAutoCommit;
 346     return "queueing job (transaction rolled back): $error";
 347   }
 348
 349   my $cust_pkg = $self->cust_svc->cust_pkg;
 350
 351   if ( $cust_pkg ) {
 352     my $cust_main = $cust_pkg->cust_main;
 353
 354     if ( $conf->exists('emailinvoiceauto') ) {
 355       my @invoicing_list = $cust_main->invoicing_list;
 356       push @invoicing_list, $self->email;
 357       $cust_main->invoicing_list(\@invoicing_list);
 358     }
 359
 360     #welcome email
 361     my $to = '';
 362     if ( $welcome_template && $cust_pkg ) {
 363       my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
 364       if ( $to ) {
 365         my $wqueue = new FS::queue {
 366           'svcnum' => $self->svcnum,
 367           'job'    => 'FS::svc_acct::send_email'
 368         };
 369         warn "attempting to queue email to $to";
 370         my $error = $wqueue->insert(
 371           'to'       => $to,
 372           'from'     => $welcome_from,
 373           'subject'  => $welcome_subject,
 374           'mimetype' => $welcome_mimetype,
 375           'body'     => $welcome_template->fill_in( HASH => {
 376                           'custnum'  => $self->custnum,
 377                           'username' => $self->username,
 378                           'password' => $self->_password,
 379                           'first'    => $cust_main->first,
 380                           'last'     => $cust_main->getfield('last'),
 381                           'pkg'      => $cust_pkg->part_pkg->pkg,
 382                         } ),
 383         );
 384         if ( $error ) {
 385           $dbh->rollback if $oldAutoCommit;
 386           return "queuing welcome email: $error";
 387         }
 388
 389         foreach my $jobnum ( @jobnums ) {
 390           my $error = $wqueue->depend_insert($jobnum);
 391           if ( $error ) {
 392             $dbh->rollback if $oldAutoCommit;
 393             return "queuing welcome email job dependancy: $error";
 394           }
 395         }
 396
 397       }
 398
 399     }
 400
 401   } # if ( $cust_pkg )
 402
 403   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 404   ''; #no error
 405 }
 406
 407 =item delete
 408
 409 Deletes this account from the database.  If there is an error, returns the
 410 error, otherwise returns false.
 411
 412 The corresponding FS::cust_svc record will be deleted as well.
 413
 414 (TODOC: new exports! $noexport_hack)
 415
 416 =cut
 417
 418 sub delete {
 419   my $self = shift;
 420
 421   return "Can't delete an account which is a (svc_forward) source!"
 422     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 423
 424   return "Can't delete an account which is a (svc_forward) destination!"
 425     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 426
 427   return "Can't delete an account with (svc_www) web service!"
 428     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 429
 430   # what about records in session ? (they should refer to history table)
 431
 432   local $SIG{HUP} = 'IGNORE';
 433   local $SIG{INT} = 'IGNORE';
 434   local $SIG{QUIT} = 'IGNORE';
 435   local $SIG{TERM} = 'IGNORE';
 436   local $SIG{TSTP} = 'IGNORE';
 437   local $SIG{PIPE} = 'IGNORE';
 438
 439   my $oldAutoCommit = $FS::UID::AutoCommit;
 440   local $FS::UID::AutoCommit = 0;
 441   my $dbh = dbh;
 442
 443   foreach my $cust_main_invoice (
 444     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 445   ) {
 446     unless ( defined($cust_main_invoice) ) {
 447       warn "WARNING: something's wrong with qsearch";
 448       next;
 449     }
 450     my %hash = $cust_main_invoice->hash;
 451     $hash{'dest'} = $self->email;
 452     my $new = new FS::cust_main_invoice \%hash;
 453     my $error = $new->replace($cust_main_invoice);
 454     if ( $error ) {
 455       $dbh->rollback if $oldAutoCommit;
 456       return $error;
 457     }
 458   }
 459
 460   foreach my $svc_domain (
 461     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 462   ) {
 463     my %hash = new FS::svc_domain->hash;
 464     $hash{'catchall'} = '';
 465     my $new = new FS::svc_domain \%hash;
 466     my $error = $new->replace($svc_domain);
 467     if ( $error ) {
 468       $dbh->rollback if $oldAutoCommit;
 469       return $error;
 470     }
 471   }
 472
 473   foreach my $radius_usergroup (
 474     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 475   ) {
 476     my $error = $radius_usergroup->delete;
 477     if ( $error ) {
 478       $dbh->rollback if $oldAutoCommit;
 479       return $error;
 480     }
 481   }
 482
 483   my $error = $self->SUPER::delete;
 484   if ( $error ) {
 485     $dbh->rollback if $oldAutoCommit;
 486     return $error;
 487   }
 488
 489   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 490   '';
 491 }
 492
 493 =item replace OLD_RECORD
 494
 495 Replaces OLD_RECORD with this one in the database.  If there is an error,
 496 returns the error, otherwise returns false.
 497
 498 The additional field I<usergroup> can optionally be defined; if so it should
 499 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 500 sqlradius export only)
 501
 502 =cut
 503
 504 sub replace {
 505   my ( $new, $old ) = ( shift, shift );
 506   my $error;
 507   warn "$me replacing $old with $new\n" if $DEBUG;
 508
 509   return "Username in use"
 510     if $old->username ne $new->username &&
 511       qsearchs( 'svc_acct', { 'username' => $new->username,
 512                                'domsvc'   => $new->domsvc,
 513                              } );
 514   {
 515     #no warnings 'numeric';  #alas, a 5.006-ism
 516     local($^W) = 0;
 517     return "Can't change uid!" if $old->uid != $new->uid;
 518   }
 519
 520   #change homdir when we change username
 521   $new->setfield('dir', '') if $old->username ne $new->username;
 522
 523   local $SIG{HUP} = 'IGNORE';
 524   local $SIG{INT} = 'IGNORE';
 525   local $SIG{QUIT} = 'IGNORE';
 526   local $SIG{TERM} = 'IGNORE';
 527   local $SIG{TSTP} = 'IGNORE';
 528   local $SIG{PIPE} = 'IGNORE';
 529
 530   my $oldAutoCommit = $FS::UID::AutoCommit;
 531   local $FS::UID::AutoCommit = 0;
 532   my $dbh = dbh;
 533
 534   # redundant, but so $new->usergroup gets set
 535   $error = $new->check;
 536   return $error if $error;
 537
 538   $old->usergroup( [ $old->radius_groups ] );
 539   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 540   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 541   if ( $new->usergroup ) {
 542     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 543     my @newgroups = @{$new->usergroup};
 544     foreach my $oldgroup ( @{$old->usergroup} ) {
 545       if ( grep { $oldgroup eq $_ } @newgroups ) {
 546         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 547         next;
 548       }
 549       my $radius_usergroup = qsearchs('radius_usergroup', {
 550         svcnum    => $old->svcnum,
 551         groupname => $oldgroup,
 552       } );
 553       my $error = $radius_usergroup->delete;
 554       if ( $error ) {
 555         $dbh->rollback if $oldAutoCommit;
 556         return "error deleting radius_usergroup $oldgroup: $error";
 557       }
 558     }
 559
 560     foreach my $newgroup ( @newgroups ) {
 561       my $radius_usergroup = new FS::radius_usergroup ( {
 562         svcnum    => $new->svcnum,
 563         groupname => $newgroup,
 564       } );
 565       my $error = $radius_usergroup->insert;
 566       if ( $error ) {
 567         $dbh->rollback if $oldAutoCommit;
 568         return "error adding radius_usergroup $newgroup: $error";
 569       }
 570     }
 571
 572   }
 573
 574   $error = $new->SUPER::replace($old);
 575   if ( $error ) {
 576     $dbh->rollback if $oldAutoCommit;
 577     return $error if $error;
 578   }
 579
 580   if ( $new->username ne $old->username ) {
 581     #false laziness with sub insert (and cust_main)
 582     my $queue = new FS::queue {
 583       'svcnum' => $new->svcnum,
 584       'job'    => 'FS::svc_acct::append_fuzzyfiles'
 585     };
 586     $error = $queue->insert($new->username);
 587     if ( $error ) {
 588       $dbh->rollback if $oldAutoCommit;
 589       return "queueing job (transaction rolled back): $error";
 590     }
 591   }
 592
 593   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 594   ''; #no error
 595 }
 596
 597 =item suspend
 598
 599 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 600 error, returns the error, otherwise returns false.
 601
 602 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 603
 604 =cut
 605
 606 sub suspend {
 607   my $self = shift;
 608   my %hash = $self->hash;
 609   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 610            || $hash{_password} eq '*'
 611          ) {
 612     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 613     my $new = new FS::svc_acct ( \%hash );
 614     my $error = $new->replace($self);
 615     return $error if $error;
 616   }
 617
 618   $self->SUPER::suspend;
 619 }
 620
 621 =item unsuspend
 622
 623 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 624 an error, returns the error, otherwise returns false.
 625
 626 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 627
 628 =cut
 629
 630 sub unsuspend {
 631   my $self = shift;
 632   my %hash = $self->hash;
 633   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 634     $hash{_password} = $1;
 635     my $new = new FS::svc_acct ( \%hash );
 636     my $error = $new->replace($self);
 637     return $error if $error;
 638   }
 639
 640   $self->SUPER::unsuspend;
 641 }
 642
 643 =item cancel
 644
 645 Just returns false (no error) for now.
 646
 647 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 648
 649 =item check
 650
 651 Checks all fields to make sure this is a valid service.  If there is an error,
 652 returns the error, otherwise returns false.  Called by the insert and replace
 653 methods.
 654
 655 Sets any fixed values; see L<FS::part_svc>.
 656
 657 =cut
 658
 659 sub check {
 660   my $self = shift;
 661
 662   my($recref) = $self->hashref;
 663
 664   my $x = $self->setfixed;
 665   return $x unless ref($x);
 666   my $part_svc = $x;
 667
 668   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 669     $self->usergroup(
 670       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 671   }
 672
 673   my $error = $self->ut_numbern('svcnum')
 674               || $self->ut_number('domsvc')
 675               || $self->ut_textn('sec_phrase')
 676   ;
 677   return $error if $error;
 678
 679   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 680   if ( $username_uppercase ) {
 681     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 682       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 683     $recref->{username} = $1;
 684   } else {
 685     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 686       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 687     $recref->{username} = $1;
 688   }
 689
 690   if ( $username_letterfirst ) {
 691     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 692   } elsif ( $username_letter ) {
 693     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 694   }
 695   if ( $username_noperiod ) {
 696     $recref->{username} =~ /\./ and return gettext('illegal_username');
 697   }
 698   if ( $username_nounderscore ) {
 699     $recref->{username} =~ /_/ and return gettext('illegal_username');
 700   }
 701   if ( $username_nodash ) {
 702     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 703   }
 704   unless ( $username_ampersand ) {
 705     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 706   }
 707
 708   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 709   $recref->{popnum} = $1;
 710   return "Unknown popnum" unless
 711     ! $recref->{popnum} ||
 712     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 713
 714   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 715
 716     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 717     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 718
 719     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 720     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 721     #not all systems use gid=uid
 722     #you can set a fixed gid in part_svc
 723
 724     return "Only root can have uid 0"
 725       if $recref->{uid} == 0
 726          && $recref->{username} ne 'root'
 727          && $recref->{username} ne 'toor';
 728
 729
 730     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 731       or return "Illegal directory: ". $recref->{dir};
 732     $recref->{dir} = $1;
 733     return "Illegal directory"
 734       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 735     return "Illegal directory"
 736       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 737     unless ( $recref->{dir} ) {
 738       $recref->{dir} = $dir_prefix . '/';
 739       if ( $dirhash > 0 ) {
 740         for my $h ( 1 .. $dirhash ) {
 741           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 742         }
 743       } elsif ( $dirhash < 0 ) {
 744         for my $h ( reverse $dirhash .. -1 ) {
 745           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 746         }
 747       }
 748       $recref->{dir} .= $recref->{username};
 749     ;
 750     }
 751
 752     unless ( $recref->{username} eq 'sync' ) {
 753       if ( grep $_ eq $recref->{shell}, @shells ) {
 754         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 755       } else {
 756         return "Illegal shell \`". $self->shell. "\'; ".
 757                $conf->dir. "/shells contains: @shells";
 758       }
 759     } else {
 760       $recref->{shell} = '/bin/sync';
 761     }
 762
 763   } else {
 764     $recref->{gid} ne '' ?
 765       return "Can't have gid without uid" : ( $recref->{gid}='' );
 766     $recref->{dir} ne '' ?
 767       return "Can't have directory without uid" : ( $recref->{dir}='' );
 768     $recref->{shell} ne '' ?
 769       return "Can't have shell without uid" : ( $recref->{shell}='' );
 770   }
 771
 772   #  $error = $self->ut_textn('finger');
 773   #  return $error if $error;
 774   $self->getfield('finger') =~
 775     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 776       or return "Illegal finger: ". $self->getfield('finger');
 777   $self->setfield('finger', $1);
 778
 779   $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
 780   $recref->{quota} = $1;
 781
 782   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 783     unless ( $recref->{slipip} eq '0e0' ) {
 784       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 785         or return "Illegal slipip: ". $self->slipip;
 786       $recref->{slipip} = $1;
 787     } else {
 788       $recref->{slipip} = '0e0';
 789     }
 790
 791   }
 792
 793   #arbitrary RADIUS stuff; allow ut_textn for now
 794   foreach ( grep /^radius_/, fields('svc_acct') ) {
 795     $self->ut_textn($_);
 796   }
 797
 798   #generate a password if it is blank
 799   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 800     unless ( $recref->{_password} );
 801
 802   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 803   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 804     $recref->{_password} = $1.$3;
 805     #uncomment this to encrypt password immediately upon entry, or run
 806     #bin/crypt_pw in cron to give new users a window during which their
 807     #password is available to techs, for faxing, etc.  (also be aware of
 808     #radius issues!)
 809     #$recref->{password} = $1.
 810     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 811     #;
 812   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,34})$/ ) {
 813     $recref->{_password} = $1.$3;
 814   } elsif ( $recref->{_password} eq '*' ) {
 815     $recref->{_password} = '*';
 816   } elsif ( $recref->{_password} eq '!!' ) {
 817     $recref->{_password} = '!!';
 818   } else {
 819     #return "Illegal password";
 820     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 821            FS::Msgcat::_gettext('illegal_password_characters').
 822            ": ". $recref->{_password};
 823   }
 824
 825   ''; #no error
 826 }
 827
 828 =item radius
 829
 830 Depriciated, use radius_reply instead.
 831
 832 =cut
 833
 834 sub radius {
 835   carp "FS::svc_acct::radius depriciated, use radius_reply";
 836   $_[0]->radius_reply;
 837 }
 838
 839 =item radius_reply
 840
 841 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 842 reply attributes of this record.
 843
 844 Note that this is now the preferred method for reading RADIUS attributes -
 845 accessing the columns directly is discouraged, as the column names are
 846 expected to change in the future.
 847
 848 =cut
 849
 850 sub radius_reply {
 851   my $self = shift;
 852   my %reply =
 853     map {
 854       /^(radius_(.*))$/;
 855       my($column, $attrib) = ($1, $2);
 856       #$attrib =~ s/_/\-/g;
 857       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 858     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 859   if ( $self->slipip && $self->slipip ne '0e0' ) {
 860     $reply{'Framed-IP-Address'} = $self->slipip;
 861   }
 862   %reply;
 863 }
 864
 865 =item radius_check
 866
 867 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 868 check attributes of this record.
 869
 870 Note that this is now the preferred method for reading RADIUS attributes -
 871 accessing the columns directly is discouraged, as the column names are
 872 expected to change in the future.
 873
 874 =cut
 875
 876 sub radius_check {
 877   my $self = shift;
 878   my $password = $self->_password;
 879   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
 880   ( $pw_attrib => $password,
 881     map {
 882       /^(rc_(.*))$/;
 883       my($column, $attrib) = ($1, $2);
 884       #$attrib =~ s/_/\-/g;
 885       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 886     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 887   );
 888 }
 889
 890 =item domain
 891
 892 Returns the domain associated with this account.
 893
 894 =cut
 895
 896 sub domain {
 897   my $self = shift;
 898   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
 899   my $svc_domain = $self->svc_domain
 900     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 901   $svc_domain->domain;
 902 }
 903
 904 =item svc_domain
 905
 906 Returns the FS::svc_domain record for this account's domain (see
 907 L<FS::svc_domain>).
 908
 909 =cut
 910
 911 sub svc_domain {
 912   my $self = shift;
 913   $self->{'_domsvc'}
 914     ? $self->{'_domsvc'}
 915     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 916 }
 917
 918 =item cust_svc
 919
 920 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
 921
 922 sub cust_svc {
 923   my $self = shift;
 924   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
 925 }
 926
 927 =item email
 928
 929 Returns an email address associated with the account.
 930
 931 =cut
 932
 933 sub email {
 934   my $self = shift;
 935   $self->username. '@'. $self->domain;
 936 }
 937
 938 =item seconds_since TIMESTAMP
 939
 940 Returns the number of seconds this account has been online since TIMESTAMP,
 941 according to the session monitor (see L<FS::Session>).
 942
 943 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 944 L<Time::Local> and L<Date::Parse> for conversion functions.
 945
 946 =cut
 947
 948 #note: POD here, implementation in FS::cust_svc
 949 sub seconds_since {
 950   my $self = shift;
 951   $self->cust_svc->seconds_since(@_);
 952 }
 953
 954 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 955
 956 Returns the numbers of seconds this account has been online between
 957 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
 958 external SQL radacct table, specified via sqlradius export.  Sessions which
 959 started in the specified range but are still open are counted from session
 960 start to the end of the range (unless they are over 1 day old, in which case
 961 they are presumed missing their stop record and not counted).  Also, sessions
 962 which end in therange but started earlier are counted from the start of the
 963 range to session end.  Finally, sessions which start before the range but end
 964 after are counted for the entire range.
 965
 966 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 967 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 968 functions.
 969
 970 =cut
 971
 972 #note: POD here, implementation in FS::cust_svc
 973 sub seconds_since_sqlradacct {
 974   my $self = shift;
 975   $self->cust_svc->seconds_since_sqlradacct(@_);
 976 }
 977
 978 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 979
 980 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 981 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 982 TIMESTAMP_END (exclusive).
 983
 984 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 985 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 986 functions.
 987
 988 =cut
 989
 990 #note: POD here, implementation in FS::cust_svc
 991 sub attribute_since_sqlradacct {
 992   my $self = shift;
 993   $self->cust_svc->attribute_since_sqlradacct(@_);
 994 }
 995
 996 =item radius_groups
 997
 998 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
 999
1000 =cut
1001
1002 sub radius_groups {
1003   my $self = shift;
1004   if ( $self->usergroup ) {
1005     #when provisioning records, export callback runs in svc_Common.pm before
1006     #radius_usergroup records can be inserted...
1007     @{$self->usergroup};
1008   } else {
1009     map { $_->groupname }
1010       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1011   }
1012 }
1013
1014 =back
1015
1016 =head1 SUBROUTINES
1017
1018 =over 4
1019
1020 =item send_email
1021
1022 =cut
1023
1024 sub send_email {
1025   my %opt = @_;
1026
1027   use Date::Format;
1028   use Mail::Internet 1.44;
1029   use Mail::Header;
1030
1031   $opt{mimetype} ||= 'text/plain';
1032   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1033
1034   $ENV{MAILADDRESS} = $opt{from};
1035   my $header = new Mail::Header ( [
1036     "From: $opt{from}",
1037     "To: $opt{to}",
1038     "Sender: $opt{from}",
1039     "Reply-To: $opt{from}",
1040     "Date: ". time2str("%a, %d %b %Y %X %z", time),
1041     "Subject: $opt{subject}",
1042     "Content-Type: $opt{mimetype}",
1043   ] );
1044   my $message = new Mail::Internet (
1045     'Header' => $header,
1046     'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1047   );
1048   $!=0;
1049   $message->smtpsend( Host => $smtpmachine )
1050     or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1051       or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1052 }
1053
1054 =item check_and_rebuild_fuzzyfiles
1055
1056 =cut
1057
1058 sub check_and_rebuild_fuzzyfiles {
1059   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1060   -e "$dir/svc_acct.username"
1061     or &rebuild_fuzzyfiles;
1062 }
1063
1064 =item rebuild_fuzzyfiles
1065
1066 =cut
1067
1068 sub rebuild_fuzzyfiles {
1069
1070   use Fcntl qw(:flock);
1071
1072   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1073
1074   #username
1075
1076   open(USERNAMELOCK,">>$dir/svc_acct.username")
1077     or die "can't open $dir/svc_acct.username: $!";
1078   flock(USERNAMELOCK,LOCK_EX)
1079     or die "can't lock $dir/svc_acct.username: $!";
1080
1081   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1082
1083   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1084     or die "can't open $dir/svc_acct.username.tmp: $!";
1085   print USERNAMECACHE join("\n", @all_username), "\n";
1086   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1087
1088   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1089   close USERNAMELOCK;
1090
1091 }
1092
1093 =item all_username
1094
1095 =cut
1096
1097 sub all_username {
1098   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1099   open(USERNAMECACHE,"<$dir/svc_acct.username")
1100     or die "can't open $dir/svc_acct.username: $!";
1101   my @array = map { chomp; $_; } <USERNAMECACHE>;
1102   close USERNAMECACHE;
1103   \@array;
1104 }
1105
1106 =item append_fuzzyfiles USERNAME
1107
1108 =cut
1109
1110 sub append_fuzzyfiles {
1111   my $username = shift;
1112
1113   &check_and_rebuild_fuzzyfiles;
1114
1115   use Fcntl qw(:flock);
1116
1117   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1118
1119   open(USERNAME,">>$dir/svc_acct.username")
1120     or die "can't open $dir/svc_acct.username: $!";
1121   flock(USERNAME,LOCK_EX)
1122     or die "can't lock $dir/svc_acct.username: $!";
1123
1124   print USERNAME "$username\n";
1125
1126   flock(USERNAME,LOCK_UN)
1127     or die "can't unlock $dir/svc_acct.username: $!";
1128   close USERNAME;
1129
1130   1;
1131 }
1132
1133
1134
1135 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1136
1137 =cut
1138
1139 sub radius_usergroup_selector {
1140   my $sel_groups = shift;
1141   my %sel_groups = map { $_=>1 } @$sel_groups;
1142
1143   my $selectname = shift || 'radius_usergroup';
1144
1145   my $dbh = dbh;
1146   my $sth = $dbh->prepare(
1147     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1148   ) or die $dbh->errstr;
1149   $sth->execute() or die $sth->errstr;
1150   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1151
1152   my $html = <<END;
1153     <SCRIPT>
1154     function ${selectname}_doadd(object) {
1155       var myvalue = object.${selectname}_add.value;
1156       var optionName = new Option(myvalue,myvalue,false,true);
1157       var length = object.$selectname.length;
1158       object.$selectname.options[length] = optionName;
1159       object.${selectname}_add.value = "";
1160     }
1161     </SCRIPT>
1162     <SELECT MULTIPLE NAME="$selectname">
1163 END
1164
1165   foreach my $group ( @all_groups ) {
1166     $html .= '<OPTION';
1167     if ( $sel_groups{$group} ) {
1168       $html .= ' SELECTED';
1169       $sel_groups{$group} = 0;
1170     }
1171     $html .= ">$group</OPTION>\n";
1172   }
1173   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1174     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1175   };
1176   $html .= '</SELECT>';
1177
1178   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1179            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1180
1181   $html;
1182 }
1183
1184 =back
1185
1186 =head1 BUGS
1187
1188 The $recref stuff in sub check should be cleaned up.
1189
1190 The suspend, unsuspend and cancel methods update the database, but not the
1191 current object.  This is probably a bug as it's unexpected and
1192 counterintuitive.
1193
1194 radius_usergroup_selector?  putting web ui components in here?  they should
1195 probably live somewhere else...
1196
1197 =head1 SEE ALSO
1198
1199 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1200 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1201 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1202 L<freeside-queued>), L<FS::svc_acct_pop>,
1203 schema.html from the base documentation.
1204
1205 =cut
1206
1207 1;
1208