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