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 $username_percent
  10              $password_noampersand $password_noexclamation
  11              $warning_template $warning_from $warning_subject $warning_mimetype
  12              $warning_cc
  13              $smtpmachine
  14              $radius_password $radius_ip
  15              $dirhash
  16              @saltset @pw_set );
  17 use Carp;
  18 use Fcntl qw(:flock);
  19 use Date::Format;
  20 use Crypt::PasswdMD5 1.2;
  21 use Data::Dumper;
  22 use Authen::Passphrase;
  23 use FS::UID qw( datasrc );
  24 use FS::Conf;
  25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  26 use FS::Msgcat qw(gettext);
  27 use FS::svc_Common;
  28 use FS::cust_svc;
  29 use FS::part_svc;
  30 use FS::svc_acct_pop;
  31 use FS::cust_main_invoice;
  32 use FS::svc_domain;
  33 use FS::raddb;
  34 use FS::queue;
  35 use FS::radius_usergroup;
  36 use FS::export_svc;
  37 use FS::part_export;
  38 use FS::svc_forward;
  39 use FS::svc_www;
  40 use FS::cdr;
  41
  42 @ISA = qw( FS::svc_Common );
  43
  44 $DEBUG = 0;
  45 $me = '[FS::svc_acct]';
  46
  47 #ask FS::UID to run this stuff for us later
  48 $FS::UID::callback{'FS::svc_acct'} = sub {
  49   $conf = new FS::Conf;
  50   $dir_prefix = $conf->config('home');
  51   @shells = $conf->config('shells');
  52   $usernamemin = $conf->config('usernamemin') || 2;
  53   $usernamemax = $conf->config('usernamemax');
  54   $passwordmin = $conf->config('passwordmin') || 6;
  55   $passwordmax = $conf->config('passwordmax') || 8;
  56   $username_letter = $conf->exists('username-letter');
  57   $username_letterfirst = $conf->exists('username-letterfirst');
  58   $username_noperiod = $conf->exists('username-noperiod');
  59   $username_nounderscore = $conf->exists('username-nounderscore');
  60   $username_nodash = $conf->exists('username-nodash');
  61   $username_uppercase = $conf->exists('username-uppercase');
  62   $username_ampersand = $conf->exists('username-ampersand');
  63   $username_percent = $conf->exists('username-percent');
  64   $password_noampersand = $conf->exists('password-noexclamation');
  65   $password_noexclamation = $conf->exists('password-noexclamation');
  66   $dirhash = $conf->config('dirhash') || 0;
  67   if ( $conf->exists('warning_email') ) {
  68     $warning_template = new Text::Template (
  69       TYPE   => 'ARRAY',
  70       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  71     ) or warn "can't create warning email template: $Text::Template::ERROR";
  72     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  73     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  74     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  75     $warning_cc = $conf->config('warning_email-cc');
  76   } else {
  77     $warning_template = '';
  78     $warning_from = '';
  79     $warning_subject = '';
  80     $warning_mimetype = '';
  81     $warning_cc = '';
  82   }
  83   $smtpmachine = $conf->config('smtpmachine');
  84   $radius_password = $conf->config('radius-password') || 'Password';
  85   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  86 };
  87
  88 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  89 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  90
  91 sub _cache {
  92   my $self = shift;
  93   my ( $hashref, $cache ) = @_;
  94   if ( $hashref->{'svc_acct_svcnum'} ) {
  95     $self->{'_domsvc'} = FS::svc_domain->new( {
  96       'svcnum'   => $hashref->{'domsvc'},
  97       'domain'   => $hashref->{'svc_acct_domain'},
  98       'catchall' => $hashref->{'svc_acct_catchall'},
  99     } );
 100   }
 101 }
 102
 103 =head1 NAME
 104
 105 FS::svc_acct - Object methods for svc_acct records
 106
 107 =head1 SYNOPSIS
 108
 109   use FS::svc_acct;
 110
 111   $record = new FS::svc_acct \%hash;
 112   $record = new FS::svc_acct { 'column' => 'value' };
 113
 114   $error = $record->insert;
 115
 116   $error = $new_record->replace($old_record);
 117
 118   $error = $record->delete;
 119
 120   $error = $record->check;
 121
 122   $error = $record->suspend;
 123
 124   $error = $record->unsuspend;
 125
 126   $error = $record->cancel;
 127
 128   %hash = $record->radius;
 129
 130   %hash = $record->radius_reply;
 131
 132   %hash = $record->radius_check;
 133
 134   $domain = $record->domain;
 135
 136   $svc_domain = $record->svc_domain;
 137
 138   $email = $record->email;
 139
 140   $seconds_since = $record->seconds_since($timestamp);
 141
 142 =head1 DESCRIPTION
 143
 144 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 145 FS::svc_Common.  The following fields are currently supported:
 146
 147 =over 4
 148
 149 =item svcnum - primary key (assigned automatcially for new accounts)
 150
 151 =item username
 152
 153 =item _password - generated if blank
 154
 155 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
 156
 157 =item sec_phrase - security phrase
 158
 159 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 160
 161 =item uid
 162
 163 =item gid
 164
 165 =item finger - GECOS
 166
 167 =item dir - set automatically if blank (and uid is not)
 168
 169 =item shell
 170
 171 =item quota - (unimplementd)
 172
 173 =item slipip - IP address
 174
 175 =item seconds -
 176
 177 =item upbytes -
 178
 179 =item downbytes -
 180
 181 =item totalbytes -
 182
 183 =item domsvc - svcnum from svc_domain
 184
 185 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 186
 187 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 188
 189 =back
 190
 191 =head1 METHODS
 192
 193 =over 4
 194
 195 =item new HASHREF
 196
 197 Creates a new account.  To add the account to the database, see L<"insert">.
 198
 199 =cut
 200
 201 sub table_info {
 202   {
 203     'name'   => 'Account',
 204     'longname_plural' => 'Access accounts and mailboxes',
 205     'sorts' => [ 'username', 'uid', ],
 206     'display_weight' => 10,
 207     'cancel_weight'  => 50,
 208     'fields' => {
 209         'dir'       => 'Home directory',
 210         'uid'       => {
 211                          label     => 'UID',
 212                          def_label => 'UID (set to fixed and blank for no UIDs)',
 213                          type      => 'text',
 214                        },
 215         'slipip'    => 'IP address',
 216     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 217         'popnum'    => {
 218                          label => 'Access number',
 219                          type => 'select',
 220                          select_table => 'svc_acct_pop',
 221                          select_key   => 'popnum',
 222                          select_label => 'city',
 223                          disable_select => 1,
 224                        },
 225         'username'  => {
 226                          label => 'Username',
 227                          type => 'text',
 228                          disable_default => 1,
 229                          disable_fixed => 1,
 230                          disable_select => 1,
 231                        },
 232         'quota'     => {
 233                          label => 'Quota',
 234                          type => 'text',
 235                          disable_inventory => 1,
 236                          disable_select => 1,
 237                        },
 238         '_password' => 'Password',
 239         'gid'       => {
 240                          label     => 'GID',
 241                          def_label => 'GID (when blank, defaults to UID)',
 242                          type      => 'text',
 243                        },
 244         'shell'     => {
 245                          #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
 246                          label    => 'Shell',
 247                          def_label=> 'Shell (set to blank for no shell tracking)',
 248                          type     =>'select',
 249                          select_list => [ $conf->config('shells') ],
 250                          disable_inventory => 1,
 251                          disable_select => 1,
 252                        },
 253         'finger'    => 'Real name (GECOS)',
 254         'domsvc'    => {
 255                          label     => 'Domain',
 256                          #def_label => 'svcnum from svc_domain',
 257                          type      => 'select',
 258                          select_table => 'svc_domain',
 259                          select_key   => 'svcnum',
 260                          select_label => 'domain',
 261                          disable_inventory => 1,
 262
 263                        },
 264         'usergroup' => {
 265                          label => 'RADIUS groups',
 266                          type  => 'radius_usergroup_selector',
 267                          disable_inventory => 1,
 268                          disable_select => 1,
 269                        },
 270         'seconds'   => { label => 'Seconds',
 271                          type  => 'text',
 272                          disable_inventory => 1,
 273                          disable_select => 1,
 274                        },
 275     },
 276   };
 277 }
 278
 279 sub table { 'svc_acct'; }
 280
 281 sub _fieldhandlers {
 282   {
 283     #false laziness with edit/svc_acct.cgi
 284     'usergroup' => sub {
 285                          my( $self, $groups ) = @_;
 286                          if ( ref($groups) eq 'ARRAY' ) {
 287                            $groups;
 288                          } elsif ( length($groups) ) {
 289                            [ split(/\s*,\s*/, $groups) ];
 290                          } else {
 291                            [];
 292                          }
 293                        },
 294   };
 295 }
 296
 297 =item search_sql STRING
 298
 299 Class method which returns an SQL fragment to search for the given string.
 300
 301 =cut
 302
 303 sub search_sql {
 304   my( $class, $string ) = @_;
 305   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 306     my( $username, $domain ) = ( $1, $2 );
 307     my $q_username = dbh->quote($username);
 308     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 309     if ( @svc_domain ) {
 310       "svc_acct.username = $q_username AND ( ".
 311         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 312       " )";
 313     } else {
 314       '1 = 0'; #false
 315     }
 316   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 317     ' ( '.
 318       $class->search_sql_field('slipip',   $string ).
 319     ' OR '.
 320       $class->search_sql_field('username', $string ).
 321     ' ) ';
 322   } else {
 323     $class->search_sql_field('username', $string);
 324   }
 325 }
 326
 327 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 328
 329 Returns the "username@domain" string for this account.
 330
 331 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 332 history records.
 333
 334 =cut
 335
 336 sub label {
 337   my $self = shift;
 338   $self->email(@_);
 339 }
 340
 341 =cut
 342
 343 =item insert [ , OPTION => VALUE ... ]
 344
 345 Adds this account to the database.  If there is an error, returns the error,
 346 otherwise returns false.
 347
 348 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 349 defined.  An FS::cust_svc record will be created and inserted.
 350
 351 The additional field I<usergroup> can optionally be defined; if so it should
 352 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 353
 354 The additional field I<child_objects> can optionally be defined; if so it
 355 should contain an arrayref of FS::tablename objects.  They will have their
 356 svcnum fields set and will be inserted after this record, but before any
 357 exports are run.  Each element of the array can also optionally be a
 358 two-element array reference containing the child object and the name of an
 359 alternate field to be filled in with the newly-inserted svcnum, for example
 360 C<[ $svc_forward, 'srcsvc' ]>
 361
 362 Currently available options are: I<depend_jobnum>
 363
 364 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 365 jobnums), all provisioning jobs will have a dependancy on the supplied
 366 jobnum(s) (they will not run until the specific job(s) complete(s)).
 367
 368 (TODOC: L<FS::queue> and L<freeside-queued>)
 369
 370 (TODOC: new exports!)
 371
 372 =cut
 373
 374 sub insert {
 375   my $self = shift;
 376   my %options = @_;
 377
 378   if ( $DEBUG ) {
 379     warn "[$me] insert called on $self: ". Dumper($self).
 380          "\nwith options: ". Dumper(%options);
 381   }
 382
 383   local $SIG{HUP} = 'IGNORE';
 384   local $SIG{INT} = 'IGNORE';
 385   local $SIG{QUIT} = 'IGNORE';
 386   local $SIG{TERM} = 'IGNORE';
 387   local $SIG{TSTP} = 'IGNORE';
 388   local $SIG{PIPE} = 'IGNORE';
 389
 390   my $oldAutoCommit = $FS::UID::AutoCommit;
 391   local $FS::UID::AutoCommit = 0;
 392   my $dbh = dbh;
 393
 394   my $error = $self->check;
 395   return $error if $error;
 396
 397   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 398     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 399     unless ( $cust_svc ) {
 400       $dbh->rollback if $oldAutoCommit;
 401       return "no cust_svc record found for svcnum ". $self->svcnum;
 402     }
 403     $self->pkgnum($cust_svc->pkgnum);
 404     $self->svcpart($cust_svc->svcpart);
 405   }
 406
 407   $error = $self->_check_duplicate;
 408   if ( $error ) {
 409     $dbh->rollback if $oldAutoCommit;
 410     return $error;
 411   }
 412
 413   my @jobnums;
 414   $error = $self->SUPER::insert(
 415     'jobnums'       => \@jobnums,
 416     'child_objects' => $self->child_objects,
 417     %options,
 418   );
 419   if ( $error ) {
 420     $dbh->rollback if $oldAutoCommit;
 421     return $error;
 422   }
 423
 424   if ( $self->usergroup ) {
 425     foreach my $groupname ( @{$self->usergroup} ) {
 426       my $radius_usergroup = new FS::radius_usergroup ( {
 427         svcnum    => $self->svcnum,
 428         groupname => $groupname,
 429       } );
 430       my $error = $radius_usergroup->insert;
 431       if ( $error ) {
 432         $dbh->rollback if $oldAutoCommit;
 433         return $error;
 434       }
 435     }
 436   }
 437
 438   unless ( $skip_fuzzyfiles ) {
 439     $error = $self->queue_fuzzyfiles_update;
 440     if ( $error ) {
 441       $dbh->rollback if $oldAutoCommit;
 442       return "updating fuzzy search cache: $error";
 443     }
 444   }
 445
 446   my $cust_pkg = $self->cust_svc->cust_pkg;
 447
 448   if ( $cust_pkg ) {
 449     my $cust_main = $cust_pkg->cust_main;
 450     my $agentnum = $cust_main->agentnum;
 451
 452     if (   $conf->exists('emailinvoiceautoalways')
 453         || $conf->exists('emailinvoiceauto')
 454         && ! $cust_main->invoicing_list_emailonly
 455        ) {
 456       my @invoicing_list = $cust_main->invoicing_list;
 457       push @invoicing_list, $self->email;
 458       $cust_main->invoicing_list(\@invoicing_list);
 459     }
 460
 461     #welcome email
 462     my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
 463       = ('','','','','','');
 464
 465     if ( $conf->exists('welcome_email', $agentnum) ) {
 466       $welcome_template = new Text::Template (
 467         TYPE   => 'ARRAY',
 468         SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
 469       ) or warn "can't create welcome email template: $Text::Template::ERROR";
 470       $welcome_from = $conf->config('welcome_email-from', $agentnum);
 471         # || 'your-isp-is-dum'
 472       $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
 473         || 'Welcome';
 474       $welcome_subject_template = new Text::Template (
 475         TYPE   => 'STRING',
 476         SOURCE => $welcome_subject,
 477       ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
 478       $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
 479         || 'text/plain';
 480     }
 481     if ( $welcome_template && $cust_pkg ) {
 482       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 483       if ( $to ) {
 484
 485         my %hash = (
 486                      'custnum'  => $self->custnum,
 487                      'username' => $self->username,
 488                      'password' => $self->_password,
 489                      'first'    => $cust_main->first,
 490                      'last'     => $cust_main->getfield('last'),
 491                      'pkg'      => $cust_pkg->part_pkg->pkg,
 492                    );
 493         my $wqueue = new FS::queue {
 494           'svcnum' => $self->svcnum,
 495           'job'    => 'FS::svc_acct::send_email'
 496         };
 497         my $error = $wqueue->insert(
 498           'to'       => $to,
 499           'from'     => $welcome_from,
 500           'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 501           'mimetype' => $welcome_mimetype,
 502           'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 503         );
 504         if ( $error ) {
 505           $dbh->rollback if $oldAutoCommit;
 506           return "error queuing welcome email: $error";
 507         }
 508
 509         if ( $options{'depend_jobnum'} ) {
 510           warn "$me depend_jobnum found; adding to welcome email dependancies"
 511             if $DEBUG;
 512           if ( ref($options{'depend_jobnum'}) ) {
 513             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 514                  "to welcome email dependancies"
 515               if $DEBUG;
 516             push @jobnums, @{ $options{'depend_jobnum'} };
 517           } else {
 518             warn "$me adding job $options{'depend_jobnum'} ".
 519                  "to welcome email dependancies"
 520               if $DEBUG;
 521             push @jobnums, $options{'depend_jobnum'};
 522           }
 523         }
 524
 525         foreach my $jobnum ( @jobnums ) {
 526           my $error = $wqueue->depend_insert($jobnum);
 527           if ( $error ) {
 528             $dbh->rollback if $oldAutoCommit;
 529             return "error queuing welcome email job dependancy: $error";
 530           }
 531         }
 532
 533       }
 534
 535     }
 536
 537   } # if ( $cust_pkg )
 538
 539   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 540   ''; #no error
 541 }
 542
 543 =item delete
 544
 545 Deletes this account from the database.  If there is an error, returns the
 546 error, otherwise returns false.
 547
 548 The corresponding FS::cust_svc record will be deleted as well.
 549
 550 (TODOC: new exports!)
 551
 552 =cut
 553
 554 sub delete {
 555   my $self = shift;
 556
 557   return "can't delete system account" if $self->_check_system;
 558
 559   return "Can't delete an account which is a (svc_forward) source!"
 560     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 561
 562   return "Can't delete an account which is a (svc_forward) destination!"
 563     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 564
 565   return "Can't delete an account with (svc_www) web service!"
 566     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 567
 568   # what about records in session ? (they should refer to history table)
 569
 570   local $SIG{HUP} = 'IGNORE';
 571   local $SIG{INT} = 'IGNORE';
 572   local $SIG{QUIT} = 'IGNORE';
 573   local $SIG{TERM} = 'IGNORE';
 574   local $SIG{TSTP} = 'IGNORE';
 575   local $SIG{PIPE} = 'IGNORE';
 576
 577   my $oldAutoCommit = $FS::UID::AutoCommit;
 578   local $FS::UID::AutoCommit = 0;
 579   my $dbh = dbh;
 580
 581   foreach my $cust_main_invoice (
 582     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 583   ) {
 584     unless ( defined($cust_main_invoice) ) {
 585       warn "WARNING: something's wrong with qsearch";
 586       next;
 587     }
 588     my %hash = $cust_main_invoice->hash;
 589     $hash{'dest'} = $self->email;
 590     my $new = new FS::cust_main_invoice \%hash;
 591     my $error = $new->replace($cust_main_invoice);
 592     if ( $error ) {
 593       $dbh->rollback if $oldAutoCommit;
 594       return $error;
 595     }
 596   }
 597
 598   foreach my $svc_domain (
 599     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 600   ) {
 601     my %hash = new FS::svc_domain->hash;
 602     $hash{'catchall'} = '';
 603     my $new = new FS::svc_domain \%hash;
 604     my $error = $new->replace($svc_domain);
 605     if ( $error ) {
 606       $dbh->rollback if $oldAutoCommit;
 607       return $error;
 608     }
 609   }
 610
 611   foreach my $radius_usergroup (
 612     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 613   ) {
 614     my $error = $radius_usergroup->delete;
 615     if ( $error ) {
 616       $dbh->rollback if $oldAutoCommit;
 617       return $error;
 618     }
 619   }
 620
 621   my $error = $self->SUPER::delete;
 622   if ( $error ) {
 623     $dbh->rollback if $oldAutoCommit;
 624     return $error;
 625   }
 626
 627   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 628   '';
 629 }
 630
 631 =item replace OLD_RECORD
 632
 633 Replaces OLD_RECORD with this one in the database.  If there is an error,
 634 returns the error, otherwise returns false.
 635
 636 The additional field I<usergroup> can optionally be defined; if so it should
 637 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 638
 639
 640 =cut
 641
 642 sub replace {
 643   my ( $new, $old ) = ( shift, shift );
 644   my $error;
 645   warn "$me replacing $old with $new\n" if $DEBUG;
 646
 647   # We absolutely have to have an old vs. new record to make this work.
 648   if (!defined($old)) {
 649     $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
 650   }
 651
 652   return "can't modify system account" if $old->_check_system;
 653
 654   {
 655     #no warnings 'numeric';  #alas, a 5.006-ism
 656     local($^W) = 0;
 657
 658     foreach my $xid (qw( uid gid )) {
 659
 660       return "Can't change $xid!"
 661         if ! $conf->exists("svc_acct-edit_$xid")
 662            && $old->$xid() != $new->$xid()
 663            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 664     }
 665
 666   }
 667
 668   #change homdir when we change username
 669   $new->setfield('dir', '') if $old->username ne $new->username;
 670
 671   local $SIG{HUP} = 'IGNORE';
 672   local $SIG{INT} = 'IGNORE';
 673   local $SIG{QUIT} = 'IGNORE';
 674   local $SIG{TERM} = 'IGNORE';
 675   local $SIG{TSTP} = 'IGNORE';
 676   local $SIG{PIPE} = 'IGNORE';
 677
 678   my $oldAutoCommit = $FS::UID::AutoCommit;
 679   local $FS::UID::AutoCommit = 0;
 680   my $dbh = dbh;
 681
 682   # redundant, but so $new->usergroup gets set
 683   $error = $new->check;
 684   return $error if $error;
 685
 686   $old->usergroup( [ $old->radius_groups ] );
 687   if ( $DEBUG ) {
 688     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 689     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 690   }
 691   if ( $new->usergroup ) {
 692     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 693     my @newgroups = @{$new->usergroup};
 694     foreach my $oldgroup ( @{$old->usergroup} ) {
 695       if ( grep { $oldgroup eq $_ } @newgroups ) {
 696         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 697         next;
 698       }
 699       my $radius_usergroup = qsearchs('radius_usergroup', {
 700         svcnum    => $old->svcnum,
 701         groupname => $oldgroup,
 702       } );
 703       my $error = $radius_usergroup->delete;
 704       if ( $error ) {
 705         $dbh->rollback if $oldAutoCommit;
 706         return "error deleting radius_usergroup $oldgroup: $error";
 707       }
 708     }
 709
 710     foreach my $newgroup ( @newgroups ) {
 711       my $radius_usergroup = new FS::radius_usergroup ( {
 712         svcnum    => $new->svcnum,
 713         groupname => $newgroup,
 714       } );
 715       my $error = $radius_usergroup->insert;
 716       if ( $error ) {
 717         $dbh->rollback if $oldAutoCommit;
 718         return "error adding radius_usergroup $newgroup: $error";
 719       }
 720     }
 721
 722   }
 723
 724   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 725     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 726     $error = $new->_check_duplicate;
 727     if ( $error ) {
 728       $dbh->rollback if $oldAutoCommit;
 729       return $error;
 730     }
 731   }
 732
 733   $error = $new->SUPER::replace($old);
 734   if ( $error ) {
 735     $dbh->rollback if $oldAutoCommit;
 736     return $error if $error;
 737   }
 738
 739   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 740     $error = $new->queue_fuzzyfiles_update;
 741     if ( $error ) {
 742       $dbh->rollback if $oldAutoCommit;
 743       return "updating fuzzy search cache: $error";
 744     }
 745   }
 746
 747   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 748   ''; #no error
 749 }
 750
 751 =item queue_fuzzyfiles_update
 752
 753 Used by insert & replace to update the fuzzy search cache
 754
 755 =cut
 756
 757 sub queue_fuzzyfiles_update {
 758   my $self = shift;
 759
 760   local $SIG{HUP} = 'IGNORE';
 761   local $SIG{INT} = 'IGNORE';
 762   local $SIG{QUIT} = 'IGNORE';
 763   local $SIG{TERM} = 'IGNORE';
 764   local $SIG{TSTP} = 'IGNORE';
 765   local $SIG{PIPE} = 'IGNORE';
 766
 767   my $oldAutoCommit = $FS::UID::AutoCommit;
 768   local $FS::UID::AutoCommit = 0;
 769   my $dbh = dbh;
 770
 771   my $queue = new FS::queue {
 772     'svcnum' => $self->svcnum,
 773     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 774   };
 775   my $error = $queue->insert($self->username);
 776   if ( $error ) {
 777     $dbh->rollback if $oldAutoCommit;
 778     return "queueing job (transaction rolled back): $error";
 779   }
 780
 781   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 782   '';
 783
 784 }
 785
 786
 787 =item suspend
 788
 789 Suspends this account by calling export-specific suspend hooks.  If there is
 790 an error, returns the error, otherwise returns false.
 791
 792 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 793
 794 =cut
 795
 796 sub suspend {
 797   my $self = shift;
 798   return "can't suspend system account" if $self->_check_system;
 799   $self->SUPER::suspend;
 800 }
 801
 802 =item unsuspend
 803
 804 Unsuspends this account by by calling export-specific suspend hooks.  If there
 805 is an error, returns the error, otherwise returns false.
 806
 807 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 808
 809 =cut
 810
 811 sub unsuspend {
 812   my $self = shift;
 813   my %hash = $self->hash;
 814   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 815     $hash{_password} = $1;
 816     my $new = new FS::svc_acct ( \%hash );
 817     my $error = $new->replace($self);
 818     return $error if $error;
 819   }
 820
 821   $self->SUPER::unsuspend;
 822 }
 823
 824 =item cancel
 825
 826 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 827
 828 If the B<auto_unset_catchall> configuration option is set, this method will
 829 automatically remove any references to the canceled service in the catchall
 830 field of svc_domain.  This allows packages that contain both a svc_domain and
 831 its catchall svc_acct to be canceled in one step.
 832
 833 =cut
 834
 835 sub cancel {
 836   # Only one thing to do at this level
 837   my $self = shift;
 838   foreach my $svc_domain (
 839       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 840     if($conf->exists('auto_unset_catchall')) {
 841       my %hash = $svc_domain->hash;
 842       $hash{catchall} = '';
 843       my $new = new FS::svc_domain ( \%hash );
 844       my $error = $new->replace($svc_domain);
 845       return $error if $error;
 846     } else {
 847       return "cannot unprovision svc_acct #".$self->svcnum.
 848           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 849     }
 850   }
 851
 852   $self->SUPER::cancel;
 853 }
 854
 855
 856 =item check
 857
 858 Checks all fields to make sure this is a valid service.  If there is an error,
 859 returns the error, otherwise returns false.  Called by the insert and replace
 860 methods.
 861
 862 Sets any fixed values; see L<FS::part_svc>.
 863
 864 =cut
 865
 866 sub check {
 867   my $self = shift;
 868
 869   my($recref) = $self->hashref;
 870
 871   my $x = $self->setfixed( $self->_fieldhandlers );
 872   return $x unless ref($x);
 873   my $part_svc = $x;
 874
 875   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 876     $self->usergroup(
 877       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 878   }
 879
 880   my $error = $self->ut_numbern('svcnum')
 881               #|| $self->ut_number('domsvc')
 882               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 883               || $self->ut_textn('sec_phrase')
 884               || $self->ut_snumbern('seconds')
 885               || $self->ut_snumbern('upbytes')
 886               || $self->ut_snumbern('downbytes')
 887               || $self->ut_snumbern('totalbytes')
 888               || $self->ut_enum( '_password_encoding',
 889                                  [ '', qw( plain crypt ldap ) ]
 890                                )
 891   ;
 892   return $error if $error;
 893
 894   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 895   if ( $username_uppercase ) {
 896     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
 897       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 898     $recref->{username} = $1;
 899   } else {
 900     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
 901       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 902     $recref->{username} = $1;
 903   }
 904
 905   if ( $username_letterfirst ) {
 906     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 907   } elsif ( $username_letter ) {
 908     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 909   }
 910   if ( $username_noperiod ) {
 911     $recref->{username} =~ /\./ and return gettext('illegal_username');
 912   }
 913   if ( $username_nounderscore ) {
 914     $recref->{username} =~ /_/ and return gettext('illegal_username');
 915   }
 916   if ( $username_nodash ) {
 917     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 918   }
 919   unless ( $username_ampersand ) {
 920     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 921   }
 922   unless ( $username_percent ) {
 923     $recref->{username} =~ /\%/ and return gettext('illegal_username');
 924   }
 925
 926   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 927   $recref->{popnum} = $1;
 928   return "Unknown popnum" unless
 929     ! $recref->{popnum} ||
 930     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 931
 932   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 933
 934     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 935     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 936
 937     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 938     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 939     #not all systems use gid=uid
 940     #you can set a fixed gid in part_svc
 941
 942     return "Only root can have uid 0"
 943       if $recref->{uid} == 0
 944          && $recref->{username} !~ /^(root|toor|smtp)$/;
 945
 946     unless ( $recref->{username} eq 'sync' ) {
 947       if ( grep $_ eq $recref->{shell}, @shells ) {
 948         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 949       } else {
 950         return "Illegal shell \`". $self->shell. "\'; ".
 951                "shells configuration value contains: @shells";
 952       }
 953     } else {
 954       $recref->{shell} = '/bin/sync';
 955     }
 956
 957   } else {
 958     $recref->{gid} ne '' ?
 959       return "Can't have gid without uid" : ( $recref->{gid}='' );
 960     #$recref->{dir} ne '' ?
 961     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
 962     $recref->{shell} ne '' ?
 963       return "Can't have shell without uid" : ( $recref->{shell}='' );
 964   }
 965
 966   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
 967
 968     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 969       or return "Illegal directory: ". $recref->{dir};
 970     $recref->{dir} = $1;
 971     return "Illegal directory"
 972       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 973     return "Illegal directory"
 974       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 975     unless ( $recref->{dir} ) {
 976       $recref->{dir} = $dir_prefix . '/';
 977       if ( $dirhash > 0 ) {
 978         for my $h ( 1 .. $dirhash ) {
 979           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 980         }
 981       } elsif ( $dirhash < 0 ) {
 982         for my $h ( reverse $dirhash .. -1 ) {
 983           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 984         }
 985       }
 986       $recref->{dir} .= $recref->{username};
 987     ;
 988     }
 989
 990   }
 991
 992   #  $error = $self->ut_textn('finger');
 993   #  return $error if $error;
 994   if ( $self->getfield('finger') eq '' ) {
 995     my $cust_pkg = $self->svcnum
 996       ? $self->cust_svc->cust_pkg
 997       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
 998     if ( $cust_pkg ) {
 999       my $cust_main = $cust_pkg->cust_main;
1000       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1001     }
1002   }
1003   $self->getfield('finger') =~
1004     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1005       or return "Illegal finger: ". $self->getfield('finger');
1006   $self->setfield('finger', $1);
1007
1008   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1009   $recref->{quota} = $1;
1010
1011   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1012     if ( $recref->{slipip} eq '' ) {
1013       $recref->{slipip} = '';
1014     } elsif ( $recref->{slipip} eq '0e0' ) {
1015       $recref->{slipip} = '0e0';
1016     } else {
1017       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1018         or return "Illegal slipip: ". $self->slipip;
1019       $recref->{slipip} = $1;
1020     }
1021
1022   }
1023
1024   #arbitrary RADIUS stuff; allow ut_textn for now
1025   foreach ( grep /^radius_/, fields('svc_acct') ) {
1026     $self->ut_textn($_);
1027   }
1028
1029   if ( $recref->{_password_encoding} eq 'ldap' ) {
1030
1031     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1032       $recref->{_password} = uc($1).$2;
1033     } else {
1034       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1035     }
1036
1037   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1038
1039     if ( $recref->{_password} =~
1040            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1041            /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1042        ) {
1043
1044       $recref->{_password} = $1.$2;
1045
1046     } else {
1047       return 'Illegal (crypt-encoded) password';
1048     }
1049
1050   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1051
1052     #generate a password if it is blank
1053     $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1054       unless length( $recref->{_password} );
1055
1056     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1057       $recref->{_password} = $1;
1058     } else {
1059       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1060              FS::Msgcat::_gettext('illegal_password_characters').
1061              ": ". $recref->{_password};
1062     }
1063
1064     if ( $password_noampersand ) {
1065       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1066     }
1067     if ( $password_noexclamation ) {
1068       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1069     }
1070
1071   } else {
1072
1073     #carp "warning: _password_encoding unspecified\n";
1074
1075     #generate a password if it is blank
1076     unless ( length( $recref->{_password} ) ) {
1077
1078       $recref->{_password} =
1079         join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1080       $recref->{_password_encoding} = 'plain';
1081
1082     } else {
1083
1084       #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1085       if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1086         $recref->{_password} = $1.$3;
1087         $recref->{_password_encoding} = 'plain';
1088       } elsif ( $recref->{_password} =~
1089                   /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1090               ) {
1091         $recref->{_password} = $1.$3;
1092         $recref->{_password_encoding} = 'crypt';
1093       } elsif ( $recref->{_password} eq '*' ) {
1094         $recref->{_password} = '*';
1095         $recref->{_password_encoding} = 'crypt';
1096       } elsif ( $recref->{_password} eq '!' ) {
1097         $recref->{_password_encoding} = 'crypt';
1098         $recref->{_password} = '!';
1099       } elsif ( $recref->{_password} eq '!!' ) {
1100         $recref->{_password} = '!!';
1101         $recref->{_password_encoding} = 'crypt';
1102       } else {
1103         #return "Illegal password";
1104         return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1105                FS::Msgcat::_gettext('illegal_password_characters').
1106                ": ". $recref->{_password};
1107       }
1108
1109     }
1110
1111   }
1112
1113   $self->SUPER::check;
1114
1115 }
1116
1117 =item _check_system
1118
1119 Internal function to check the username against the list of system usernames
1120 from the I<system_usernames> configuration value.  Returns true if the username
1121 is listed on the system username list.
1122
1123 =cut
1124
1125 sub _check_system {
1126   my $self = shift;
1127   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1128                $conf->config('system_usernames')
1129         );
1130 }
1131
1132 =item _check_duplicate
1133
1134 Internal function to check for duplicates usernames, username@domain pairs and
1135 uids.
1136
1137 If the I<global_unique-username> configuration value is set to B<username> or
1138 B<username@domain>, enforces global username or username@domain uniqueness.
1139
1140 In all cases, check for duplicate uids and usernames or username@domain pairs
1141 per export and with identical I<svcpart> values.
1142
1143 =cut
1144
1145 sub _check_duplicate {
1146   my $self = shift;
1147
1148   my $global_unique = $conf->config('global_unique-username') || 'none';
1149   return '' if $global_unique eq 'disabled';
1150
1151   #this is Pg-specific.  what to do for mysql etc?
1152   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
1153   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1154   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1155     or die dbh->errstr;
1156   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1157
1158   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1159   unless ( $part_svc ) {
1160     return 'unknown svcpart '. $self->svcpart;
1161   }
1162
1163   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1164                  qsearch( 'svc_acct', { 'username' => $self->username } );
1165   return gettext('username_in_use')
1166     if $global_unique eq 'username' && @dup_user;
1167
1168   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1169                        qsearch( 'svc_acct', { 'username' => $self->username,
1170                                               'domsvc'   => $self->domsvc } );
1171   return gettext('username_in_use')
1172     if $global_unique eq 'username@domain' && @dup_userdomain;
1173
1174   my @dup_uid;
1175   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1176        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1177     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1178                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1179   } else {
1180     @dup_uid = ();
1181   }
1182
1183   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1184     my $exports = FS::part_export::export_info('svc_acct');
1185     my %conflict_user_svcpart;
1186     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1187
1188     foreach my $part_export ( $part_svc->part_export ) {
1189
1190       #this will catch to the same exact export
1191       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1192
1193       #this will catch to exports w/same exporthost+type ???
1194       #my @other_part_export = qsearch('part_export', {
1195       #  'machine'    => $part_export->machine,
1196       #  'exporttype' => $part_export->exporttype,
1197       #} );
1198       #foreach my $other_part_export ( @other_part_export ) {
1199       #  push @svcparts, map { $_->svcpart }
1200       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1201       #}
1202
1203       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1204       #silly kludge to avoid uninitialized value errors
1205       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1206                      ? $exports->{$part_export->exporttype}{'nodomain'}
1207                      : '';
1208       if ( $nodomain =~ /^Y/i ) {
1209         $conflict_user_svcpart{$_} = $part_export->exportnum
1210           foreach @svcparts;
1211       } else {
1212         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1213           foreach @svcparts;
1214       }
1215     }
1216
1217     foreach my $dup_user ( @dup_user ) {
1218       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1219       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1220         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1221                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1222       }
1223     }
1224
1225     foreach my $dup_userdomain ( @dup_userdomain ) {
1226       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1227       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1228         return "duplicate username\@domain: conflicts with svcnum ".
1229                $dup_userdomain->svcnum. " via exportnum ".
1230                $conflict_userdomain_svcpart{$dup_svcpart};
1231       }
1232     }
1233
1234     foreach my $dup_uid ( @dup_uid ) {
1235       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1236       if ( exists($conflict_user_svcpart{$dup_svcpart})
1237            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1238         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1239                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1240                                  || $conflict_userdomain_svcpart{$dup_svcpart};
1241       }
1242     }
1243
1244   }
1245
1246   return '';
1247
1248 }
1249
1250 =item radius
1251
1252 Depriciated, use radius_reply instead.
1253
1254 =cut
1255
1256 sub radius {
1257   carp "FS::svc_acct::radius depriciated, use radius_reply";
1258   $_[0]->radius_reply;
1259 }
1260
1261 =item radius_reply
1262
1263 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1264 reply attributes of this record.
1265
1266 Note that this is now the preferred method for reading RADIUS attributes -
1267 accessing the columns directly is discouraged, as the column names are
1268 expected to change in the future.
1269
1270 =cut
1271
1272 sub radius_reply {
1273   my $self = shift;
1274
1275   return %{ $self->{'radius_reply'} }
1276     if exists $self->{'radius_reply'};
1277
1278   my %reply =
1279     map {
1280       /^(radius_(.*))$/;
1281       my($column, $attrib) = ($1, $2);
1282       #$attrib =~ s/_/\-/g;
1283       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1284     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1285
1286   if ( $self->slipip && $self->slipip ne '0e0' ) {
1287     $reply{$radius_ip} = $self->slipip;
1288   }
1289
1290   if ( $self->seconds !~ /^$/ ) {
1291     $reply{'Session-Timeout'} = $self->seconds;
1292   }
1293
1294   %reply;
1295 }
1296
1297 =item radius_check
1298
1299 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1300 check attributes of this record.
1301
1302 Note that this is now the preferred method for reading RADIUS attributes -
1303 accessing the columns directly is discouraged, as the column names are
1304 expected to change in the future.
1305
1306 =cut
1307
1308 sub radius_check {
1309   my $self = shift;
1310
1311   return %{ $self->{'radius_check'} }
1312     if exists $self->{'radius_check'};
1313
1314   my %check =
1315     map {
1316       /^(rc_(.*))$/;
1317       my($column, $attrib) = ($1, $2);
1318       #$attrib =~ s/_/\-/g;
1319       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1320     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1321
1322   my $password = $self->_password;
1323   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1324
1325   my $cust_svc = $self->cust_svc;
1326   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1327     unless $cust_svc;
1328   my $cust_pkg = $cust_svc->cust_pkg;
1329   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1330     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1331   }
1332
1333   %check;
1334
1335 }
1336
1337 =item snapshot
1338
1339 This method instructs the object to "snapshot" or freeze RADIUS check and
1340 reply attributes to the current values.
1341
1342 =cut
1343
1344 #bah, my english is too broken this morning
1345 #Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill.  (This is used by
1346 #the FS::cust_pkg's replace method to trigger the correct export updates when
1347 #package dates change)
1348
1349 sub snapshot {
1350   my $self = shift;
1351
1352   $self->{$_} = { $self->$_() }
1353     foreach qw( radius_reply radius_check );
1354
1355 }
1356
1357 =item forget_snapshot
1358
1359 This methos instructs the object to forget any previously snapshotted
1360 RADIUS check and reply attributes.
1361
1362 =cut
1363
1364 sub forget_snapshot {
1365   my $self = shift;
1366
1367   delete $self->{$_}
1368     foreach qw( radius_reply radius_check );
1369
1370 }
1371
1372 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1373
1374 Returns the domain associated with this account.
1375
1376 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1377 history records.
1378
1379 =cut
1380
1381 sub domain {
1382   my $self = shift;
1383   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1384   my $svc_domain = $self->svc_domain(@_)
1385     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1386   $svc_domain->domain;
1387 }
1388
1389 =item svc_domain
1390
1391 Returns the FS::svc_domain record for this account's domain (see
1392 L<FS::svc_domain>).
1393
1394 =cut
1395
1396 # FS::h_svc_acct has a history-aware svc_domain override
1397
1398 sub svc_domain {
1399   my $self = shift;
1400   $self->{'_domsvc'}
1401     ? $self->{'_domsvc'}
1402     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1403 }
1404
1405 =item cust_svc
1406
1407 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1408
1409 =cut
1410
1411 #inherited from svc_Common
1412
1413 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1414
1415 Returns an email address associated with the account.
1416
1417 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1418 history records.
1419
1420 =cut
1421
1422 sub email {
1423   my $self = shift;
1424   $self->username. '@'. $self->domain(@_);
1425 }
1426
1427 =item acct_snarf
1428
1429 Returns an array of FS::acct_snarf records associated with the account.
1430 If the acct_snarf table does not exist or there are no associated records,
1431 an empty list is returned
1432
1433 =cut
1434
1435 sub acct_snarf {
1436   my $self = shift;
1437   return () unless dbdef->table('acct_snarf');
1438   eval "use FS::acct_snarf;";
1439   die $@ if $@;
1440   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1441 }
1442
1443 =item decrement_upbytes OCTETS
1444
1445 Decrements the I<upbytes> field of this record by the given amount.  If there
1446 is an error, returns the error, otherwise returns false.
1447
1448 =cut
1449
1450 sub decrement_upbytes {
1451   shift->_op_usage('-', 'upbytes', @_);
1452 }
1453
1454 =item increment_upbytes OCTETS
1455
1456 Increments the I<upbytes> field of this record by the given amount.  If there
1457 is an error, returns the error, otherwise returns false.
1458
1459 =cut
1460
1461 sub increment_upbytes {
1462   shift->_op_usage('+', 'upbytes', @_);
1463 }
1464
1465 =item decrement_downbytes OCTETS
1466
1467 Decrements the I<downbytes> field of this record by the given amount.  If there
1468 is an error, returns the error, otherwise returns false.
1469
1470 =cut
1471
1472 sub decrement_downbytes {
1473   shift->_op_usage('-', 'downbytes', @_);
1474 }
1475
1476 =item increment_downbytes OCTETS
1477
1478 Increments the I<downbytes> field of this record by the given amount.  If there
1479 is an error, returns the error, otherwise returns false.
1480
1481 =cut
1482
1483 sub increment_downbytes {
1484   shift->_op_usage('+', 'downbytes', @_);
1485 }
1486
1487 =item decrement_totalbytes OCTETS
1488
1489 Decrements the I<totalbytes> field of this record by the given amount.  If there
1490 is an error, returns the error, otherwise returns false.
1491
1492 =cut
1493
1494 sub decrement_totalbytes {
1495   shift->_op_usage('-', 'totalbytes', @_);
1496 }
1497
1498 =item increment_totalbytes OCTETS
1499
1500 Increments the I<totalbytes> field of this record by the given amount.  If there
1501 is an error, returns the error, otherwise returns false.
1502
1503 =cut
1504
1505 sub increment_totalbytes {
1506   shift->_op_usage('+', 'totalbytes', @_);
1507 }
1508
1509 =item decrement_seconds SECONDS
1510
1511 Decrements the I<seconds> field of this record by the given amount.  If there
1512 is an error, returns the error, otherwise returns false.
1513
1514 =cut
1515
1516 sub decrement_seconds {
1517   shift->_op_usage('-', 'seconds', @_);
1518 }
1519
1520 =item increment_seconds SECONDS
1521
1522 Increments the I<seconds> field of this record by the given amount.  If there
1523 is an error, returns the error, otherwise returns false.
1524
1525 =cut
1526
1527 sub increment_seconds {
1528   shift->_op_usage('+', 'seconds', @_);
1529 }
1530
1531
1532 my %op2action = (
1533   '-' => 'suspend',
1534   '+' => 'unsuspend',
1535 );
1536 my %op2condition = (
1537   '-' => sub { my($self, $column, $amount) = @_;
1538                $self->$column - $amount <= 0;
1539              },
1540   '+' => sub { my($self, $column, $amount) = @_;
1541                $self->$column + $amount > 0;
1542              },
1543 );
1544 my %op2warncondition = (
1545   '-' => sub { my($self, $column, $amount) = @_;
1546                my $threshold = $column . '_threshold';
1547                $self->$column - $amount <= $self->$threshold + 0;
1548              },
1549   '+' => sub { my($self, $column, $amount) = @_;
1550                $self->$column + $amount > 0;
1551              },
1552 );
1553
1554 sub _op_usage {
1555   my( $self, $op, $column, $amount ) = @_;
1556
1557   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1558        ' ('. $self->email. "): $op $amount\n"
1559     if $DEBUG;
1560
1561   return '' unless $amount;
1562
1563   local $SIG{HUP} = 'IGNORE';
1564   local $SIG{INT} = 'IGNORE';
1565   local $SIG{QUIT} = 'IGNORE';
1566   local $SIG{TERM} = 'IGNORE';
1567   local $SIG{TSTP} = 'IGNORE';
1568   local $SIG{PIPE} = 'IGNORE';
1569
1570   my $oldAutoCommit = $FS::UID::AutoCommit;
1571   local $FS::UID::AutoCommit = 0;
1572   my $dbh = dbh;
1573
1574   my $sql = "UPDATE svc_acct SET $column = ".
1575             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1576             " $op ? WHERE svcnum = ?";
1577   warn "$me $sql\n"
1578     if $DEBUG;
1579
1580   my $sth = $dbh->prepare( $sql )
1581     or die "Error preparing $sql: ". $dbh->errstr;
1582   my $rv = $sth->execute($amount, $self->svcnum);
1583   die "Error executing $sql: ". $sth->errstr
1584     unless defined($rv);
1585   die "Can't update $column for svcnum". $self->svcnum
1586     if $rv == 0;
1587
1588   my $action = $op2action{$op};
1589
1590   if ( &{$op2condition{$op}}($self, $column, $amount) ) {
1591     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1592       if ($part_export->option('overlimit_groups')) {
1593         my ($new,$old);
1594         my $other = new FS::svc_acct $self->hashref;
1595         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1596                        ($self, $part_export->option('overlimit_groups'));
1597         $other->usergroup( $groups );
1598         if ($action eq 'suspend'){
1599           $new = $other; $old = $self;
1600         }else{
1601           $new = $self; $old = $other;
1602         }
1603         my $error = $part_export->export_replace($new, $old);
1604         if ( $error ) {
1605           $dbh->rollback if $oldAutoCommit;
1606           return "Error replacing radius groups in export, ${op}: $error";
1607         }
1608       }
1609     }
1610   }
1611
1612   if ( $conf->exists("svc_acct-usage_$action")
1613        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1614     #my $error = $self->$action();
1615     my $error = $self->cust_svc->cust_pkg->$action();
1616     if ( $error ) {
1617       $dbh->rollback if $oldAutoCommit;
1618       return "Error ${action}ing: $error";
1619     }
1620   }
1621
1622   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1623     my $wqueue = new FS::queue {
1624       'svcnum' => $self->svcnum,
1625       'job'    => 'FS::svc_acct::reached_threshold',
1626     };
1627
1628     my $to = '';
1629     if ($op eq '-'){
1630       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1631     }
1632
1633     # x_threshold race
1634     my $error = $wqueue->insert(
1635       'svcnum' => $self->svcnum,
1636       'op'     => $op,
1637       'column' => $column,
1638       'to'     => $to,
1639     );
1640     if ( $error ) {
1641       $dbh->rollback if $oldAutoCommit;
1642       return "Error queuing threshold activity: $error";
1643     }
1644   }
1645
1646   warn "$me update successful; committing\n"
1647     if $DEBUG;
1648   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1649   '';
1650
1651 }
1652
1653 sub set_usage {
1654   my( $self, $valueref ) = @_;
1655
1656   warn "$me set_usage called for svcnum ". $self->svcnum.
1657        ' ('. $self->email. "): ".
1658        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1659     if $DEBUG;
1660
1661   local $SIG{HUP} = 'IGNORE';
1662   local $SIG{INT} = 'IGNORE';
1663   local $SIG{QUIT} = 'IGNORE';
1664   local $SIG{TERM} = 'IGNORE';
1665   local $SIG{TSTP} = 'IGNORE';
1666   local $SIG{PIPE} = 'IGNORE';
1667
1668   local $FS::svc_Common::noexport_hack = 1;
1669   my $oldAutoCommit = $FS::UID::AutoCommit;
1670   local $FS::UID::AutoCommit = 0;
1671   my $dbh = dbh;
1672
1673   my $reset = 0;
1674   foreach my $field (keys %$valueref){
1675     $reset = 1 if $valueref->{$field};
1676     $self->setfield($field, $valueref->{$field});
1677     $self->setfield( $field.'_threshold',
1678                      int($self->getfield($field)
1679                          * ( $conf->exists('svc_acct-usage_threshold')
1680                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1681                              : 0.20
1682                            )
1683                        )
1684                      );
1685   }
1686   my $error = $self->replace;
1687   die $error if $error;
1688
1689   if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) {
1690     my $error = $self->cust_svc->cust_pkg->unsuspend;
1691     if ( $error ) {
1692       $dbh->rollback if $oldAutoCommit;
1693       return "Error unsuspending: $error";
1694     }
1695   }
1696
1697   warn "$me update successful; committing\n"
1698     if $DEBUG;
1699   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1700   '';
1701
1702 }
1703
1704
1705 =item recharge HASHREF
1706
1707   Increments usage columns by the amount specified in HASHREF as
1708   column=>amount pairs.
1709
1710 =cut
1711
1712 sub recharge {
1713   my ($self, $vhash) = @_;
1714
1715   if ( $DEBUG ) {
1716     warn "[$me] recharge called on $self: ". Dumper($self).
1717          "\nwith vhash: ". Dumper($vhash);
1718   }
1719
1720   my $oldAutoCommit = $FS::UID::AutoCommit;
1721   local $FS::UID::AutoCommit = 0;
1722   my $dbh = dbh;
1723   my $error = '';
1724
1725   foreach my $column (keys %$vhash){
1726     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1727   }
1728
1729   if ( $error ) {
1730     $dbh->rollback if $oldAutoCommit;
1731   }else{
1732     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1733   }
1734   return $error;
1735 }
1736
1737 =item is_rechargeable
1738
1739 Returns true if this svc_account can be "recharged" and false otherwise.
1740
1741 =cut
1742
1743 sub is_rechargable {
1744   my $self = shift;
1745   $self->seconds ne ''
1746     || $self->upbytes ne ''
1747     || $self->downbytes ne ''
1748     || $self->totalbytes ne '';
1749 }
1750
1751 =item seconds_since TIMESTAMP
1752
1753 Returns the number of seconds this account has been online since TIMESTAMP,
1754 according to the session monitor (see L<FS::Session>).
1755
1756 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1757 L<Time::Local> and L<Date::Parse> for conversion functions.
1758
1759 =cut
1760
1761 #note: POD here, implementation in FS::cust_svc
1762 sub seconds_since {
1763   my $self = shift;
1764   $self->cust_svc->seconds_since(@_);
1765 }
1766
1767 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1768
1769 Returns the numbers of seconds this account has been online between
1770 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1771 external SQL radacct table, specified via sqlradius export.  Sessions which
1772 started in the specified range but are still open are counted from session
1773 start to the end of the range (unless they are over 1 day old, in which case
1774 they are presumed missing their stop record and not counted).  Also, sessions
1775 which end in the range but started earlier are counted from the start of the
1776 range to session end.  Finally, sessions which start before the range but end
1777 after are counted for the entire range.
1778
1779 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1780 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1781 functions.
1782
1783 =cut
1784
1785 #note: POD here, implementation in FS::cust_svc
1786 sub seconds_since_sqlradacct {
1787   my $self = shift;
1788   $self->cust_svc->seconds_since_sqlradacct(@_);
1789 }
1790
1791 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1792
1793 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1794 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1795 TIMESTAMP_END (exclusive).
1796
1797 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1798 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1799 functions.
1800
1801 =cut
1802
1803 #note: POD here, implementation in FS::cust_svc
1804 sub attribute_since_sqlradacct {
1805   my $self = shift;
1806   $self->cust_svc->attribute_since_sqlradacct(@_);
1807 }
1808
1809 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1810
1811 Returns an array of hash references of this customers login history for the
1812 given time range.  (document this better)
1813
1814 =cut
1815
1816 sub get_session_history {
1817   my $self = shift;
1818   $self->cust_svc->get_session_history(@_);
1819 }
1820
1821 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1822
1823 =cut
1824
1825 sub get_cdrs {
1826   my($self, $start, $end, %opt ) = @_;
1827
1828   my $did = $self->username; #yup
1829
1830   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1831
1832   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1833
1834   #SELECT $for_update * FROM cdr
1835   #  WHERE calldate >= $start #need a conversion
1836   #    AND calldate <  $end   #ditto
1837   #    AND (    charged_party = "$did"
1838   #          OR charged_party = "$prefix$did" #if length($prefix);
1839   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1840   #               AND
1841   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1842   #             )
1843   #        )
1844   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1845
1846   my $charged_or_src;
1847   if ( length($prefix) ) {
1848     $charged_or_src =
1849       " AND (    charged_party = '$did'
1850               OR charged_party = '$prefix$did'
1851               OR ( ( charged_party IS NULL OR charged_party = '' )
1852                    AND
1853                    ( src = '$did' OR src = '$prefix$did' )
1854                  )
1855             )
1856       ";
1857   } else {
1858     $charged_or_src =
1859       " AND (    charged_party = '$did'
1860               OR ( ( charged_party IS NULL OR charged_party = '' )
1861                    AND
1862                    src = '$did'
1863                  )
1864             )
1865       ";
1866
1867   }
1868
1869   qsearch(
1870     'select'    => "$for_update *",
1871     'table'     => 'cdr',
1872     'hashref'   => {
1873                      #( freesidestatus IS NULL OR freesidestatus = '' )
1874                      'freesidestatus' => '',
1875                    },
1876     'extra_sql' => $charged_or_src,
1877
1878   );
1879
1880 }
1881
1882 =item radius_groups
1883
1884 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1885
1886 =cut
1887
1888 sub radius_groups {
1889   my $self = shift;
1890   if ( $self->usergroup ) {
1891     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1892       unless ref($self->usergroup) eq 'ARRAY';
1893     #when provisioning records, export callback runs in svc_Common.pm before
1894     #radius_usergroup records can be inserted...
1895     @{$self->usergroup};
1896   } else {
1897     map { $_->groupname }
1898       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1899   }
1900 }
1901
1902 =item clone_suspended
1903
1904 Constructor used by FS::part_export::_export_suspend fallback.  Document
1905 better.
1906
1907 =cut
1908
1909 sub clone_suspended {
1910   my $self = shift;
1911   my %hash = $self->hash;
1912   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1913   new FS::svc_acct \%hash;
1914 }
1915
1916 =item clone_kludge_unsuspend
1917
1918 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1919 better.
1920
1921 =cut
1922
1923 sub clone_kludge_unsuspend {
1924   my $self = shift;
1925   my %hash = $self->hash;
1926   $hash{_password} = '';
1927   new FS::svc_acct \%hash;
1928 }
1929
1930 =item check_password
1931
1932 Checks the supplied password against the (possibly encrypted) password in the
1933 database.  Returns true for a successful authentication, false for no match.
1934
1935 Currently supported encryptions are: classic DES crypt() and MD5
1936
1937 =cut
1938
1939 sub check_password {
1940   my($self, $check_password) = @_;
1941
1942   #remove old-style SUSPENDED kludge, they should be allowed to login to
1943   #self-service and pay up
1944   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1945
1946   if ( $self->_password_encoding eq 'ldap' ) {
1947
1948     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
1949     return $auth->match($check_password);
1950
1951   } elsif ( $self->_password_encoding eq 'crypt' ) {
1952
1953     my $auth = from_crypt Authen::Passphrase $self->_password;
1954     return $auth->match($check_password);
1955
1956   } elsif ( $self->_password_encoding eq 'plain' ) {
1957
1958     return $check_password eq $password;
1959
1960   } else {
1961
1962     #XXX this could be replaced with Authen::Passphrase stuff
1963
1964     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1965       return 0;
1966     } elsif ( length($password) < 13 ) { #plaintext
1967       $check_password eq $password;
1968     } elsif ( length($password) == 13 ) { #traditional DES crypt
1969       crypt($check_password, $password) eq $password;
1970     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1971       unix_md5_crypt($check_password, $password) eq $password;
1972     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1973       warn "Can't check password: Blowfish encryption not yet supported, ".
1974            "svcnum ".  $self->svcnum. "\n";
1975       0;
1976     } else {
1977       warn "Can't check password: Unrecognized encryption for svcnum ".
1978            $self->svcnum. "\n";
1979       0;
1980     }
1981
1982   }
1983
1984 }
1985
1986 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1987
1988 Returns an encrypted password, either by passing through an encrypted password
1989 in the database or by encrypting a plaintext password from the database.
1990
1991 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1992 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1993 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1994 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1995 encryption type is only used if the password is not already encrypted in the
1996 database.
1997
1998 =cut
1999
2000 sub crypt_password {
2001   my $self = shift;
2002
2003   if ( $self->_password_encoding eq 'ldap' ) {
2004
2005     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2006       my $plain = $2;
2007
2008       #XXX this could be replaced with Authen::Passphrase stuff
2009
2010       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2011       if ( $encryption eq 'crypt' ) {
2012         crypt(
2013           $self->_password,
2014           $saltset[int(rand(64))].$saltset[int(rand(64))]
2015         );
2016       } elsif ( $encryption eq 'md5' ) {
2017         unix_md5_crypt( $self->_password );
2018       } elsif ( $encryption eq 'blowfish' ) {
2019         croak "unknown encryption method $encryption";
2020       } else {
2021         croak "unknown encryption method $encryption";
2022       }
2023
2024     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2025       $1;
2026     }
2027
2028   } elsif ( $self->_password_encoding eq 'crypt' ) {
2029
2030     return $self->_password;
2031
2032   } elsif ( $self->_password_encoding eq 'plain' ) {
2033
2034     #XXX this could be replaced with Authen::Passphrase stuff
2035
2036     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2037     if ( $encryption eq 'crypt' ) {
2038       crypt(
2039         $self->_password,
2040         $saltset[int(rand(64))].$saltset[int(rand(64))]
2041       );
2042     } elsif ( $encryption eq 'md5' ) {
2043       unix_md5_crypt( $self->_password );
2044     } elsif ( $encryption eq 'blowfish' ) {
2045       croak "unknown encryption method $encryption";
2046     } else {
2047       croak "unknown encryption method $encryption";
2048     }
2049
2050   } else {
2051
2052     if ( length($self->_password) == 13
2053          || $self->_password =~ /^\$(1|2a?)\$/
2054          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2055        )
2056     {
2057       $self->_password;
2058     } else {
2059
2060       #XXX this could be replaced with Authen::Passphrase stuff
2061
2062       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2063       if ( $encryption eq 'crypt' ) {
2064         crypt(
2065           $self->_password,
2066           $saltset[int(rand(64))].$saltset[int(rand(64))]
2067         );
2068       } elsif ( $encryption eq 'md5' ) {
2069         unix_md5_crypt( $self->_password );
2070       } elsif ( $encryption eq 'blowfish' ) {
2071         croak "unknown encryption method $encryption";
2072       } else {
2073         croak "unknown encryption method $encryption";
2074       }
2075
2076     }
2077
2078   }
2079
2080 }
2081
2082 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2083
2084 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2085 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2086 "{MD5}5426824942db4253f87a1009fd5d2d4".
2087
2088 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2089 to work the same as the B</crypt_password> method.
2090
2091 =cut
2092
2093 sub ldap_password {
2094   my $self = shift;
2095   #eventually should check a "password-encoding" field
2096
2097   if ( $self->_password_encoding eq 'ldap' ) {
2098
2099     return $self->_password;
2100
2101   } elsif ( $self->_password_encoding eq 'crypt' ) {
2102
2103     if ( length($self->_password) == 13 ) { #crypt
2104       return '{CRYPT}'. $self->_password;
2105     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2106       return '{MD5}'. $1;
2107     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2108     #  die "Blowfish encryption not supported in this context, svcnum ".
2109     #      $self->svcnum. "\n";
2110     } else {
2111       warn "encryption method not (yet?) supported in LDAP context";
2112       return '{CRYPT}*'; #unsupported, should not auth
2113     }
2114
2115   } elsif ( $self->_password_encoding eq 'plain' ) {
2116
2117     return '{PLAIN}'. $self->_password;
2118
2119     #return '{CLEARTEXT}'. $self->_password; #?
2120
2121   } else {
2122
2123     if ( length($self->_password) == 13 ) { #crypt
2124       return '{CRYPT}'. $self->_password;
2125     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2126       return '{MD5}'. $1;
2127     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2128       warn "Blowfish encryption not supported in this context, svcnum ".
2129           $self->svcnum. "\n";
2130       return '{CRYPT}*';
2131
2132     #are these two necessary anymore?
2133     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2134       return '{SSHA}'. $1;
2135     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2136       return '{NS-MTA-MD5}'. $1;
2137
2138     } else { #plaintext
2139       return '{PLAIN}'. $self->_password;
2140
2141       #return '{CLEARTEXT}'. $self->_password; #?
2142
2143       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2144       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2145       #if ( $encryption eq 'crypt' ) {
2146       #  return '{CRYPT}'. crypt(
2147       #    $self->_password,
2148       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2149       #  );
2150       #} elsif ( $encryption eq 'md5' ) {
2151       #  unix_md5_crypt( $self->_password );
2152       #} elsif ( $encryption eq 'blowfish' ) {
2153       #  croak "unknown encryption method $encryption";
2154       #} else {
2155       #  croak "unknown encryption method $encryption";
2156       #}
2157     }
2158
2159   }
2160
2161 }
2162
2163 =item domain_slash_username
2164
2165 Returns $domain/$username/
2166
2167 =cut
2168
2169 sub domain_slash_username {
2170   my $self = shift;
2171   $self->domain. '/'. $self->username. '/';
2172 }
2173
2174 =item virtual_maildir
2175
2176 Returns $domain/maildirs/$username/
2177
2178 =cut
2179
2180 sub virtual_maildir {
2181   my $self = shift;
2182   $self->domain. '/maildirs/'. $self->username. '/';
2183 }
2184
2185 =back
2186
2187 =head1 SUBROUTINES
2188
2189 =over 4
2190
2191 =item send_email
2192
2193 This is the FS::svc_acct job-queue-able version.  It still uses
2194 FS::Misc::send_email under-the-hood.
2195
2196 =cut
2197
2198 sub send_email {
2199   my %opt = @_;
2200
2201   eval "use FS::Misc qw(send_email)";
2202   die $@ if $@;
2203
2204   $opt{mimetype} ||= 'text/plain';
2205   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2206
2207   my $error = send_email(
2208     'from'         => $opt{from},
2209     'to'           => $opt{to},
2210     'subject'      => $opt{subject},
2211     'content-type' => $opt{mimetype},
2212     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2213   );
2214   die $error if $error;
2215 }
2216
2217 =item check_and_rebuild_fuzzyfiles
2218
2219 =cut
2220
2221 sub check_and_rebuild_fuzzyfiles {
2222   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2223   -e "$dir/svc_acct.username"
2224     or &rebuild_fuzzyfiles;
2225 }
2226
2227 =item rebuild_fuzzyfiles
2228
2229 =cut
2230
2231 sub rebuild_fuzzyfiles {
2232
2233   use Fcntl qw(:flock);
2234
2235   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2236
2237   #username
2238
2239   open(USERNAMELOCK,">>$dir/svc_acct.username")
2240     or die "can't open $dir/svc_acct.username: $!";
2241   flock(USERNAMELOCK,LOCK_EX)
2242     or die "can't lock $dir/svc_acct.username: $!";
2243
2244   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2245
2246   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2247     or die "can't open $dir/svc_acct.username.tmp: $!";
2248   print USERNAMECACHE join("\n", @all_username), "\n";
2249   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2250
2251   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2252   close USERNAMELOCK;
2253
2254 }
2255
2256 =item all_username
2257
2258 =cut
2259
2260 sub all_username {
2261   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2262   open(USERNAMECACHE,"<$dir/svc_acct.username")
2263     or die "can't open $dir/svc_acct.username: $!";
2264   my @array = map { chomp; $_; } <USERNAMECACHE>;
2265   close USERNAMECACHE;
2266   \@array;
2267 }
2268
2269 =item append_fuzzyfiles USERNAME
2270
2271 =cut
2272
2273 sub append_fuzzyfiles {
2274   my $username = shift;
2275
2276   &check_and_rebuild_fuzzyfiles;
2277
2278   use Fcntl qw(:flock);
2279
2280   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2281
2282   open(USERNAME,">>$dir/svc_acct.username")
2283     or die "can't open $dir/svc_acct.username: $!";
2284   flock(USERNAME,LOCK_EX)
2285     or die "can't lock $dir/svc_acct.username: $!";
2286
2287   print USERNAME "$username\n";
2288
2289   flock(USERNAME,LOCK_UN)
2290     or die "can't unlock $dir/svc_acct.username: $!";
2291   close USERNAME;
2292
2293   1;
2294 }
2295
2296
2297
2298 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2299
2300 =cut
2301
2302 sub radius_usergroup_selector {
2303   my $sel_groups = shift;
2304   my %sel_groups = map { $_=>1 } @$sel_groups;
2305
2306   my $selectname = shift || 'radius_usergroup';
2307
2308   my $dbh = dbh;
2309   my $sth = $dbh->prepare(
2310     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2311   ) or die $dbh->errstr;
2312   $sth->execute() or die $sth->errstr;
2313   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2314
2315   my $html = <<END;
2316     <SCRIPT>
2317     function ${selectname}_doadd(object) {
2318       var myvalue = object.${selectname}_add.value;
2319       var optionName = new Option(myvalue,myvalue,false,true);
2320       var length = object.$selectname.length;
2321       object.$selectname.options[length] = optionName;
2322       object.${selectname}_add.value = "";
2323     }
2324     </SCRIPT>
2325     <SELECT MULTIPLE NAME="$selectname">
2326 END
2327
2328   foreach my $group ( @all_groups ) {
2329     $html .= qq(<OPTION VALUE="$group");
2330     if ( $sel_groups{$group} ) {
2331       $html .= ' SELECTED';
2332       $sel_groups{$group} = 0;
2333     }
2334     $html .= ">$group</OPTION>\n";
2335   }
2336   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2337     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2338   };
2339   $html .= '</SELECT>';
2340
2341   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2342            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2343
2344   $html;
2345 }
2346
2347 =item reached_threshold
2348
2349 Performs some activities when svc_acct thresholds (such as number of seconds
2350 remaining) are reached.
2351
2352 =cut
2353
2354 sub reached_threshold {
2355   my %opt = @_;
2356
2357   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2358   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2359
2360   if ( $opt{'op'} eq '+' ){
2361     $svc_acct->setfield( $opt{'column'}.'_threshold',
2362                          int($svc_acct->getfield($opt{'column'})
2363                              * ( $conf->exists('svc_acct-usage_threshold')
2364                                  ? $conf->config('svc_acct-usage_threshold')/100
2365                                  : 0.80
2366                                )
2367                          )
2368                        );
2369     my $error = $svc_acct->replace;
2370     die $error if $error;
2371   }elsif ( $opt{'op'} eq '-' ){
2372
2373     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2374     return '' if ($threshold eq '' );
2375
2376     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2377     my $error = $svc_acct->replace;
2378     die $error if $error; # email next time, i guess
2379
2380     if ( $warning_template ) {
2381       eval "use FS::Misc qw(send_email)";
2382       die $@ if $@;
2383
2384       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2385       my $cust_main = $cust_pkg->cust_main;
2386
2387       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2388                                $cust_main->invoicing_list,
2389                                $svc_acct->email,
2390                                ($opt{'to'} ? $opt{'to'} : ())
2391                    );
2392
2393       my $mimetype = $warning_mimetype;
2394       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2395
2396       my $body       =  $warning_template->fill_in( HASH => {
2397                         'custnum'   => $cust_main->custnum,
2398                         'username'  => $svc_acct->username,
2399                         'password'  => $svc_acct->_password,
2400                         'first'     => $cust_main->first,
2401                         'last'      => $cust_main->getfield('last'),
2402                         'pkg'       => $cust_pkg->part_pkg->pkg,
2403                         'column'    => $opt{'column'},
2404                         'amount'    => $svc_acct->getfield($opt{'column'}),
2405                         'threshold' => $threshold,
2406                       } );
2407
2408
2409       my $error = send_email(
2410         'from'         => $warning_from,
2411         'to'           => $to,
2412         'subject'      => $warning_subject,
2413         'content-type' => $mimetype,
2414         'body'         => [ map "$_\n", split("\n", $body) ],
2415       );
2416       die $error if $error;
2417     }
2418   }else{
2419     die "unknown op: " . $opt{'op'};
2420   }
2421 }
2422
2423 =back
2424
2425 =head1 BUGS
2426
2427 The $recref stuff in sub check should be cleaned up.
2428
2429 The suspend, unsuspend and cancel methods update the database, but not the
2430 current object.  This is probably a bug as it's unexpected and
2431 counterintuitive.
2432
2433 radius_usergroup_selector?  putting web ui components in here?  they should
2434 probably live somewhere else...
2435
2436 insertion of RADIUS group stuff in insert could be done with child_objects now
2437 (would probably clean up export of them too)
2438
2439 =head1 SEE ALSO
2440
2441 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2442 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2443 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2444 L<freeside-queued>), L<FS::svc_acct_pop>,
2445 schema.html from the base documentation.
2446
2447 =cut
2448
2449 1;
2450