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