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