FS/FS/svc_acct.pm

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