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               #settings
1115               || $self->ut_alphasn('cgp_rulesallowed')
1116               || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1117               || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1118               || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1119               #preferences
1120               || $self->ut_alphasn('cgp_deletemode')
1121               || $self->ut_alphan('cgp_emptytrash')
1122   ;
1123   return $error if $error;
1124
1125   my $cust_pkg;
1126   local $username_letter = $username_letter;
1127   if ($self->svcnum) {
1128     my $cust_svc = $self->cust_svc
1129       or return "no cust_svc record found for svcnum ". $self->svcnum;
1130     my $cust_pkg = $cust_svc->cust_pkg;
1131   }
1132   if ($self->pkgnum) {
1133     $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1134   }
1135   if ($cust_pkg) {
1136     $username_letter =
1137       $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1138   }
1139
1140   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1141   if ( $username_uppercase ) {
1142     $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1143       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1144     $recref->{username} = $1;
1145   } else {
1146     $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1147       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1148     $recref->{username} = $1;
1149   }
1150
1151   if ( $username_letterfirst ) {
1152     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1153   } elsif ( $username_letter ) {
1154     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1155   }
1156   if ( $username_noperiod ) {
1157     $recref->{username} =~ /\./ and return gettext('illegal_username');
1158   }
1159   if ( $username_nounderscore ) {
1160     $recref->{username} =~ /_/ and return gettext('illegal_username');
1161   }
1162   if ( $username_nodash ) {
1163     $recref->{username} =~ /\-/ and return gettext('illegal_username');
1164   }
1165   unless ( $username_ampersand ) {
1166     $recref->{username} =~ /\&/ and return gettext('illegal_username');
1167   }
1168   unless ( $username_percent ) {
1169     $recref->{username} =~ /\%/ and return gettext('illegal_username');
1170   }
1171   unless ( $username_colon ) {
1172     $recref->{username} =~ /\:/ and return gettext('illegal_username');
1173   }
1174
1175   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1176   $recref->{popnum} = $1;
1177   return "Unknown popnum" unless
1178     ! $recref->{popnum} ||
1179     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1180
1181   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1182
1183     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1184     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1185
1186     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1187     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1188     #not all systems use gid=uid
1189     #you can set a fixed gid in part_svc
1190
1191     return "Only root can have uid 0"
1192       if $recref->{uid} == 0
1193          && $recref->{username} !~ /^(root|toor|smtp)$/;
1194
1195     unless ( $recref->{username} eq 'sync' ) {
1196       if ( grep $_ eq $recref->{shell}, @shells ) {
1197         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1198       } else {
1199         return "Illegal shell \`". $self->shell. "\'; ".
1200                "shells configuration value contains: @shells";
1201       }
1202     } else {
1203       $recref->{shell} = '/bin/sync';
1204     }
1205
1206   } else {
1207     $recref->{gid} ne '' ?
1208       return "Can't have gid without uid" : ( $recref->{gid}='' );
1209     #$recref->{dir} ne '' ?
1210     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1211     $recref->{shell} ne '' ?
1212       return "Can't have shell without uid" : ( $recref->{shell}='' );
1213   }
1214
1215   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1216
1217     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1218       or return "Illegal directory: ". $recref->{dir};
1219     $recref->{dir} = $1;
1220     return "Illegal directory"
1221       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1222     return "Illegal directory"
1223       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1224     unless ( $recref->{dir} ) {
1225       $recref->{dir} = $dir_prefix . '/';
1226       if ( $dirhash > 0 ) {
1227         for my $h ( 1 .. $dirhash ) {
1228           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1229         }
1230       } elsif ( $dirhash < 0 ) {
1231         for my $h ( reverse $dirhash .. -1 ) {
1232           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1233         }
1234       }
1235       $recref->{dir} .= $recref->{username};
1236     ;
1237     }
1238
1239   }
1240
1241   #  $error = $self->ut_textn('finger');
1242   #  return $error if $error;
1243   if ( $self->getfield('finger') eq '' ) {
1244     my $cust_pkg = $self->svcnum
1245       ? $self->cust_svc->cust_pkg
1246       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1247     if ( $cust_pkg ) {
1248       my $cust_main = $cust_pkg->cust_main;
1249       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1250     }
1251   }
1252   $self->getfield('finger') =~
1253     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1254       or return "Illegal finger: ". $self->getfield('finger');
1255   $self->setfield('finger', $1);
1256
1257   for (qw( quota file_quota file_maxsize )) {
1258     $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1259     $recref->{$_} = $1;
1260   }
1261   $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1262   $recref->{file_maxnum} = $1;
1263
1264   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1265     if ( $recref->{slipip} eq '' ) {
1266       $recref->{slipip} = '';
1267     } elsif ( $recref->{slipip} eq '0e0' ) {
1268       $recref->{slipip} = '0e0';
1269     } else {
1270       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1271         or return "Illegal slipip: ". $self->slipip;
1272       $recref->{slipip} = $1;
1273     }
1274
1275   }
1276
1277   #arbitrary RADIUS stuff; allow ut_textn for now
1278   foreach ( grep /^radius_/, fields('svc_acct') ) {
1279     $self->ut_textn($_);
1280   }
1281
1282   # First, if _password is blank, generate one and set default encoding.
1283   if ( ! $recref->{_password} ) {
1284     $error = $self->set_password('');
1285   }
1286   # But if there's a _password but no encoding, assume it's plaintext and
1287   # set it to default encoding.
1288   elsif ( ! $recref->{_password_encoding} ) {
1289     $error = $self->set_password($recref->{_password});
1290   }
1291   return $error if $error;
1292
1293   # Next, check _password to ensure compliance with the encoding.
1294   if ( $recref->{_password_encoding} eq 'ldap' ) {
1295
1296     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1297       $recref->{_password} = uc($1).$2;
1298     } else {
1299       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1300     }
1301
1302   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1303
1304     if ( $recref->{_password} =~
1305            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1306            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1307        ) {
1308
1309       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1310
1311     } else {
1312       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1313     }
1314
1315   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1316     # Password randomization is now in set_password.
1317     # Strip whitespace characters, check length requirements, etc.
1318     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1319       $recref->{_password} = $1;
1320     } else {
1321       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1322              FS::Msgcat::_gettext('illegal_password_characters').
1323              ": ". $recref->{_password};
1324     }
1325
1326     if ( $password_noampersand ) {
1327       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1328     }
1329     if ( $password_noexclamation ) {
1330       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1331     }
1332   }
1333   else {
1334     return "invalid password encoding ('".$recref->{_password_encoding}."'";
1335   }
1336   $self->SUPER::check;
1337
1338 }
1339
1340
1341 sub _password_encryption {
1342   my $self = shift;
1343   my $encoding = lc($self->_password_encoding);
1344   return if !$encoding;
1345   return 'plain' if $encoding eq 'plain';
1346   if($encoding eq 'crypt') {
1347     my $pass = $self->_password;
1348     $pass =~ s/^\*SUSPENDED\* //;
1349     $pass =~ s/^!!?//;
1350     return 'md5' if $pass =~ /^\$1\$/;
1351     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1352     return 'des' if length($pass) == 13;
1353     return;
1354   }
1355   if($encoding eq 'ldap') {
1356     uc($self->_password) =~ /^\{([\w-]+)\}/;
1357     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1358     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1359     return 'md5' if $1 eq 'MD5';
1360     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1361
1362     return;
1363   }
1364   return;
1365 }
1366
1367 sub get_cleartext_password {
1368   my $self = shift;
1369   if($self->_password_encryption eq 'plain') {
1370     if($self->_password_encoding eq 'ldap') {
1371       $self->_password =~ /\{\w+\}(.*)$/;
1372       return $1;
1373     }
1374     else {
1375       return $self->_password;
1376     }
1377   }
1378   return;
1379 }
1380
1381
1382 =item set_password
1383
1384 Set the cleartext password for the account.  If _password_encoding is set, the
1385 new password will be encoded according to the existing method (including
1386 encryption mode, if it can be determined).  Otherwise,
1387 config('default-password-encoding') is used.
1388
1389 If no password is supplied (or a zero-length password when minimum password length
1390 is >0), one will be generated randomly.
1391
1392 =cut
1393
1394 sub set_password {
1395   my( $self, $pass ) = ( shift, shift );
1396
1397   warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1398      if $DEBUG;
1399
1400   my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1401                 FS::Msgcat::_gettext('illegal_password_characters').
1402                 ": ". $pass;
1403
1404   my( $encoding, $encryption ) = ('', '');
1405
1406   if ( $self->_password_encoding ) {
1407     $encoding = $self->_password_encoding;
1408     # identify existing encryption method, try to use it.
1409     $encryption = $self->_password_encryption;
1410     if (!$encryption) {
1411       # use the system default
1412       undef $encoding;
1413     }
1414   }
1415
1416   if ( !$encoding ) {
1417     # set encoding to system default
1418     ($encoding, $encryption) =
1419       split(/-/, lc($conf->config('default-password-encoding')));
1420     $encoding ||= 'legacy';
1421     $self->_password_encoding($encoding);
1422   }
1423
1424   if ( $encoding eq 'legacy' ) {
1425
1426     # The legacy behavior from check():
1427     # If the password is blank, randomize it and set encoding to 'plain'.
1428     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1429       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1430       $self->_password_encoding('plain');
1431     } else {
1432       # Prefix + valid-length password
1433       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1434         $pass = $1.$3;
1435         $self->_password_encoding('plain');
1436       # Prefix + crypt string
1437       } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1438         $pass = $1.$3;
1439         $self->_password_encoding('crypt');
1440       # Various disabled crypt passwords
1441       } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1442         $self->_password_encoding('crypt');
1443       } else {
1444         return $failure;
1445       }
1446     }
1447
1448     $self->_password($pass);
1449     return;
1450
1451   }
1452
1453   return $failure
1454     if $passwordmin && length($pass) < $passwordmin
1455     or $passwordmax && length($pass) > $passwordmax;
1456
1457   if ( $encoding eq 'crypt' ) {
1458     if ($encryption eq 'md5') {
1459       $pass = unix_md5_crypt($pass);
1460     } elsif ($encryption eq 'des') {
1461       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1462     }
1463
1464   } elsif ( $encoding eq 'ldap' ) {
1465     if ($encryption eq 'md5') {
1466       $pass = md5_base64($pass);
1467     } elsif ($encryption eq 'sha1') {
1468       $pass = sha1_base64($pass);
1469     } elsif ($encryption eq 'crypt') {
1470       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1471     }
1472     # else $encryption eq 'plain', do nothing
1473     $pass = '{'.uc($encryption).'}'.$pass;
1474   }
1475   # else encoding eq 'plain'
1476
1477   $self->_password($pass);
1478   return;
1479 }
1480
1481 =item _check_system
1482
1483 Internal function to check the username against the list of system usernames
1484 from the I<system_usernames> configuration value.  Returns true if the username
1485 is listed on the system username list.
1486
1487 =cut
1488
1489 sub _check_system {
1490   my $self = shift;
1491   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1492                $conf->config('system_usernames')
1493         );
1494 }
1495
1496 =item _check_duplicate
1497
1498 Internal method to check for duplicates usernames, username@domain pairs and
1499 uids.
1500
1501 If the I<global_unique-username> configuration value is set to B<username> or
1502 B<username@domain>, enforces global username or username@domain uniqueness.
1503
1504 In all cases, check for duplicate uids and usernames or username@domain pairs
1505 per export and with identical I<svcpart> values.
1506
1507 =cut
1508
1509 sub _check_duplicate {
1510   my $self = shift;
1511
1512   my $global_unique = $conf->config('global_unique-username') || 'none';
1513   return '' if $global_unique eq 'disabled';
1514
1515   $self->lock_table;
1516
1517   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1518   unless ( $part_svc ) {
1519     return 'unknown svcpart '. $self->svcpart;
1520   }
1521
1522   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1523                  qsearch( 'svc_acct', { 'username' => $self->username } );
1524   return gettext('username_in_use')
1525     if $global_unique eq 'username' && @dup_user;
1526
1527   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1528                        qsearch( 'svc_acct', { 'username' => $self->username,
1529                                               'domsvc'   => $self->domsvc } );
1530   return gettext('username_in_use')
1531     if $global_unique eq 'username@domain' && @dup_userdomain;
1532
1533   my @dup_uid;
1534   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1535        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1536     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1537                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1538   } else {
1539     @dup_uid = ();
1540   }
1541
1542   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1543     my $exports = FS::part_export::export_info('svc_acct');
1544     my %conflict_user_svcpart;
1545     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1546
1547     foreach my $part_export ( $part_svc->part_export ) {
1548
1549       #this will catch to the same exact export
1550       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1551
1552       #this will catch to exports w/same exporthost+type ???
1553       #my @other_part_export = qsearch('part_export', {
1554       #  'machine'    => $part_export->machine,
1555       #  'exporttype' => $part_export->exporttype,
1556       #} );
1557       #foreach my $other_part_export ( @other_part_export ) {
1558       #  push @svcparts, map { $_->svcpart }
1559       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1560       #}
1561
1562       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1563       #silly kludge to avoid uninitialized value errors
1564       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1565                      ? $exports->{$part_export->exporttype}{'nodomain'}
1566                      : '';
1567       if ( $nodomain =~ /^Y/i ) {
1568         $conflict_user_svcpart{$_} = $part_export->exportnum
1569           foreach @svcparts;
1570       } else {
1571         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1572           foreach @svcparts;
1573       }
1574     }
1575
1576     foreach my $dup_user ( @dup_user ) {
1577       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1578       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1579         return "duplicate username ". $self->username.
1580                ": conflicts with svcnum ". $dup_user->svcnum.
1581                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1582       }
1583     }
1584
1585     foreach my $dup_userdomain ( @dup_userdomain ) {
1586       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1587       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1588         return "duplicate username\@domain ". $self->email.
1589                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1590                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1591       }
1592     }
1593
1594     foreach my $dup_uid ( @dup_uid ) {
1595       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1596       if ( exists($conflict_user_svcpart{$dup_svcpart})
1597            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1598         return "duplicate uid ". $self->uid.
1599                ": conflicts with svcnum ". $dup_uid->svcnum.
1600                " via exportnum ".
1601                ( $conflict_user_svcpart{$dup_svcpart}
1602                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1603       }
1604     }
1605
1606   }
1607
1608   return '';
1609
1610 }
1611
1612 =item radius
1613
1614 Depriciated, use radius_reply instead.
1615
1616 =cut
1617
1618 sub radius {
1619   carp "FS::svc_acct::radius depriciated, use radius_reply";
1620   $_[0]->radius_reply;
1621 }
1622
1623 =item radius_reply
1624
1625 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1626 reply attributes of this record.
1627
1628 Note that this is now the preferred method for reading RADIUS attributes -
1629 accessing the columns directly is discouraged, as the column names are
1630 expected to change in the future.
1631
1632 =cut
1633
1634 sub radius_reply {
1635   my $self = shift;
1636
1637   return %{ $self->{'radius_reply'} }
1638     if exists $self->{'radius_reply'};
1639
1640   my %reply =
1641     map {
1642       /^(radius_(.*))$/;
1643       my($column, $attrib) = ($1, $2);
1644       #$attrib =~ s/_/\-/g;
1645       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1646     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1647
1648   if ( $self->slipip && $self->slipip ne '0e0' ) {
1649     $reply{$radius_ip} = $self->slipip;
1650   }
1651
1652   if ( $self->seconds !~ /^$/ ) {
1653     $reply{'Session-Timeout'} = $self->seconds;
1654   }
1655
1656   if ( $conf->exists('radius-chillispot-max') ) {
1657     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1658
1659     #hmm.  just because sqlradius.pm says so?
1660     my %whatis = (
1661       'input'  => 'up',
1662       'output' => 'down',
1663       'total'  => 'total',
1664     );
1665
1666     foreach my $what (qw( input output total )) {
1667       my $is = $whatis{$what}.'bytes';
1668       if ( $self->$is() =~ /\d/ ) {
1669         my $big = new Math::BigInt $self->$is();
1670         $big = new Math::BigInt '0' if $big->is_neg();
1671         my $att = "Chillispot-Max-\u$what";
1672         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1673         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1674       }
1675     }
1676
1677   }
1678
1679   %reply;
1680 }
1681
1682 =item radius_check
1683
1684 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1685 check attributes of this record.
1686
1687 Note that this is now the preferred method for reading RADIUS attributes -
1688 accessing the columns directly is discouraged, as the column names are
1689 expected to change in the future.
1690
1691 =cut
1692
1693 sub radius_check {
1694   my $self = shift;
1695
1696   return %{ $self->{'radius_check'} }
1697     if exists $self->{'radius_check'};
1698
1699   my %check =
1700     map {
1701       /^(rc_(.*))$/;
1702       my($column, $attrib) = ($1, $2);
1703       #$attrib =~ s/_/\-/g;
1704       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1705     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1706
1707
1708   my($pw_attrib, $password) = $self->radius_password;
1709   $check{$pw_attrib} = $password;
1710
1711   my $cust_svc = $self->cust_svc;
1712   if ( $cust_svc ) {
1713     my $cust_pkg = $cust_svc->cust_pkg;
1714     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1715       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1716     }
1717   } else {
1718     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1719          "; can't set Expiration\n"
1720       unless $cust_svc;
1721   }
1722
1723   %check;
1724
1725 }
1726
1727 =item radius_password
1728
1729 Returns a key/value pair containing the RADIUS attribute name and value
1730 for the password.
1731
1732 =cut
1733
1734 sub radius_password {
1735   my $self = shift;
1736
1737   my $pw_attrib;
1738   if ( $self->_password_encoding eq 'ldap' ) {
1739     $pw_attrib = 'Password-With-Header';
1740   } elsif ( $self->_password_encoding eq 'crypt' ) {
1741     $pw_attrib = 'Crypt-Password';
1742   } elsif ( $self->_password_encoding eq 'plain' ) {
1743     $pw_attrib = $radius_password;
1744   } else {
1745     $pw_attrib = length($self->_password) <= 12
1746                    ? $radius_password
1747                    : 'Crypt-Password';
1748   }
1749
1750   ($pw_attrib, $self->_password);
1751
1752 }
1753
1754 =item snapshot
1755
1756 This method instructs the object to "snapshot" or freeze RADIUS check and
1757 reply attributes to the current values.
1758
1759 =cut
1760
1761 #bah, my english is too broken this morning
1762 #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
1763 #the FS::cust_pkg's replace method to trigger the correct export updates when
1764 #package dates change)
1765
1766 sub snapshot {
1767   my $self = shift;
1768
1769   $self->{$_} = { $self->$_() }
1770     foreach qw( radius_reply radius_check );
1771
1772 }
1773
1774 =item forget_snapshot
1775
1776 This methos instructs the object to forget any previously snapshotted
1777 RADIUS check and reply attributes.
1778
1779 =cut
1780
1781 sub forget_snapshot {
1782   my $self = shift;
1783
1784   delete $self->{$_}
1785     foreach qw( radius_reply radius_check );
1786
1787 }
1788
1789 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1790
1791 Returns the domain associated with this account.
1792
1793 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1794 history records.
1795
1796 =cut
1797
1798 sub domain {
1799   my $self = shift;
1800   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1801   my $svc_domain = $self->svc_domain(@_)
1802     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1803   $svc_domain->domain;
1804 }
1805
1806 =item cust_svc
1807
1808 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1809
1810 =cut
1811
1812 #inherited from svc_Common
1813
1814 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1815
1816 Returns an email address associated with the account.
1817
1818 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1819 history records.
1820
1821 =cut
1822
1823 sub email {
1824   my $self = shift;
1825   $self->username. '@'. $self->domain(@_);
1826 }
1827
1828 =item acct_snarf
1829
1830 Returns an array of FS::acct_snarf records associated with the account.
1831 If the acct_snarf table does not exist or there are no associated records,
1832 an empty list is returned
1833
1834 =cut
1835
1836 sub acct_snarf {
1837   my $self = shift;
1838   return () unless dbdef->table('acct_snarf');
1839   eval "use FS::acct_snarf;";
1840   die $@ if $@;
1841   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1842 }
1843
1844 =item decrement_upbytes OCTETS
1845
1846 Decrements the I<upbytes> field of this record by the given amount.  If there
1847 is an error, returns the error, otherwise returns false.
1848
1849 =cut
1850
1851 sub decrement_upbytes {
1852   shift->_op_usage('-', 'upbytes', @_);
1853 }
1854
1855 =item increment_upbytes OCTETS
1856
1857 Increments the I<upbytes> field of this record by the given amount.  If there
1858 is an error, returns the error, otherwise returns false.
1859
1860 =cut
1861
1862 sub increment_upbytes {
1863   shift->_op_usage('+', 'upbytes', @_);
1864 }
1865
1866 =item decrement_downbytes OCTETS
1867
1868 Decrements the I<downbytes> field of this record by the given amount.  If there
1869 is an error, returns the error, otherwise returns false.
1870
1871 =cut
1872
1873 sub decrement_downbytes {
1874   shift->_op_usage('-', 'downbytes', @_);
1875 }
1876
1877 =item increment_downbytes OCTETS
1878
1879 Increments the I<downbytes> field of this record by the given amount.  If there
1880 is an error, returns the error, otherwise returns false.
1881
1882 =cut
1883
1884 sub increment_downbytes {
1885   shift->_op_usage('+', 'downbytes', @_);
1886 }
1887
1888 =item decrement_totalbytes OCTETS
1889
1890 Decrements the I<totalbytes> field of this record by the given amount.  If there
1891 is an error, returns the error, otherwise returns false.
1892
1893 =cut
1894
1895 sub decrement_totalbytes {
1896   shift->_op_usage('-', 'totalbytes', @_);
1897 }
1898
1899 =item increment_totalbytes OCTETS
1900
1901 Increments the I<totalbytes> field of this record by the given amount.  If there
1902 is an error, returns the error, otherwise returns false.
1903
1904 =cut
1905
1906 sub increment_totalbytes {
1907   shift->_op_usage('+', 'totalbytes', @_);
1908 }
1909
1910 =item decrement_seconds SECONDS
1911
1912 Decrements the I<seconds> field of this record by the given amount.  If there
1913 is an error, returns the error, otherwise returns false.
1914
1915 =cut
1916
1917 sub decrement_seconds {
1918   shift->_op_usage('-', 'seconds', @_);
1919 }
1920
1921 =item increment_seconds SECONDS
1922
1923 Increments the I<seconds> field of this record by the given amount.  If there
1924 is an error, returns the error, otherwise returns false.
1925
1926 =cut
1927
1928 sub increment_seconds {
1929   shift->_op_usage('+', 'seconds', @_);
1930 }
1931
1932
1933 my %op2action = (
1934   '-' => 'suspend',
1935   '+' => 'unsuspend',
1936 );
1937 my %op2condition = (
1938   '-' => sub { my($self, $column, $amount) = @_;
1939                $self->$column - $amount <= 0;
1940              },
1941   '+' => sub { my($self, $column, $amount) = @_;
1942                ($self->$column || 0) + $amount > 0;
1943              },
1944 );
1945 my %op2warncondition = (
1946   '-' => sub { my($self, $column, $amount) = @_;
1947                my $threshold = $column . '_threshold';
1948                $self->$column - $amount <= $self->$threshold + 0;
1949              },
1950   '+' => sub { my($self, $column, $amount) = @_;
1951                ($self->$column || 0) + $amount > 0;
1952              },
1953 );
1954
1955 sub _op_usage {
1956   my( $self, $op, $column, $amount ) = @_;
1957
1958   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1959        ' ('. $self->email. "): $op $amount\n"
1960     if $DEBUG;
1961
1962   return '' unless $amount;
1963
1964   local $SIG{HUP} = 'IGNORE';
1965   local $SIG{INT} = 'IGNORE';
1966   local $SIG{QUIT} = 'IGNORE';
1967   local $SIG{TERM} = 'IGNORE';
1968   local $SIG{TSTP} = 'IGNORE';
1969   local $SIG{PIPE} = 'IGNORE';
1970
1971   my $oldAutoCommit = $FS::UID::AutoCommit;
1972   local $FS::UID::AutoCommit = 0;
1973   my $dbh = dbh;
1974
1975   my $sql = "UPDATE svc_acct SET $column = ".
1976             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1977             " $op ? WHERE svcnum = ?";
1978   warn "$me $sql\n"
1979     if $DEBUG;
1980
1981   my $sth = $dbh->prepare( $sql )
1982     or die "Error preparing $sql: ". $dbh->errstr;
1983   my $rv = $sth->execute($amount, $self->svcnum);
1984   die "Error executing $sql: ". $sth->errstr
1985     unless defined($rv);
1986   die "Can't update $column for svcnum". $self->svcnum
1987     if $rv == 0;
1988
1989   #$self->snapshot; #not necessary, we retain the old values
1990   #create an object with the updated usage values
1991   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1992   #call exports
1993   my $error = $new->replace($self);
1994   if ( $error ) {
1995     $dbh->rollback if $oldAutoCommit;
1996     return "Error replacing: $error";
1997   }
1998
1999   #overlimit_action eq 'cancel' handling
2000   my $cust_pkg = $self->cust_svc->cust_pkg;
2001   if ( $cust_pkg
2002        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2003        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2004      )
2005   {
2006
2007     my $error = $cust_pkg->cancel; #XXX should have a reason
2008     if ( $error ) {
2009       $dbh->rollback if $oldAutoCommit;
2010       return "Error cancelling: $error";
2011     }
2012
2013     #nothing else is relevant if we're cancelling, so commit & return success
2014     warn "$me update successful; committing\n"
2015       if $DEBUG;
2016     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2017     return '';
2018
2019   }
2020
2021   my $action = $op2action{$op};
2022
2023   if ( &{$op2condition{$op}}($self, $column, $amount) &&
2024         ( $action eq 'suspend'   && !$self->overlimit
2025        || $action eq 'unsuspend' &&  $self->overlimit )
2026      ) {
2027
2028     my $error = $self->_op_overlimit($action);
2029     if ( $error ) {
2030       $dbh->rollback if $oldAutoCommit;
2031       return $error;
2032     }
2033
2034   }
2035
2036   if ( $conf->exists("svc_acct-usage_$action")
2037        && &{$op2condition{$op}}($self, $column, $amount)    ) {
2038     #my $error = $self->$action();
2039     my $error = $self->cust_svc->cust_pkg->$action();
2040     # $error ||= $self->overlimit($action);
2041     if ( $error ) {
2042       $dbh->rollback if $oldAutoCommit;
2043       return "Error ${action}ing: $error";
2044     }
2045   }
2046
2047   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2048     my $wqueue = new FS::queue {
2049       'svcnum' => $self->svcnum,
2050       'job'    => 'FS::svc_acct::reached_threshold',
2051     };
2052
2053     my $to = '';
2054     if ($op eq '-'){
2055       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2056     }
2057
2058     # x_threshold race
2059     my $error = $wqueue->insert(
2060       'svcnum' => $self->svcnum,
2061       'op'     => $op,
2062       'column' => $column,
2063       'to'     => $to,
2064     );
2065     if ( $error ) {
2066       $dbh->rollback if $oldAutoCommit;
2067       return "Error queuing threshold activity: $error";
2068     }
2069   }
2070
2071   warn "$me update successful; committing\n"
2072     if $DEBUG;
2073   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2074   '';
2075
2076 }
2077
2078 sub _op_overlimit {
2079   my( $self, $action ) = @_;
2080
2081   local $SIG{HUP} = 'IGNORE';
2082   local $SIG{INT} = 'IGNORE';
2083   local $SIG{QUIT} = 'IGNORE';
2084   local $SIG{TERM} = 'IGNORE';
2085   local $SIG{TSTP} = 'IGNORE';
2086   local $SIG{PIPE} = 'IGNORE';
2087
2088   my $oldAutoCommit = $FS::UID::AutoCommit;
2089   local $FS::UID::AutoCommit = 0;
2090   my $dbh = dbh;
2091
2092   my $cust_pkg = $self->cust_svc->cust_pkg;
2093
2094   my $conf_overlimit =
2095     $cust_pkg
2096       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2097       : $conf->config('overlimit_groups');
2098
2099   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2100
2101     my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2102     next unless $groups;
2103
2104     my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2105
2106     my $other = new FS::svc_acct $self->hashref;
2107     $other->usergroup( $gref );
2108
2109     my($new,$old);
2110     if ($action eq 'suspend') {
2111       $new = $other;
2112       $old = $self;
2113     } else { # $action eq 'unsuspend'
2114       $new = $self;
2115       $old = $other;
2116     }
2117
2118     my $error = $part_export->export_replace($new, $old)
2119                 || $self->overlimit($action);
2120
2121     if ( $error ) {
2122       $dbh->rollback if $oldAutoCommit;
2123       return "Error replacing radius groups: $error";
2124     }
2125
2126   }
2127
2128   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2129   '';
2130
2131 }
2132
2133 sub set_usage {
2134   my( $self, $valueref, %options ) = @_;
2135
2136   warn "$me set_usage called for svcnum ". $self->svcnum.
2137        ' ('. $self->email. "): ".
2138        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2139     if $DEBUG;
2140
2141   local $SIG{HUP} = 'IGNORE';
2142   local $SIG{INT} = 'IGNORE';
2143   local $SIG{QUIT} = 'IGNORE';
2144   local $SIG{TERM} = 'IGNORE';
2145   local $SIG{TSTP} = 'IGNORE';
2146   local $SIG{PIPE} = 'IGNORE';
2147
2148   local $FS::svc_Common::noexport_hack = 1;
2149   my $oldAutoCommit = $FS::UID::AutoCommit;
2150   local $FS::UID::AutoCommit = 0;
2151   my $dbh = dbh;
2152
2153   my $reset = 0;
2154   my %handyhash = ();
2155   if ( $options{null} ) {
2156     %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2157                    qw( seconds upbytes downbytes totalbytes )
2158                  );
2159   }
2160   foreach my $field (keys %$valueref){
2161     $reset = 1 if $valueref->{$field};
2162     $self->setfield($field, $valueref->{$field});
2163     $self->setfield( $field.'_threshold',
2164                      int($self->getfield($field)
2165                          * ( $conf->exists('svc_acct-usage_threshold')
2166                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2167                              : 0.20
2168                            )
2169                        )
2170                      );
2171     $handyhash{$field} = $self->getfield($field);
2172     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2173   }
2174   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2175   #die $error if $error;         #services not explicity changed via the UI
2176
2177   my $sql = "UPDATE svc_acct SET " .
2178     join (',', map { "$_ =  $handyhash{$_}" } (keys %handyhash) ).
2179     " WHERE svcnum = ". $self->svcnum;
2180
2181   warn "$me $sql\n"
2182     if $DEBUG;
2183
2184   if (scalar(keys %handyhash)) {
2185     my $sth = $dbh->prepare( $sql )
2186       or die "Error preparing $sql: ". $dbh->errstr;
2187     my $rv = $sth->execute();
2188     die "Error executing $sql: ". $sth->errstr
2189       unless defined($rv);
2190     die "Can't update usage for svcnum ". $self->svcnum
2191       if $rv == 0;
2192   }
2193
2194   #$self->snapshot; #not necessary, we retain the old values
2195   #create an object with the updated usage values
2196   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2197   local($FS::Record::nowarn_identical) = 1;
2198   my $error = $new->replace($self); #call exports
2199   if ( $error ) {
2200     $dbh->rollback if $oldAutoCommit;
2201     return "Error replacing: $error";
2202   }
2203
2204   if ( $reset ) {
2205
2206     my $error = '';
2207
2208     $error = $self->_op_overlimit('unsuspend')
2209       if $self->overlimit;;
2210
2211     $error ||= $self->cust_svc->cust_pkg->unsuspend
2212       if $conf->exists("svc_acct-usage_unsuspend");
2213
2214     if ( $error ) {
2215       $dbh->rollback if $oldAutoCommit;
2216       return "Error unsuspending: $error";
2217     }
2218
2219   }
2220
2221   warn "$me update successful; committing\n"
2222     if $DEBUG;
2223   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2224   '';
2225
2226 }
2227
2228
2229 =item recharge HASHREF
2230
2231   Increments usage columns by the amount specified in HASHREF as
2232   column=>amount pairs.
2233
2234 =cut
2235
2236 sub recharge {
2237   my ($self, $vhash) = @_;
2238
2239   if ( $DEBUG ) {
2240     warn "[$me] recharge called on $self: ". Dumper($self).
2241          "\nwith vhash: ". Dumper($vhash);
2242   }
2243
2244   my $oldAutoCommit = $FS::UID::AutoCommit;
2245   local $FS::UID::AutoCommit = 0;
2246   my $dbh = dbh;
2247   my $error = '';
2248
2249   foreach my $column (keys %$vhash){
2250     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2251   }
2252
2253   if ( $error ) {
2254     $dbh->rollback if $oldAutoCommit;
2255   }else{
2256     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2257   }
2258   return $error;
2259 }
2260
2261 =item is_rechargeable
2262
2263 Returns true if this svc_account can be "recharged" and false otherwise.
2264
2265 =cut
2266
2267 sub is_rechargable {
2268   my $self = shift;
2269   $self->seconds ne ''
2270     || $self->upbytes ne ''
2271     || $self->downbytes ne ''
2272     || $self->totalbytes ne '';
2273 }
2274
2275 =item seconds_since TIMESTAMP
2276
2277 Returns the number of seconds this account has been online since TIMESTAMP,
2278 according to the session monitor (see L<FS::Session>).
2279
2280 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2281 L<Time::Local> and L<Date::Parse> for conversion functions.
2282
2283 =cut
2284
2285 #note: POD here, implementation in FS::cust_svc
2286 sub seconds_since {
2287   my $self = shift;
2288   $self->cust_svc->seconds_since(@_);
2289 }
2290
2291 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2292
2293 Returns the numbers of seconds this account has been online between
2294 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2295 external SQL radacct table, specified via sqlradius export.  Sessions which
2296 started in the specified range but are still open are counted from session
2297 start to the end of the range (unless they are over 1 day old, in which case
2298 they are presumed missing their stop record and not counted).  Also, sessions
2299 which end in the range but started earlier are counted from the start of the
2300 range to session end.  Finally, sessions which start before the range but end
2301 after are counted for the entire range.
2302
2303 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2304 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2305 functions.
2306
2307 =cut
2308
2309 #note: POD here, implementation in FS::cust_svc
2310 sub seconds_since_sqlradacct {
2311   my $self = shift;
2312   $self->cust_svc->seconds_since_sqlradacct(@_);
2313 }
2314
2315 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2316
2317 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2318 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2319 TIMESTAMP_END (exclusive).
2320
2321 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2322 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2323 functions.
2324
2325 =cut
2326
2327 #note: POD here, implementation in FS::cust_svc
2328 sub attribute_since_sqlradacct {
2329   my $self = shift;
2330   $self->cust_svc->attribute_since_sqlradacct(@_);
2331 }
2332
2333 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2334
2335 Returns an array of hash references of this customers login history for the
2336 given time range.  (document this better)
2337
2338 =cut
2339
2340 sub get_session_history {
2341   my $self = shift;
2342   $self->cust_svc->get_session_history(@_);
2343 }
2344
2345 =item last_login_text
2346
2347 Returns text describing the time of last login.
2348
2349 =cut
2350
2351 sub last_login_text {
2352   my $self = shift;
2353   $self->last_login ? ctime($self->last_login) : 'unknown';
2354 }
2355
2356 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2357
2358 =cut
2359
2360 sub get_cdrs {
2361   my($self, $start, $end, %opt ) = @_;
2362
2363   my $did = $self->username; #yup
2364
2365   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2366
2367   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2368
2369   #SELECT $for_update * FROM cdr
2370   #  WHERE calldate >= $start #need a conversion
2371   #    AND calldate <  $end   #ditto
2372   #    AND (    charged_party = "$did"
2373   #          OR charged_party = "$prefix$did" #if length($prefix);
2374   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2375   #               AND
2376   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2377   #             )
2378   #        )
2379   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2380
2381   my $charged_or_src;
2382   if ( length($prefix) ) {
2383     $charged_or_src =
2384       " AND (    charged_party = '$did'
2385               OR charged_party = '$prefix$did'
2386               OR ( ( charged_party IS NULL OR charged_party = '' )
2387                    AND
2388                    ( src = '$did' OR src = '$prefix$did' )
2389                  )
2390             )
2391       ";
2392   } else {
2393     $charged_or_src =
2394       " AND (    charged_party = '$did'
2395               OR ( ( charged_party IS NULL OR charged_party = '' )
2396                    AND
2397                    src = '$did'
2398                  )
2399             )
2400       ";
2401
2402   }
2403
2404   qsearch(
2405     'select'    => "$for_update *",
2406     'table'     => 'cdr',
2407     'hashref'   => {
2408                      #( freesidestatus IS NULL OR freesidestatus = '' )
2409                      'freesidestatus' => '',
2410                    },
2411     'extra_sql' => $charged_or_src,
2412
2413   );
2414
2415 }
2416
2417 =item radius_groups
2418
2419 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2420
2421 =cut
2422
2423 sub radius_groups {
2424   my $self = shift;
2425   if ( $self->usergroup ) {
2426     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2427       unless ref($self->usergroup) eq 'ARRAY';
2428     #when provisioning records, export callback runs in svc_Common.pm before
2429     #radius_usergroup records can be inserted...
2430     @{$self->usergroup};
2431   } else {
2432     map { $_->groupname }
2433       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2434   }
2435 }
2436
2437 =item clone_suspended
2438
2439 Constructor used by FS::part_export::_export_suspend fallback.  Document
2440 better.
2441
2442 =cut
2443
2444 sub clone_suspended {
2445   my $self = shift;
2446   my %hash = $self->hash;
2447   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2448   new FS::svc_acct \%hash;
2449 }
2450
2451 =item clone_kludge_unsuspend
2452
2453 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2454 better.
2455
2456 =cut
2457
2458 sub clone_kludge_unsuspend {
2459   my $self = shift;
2460   my %hash = $self->hash;
2461   $hash{_password} = '';
2462   new FS::svc_acct \%hash;
2463 }
2464
2465 =item check_password
2466
2467 Checks the supplied password against the (possibly encrypted) password in the
2468 database.  Returns true for a successful authentication, false for no match.
2469
2470 Currently supported encryptions are: classic DES crypt() and MD5
2471
2472 =cut
2473
2474 sub check_password {
2475   my($self, $check_password) = @_;
2476
2477   #remove old-style SUSPENDED kludge, they should be allowed to login to
2478   #self-service and pay up
2479   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2480
2481   if ( $self->_password_encoding eq 'ldap' ) {
2482
2483     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2484     return $auth->match($check_password);
2485
2486   } elsif ( $self->_password_encoding eq 'crypt' ) {
2487
2488     my $auth = from_crypt Authen::Passphrase $self->_password;
2489     return $auth->match($check_password);
2490
2491   } elsif ( $self->_password_encoding eq 'plain' ) {
2492
2493     return $check_password eq $password;
2494
2495   } else {
2496
2497     #XXX this could be replaced with Authen::Passphrase stuff
2498
2499     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2500       return 0;
2501     } elsif ( length($password) < 13 ) { #plaintext
2502       $check_password eq $password;
2503     } elsif ( length($password) == 13 ) { #traditional DES crypt
2504       crypt($check_password, $password) eq $password;
2505     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2506       unix_md5_crypt($check_password, $password) eq $password;
2507     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2508       warn "Can't check password: Blowfish encryption not yet supported, ".
2509            "svcnum ".  $self->svcnum. "\n";
2510       0;
2511     } else {
2512       warn "Can't check password: Unrecognized encryption for svcnum ".
2513            $self->svcnum. "\n";
2514       0;
2515     }
2516
2517   }
2518
2519 }
2520
2521 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2522
2523 Returns an encrypted password, either by passing through an encrypted password
2524 in the database or by encrypting a plaintext password from the database.
2525
2526 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2527 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2528 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2529 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2530 encryption type is only used if the password is not already encrypted in the
2531 database.
2532
2533 =cut
2534
2535 sub crypt_password {
2536   my $self = shift;
2537
2538   if ( $self->_password_encoding eq 'ldap' ) {
2539
2540     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2541       my $plain = $2;
2542
2543       #XXX this could be replaced with Authen::Passphrase stuff
2544
2545       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2546       if ( $encryption eq 'crypt' ) {
2547         crypt(
2548           $self->_password,
2549           $saltset[int(rand(64))].$saltset[int(rand(64))]
2550         );
2551       } elsif ( $encryption eq 'md5' ) {
2552         unix_md5_crypt( $self->_password );
2553       } elsif ( $encryption eq 'blowfish' ) {
2554         croak "unknown encryption method $encryption";
2555       } else {
2556         croak "unknown encryption method $encryption";
2557       }
2558
2559     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2560       $1;
2561     }
2562
2563   } elsif ( $self->_password_encoding eq 'crypt' ) {
2564
2565     return $self->_password;
2566
2567   } elsif ( $self->_password_encoding eq 'plain' ) {
2568
2569     #XXX this could be replaced with Authen::Passphrase stuff
2570
2571     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2572     if ( $encryption eq 'crypt' ) {
2573       crypt(
2574         $self->_password,
2575         $saltset[int(rand(64))].$saltset[int(rand(64))]
2576       );
2577     } elsif ( $encryption eq 'md5' ) {
2578       unix_md5_crypt( $self->_password );
2579     } elsif ( $encryption eq 'blowfish' ) {
2580       croak "unknown encryption method $encryption";
2581     } else {
2582       croak "unknown encryption method $encryption";
2583     }
2584
2585   } else {
2586
2587     if ( length($self->_password) == 13
2588          || $self->_password =~ /^\$(1|2a?)\$/
2589          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2590        )
2591     {
2592       $self->_password;
2593     } else {
2594
2595       #XXX this could be replaced with Authen::Passphrase stuff
2596
2597       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2598       if ( $encryption eq 'crypt' ) {
2599         crypt(
2600           $self->_password,
2601           $saltset[int(rand(64))].$saltset[int(rand(64))]
2602         );
2603       } elsif ( $encryption eq 'md5' ) {
2604         unix_md5_crypt( $self->_password );
2605       } elsif ( $encryption eq 'blowfish' ) {
2606         croak "unknown encryption method $encryption";
2607       } else {
2608         croak "unknown encryption method $encryption";
2609       }
2610
2611     }
2612
2613   }
2614
2615 }
2616
2617 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2618
2619 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2620 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2621 "{MD5}5426824942db4253f87a1009fd5d2d4".
2622
2623 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2624 to work the same as the B</crypt_password> method.
2625
2626 =cut
2627
2628 sub ldap_password {
2629   my $self = shift;
2630   #eventually should check a "password-encoding" field
2631
2632   if ( $self->_password_encoding eq 'ldap' ) {
2633
2634     return $self->_password;
2635
2636   } elsif ( $self->_password_encoding eq 'crypt' ) {
2637
2638     if ( length($self->_password) == 13 ) { #crypt
2639       return '{CRYPT}'. $self->_password;
2640     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2641       return '{MD5}'. $1;
2642     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2643     #  die "Blowfish encryption not supported in this context, svcnum ".
2644     #      $self->svcnum. "\n";
2645     } else {
2646       warn "encryption method not (yet?) supported in LDAP context";
2647       return '{CRYPT}*'; #unsupported, should not auth
2648     }
2649
2650   } elsif ( $self->_password_encoding eq 'plain' ) {
2651
2652     return '{PLAIN}'. $self->_password;
2653
2654     #return '{CLEARTEXT}'. $self->_password; #?
2655
2656   } else {
2657
2658     if ( length($self->_password) == 13 ) { #crypt
2659       return '{CRYPT}'. $self->_password;
2660     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2661       return '{MD5}'. $1;
2662     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2663       warn "Blowfish encryption not supported in this context, svcnum ".
2664           $self->svcnum. "\n";
2665       return '{CRYPT}*';
2666
2667     #are these two necessary anymore?
2668     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2669       return '{SSHA}'. $1;
2670     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2671       return '{NS-MTA-MD5}'. $1;
2672
2673     } else { #plaintext
2674       return '{PLAIN}'. $self->_password;
2675
2676       #return '{CLEARTEXT}'. $self->_password; #?
2677
2678       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2679       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2680       #if ( $encryption eq 'crypt' ) {
2681       #  return '{CRYPT}'. crypt(
2682       #    $self->_password,
2683       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2684       #  );
2685       #} elsif ( $encryption eq 'md5' ) {
2686       #  unix_md5_crypt( $self->_password );
2687       #} elsif ( $encryption eq 'blowfish' ) {
2688       #  croak "unknown encryption method $encryption";
2689       #} else {
2690       #  croak "unknown encryption method $encryption";
2691       #}
2692     }
2693
2694   }
2695
2696 }
2697
2698 =item domain_slash_username
2699
2700 Returns $domain/$username/
2701
2702 =cut
2703
2704 sub domain_slash_username {
2705   my $self = shift;
2706   $self->domain. '/'. $self->username. '/';
2707 }
2708
2709 =item virtual_maildir
2710
2711 Returns $domain/maildirs/$username/
2712
2713 =cut
2714
2715 sub virtual_maildir {
2716   my $self = shift;
2717   $self->domain. '/maildirs/'. $self->username. '/';
2718 }
2719
2720 =back
2721
2722 =head1 CLASS METHODS
2723
2724 =over 4
2725
2726 =item search HASHREF
2727
2728 Class method which returns a qsearch hash expression to search for parameters
2729 specified in HASHREF.  Valid parameters are
2730
2731 =over 4
2732
2733 =item domain
2734
2735 =item domsvc
2736
2737 =item unlinked
2738
2739 =item agentnum
2740
2741 =item pkgpart
2742
2743 Arrayref of pkgparts
2744
2745 =item pkgpart
2746
2747 =item where
2748
2749 Arrayref of additional WHERE clauses, will be ANDed together.
2750
2751 =item order_by
2752
2753 =item cust_fields
2754
2755 =back
2756
2757 =cut
2758
2759 sub search {
2760   my ($class, $params) = @_;
2761
2762   my @where = ();
2763
2764   # domain
2765   if ( $params->{'domain'} ) {
2766     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2767     #preserve previous behavior & bubble up an error if $svc_domain not found?
2768     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2769   }
2770
2771   # domsvc
2772   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2773     push @where, "domsvc = $1";
2774   }
2775
2776   #unlinked
2777   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2778
2779   #agentnum
2780   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2781     push @where, "agentnum = $1";
2782   }
2783
2784   #custnum
2785   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2786     push @where, "custnum = $1";
2787   }
2788
2789   #pkgpart
2790   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2791     #XXX untaint or sql quote
2792     push @where,
2793       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2794   }
2795
2796   # popnum
2797   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2798     push @where, "popnum = $1";
2799   }
2800
2801   # svcpart
2802   if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2803     push @where, "svcpart = $1";
2804   }
2805
2806
2807   # here is the agent virtualization
2808   #if ($params->{CurrentUser}) {
2809   #  my $access_user =
2810   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2811   #
2812   #  if ($access_user) {
2813   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2814   #  }else{
2815   #    push @where, "1=0";
2816   #  }
2817   #} else {
2818     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2819                    'table'      => 'cust_main',
2820                    'null_right' => 'View/link unlinked services',
2821                  );
2822   #}
2823
2824   push @where, @{ $params->{'where'} } if $params->{'where'};
2825
2826   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2827
2828   my $addl_from = ' LEFT JOIN cust_svc  USING ( svcnum  ) '.
2829                   ' LEFT JOIN part_svc  USING ( svcpart ) '.
2830                   ' LEFT JOIN cust_pkg  USING ( pkgnum  ) '.
2831                   ' LEFT JOIN cust_main USING ( custnum ) ';
2832
2833   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2834   #if ( keys %svc_acct ) {
2835   #  $count_query .= ' WHERE '.
2836   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2837   #                                      keys %svc_acct
2838   #                        );
2839   #}
2840
2841   my $sql_query = {
2842     'table'       => 'svc_acct',
2843     'hashref'     => {}, # \%svc_acct,
2844     'select'      => join(', ',
2845                        'svc_acct.*',
2846                        'part_svc.svc',
2847                        'cust_main.custnum',
2848                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2849                      ),
2850     'addl_from'   => $addl_from,
2851     'extra_sql'   => $extra_sql,
2852     'order_by'    => $params->{'order_by'},
2853     'count_query' => $count_query,
2854   };
2855
2856 }
2857
2858 =back
2859
2860 =head1 SUBROUTINES
2861
2862 =over 4
2863
2864 =item send_email
2865
2866 This is the FS::svc_acct job-queue-able version.  It still uses
2867 FS::Misc::send_email under-the-hood.
2868
2869 =cut
2870
2871 sub send_email {
2872   my %opt = @_;
2873
2874   eval "use FS::Misc qw(send_email)";
2875   die $@ if $@;
2876
2877   $opt{mimetype} ||= 'text/plain';
2878   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2879
2880   my $error = send_email(
2881     'from'         => $opt{from},
2882     'to'           => $opt{to},
2883     'subject'      => $opt{subject},
2884     'content-type' => $opt{mimetype},
2885     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2886   );
2887   die $error if $error;
2888 }
2889
2890 =item check_and_rebuild_fuzzyfiles
2891
2892 =cut
2893
2894 sub check_and_rebuild_fuzzyfiles {
2895   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2896   -e "$dir/svc_acct.username"
2897     or &rebuild_fuzzyfiles;
2898 }
2899
2900 =item rebuild_fuzzyfiles
2901
2902 =cut
2903
2904 sub rebuild_fuzzyfiles {
2905
2906   use Fcntl qw(:flock);
2907
2908   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2909
2910   #username
2911
2912   open(USERNAMELOCK,">>$dir/svc_acct.username")
2913     or die "can't open $dir/svc_acct.username: $!";
2914   flock(USERNAMELOCK,LOCK_EX)
2915     or die "can't lock $dir/svc_acct.username: $!";
2916
2917   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2918
2919   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2920     or die "can't open $dir/svc_acct.username.tmp: $!";
2921   print USERNAMECACHE join("\n", @all_username), "\n";
2922   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2923
2924   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2925   close USERNAMELOCK;
2926
2927 }
2928
2929 =item all_username
2930
2931 =cut
2932
2933 sub all_username {
2934   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2935   open(USERNAMECACHE,"<$dir/svc_acct.username")
2936     or die "can't open $dir/svc_acct.username: $!";
2937   my @array = map { chomp; $_; } <USERNAMECACHE>;
2938   close USERNAMECACHE;
2939   \@array;
2940 }
2941
2942 =item append_fuzzyfiles USERNAME
2943
2944 =cut
2945
2946 sub append_fuzzyfiles {
2947   my $username = shift;
2948
2949   &check_and_rebuild_fuzzyfiles;
2950
2951   use Fcntl qw(:flock);
2952
2953   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2954
2955   open(USERNAME,">>$dir/svc_acct.username")
2956     or die "can't open $dir/svc_acct.username: $!";
2957   flock(USERNAME,LOCK_EX)
2958     or die "can't lock $dir/svc_acct.username: $!";
2959
2960   print USERNAME "$username\n";
2961
2962   flock(USERNAME,LOCK_UN)
2963     or die "can't unlock $dir/svc_acct.username: $!";
2964   close USERNAME;
2965
2966   1;
2967 }
2968
2969
2970
2971 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2972
2973 =cut
2974
2975 sub radius_usergroup_selector {
2976   my $sel_groups = shift;
2977   my %sel_groups = map { $_=>1 } @$sel_groups;
2978
2979   my $selectname = shift || 'radius_usergroup';
2980
2981   my $dbh = dbh;
2982   my $sth = $dbh->prepare(
2983     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2984   ) or die $dbh->errstr;
2985   $sth->execute() or die $sth->errstr;
2986   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2987
2988   my $html = <<END;
2989     <SCRIPT>
2990     function ${selectname}_doadd(object) {
2991       var myvalue = object.${selectname}_add.value;
2992       var optionName = new Option(myvalue,myvalue,false,true);
2993       var length = object.$selectname.length;
2994       object.$selectname.options[length] = optionName;
2995       object.${selectname}_add.value = "";
2996     }
2997     </SCRIPT>
2998     <SELECT MULTIPLE NAME="$selectname">
2999 END
3000
3001   foreach my $group ( @all_groups ) {
3002     $html .= qq(<OPTION VALUE="$group");
3003     if ( $sel_groups{$group} ) {
3004       $html .= ' SELECTED';
3005       $sel_groups{$group} = 0;
3006     }
3007     $html .= ">$group</OPTION>\n";
3008   }
3009   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
3010     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
3011   };
3012   $html .= '</SELECT>';
3013
3014   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
3015            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
3016
3017   $html;
3018 }
3019
3020 =item reached_threshold
3021
3022 Performs some activities when svc_acct thresholds (such as number of seconds
3023 remaining) are reached.
3024
3025 =cut
3026
3027 sub reached_threshold {
3028   my %opt = @_;
3029
3030   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3031   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3032
3033   if ( $opt{'op'} eq '+' ){
3034     $svc_acct->setfield( $opt{'column'}.'_threshold',
3035                          int($svc_acct->getfield($opt{'column'})
3036                              * ( $conf->exists('svc_acct-usage_threshold')
3037                                  ? $conf->config('svc_acct-usage_threshold')/100
3038                                  : 0.80
3039                                )
3040                          )
3041                        );
3042     my $error = $svc_acct->replace;
3043     die $error if $error;
3044   }elsif ( $opt{'op'} eq '-' ){
3045
3046     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3047     return '' if ($threshold eq '' );
3048
3049     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3050     my $error = $svc_acct->replace;
3051     die $error if $error; # email next time, i guess
3052
3053     if ( $warning_template ) {
3054       eval "use FS::Misc qw(send_email)";
3055       die $@ if $@;
3056
3057       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
3058       my $cust_main = $cust_pkg->cust_main;
3059
3060       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3061                                $cust_main->invoicing_list,
3062                                ($opt{'to'} ? $opt{'to'} : ())
3063                    );
3064
3065       my $mimetype = $warning_mimetype;
3066       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3067
3068       my $body       =  $warning_template->fill_in( HASH => {
3069                         'custnum'   => $cust_main->custnum,
3070                         'username'  => $svc_acct->username,
3071                         'password'  => $svc_acct->_password,
3072                         'first'     => $cust_main->first,
3073                         'last'      => $cust_main->getfield('last'),
3074                         'pkg'       => $cust_pkg->part_pkg->pkg,
3075                         'column'    => $opt{'column'},
3076                         'amount'    => $opt{'column'} =~/bytes/
3077                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3078                                        : $svc_acct->getfield($opt{'column'}),
3079                         'threshold' => $opt{'column'} =~/bytes/
3080                                        ? FS::UI::bytecount::display_bytecount($threshold)
3081                                        : $threshold,
3082                       } );
3083
3084
3085       my $error = send_email(
3086         'from'         => $warning_from,
3087         'to'           => $to,
3088         'subject'      => $warning_subject,
3089         'content-type' => $mimetype,
3090         'body'         => [ map "$_\n", split("\n", $body) ],
3091       );
3092       die $error if $error;
3093     }
3094   }else{
3095     die "unknown op: " . $opt{'op'};
3096   }
3097 }
3098
3099 =back
3100
3101 =head1 BUGS
3102
3103 The $recref stuff in sub check should be cleaned up.
3104
3105 The suspend, unsuspend and cancel methods update the database, but not the
3106 current object.  This is probably a bug as it's unexpected and
3107 counterintuitive.
3108
3109 radius_usergroup_selector?  putting web ui components in here?  they should
3110 probably live somewhere else...
3111
3112 insertion of RADIUS group stuff in insert could be done with child_objects now
3113 (would probably clean up export of them too)
3114
3115 _op_usage and set_usage bypass the history... maybe they shouldn't
3116
3117 =head1 SEE ALSO
3118
3119 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3120 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3121 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3122 L<freeside-queued>), L<FS::svc_acct_pop>,
3123 schema.html from the base documentation.
3124
3125 =cut
3126
3127 1;