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