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