FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
   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              $password_noampersand $password_noexclamation
  11              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
  12              $smtpmachine
  13              $radius_password $radius_ip
  14              $dirhash
  15              @saltset @pw_set );
  16 use Carp;
  17 use Fcntl qw(:flock);
  18 use Crypt::PasswdMD5;
  19 use FS::UID qw( datasrc );
  20 use FS::Conf;
  21 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  22 use FS::svc_Common;
  23 use FS::cust_svc;
  24 use FS::part_svc;
  25 use FS::svc_acct_pop;
  26 use FS::cust_main_invoice;
  27 use FS::svc_domain;
  28 use FS::raddb;
  29 use FS::queue;
  30 use FS::radius_usergroup;
  31 use FS::export_svc;
  32 use FS::part_export;
  33 use FS::Msgcat qw(gettext);
  34 use FS::svc_forward;
  35 use FS::svc_www;
  36
  37 @ISA = qw( FS::svc_Common );
  38
  39 $DEBUG = 0;
  40 #$DEBUG = 1;
  41 $me = '[FS::svc_acct]';
  42
  43 #ask FS::UID to run this stuff for us later
  44 $FS::UID::callback{'FS::svc_acct'} = sub {
  45   $conf = new FS::Conf;
  46   $dir_prefix = $conf->config('home');
  47   @shells = $conf->config('shells');
  48   $usernamemin = $conf->config('usernamemin') || 2;
  49   $usernamemax = $conf->config('usernamemax');
  50   $passwordmin = $conf->config('passwordmin') || 6;
  51   $passwordmax = $conf->config('passwordmax') || 8;
  52   $username_letter = $conf->exists('username-letter');
  53   $username_letterfirst = $conf->exists('username-letterfirst');
  54   $username_noperiod = $conf->exists('username-noperiod');
  55   $username_nounderscore = $conf->exists('username-nounderscore');
  56   $username_nodash = $conf->exists('username-nodash');
  57   $username_uppercase = $conf->exists('username-uppercase');
  58   $username_ampersand = $conf->exists('username-ampersand');
  59   $password_noampersand = $conf->exists('password-noexclamation');
  60   $password_noexclamation = $conf->exists('password-noexclamation');
  61   $dirhash = $conf->config('dirhash') || 0;
  62   if ( $conf->exists('welcome_email') ) {
  63     $welcome_template = new Text::Template (
  64       TYPE   => 'ARRAY',
  65       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
  66     ) or warn "can't create welcome email template: $Text::Template::ERROR";
  67     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
  68     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
  69     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
  70   } else {
  71     $welcome_template = '';
  72     $welcome_from = '';
  73     $welcome_subject = '';
  74     $welcome_mimetype = '';
  75   }
  76   $smtpmachine = $conf->config('smtpmachine');
  77   $radius_password = $conf->config('radius-password') || 'Password';
  78   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  79 };
  80
  81 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  82 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  83
  84 sub _cache {
  85   my $self = shift;
  86   my ( $hashref, $cache ) = @_;
  87   if ( $hashref->{'svc_acct_svcnum'} ) {
  88     $self->{'_domsvc'} = FS::svc_domain->new( {
  89       'svcnum'   => $hashref->{'domsvc'},
  90       'domain'   => $hashref->{'svc_acct_domain'},
  91       'catchall' => $hashref->{'svc_acct_catchall'},
  92     } );
  93   }
  94 }
  95
  96 =head1 NAME
  97
  98 FS::svc_acct - Object methods for svc_acct records
  99
 100 =head1 SYNOPSIS
 101
 102   use FS::svc_acct;
 103
 104   $record = new FS::svc_acct \%hash;
 105   $record = new FS::svc_acct { 'column' => 'value' };
 106
 107   $error = $record->insert;
 108
 109   $error = $new_record->replace($old_record);
 110
 111   $error = $record->delete;
 112
 113   $error = $record->check;
 114
 115   $error = $record->suspend;
 116
 117   $error = $record->unsuspend;
 118
 119   $error = $record->cancel;
 120
 121   %hash = $record->radius;
 122
 123   %hash = $record->radius_reply;
 124
 125   %hash = $record->radius_check;
 126
 127   $domain = $record->domain;
 128
 129   $svc_domain = $record->svc_domain;
 130
 131   $email = $record->email;
 132
 133   $seconds_since = $record->seconds_since($timestamp);
 134
 135 =head1 DESCRIPTION
 136
 137 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 138 FS::svc_Common.  The following fields are currently supported:
 139
 140 =over 4
 141
 142 =item svcnum - primary key (assigned automatcially for new accounts)
 143
 144 =item username
 145
 146 =item _password - generated if blank
 147
 148 =item sec_phrase - security phrase
 149
 150 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 151
 152 =item uid
 153
 154 =item gid
 155
 156 =item finger - GECOS
 157
 158 =item dir - set automatically if blank (and uid is not)
 159
 160 =item shell
 161
 162 =item quota - (unimplementd)
 163
 164 =item slipip - IP address
 165
 166 =item seconds -
 167
 168 =item domsvc - svcnum from svc_domain
 169
 170 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 171
 172 =back
 173
 174 =head1 METHODS
 175
 176 =over 4
 177
 178 =item new HASHREF
 179
 180 Creates a new account.  To add the account to the database, see L<"insert">.
 181
 182 =cut
 183
 184 sub table { 'svc_acct'; }
 185
 186 =item insert [ , OPTION => VALUE ... ]
 187
 188 Adds this account to the database.  If there is an error, returns the error,
 189 otherwise returns false.
 190
 191 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 192 defined.  An FS::cust_svc record will be created and inserted.
 193
 194 The additional field I<usergroup> can optionally be defined; if so it should
 195 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 196
 197 The additional field I<child_objects> can optionally be defined; if so it
 198 should contain an arrayref of FS::tablename objects.  They will have their
 199 svcnum fields set and will be inserted after this record, but before any
 200 exports are run.  Each element of the array can also optionally be a
 201 two-element array reference containing the child object and the name of an
 202 alternate field to be filled in with the newly-inserted svcnum, for example
 203 C<[ $svc_forward, 'srcsvc' ]>
 204
 205 Currently available options are: I<depend_jobnum>
 206
 207 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 208 jobnums), all provisioning jobs will have a dependancy on the supplied
 209 jobnum(s) (they will not run until the specific job(s) complete(s)).
 210
 211 (TODOC: L<FS::queue> and L<freeside-queued>)
 212
 213 (TODOC: new exports!)
 214
 215 =cut
 216
 217 sub insert {
 218   my $self = shift;
 219   my %options = @_;
 220   my $error;
 221
 222   local $SIG{HUP} = 'IGNORE';
 223   local $SIG{INT} = 'IGNORE';
 224   local $SIG{QUIT} = 'IGNORE';
 225   local $SIG{TERM} = 'IGNORE';
 226   local $SIG{TSTP} = 'IGNORE';
 227   local $SIG{PIPE} = 'IGNORE';
 228
 229   my $oldAutoCommit = $FS::UID::AutoCommit;
 230   local $FS::UID::AutoCommit = 0;
 231   my $dbh = dbh;
 232
 233   $error = $self->check;
 234   return $error if $error;
 235
 236   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 237     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 238     unless ( $cust_svc ) {
 239       $dbh->rollback if $oldAutoCommit;
 240       return "no cust_svc record found for svcnum ". $self->svcnum;
 241     }
 242     $self->pkgnum($cust_svc->pkgnum);
 243     $self->svcpart($cust_svc->svcpart);
 244   }
 245
 246   $error = $self->_check_duplicate;
 247   if ( $error ) {
 248     $dbh->rollback if $oldAutoCommit;
 249     return $error;
 250   }
 251
 252   my @jobnums;
 253   $error = $self->SUPER::insert(
 254     'jobnums'       => \@jobnums,
 255     'child_objects' => $self->child_objects,
 256     %options,
 257   );
 258   if ( $error ) {
 259     $dbh->rollback if $oldAutoCommit;
 260     return $error;
 261   }
 262
 263   if ( $self->usergroup ) {
 264     foreach my $groupname ( @{$self->usergroup} ) {
 265       my $radius_usergroup = new FS::radius_usergroup ( {
 266         svcnum    => $self->svcnum,
 267         groupname => $groupname,
 268       } );
 269       my $error = $radius_usergroup->insert;
 270       if ( $error ) {
 271         $dbh->rollback if $oldAutoCommit;
 272         return $error;
 273       }
 274     }
 275   }
 276
 277   unless ( $skip_fuzzyfiles ) {
 278     $error = $self->queue_fuzzyfiles_update;
 279     if ( $error ) {
 280       $dbh->rollback if $oldAutoCommit;
 281       return "updating fuzzy search cache: $error";
 282     }
 283   }
 284
 285   my $cust_pkg = $self->cust_svc->cust_pkg;
 286
 287   if ( $cust_pkg ) {
 288     my $cust_main = $cust_pkg->cust_main;
 289
 290     if ( $conf->exists('emailinvoiceauto') ) {
 291       my @invoicing_list = $cust_main->invoicing_list;
 292       push @invoicing_list, $self->email;
 293       $cust_main->invoicing_list(\@invoicing_list);
 294     }
 295
 296     #welcome email
 297     my $to = '';
 298     if ( $welcome_template && $cust_pkg ) {
 299       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 300       if ( $to ) {
 301         my $wqueue = new FS::queue {
 302           'svcnum' => $self->svcnum,
 303           'job'    => 'FS::svc_acct::send_email'
 304         };
 305         my $error = $wqueue->insert(
 306           'to'       => $to,
 307           'from'     => $welcome_from,
 308           'subject'  => $welcome_subject,
 309           'mimetype' => $welcome_mimetype,
 310           'body'     => $welcome_template->fill_in( HASH => {
 311                           'custnum'  => $self->custnum,
 312                           'username' => $self->username,
 313                           'password' => $self->_password,
 314                           'first'    => $cust_main->first,
 315                           'last'     => $cust_main->getfield('last'),
 316                           'pkg'      => $cust_pkg->part_pkg->pkg,
 317                         } ),
 318         );
 319         if ( $error ) {
 320           $dbh->rollback if $oldAutoCommit;
 321           return "error queuing welcome email: $error";
 322         }
 323
 324         if ( $options{'depend_jobnum'} ) {
 325           warn "$me depend_jobnum found; adding to welcome email dependancies"
 326             if $DEBUG;
 327           if ( ref($options{'depend_jobnum'}) ) {
 328             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 329                  "to welcome email dependancies"
 330               if $DEBUG;
 331             push @jobnums, @{ $options{'depend_jobnum'} };
 332           } else {
 333             warn "$me adding job $options{'depend_jobnum'} ".
 334                  "to welcome email dependancies"
 335               if $DEBUG;
 336             push @jobnums, $options{'depend_jobnum'};
 337           }
 338         }
 339
 340         foreach my $jobnum ( @jobnums ) {
 341           my $error = $wqueue->depend_insert($jobnum);
 342           if ( $error ) {
 343             $dbh->rollback if $oldAutoCommit;
 344             return "error queuing welcome email job dependancy: $error";
 345           }
 346         }
 347
 348       }
 349
 350     }
 351
 352   } # if ( $cust_pkg )
 353
 354   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 355   ''; #no error
 356 }
 357
 358 =item delete
 359
 360 Deletes this account from the database.  If there is an error, returns the
 361 error, otherwise returns false.
 362
 363 The corresponding FS::cust_svc record will be deleted as well.
 364
 365 (TODOC: new exports!)
 366
 367 =cut
 368
 369 sub delete {
 370   my $self = shift;
 371
 372   return "can't delete system account" if $self->_check_system;
 373
 374   return "Can't delete an account which is a (svc_forward) source!"
 375     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 376
 377   return "Can't delete an account which is a (svc_forward) destination!"
 378     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 379
 380   return "Can't delete an account with (svc_www) web service!"
 381     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 382
 383   # what about records in session ? (they should refer to history table)
 384
 385   local $SIG{HUP} = 'IGNORE';
 386   local $SIG{INT} = 'IGNORE';
 387   local $SIG{QUIT} = 'IGNORE';
 388   local $SIG{TERM} = 'IGNORE';
 389   local $SIG{TSTP} = 'IGNORE';
 390   local $SIG{PIPE} = 'IGNORE';
 391
 392   my $oldAutoCommit = $FS::UID::AutoCommit;
 393   local $FS::UID::AutoCommit = 0;
 394   my $dbh = dbh;
 395
 396   foreach my $cust_main_invoice (
 397     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 398   ) {
 399     unless ( defined($cust_main_invoice) ) {
 400       warn "WARNING: something's wrong with qsearch";
 401       next;
 402     }
 403     my %hash = $cust_main_invoice->hash;
 404     $hash{'dest'} = $self->email;
 405     my $new = new FS::cust_main_invoice \%hash;
 406     my $error = $new->replace($cust_main_invoice);
 407     if ( $error ) {
 408       $dbh->rollback if $oldAutoCommit;
 409       return $error;
 410     }
 411   }
 412
 413   foreach my $svc_domain (
 414     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 415   ) {
 416     my %hash = new FS::svc_domain->hash;
 417     $hash{'catchall'} = '';
 418     my $new = new FS::svc_domain \%hash;
 419     my $error = $new->replace($svc_domain);
 420     if ( $error ) {
 421       $dbh->rollback if $oldAutoCommit;
 422       return $error;
 423     }
 424   }
 425
 426   foreach my $radius_usergroup (
 427     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 428   ) {
 429     my $error = $radius_usergroup->delete;
 430     if ( $error ) {
 431       $dbh->rollback if $oldAutoCommit;
 432       return $error;
 433     }
 434   }
 435
 436   my $error = $self->SUPER::delete;
 437   if ( $error ) {
 438     $dbh->rollback if $oldAutoCommit;
 439     return $error;
 440   }
 441
 442   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 443   '';
 444 }
 445
 446 =item replace OLD_RECORD
 447
 448 Replaces OLD_RECORD with this one in the database.  If there is an error,
 449 returns the error, otherwise returns false.
 450
 451 The additional field I<usergroup> can optionally be defined; if so it should
 452 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 453
 454
 455 =cut
 456
 457 sub replace {
 458   my ( $new, $old ) = ( shift, shift );
 459   my $error;
 460   warn "$me replacing $old with $new\n" if $DEBUG;
 461
 462   return "can't modify system account" if $old->_check_system;
 463
 464   return "Username in use"
 465     if $old->username ne $new->username &&
 466       qsearchs( 'svc_acct', { 'username' => $new->username,
 467                                'domsvc'   => $new->domsvc,
 468                              } );
 469   {
 470     #no warnings 'numeric';  #alas, a 5.006-ism
 471     local($^W) = 0;
 472     return "Can't change uid!" if $old->uid != $new->uid;
 473   }
 474
 475   #change homdir when we change username
 476   $new->setfield('dir', '') if $old->username ne $new->username;
 477
 478   local $SIG{HUP} = 'IGNORE';
 479   local $SIG{INT} = 'IGNORE';
 480   local $SIG{QUIT} = 'IGNORE';
 481   local $SIG{TERM} = 'IGNORE';
 482   local $SIG{TSTP} = 'IGNORE';
 483   local $SIG{PIPE} = 'IGNORE';
 484
 485   my $oldAutoCommit = $FS::UID::AutoCommit;
 486   local $FS::UID::AutoCommit = 0;
 487   my $dbh = dbh;
 488
 489   # redundant, but so $new->usergroup gets set
 490   $error = $new->check;
 491   return $error if $error;
 492
 493   $old->usergroup( [ $old->radius_groups ] );
 494   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
 495   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
 496   if ( $new->usergroup ) {
 497     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 498     my @newgroups = @{$new->usergroup};
 499     foreach my $oldgroup ( @{$old->usergroup} ) {
 500       if ( grep { $oldgroup eq $_ } @newgroups ) {
 501         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 502         next;
 503       }
 504       my $radius_usergroup = qsearchs('radius_usergroup', {
 505         svcnum    => $old->svcnum,
 506         groupname => $oldgroup,
 507       } );
 508       my $error = $radius_usergroup->delete;
 509       if ( $error ) {
 510         $dbh->rollback if $oldAutoCommit;
 511         return "error deleting radius_usergroup $oldgroup: $error";
 512       }
 513     }
 514
 515     foreach my $newgroup ( @newgroups ) {
 516       my $radius_usergroup = new FS::radius_usergroup ( {
 517         svcnum    => $new->svcnum,
 518         groupname => $newgroup,
 519       } );
 520       my $error = $radius_usergroup->insert;
 521       if ( $error ) {
 522         $dbh->rollback if $oldAutoCommit;
 523         return "error adding radius_usergroup $newgroup: $error";
 524       }
 525     }
 526
 527   }
 528
 529   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 530     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 531     $error = $new->_check_duplicate;
 532     if ( $error ) {
 533       $dbh->rollback if $oldAutoCommit;
 534       return $error;
 535     }
 536   }
 537
 538   $error = $new->SUPER::replace($old);
 539   if ( $error ) {
 540     $dbh->rollback if $oldAutoCommit;
 541     return $error if $error;
 542   }
 543
 544   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 545     $error = $new->queue_fuzzyfiles_update;
 546     if ( $error ) {
 547       $dbh->rollback if $oldAutoCommit;
 548       return "updating fuzzy search cache: $error";
 549     }
 550   }
 551
 552   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 553   ''; #no error
 554 }
 555
 556 =item queue_fuzzyfiles_update
 557
 558 Used by insert & replace to update the fuzzy search cache
 559
 560 =cut
 561
 562 sub queue_fuzzyfiles_update {
 563   my $self = shift;
 564
 565   local $SIG{HUP} = 'IGNORE';
 566   local $SIG{INT} = 'IGNORE';
 567   local $SIG{QUIT} = 'IGNORE';
 568   local $SIG{TERM} = 'IGNORE';
 569   local $SIG{TSTP} = 'IGNORE';
 570   local $SIG{PIPE} = 'IGNORE';
 571
 572   my $oldAutoCommit = $FS::UID::AutoCommit;
 573   local $FS::UID::AutoCommit = 0;
 574   my $dbh = dbh;
 575
 576   my $queue = new FS::queue {
 577     'svcnum' => $self->svcnum,
 578     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 579   };
 580   my $error = $queue->insert($self->username);
 581   if ( $error ) {
 582     $dbh->rollback if $oldAutoCommit;
 583     return "queueing job (transaction rolled back): $error";
 584   }
 585
 586   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 587   '';
 588
 589 }
 590
 591
 592 =item suspend
 593
 594 Suspends this account by calling export-specific suspend hooks.  If there is
 595 an error, returns the error, otherwise returns false.
 596
 597 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 598
 599 =cut
 600
 601 sub suspend {
 602   my $self = shift;
 603   return "can't suspend system account" if $self->_check_system;
 604   $self->SUPER::suspend;
 605 }
 606
 607 =item unsuspend
 608
 609 Unsuspends this account by by calling export-specific suspend hooks.  If there
 610 is an error, returns the error, otherwise returns false.
 611
 612 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 613
 614 =cut
 615
 616 sub unsuspend {
 617   my $self = shift;
 618   my %hash = $self->hash;
 619   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 620     $hash{_password} = $1;
 621     my $new = new FS::svc_acct ( \%hash );
 622     my $error = $new->replace($self);
 623     return $error if $error;
 624   }
 625
 626   $self->SUPER::unsuspend;
 627 }
 628
 629 =item cancel
 630
 631 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 632
 633 If the B<auto_unset_catchall> configuration option is set, this method will
 634 automatically remove any references to the canceled service in the catchall
 635 field of svc_domain.  This allows packages that contain both a svc_domain and
 636 its catchall svc_acct to be canceled in one step.
 637
 638 =cut
 639
 640 sub cancel {
 641   # Only one thing to do at this level
 642   my $self = shift;
 643   foreach my $svc_domain (
 644       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 645     if($conf->exists('auto_unset_catchall')) {
 646       my %hash = $svc_domain->hash;
 647       $hash{catchall} = '';
 648       my $new = new FS::svc_domain ( \%hash );
 649       my $error = $new->replace($svc_domain);
 650       return $error if $error;
 651     } else {
 652       return "cannot unprovision svc_acct #".$self->svcnum.
 653           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 654     }
 655   }
 656
 657   $self->SUPER::cancel;
 658 }
 659
 660
 661 =item check
 662
 663 Checks all fields to make sure this is a valid service.  If there is an error,
 664 returns the error, otherwise returns false.  Called by the insert and replace
 665 methods.
 666
 667 Sets any fixed values; see L<FS::part_svc>.
 668
 669 =cut
 670
 671 sub check {
 672   my $self = shift;
 673
 674   my($recref) = $self->hashref;
 675
 676   my $x = $self->setfixed;
 677   return $x unless ref($x);
 678   my $part_svc = $x;
 679
 680   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 681     $self->usergroup(
 682       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 683   }
 684
 685   my $error = $self->ut_numbern('svcnum')
 686               #|| $self->ut_number('domsvc')
 687               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 688               || $self->ut_textn('sec_phrase')
 689   ;
 690   return $error if $error;
 691
 692   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 693   if ( $username_uppercase ) {
 694     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 695       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 696     $recref->{username} = $1;
 697   } else {
 698     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 699       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 700     $recref->{username} = $1;
 701   }
 702
 703   if ( $username_letterfirst ) {
 704     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 705   } elsif ( $username_letter ) {
 706     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 707   }
 708   if ( $username_noperiod ) {
 709     $recref->{username} =~ /\./ and return gettext('illegal_username');
 710   }
 711   if ( $username_nounderscore ) {
 712     $recref->{username} =~ /_/ and return gettext('illegal_username');
 713   }
 714   if ( $username_nodash ) {
 715     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 716   }
 717   unless ( $username_ampersand ) {
 718     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 719   }
 720   if ( $password_noampersand ) {
 721     $recref->{_password} =~ /\&/ and return gettext('illegal_password');
 722   }
 723   if ( $password_noexclamation ) {
 724     $recref->{_password} =~ /\!/ and return gettext('illegal_password');
 725   }
 726
 727   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 728   $recref->{popnum} = $1;
 729   return "Unknown popnum" unless
 730     ! $recref->{popnum} ||
 731     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 732
 733   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 734
 735     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 736     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 737
 738     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 739     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 740     #not all systems use gid=uid
 741     #you can set a fixed gid in part_svc
 742
 743     return "Only root can have uid 0"
 744       if $recref->{uid} == 0
 745          && $recref->{username} !~ /^(root|toor|smtp)$/;
 746
 747     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 748       or return "Illegal directory: ". $recref->{dir};
 749     $recref->{dir} = $1;
 750     return "Illegal directory"
 751       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 752     return "Illegal directory"
 753       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 754     unless ( $recref->{dir} ) {
 755       $recref->{dir} = $dir_prefix . '/';
 756       if ( $dirhash > 0 ) {
 757         for my $h ( 1 .. $dirhash ) {
 758           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 759         }
 760       } elsif ( $dirhash < 0 ) {
 761         for my $h ( reverse $dirhash .. -1 ) {
 762           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 763         }
 764       }
 765       $recref->{dir} .= $recref->{username};
 766     ;
 767     }
 768
 769     unless ( $recref->{username} eq 'sync' ) {
 770       if ( grep $_ eq $recref->{shell}, @shells ) {
 771         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 772       } else {
 773         return "Illegal shell \`". $self->shell. "\'; ".
 774                $conf->dir. "/shells contains: @shells";
 775       }
 776     } else {
 777       $recref->{shell} = '/bin/sync';
 778     }
 779
 780   } else {
 781     $recref->{gid} ne '' ?
 782       return "Can't have gid without uid" : ( $recref->{gid}='' );
 783     $recref->{dir} ne '' ?
 784       return "Can't have directory without uid" : ( $recref->{dir}='' );
 785     $recref->{shell} ne '' ?
 786       return "Can't have shell without uid" : ( $recref->{shell}='' );
 787   }
 788
 789   #  $error = $self->ut_textn('finger');
 790   #  return $error if $error;
 791   if ( $self->getfield('finger') eq '' ) {
 792     my $cust_pkg = $self->svcnum
 793       ? $self->cust_svc->cust_pkg
 794       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
 795     if ( $cust_pkg ) {
 796       my $cust_main = $cust_pkg->cust_main;
 797       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
 798     }
 799   }
 800   $self->getfield('finger') =~
 801     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
 802       or return "Illegal finger: ". $self->getfield('finger');
 803   $self->setfield('finger', $1);
 804
 805   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
 806   $recref->{quota} = $1;
 807
 808   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 809     if ( $recref->{slipip} eq '' ) {
 810       $recref->{slipip} = '';
 811     } elsif ( $recref->{slipip} eq '0e0' ) {
 812       $recref->{slipip} = '0e0';
 813     } else {
 814       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 815         or return "Illegal slipip: ". $self->slipip;
 816       $recref->{slipip} = $1;
 817     }
 818
 819   }
 820
 821   #arbitrary RADIUS stuff; allow ut_textn for now
 822   foreach ( grep /^radius_/, fields('svc_acct') ) {
 823     $self->ut_textn($_);
 824   }
 825
 826   #generate a password if it is blank
 827   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 828     unless ( $recref->{_password} );
 829
 830   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 831   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 832     $recref->{_password} = $1.$3;
 833     #uncomment this to encrypt password immediately upon entry, or run
 834     #bin/crypt_pw in cron to give new users a window during which their
 835     #password is available to techs, for faxing, etc.  (also be aware of
 836     #radius issues!)
 837     #$recref->{password} = $1.
 838     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 839     #;
 840   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
 841     $recref->{_password} = $1.$3;
 842   } elsif ( $recref->{_password} eq '*' ) {
 843     $recref->{_password} = '*';
 844   } elsif ( $recref->{_password} eq '!' ) {
 845     $recref->{_password} = '!';
 846   } elsif ( $recref->{_password} eq '!!' ) {
 847     $recref->{_password} = '!!';
 848   } else {
 849     #return "Illegal password";
 850     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
 851            FS::Msgcat::_gettext('illegal_password_characters').
 852            ": ". $recref->{_password};
 853   }
 854
 855   $self->SUPER::check;
 856 }
 857
 858 =item _check_system
 859
 860 Internal function to check the username against the list of system usernames
 861 from the I<system_usernames> configuration value.  Returns true if the username
 862 is listed on the system username list.
 863
 864 =cut
 865
 866 sub _check_system {
 867   my $self = shift;
 868   scalar( grep { $self->username eq $_ || $self->email eq $_ }
 869                $conf->config('system_usernames')
 870         );
 871 }
 872
 873 =item _check_duplicate
 874
 875 Internal function to check for duplicates usernames, username@domain pairs and
 876 uids.
 877
 878 If the I<global_unique-username> configuration value is set to B<username> or
 879 B<username@domain>, enforces global username or username@domain uniqueness.
 880
 881 In all cases, check for duplicate uids and usernames or username@domain pairs
 882 per export and with identical I<svcpart> values.
 883
 884 =cut
 885
 886 sub _check_duplicate {
 887   my $self = shift;
 888
 889   #this is Pg-specific.  what to do for mysql etc?
 890   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
 891   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
 892   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
 893     or die dbh->errstr;
 894   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
 895
 896   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
 897   unless ( $part_svc ) {
 898     return 'unknown svcpart '. $self->svcpart;
 899   }
 900
 901   my $global_unique = $conf->config('global_unique-username') || 'none';
 902
 903   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 904                  qsearch( 'svc_acct', { 'username' => $self->username } );
 905   return gettext('username_in_use')
 906     if $global_unique eq 'username' && @dup_user;
 907
 908   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 909                        qsearch( 'svc_acct', { 'username' => $self->username,
 910                                               'domsvc'   => $self->domsvc } );
 911   return gettext('username_in_use')
 912     if $global_unique eq 'username@domain' && @dup_userdomain;
 913
 914   my @dup_uid;
 915   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
 916        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
 917     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
 918                qsearch( 'svc_acct', { 'uid' => $self->uid } );
 919   } else {
 920     @dup_uid = ();
 921   }
 922
 923   if ( @dup_user || @dup_userdomain || @dup_uid ) {
 924     my $exports = FS::part_export::export_info('svc_acct');
 925     my %conflict_user_svcpart;
 926     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
 927
 928     foreach my $part_export ( $part_svc->part_export ) {
 929
 930       #this will catch to the same exact export
 931       my @svcparts = map { $_->svcpart } $part_export->export_svc;
 932
 933       #this will catch to exports w/same exporthost+type ???
 934       #my @other_part_export = qsearch('part_export', {
 935       #  'machine'    => $part_export->machine,
 936       #  'exporttype' => $part_export->exporttype,
 937       #} );
 938       #foreach my $other_part_export ( @other_part_export ) {
 939       #  push @svcparts, map { $_->svcpart }
 940       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
 941       #}
 942
 943       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
 944       #silly kludge to avoid uninitialized value errors
 945       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
 946                      ? $exports->{$part_export->exporttype}{'nodomain'}
 947                      : '';
 948       if ( $nodomain =~ /^Y/i ) {
 949         $conflict_user_svcpart{$_} = $part_export->exportnum
 950           foreach @svcparts;
 951       } else {
 952         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
 953           foreach @svcparts;
 954       }
 955     }
 956
 957     foreach my $dup_user ( @dup_user ) {
 958       my $dup_svcpart = $dup_user->cust_svc->svcpart;
 959       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
 960         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
 961                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
 962       }
 963     }
 964
 965     foreach my $dup_userdomain ( @dup_userdomain ) {
 966       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
 967       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 968         return "duplicate username\@domain: conflicts with svcnum ".
 969                $dup_userdomain->svcnum. " via exportnum ".
 970                $conflict_userdomain_svcpart{$dup_svcpart};
 971       }
 972     }
 973
 974     foreach my $dup_uid ( @dup_uid ) {
 975       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
 976       if ( exists($conflict_user_svcpart{$dup_svcpart})
 977            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
 978         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
 979                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
 980                                  || $conflict_userdomain_svcpart{$dup_svcpart};
 981       }
 982     }
 983
 984   }
 985
 986   return '';
 987
 988 }
 989
 990 =item radius
 991
 992 Depriciated, use radius_reply instead.
 993
 994 =cut
 995
 996 sub radius {
 997   carp "FS::svc_acct::radius depriciated, use radius_reply";
 998   $_[0]->radius_reply;
 999 }
1000
1001 =item radius_reply
1002
1003 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1004 reply attributes of this record.
1005
1006 Note that this is now the preferred method for reading RADIUS attributes -
1007 accessing the columns directly is discouraged, as the column names are
1008 expected to change in the future.
1009
1010 =cut
1011
1012 sub radius_reply {
1013   my $self = shift;
1014   my %reply =
1015     map {
1016       /^(radius_(.*))$/;
1017       my($column, $attrib) = ($1, $2);
1018       #$attrib =~ s/_/\-/g;
1019       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1020     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1021   if ( $self->slipip && $self->slipip ne '0e0' ) {
1022     $reply{$radius_ip} = $self->slipip;
1023   }
1024   if ( $self->seconds !~ /^$/ ) {
1025     $reply{'Session-Timeout'} = $self->seconds;
1026   }
1027   %reply;
1028 }
1029
1030 =item radius_check
1031
1032 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1033 check attributes of this record.
1034
1035 Note that this is now the preferred method for reading RADIUS attributes -
1036 accessing the columns directly is discouraged, as the column names are
1037 expected to change in the future.
1038
1039 =cut
1040
1041 sub radius_check {
1042   my $self = shift;
1043   my $password = $self->_password;
1044   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1045   ( $pw_attrib => $password,
1046     map {
1047       /^(rc_(.*))$/;
1048       my($column, $attrib) = ($1, $2);
1049       #$attrib =~ s/_/\-/g;
1050       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1051     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1052   );
1053 }
1054
1055 =item domain
1056
1057 Returns the domain associated with this account.
1058
1059 =cut
1060
1061 sub domain {
1062   my $self = shift;
1063   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1064   my $svc_domain = $self->svc_domain(@_)
1065     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1066   $svc_domain->domain;
1067 }
1068
1069 =item svc_domain
1070
1071 Returns the FS::svc_domain record for this account's domain (see
1072 L<FS::svc_domain>).
1073
1074 =cut
1075
1076 sub svc_domain {
1077   my $self = shift;
1078   $self->{'_domsvc'}
1079     ? $self->{'_domsvc'}
1080     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1081 }
1082
1083 =item cust_svc
1084
1085 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1086
1087 =cut
1088
1089 sub cust_svc {
1090   my $self = shift;
1091   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1092 }
1093
1094 =item email
1095
1096 Returns an email address associated with the account.
1097
1098 =cut
1099
1100 sub email {
1101   my $self = shift;
1102   $self->username. '@'. $self->domain(@_);
1103 }
1104
1105 =item acct_snarf
1106
1107 Returns an array of FS::acct_snarf records associated with the account.
1108 If the acct_snarf table does not exist or there are no associated records,
1109 an empty list is returned
1110
1111 =cut
1112
1113 sub acct_snarf {
1114   my $self = shift;
1115   return () unless dbdef->table('acct_snarf');
1116   eval "use FS::acct_snarf;";
1117   die $@ if $@;
1118   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1119 }
1120
1121 =item seconds_since TIMESTAMP
1122
1123 Returns the number of seconds this account has been online since TIMESTAMP,
1124 according to the session monitor (see L<FS::Session>).
1125
1126 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1127 L<Time::Local> and L<Date::Parse> for conversion functions.
1128
1129 =cut
1130
1131 #note: POD here, implementation in FS::cust_svc
1132 sub seconds_since {
1133   my $self = shift;
1134   $self->cust_svc->seconds_since(@_);
1135 }
1136
1137 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1138
1139 Returns the numbers of seconds this account has been online between
1140 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1141 external SQL radacct table, specified via sqlradius export.  Sessions which
1142 started in the specified range but are still open are counted from session
1143 start to the end of the range (unless they are over 1 day old, in which case
1144 they are presumed missing their stop record and not counted).  Also, sessions
1145 which end in the range but started earlier are counted from the start of the
1146 range to session end.  Finally, sessions which start before the range but end
1147 after are counted for the entire range.
1148
1149 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1150 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1151 functions.
1152
1153 =cut
1154
1155 #note: POD here, implementation in FS::cust_svc
1156 sub seconds_since_sqlradacct {
1157   my $self = shift;
1158   $self->cust_svc->seconds_since_sqlradacct(@_);
1159 }
1160
1161 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1162
1163 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1164 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1165 TIMESTAMP_END (exclusive).
1166
1167 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1168 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1169 functions.
1170
1171 =cut
1172
1173 #note: POD here, implementation in FS::cust_svc
1174 sub attribute_since_sqlradacct {
1175   my $self = shift;
1176   $self->cust_svc->attribute_since_sqlradacct(@_);
1177 }
1178
1179 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1180
1181 Returns an array of hash references of this customers login history for the
1182 given time range.  (document this better)
1183
1184 =cut
1185
1186 sub get_session_history {
1187   my $self = shift;
1188   $self->cust_svc->get_session_history(@_);
1189 }
1190
1191 =item radius_groups
1192
1193 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1194
1195 =cut
1196
1197 sub radius_groups {
1198   my $self = shift;
1199   if ( $self->usergroup ) {
1200     #when provisioning records, export callback runs in svc_Common.pm before
1201     #radius_usergroup records can be inserted...
1202     @{$self->usergroup};
1203   } else {
1204     map { $_->groupname }
1205       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1206   }
1207 }
1208
1209 =item clone_suspended
1210
1211 Constructor used by FS::part_export::_export_suspend fallback.  Document
1212 better.
1213
1214 =cut
1215
1216 sub clone_suspended {
1217   my $self = shift;
1218   my %hash = $self->hash;
1219   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1220   new FS::svc_acct \%hash;
1221 }
1222
1223 =item clone_kludge_unsuspend
1224
1225 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1226 better.
1227
1228 =cut
1229
1230 sub clone_kludge_unsuspend {
1231   my $self = shift;
1232   my %hash = $self->hash;
1233   $hash{_password} = '';
1234   new FS::svc_acct \%hash;
1235 }
1236
1237 =item check_password
1238
1239 Checks the supplied password against the (possibly encrypted) password in the
1240 database.  Returns true for a sucessful authentication, false for no match.
1241
1242 Currently supported encryptions are: classic DES crypt() and MD5
1243
1244 =cut
1245
1246 sub check_password {
1247   my($self, $check_password) = @_;
1248
1249   #remove old-style SUSPENDED kludge, they should be allowed to login to
1250   #self-service and pay up
1251   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1252
1253   #eventually should check a "password-encoding" field
1254   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1255     return 0;
1256   } elsif ( length($password) < 13 ) { #plaintext
1257     $check_password eq $password;
1258   } elsif ( length($password) == 13 ) { #traditional DES crypt
1259     crypt($check_password, $password) eq $password;
1260   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1261     unix_md5_crypt($check_password, $password) eq $password;
1262   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1263     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1264          $self->svcnum. "\n";
1265     0;
1266   } else {
1267     warn "Can't check password: Unrecognized encryption for svcnum ".
1268          $self->svcnum. "\n";
1269     0;
1270   }
1271
1272 }
1273
1274 =item crypt_password
1275
1276 Returns an encrypted password, either by passing through an encrypted password
1277 in the database or by encrypting a plaintext password from the database.
1278
1279 =cut
1280
1281 sub crypt_password {
1282   my $self = shift;
1283   #false laziness w/shellcommands.pm
1284   #eventually should check a "password-encoding" field
1285   if ( length($self->_password) == 13
1286        || $self->_password =~ /^\$(1|2a?)\$/ ) {
1287     $self->_password;
1288   } else {
1289     crypt(
1290       $self->_password,
1291       $saltset[int(rand(64))].$saltset[int(rand(64))]
1292     );
1293   }
1294 }
1295
1296 =item virtual_maildir
1297
1298 Returns $domain/maildirs/$username/
1299
1300 =cut
1301
1302 sub virtual_maildir {
1303   my $self = shift;
1304   $self->domain. '/maildirs/'. $self->username. '/';
1305 }
1306
1307 =back
1308
1309 =head1 SUBROUTINES
1310
1311 =over 4
1312
1313 =item send_email
1314
1315 This is the FS::svc_acct job-queue-able version.  It still uses
1316 FS::Misc::send_email under-the-hood.
1317
1318 =cut
1319
1320 sub send_email {
1321   my %opt = @_;
1322
1323   eval "use FS::Misc qw(send_email)";
1324   die $@ if $@;
1325
1326   $opt{mimetype} ||= 'text/plain';
1327   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1328
1329   my $error = send_email(
1330     'from'         => $opt{from},
1331     'to'           => $opt{to},
1332     'subject'      => $opt{subject},
1333     'content-type' => $opt{mimetype},
1334     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1335   );
1336   die $error if $error;
1337 }
1338
1339 =item check_and_rebuild_fuzzyfiles
1340
1341 =cut
1342
1343 sub check_and_rebuild_fuzzyfiles {
1344   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1345   -e "$dir/svc_acct.username"
1346     or &rebuild_fuzzyfiles;
1347 }
1348
1349 =item rebuild_fuzzyfiles
1350
1351 =cut
1352
1353 sub rebuild_fuzzyfiles {
1354
1355   use Fcntl qw(:flock);
1356
1357   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1358
1359   #username
1360
1361   open(USERNAMELOCK,">>$dir/svc_acct.username")
1362     or die "can't open $dir/svc_acct.username: $!";
1363   flock(USERNAMELOCK,LOCK_EX)
1364     or die "can't lock $dir/svc_acct.username: $!";
1365
1366   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1367
1368   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1369     or die "can't open $dir/svc_acct.username.tmp: $!";
1370   print USERNAMECACHE join("\n", @all_username), "\n";
1371   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1372
1373   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1374   close USERNAMELOCK;
1375
1376 }
1377
1378 =item all_username
1379
1380 =cut
1381
1382 sub all_username {
1383   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1384   open(USERNAMECACHE,"<$dir/svc_acct.username")
1385     or die "can't open $dir/svc_acct.username: $!";
1386   my @array = map { chomp; $_; } <USERNAMECACHE>;
1387   close USERNAMECACHE;
1388   \@array;
1389 }
1390
1391 =item append_fuzzyfiles USERNAME
1392
1393 =cut
1394
1395 sub append_fuzzyfiles {
1396   my $username = shift;
1397
1398   &check_and_rebuild_fuzzyfiles;
1399
1400   use Fcntl qw(:flock);
1401
1402   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1403
1404   open(USERNAME,">>$dir/svc_acct.username")
1405     or die "can't open $dir/svc_acct.username: $!";
1406   flock(USERNAME,LOCK_EX)
1407     or die "can't lock $dir/svc_acct.username: $!";
1408
1409   print USERNAME "$username\n";
1410
1411   flock(USERNAME,LOCK_UN)
1412     or die "can't unlock $dir/svc_acct.username: $!";
1413   close USERNAME;
1414
1415   1;
1416 }
1417
1418
1419
1420 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1421
1422 =cut
1423
1424 sub radius_usergroup_selector {
1425   my $sel_groups = shift;
1426   my %sel_groups = map { $_=>1 } @$sel_groups;
1427
1428   my $selectname = shift || 'radius_usergroup';
1429
1430   my $dbh = dbh;
1431   my $sth = $dbh->prepare(
1432     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1433   ) or die $dbh->errstr;
1434   $sth->execute() or die $sth->errstr;
1435   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1436
1437   my $html = <<END;
1438     <SCRIPT>
1439     function ${selectname}_doadd(object) {
1440       var myvalue = object.${selectname}_add.value;
1441       var optionName = new Option(myvalue,myvalue,false,true);
1442       var length = object.$selectname.length;
1443       object.$selectname.options[length] = optionName;
1444       object.${selectname}_add.value = "";
1445     }
1446     </SCRIPT>
1447     <SELECT MULTIPLE NAME="$selectname">
1448 END
1449
1450   foreach my $group ( @all_groups ) {
1451     $html .= qq(<OPTION VALUE="$group");
1452     if ( $sel_groups{$group} ) {
1453       $html .= ' SELECTED';
1454       $sel_groups{$group} = 0;
1455     }
1456     $html .= ">$group</OPTION>\n";
1457   }
1458   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1459     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1460   };
1461   $html .= '</SELECT>';
1462
1463   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1464            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1465
1466   $html;
1467 }
1468
1469 =back
1470
1471 =head1 BUGS
1472
1473 The $recref stuff in sub check should be cleaned up.
1474
1475 The suspend, unsuspend and cancel methods update the database, but not the
1476 current object.  This is probably a bug as it's unexpected and
1477 counterintuitive.
1478
1479 radius_usergroup_selector?  putting web ui components in here?  they should
1480 probably live somewhere else...
1481
1482 insertion of RADIUS group stuff in insert could be done with child_objects now
1483 (would probably clean up export of them too)
1484
1485 =head1 SEE ALSO
1486
1487 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1488 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1489 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1490 L<freeside-queued>), L<FS::svc_acct_pop>,
1491 schema.html from the base documentation.
1492
1493 =cut
1494
1495 1;
1496