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