FS/FS/svc_acct.pm

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