FS/FS/svc_acct.pm

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