FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
   5              $dir_prefix @shells $usernamemin
   6              $usernamemax $passwordmin $passwordmax
   7              $username_ampersand $username_letter $username_letterfirst
   8              $username_noperiod $username_nounderscore $username_nodash
   9              $username_uppercase $username_percent $username_colon
  10              $password_noampersand $password_noexclamation
  11              $warning_template $warning_from $warning_subject $warning_mimetype
  12              $warning_cc
  13              $smtpmachine
  14              $radius_password $radius_ip
  15              $dirhash
  16              @saltset @pw_set );
  17 use Scalar::Util qw( blessed );
  18 use Math::BigInt;
  19 use Carp;
  20 use Fcntl qw(:flock);
  21 use Date::Format;
  22 use Crypt::PasswdMD5 1.2;
  23 use Digest::SHA1 'sha1_base64';
  24 use Digest::MD5 'md5_base64';
  25 use Data::Dumper;
  26 use Text::Template;
  27 use Authen::Passphrase;
  28 use FS::UID qw( datasrc driver_name );
  29 use FS::Conf;
  30 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  31 use FS::Msgcat qw(gettext);
  32 use FS::UI::bytecount;
  33 use FS::UI::Web;
  34 use FS::part_pkg;
  35 use FS::svc_Common;
  36 use FS::cust_svc;
  37 use FS::part_svc;
  38 use FS::svc_acct_pop;
  39 use FS::cust_main_invoice;
  40 use FS::svc_domain;
  41 use FS::svc_pbx;
  42 use FS::raddb;
  43 use FS::queue;
  44 use FS::radius_usergroup;
  45 use FS::export_svc;
  46 use FS::part_export;
  47 use FS::svc_forward;
  48 use FS::svc_www;
  49 use FS::cdr;
  50
  51 @ISA = qw( FS::svc_Common );
  52
  53 $DEBUG = 0;
  54 $me = '[FS::svc_acct]';
  55
  56 #ask FS::UID to run this stuff for us later
  57 FS::UID->install_callback( sub {
  58   $conf = new FS::Conf;
  59   $dir_prefix = $conf->config('home');
  60   @shells = $conf->config('shells');
  61   $usernamemin = $conf->config('usernamemin') || 2;
  62   $usernamemax = $conf->config('usernamemax');
  63   $passwordmin = $conf->config('passwordmin'); # || 6;
  64   #blank->6, keep 0
  65   $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
  66                    ? $passwordmin
  67                    : 6;
  68   $passwordmax = $conf->config('passwordmax') || 8;
  69   $username_letter = $conf->exists('username-letter');
  70   $username_letterfirst = $conf->exists('username-letterfirst');
  71   $username_noperiod = $conf->exists('username-noperiod');
  72   $username_nounderscore = $conf->exists('username-nounderscore');
  73   $username_nodash = $conf->exists('username-nodash');
  74   $username_uppercase = $conf->exists('username-uppercase');
  75   $username_ampersand = $conf->exists('username-ampersand');
  76   $username_percent = $conf->exists('username-percent');
  77   $username_colon = $conf->exists('username-colon');
  78   $password_noampersand = $conf->exists('password-noexclamation');
  79   $password_noexclamation = $conf->exists('password-noexclamation');
  80   $dirhash = $conf->config('dirhash') || 0;
  81   if ( $conf->exists('warning_email') ) {
  82     $warning_template = new Text::Template (
  83       TYPE   => 'ARRAY',
  84       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  85     ) or warn "can't create warning email template: $Text::Template::ERROR";
  86     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  87     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  88     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  89     $warning_cc = $conf->config('warning_email-cc');
  90   } else {
  91     $warning_template = '';
  92     $warning_from = '';
  93     $warning_subject = '';
  94     $warning_mimetype = '';
  95     $warning_cc = '';
  96   }
  97   $smtpmachine = $conf->config('smtpmachine');
  98   $radius_password = $conf->config('radius-password') || 'Password';
  99   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
 100   @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
 101 }
 102 );
 103
 104 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
 105 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
 106
 107 sub _cache {
 108   my $self = shift;
 109   my ( $hashref, $cache ) = @_;
 110   if ( $hashref->{'svc_acct_svcnum'} ) {
 111     $self->{'_domsvc'} = FS::svc_domain->new( {
 112       'svcnum'   => $hashref->{'domsvc'},
 113       'domain'   => $hashref->{'svc_acct_domain'},
 114       'catchall' => $hashref->{'svc_acct_catchall'},
 115     } );
 116   }
 117 }
 118
 119 =head1 NAME
 120
 121 FS::svc_acct - Object methods for svc_acct records
 122
 123 =head1 SYNOPSIS
 124
 125   use FS::svc_acct;
 126
 127   $record = new FS::svc_acct \%hash;
 128   $record = new FS::svc_acct { 'column' => 'value' };
 129
 130   $error = $record->insert;
 131
 132   $error = $new_record->replace($old_record);
 133
 134   $error = $record->delete;
 135
 136   $error = $record->check;
 137
 138   $error = $record->suspend;
 139
 140   $error = $record->unsuspend;
 141
 142   $error = $record->cancel;
 143
 144   %hash = $record->radius;
 145
 146   %hash = $record->radius_reply;
 147
 148   %hash = $record->radius_check;
 149
 150   $domain = $record->domain;
 151
 152   $svc_domain = $record->svc_domain;
 153
 154   $email = $record->email;
 155
 156   $seconds_since = $record->seconds_since($timestamp);
 157
 158 =head1 DESCRIPTION
 159
 160 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 161 FS::svc_Common.  The following fields are currently supported:
 162
 163 =over 4
 164
 165 =item svcnum
 166
 167 Primary key (assigned automatcially for new accounts)
 168
 169 =item username
 170
 171 =item _password
 172
 173 generated if blank
 174
 175 =item _password_encoding
 176
 177 plain, crypt, ldap (or empty for autodetection)
 178
 179 =item sec_phrase
 180
 181 security phrase
 182
 183 =item popnum
 184
 185 Point of presence (see L<FS::svc_acct_pop>)
 186
 187 =item uid
 188
 189 =item gid
 190
 191 =item finger
 192
 193 GECOS
 194
 195 =item dir
 196
 197 set automatically if blank (and uid is not)
 198
 199 =item shell
 200
 201 =item quota
 202
 203 =item slipip
 204
 205 IP address
 206
 207 =item seconds
 208
 209 =item upbytes
 210
 211 =item downbyte
 212
 213 =item totalbytes
 214
 215 =item domsvc
 216
 217 svcnum from svc_domain
 218
 219 =item pbxsvc
 220
 221 Optional svcnum from svc_pbx
 222
 223 =item radius_I<Radius_Attribute>
 224
 225 I<Radius-Attribute> (reply)
 226
 227 =item rc_I<Radius_Attribute>
 228
 229 I<Radius-Attribute> (check)
 230
 231 =back
 232
 233 =head1 METHODS
 234
 235 =over 4
 236
 237 =item new HASHREF
 238
 239 Creates a new account.  To add the account to the database, see L<"insert">.
 240
 241 =cut
 242
 243 sub table_info {
 244   {
 245     'name'   => 'Account',
 246     'longname_plural' => 'Access accounts and mailboxes',
 247     'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
 248     'display_weight' => 10,
 249     'cancel_weight'  => 50,
 250     'fields' => {
 251         'dir'       => 'Home directory',
 252         'uid'       => {
 253                          label    => 'UID',
 254                          def_info => 'set to fixed and blank for no UIDs',
 255                          type     => 'text',
 256                        },
 257         'slipip'    => 'IP address',
 258     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 259         'popnum'    => {
 260                          label => 'Access number',
 261                          type => 'select',
 262                          select_table => 'svc_acct_pop',
 263                          select_key   => 'popnum',
 264                          select_label => 'city',
 265                          disable_select => 1,
 266                        },
 267         'username'  => {
 268                          label => 'Username',
 269                          type => 'text',
 270                          disable_default => 1,
 271                          disable_fixed => 1,
 272                          disable_select => 1,
 273                        },
 274         'cgp_type'=> {
 275                        label => 'Communigate account type',
 276                        type => 'select',
 277                        select_list => [ ],
 278                        disable_inventory => 1,
 279                        disable_select    => 1,
 280                      },
 281         'cgp_accessmodes' => {
 282                                label => 'Communigate enabled services',
 283                                type  => 'communigate_pro-accessmodes',
 284                                disable_inventory => 1,
 285                                disable_select    => 1,
 286                              },
 287         'quota'     => {
 288                          label => 'Quota', #Mail storage limit
 289                          type => 'text',
 290                          disable_inventory => 1,
 291                          disable_select => 1,
 292                        },
 293         'file_quota'=> {
 294                          label => 'File storage limit',
 295                          type => 'text',
 296                          disable_inventory => 1,
 297                          disable_select => 1,
 298                        },
 299         'file_maxnum'=> {
 300                          label => 'Number of files limit',
 301                          type => 'text',
 302                          disable_inventory => 1,
 303                          disable_select => 1,
 304                        },
 305         'file_maxsize'=> {
 306                          label => 'File size limit',
 307                          type => 'text',
 308                          disable_inventory => 1,
 309                          disable_select => 1,
 310                        },
 311         '_password' => 'Password',
 312         'gid'       => {
 313                          label    => 'GID',
 314                          def_info => 'when blank, defaults to UID',
 315                          type     => 'text',
 316                        },
 317         'shell'     => {
 318                          label    => 'Shell',
 319                          def_info => 'set to blank for no shell tracking',
 320                          type     => 'select',
 321                          #select_list => [ $conf->config('shells') ],
 322                          select_list => [ $conf ? $conf->config('shells') : () ],
 323                          disable_inventory => 1,
 324                          disable_select => 1,
 325                        },
 326         'finger'    => 'Real name', # (GECOS)',
 327         'domsvc'    => {
 328                          label     => 'Domain',
 329                          type      => 'select',
 330                          select_table => 'svc_domain',
 331                          select_key   => 'svcnum',
 332                          select_label => 'domain',
 333                          disable_inventory => 1,
 334
 335                        },
 336         'domsvc'    => {
 337                          label     => 'Domain',
 338                          type      => 'select',
 339                          select_table => 'svc_domain',
 340                          select_key   => 'svcnum',
 341                          select_label => 'domain',
 342                          disable_inventory => 1,
 343
 344                        },
 345         'pbxsvc'    => { label => 'PBX',
 346                          type  => 'select-svc_pbx.html',
 347                          disable_inventory => 1,
 348                          disable_select => 1, #UI wonky, pry works otherwise
 349                        },
 350         'usergroup' => {
 351                          label => 'RADIUS groups',
 352                          type  => 'radius_usergroup_selector',
 353                          disable_inventory => 1,
 354                          disable_select => 1,
 355                        },
 356         'seconds'   => { label => 'Seconds',
 357                          label_sort => 'with Time Remaining',
 358                          type  => 'text',
 359                          disable_inventory => 1,
 360                          disable_select => 1,
 361                          disable_part_svc_column => 1,
 362                        },
 363         'upbytes'   => { label => 'Upload',
 364                          type  => 'text',
 365                          disable_inventory => 1,
 366                          disable_select => 1,
 367                          'format' => \&FS::UI::bytecount::display_bytecount,
 368                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 369                          disable_part_svc_column => 1,
 370                        },
 371         'downbytes' => { label => 'Download',
 372                          type  => 'text',
 373                          disable_inventory => 1,
 374                          disable_select => 1,
 375                          'format' => \&FS::UI::bytecount::display_bytecount,
 376                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 377                          disable_part_svc_column => 1,
 378                        },
 379         'totalbytes'=> { label => 'Total up and download',
 380                          type  => 'text',
 381                          disable_inventory => 1,
 382                          disable_select => 1,
 383                          'format' => \&FS::UI::bytecount::display_bytecount,
 384                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 385                          disable_part_svc_column => 1,
 386                        },
 387         'seconds_threshold'   => { label => 'Seconds threshold',
 388                                    type  => 'text',
 389                                    disable_inventory => 1,
 390                                    disable_select => 1,
 391                                    disable_part_svc_column => 1,
 392                                  },
 393         'upbytes_threshold'   => { label => 'Upload threshold',
 394                                    type  => 'text',
 395                                    disable_inventory => 1,
 396                                    disable_select => 1,
 397                                    'format' => \&FS::UI::bytecount::display_bytecount,
 398                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 399                                    disable_part_svc_column => 1,
 400                                  },
 401         'downbytes_threshold' => { label => 'Download threshold',
 402                                    type  => 'text',
 403                                    disable_inventory => 1,
 404                                    disable_select => 1,
 405                                    'format' => \&FS::UI::bytecount::display_bytecount,
 406                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 407                                    disable_part_svc_column => 1,
 408                                  },
 409         'totalbytes_threshold'=> { label => 'Total up and download threshold',
 410                                    type  => 'text',
 411                                    disable_inventory => 1,
 412                                    disable_select => 1,
 413                                    'format' => \&FS::UI::bytecount::display_bytecount,
 414                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 415                                    disable_part_svc_column => 1,
 416                                  },
 417         'last_login'=>           {
 418                                    label     => 'Last login',
 419                                    type      => 'disabled',
 420                                  },
 421         'last_logout'=>          {
 422                                    label     => 'Last logout',
 423                                    type      => 'disabled',
 424                                  },
 425     },
 426   };
 427 }
 428
 429 sub table { 'svc_acct'; }
 430
 431 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
 432
 433 sub _fieldhandlers {
 434   {
 435     #false laziness with edit/svc_acct.cgi
 436     'usergroup' => sub {
 437                          my( $self, $groups ) = @_;
 438                          if ( ref($groups) eq 'ARRAY' ) {
 439                            $groups;
 440                          } elsif ( length($groups) ) {
 441                            [ split(/\s*,\s*/, $groups) ];
 442                          } else {
 443                            [];
 444                          }
 445                        },
 446   };
 447 }
 448
 449 sub last_login {
 450   shift->_lastlog('in', @_);
 451 }
 452
 453 sub last_logout {
 454   shift->_lastlog('out', @_);
 455 }
 456
 457 sub _lastlog {
 458   my( $self, $op, $time ) = @_;
 459
 460   if ( defined($time) ) {
 461     warn "$me last_log$op called on svcnum ". $self->svcnum.
 462          ' ('. $self->email. "): $time\n"
 463       if $DEBUG;
 464
 465     my $dbh = dbh;
 466
 467     my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
 468     warn "$me $sql\n"
 469       if $DEBUG;
 470
 471     my $sth = $dbh->prepare( $sql )
 472       or die "Error preparing $sql: ". $dbh->errstr;
 473     my $rv = $sth->execute($time, $self->svcnum);
 474     die "Error executing $sql: ". $sth->errstr
 475       unless defined($rv);
 476     die "Can't update last_log$op for svcnum". $self->svcnum
 477       if $rv == 0;
 478
 479     $self->{'Hash'}->{"last_log$op"} = $time;
 480   }else{
 481     $self->getfield("last_log$op");
 482   }
 483 }
 484
 485 =item search_sql STRING
 486
 487 Class method which returns an SQL fragment to search for the given string.
 488
 489 =cut
 490
 491 sub search_sql {
 492   my( $class, $string ) = @_;
 493   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 494     my( $username, $domain ) = ( $1, $2 );
 495     my $q_username = dbh->quote($username);
 496     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 497     if ( @svc_domain ) {
 498       "svc_acct.username = $q_username AND ( ".
 499         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 500       " )";
 501     } else {
 502       '1 = 0'; #false
 503     }
 504   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 505     ' ( '.
 506       $class->search_sql_field('slipip',   $string ).
 507     ' OR '.
 508       $class->search_sql_field('username', $string ).
 509     ' ) ';
 510   } else {
 511     $class->search_sql_field('username', $string);
 512   }
 513 }
 514
 515 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 516
 517 Returns the "username@domain" string for this account.
 518
 519 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 520 history records.
 521
 522 =cut
 523
 524 sub label {
 525   my $self = shift;
 526   $self->email(@_);
 527 }
 528
 529 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 530
 531 Returns a longer string label for this acccount ("Real Name <username@domain>"
 532 if available, or "username@domain").
 533
 534 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 535 history records.
 536
 537 =cut
 538
 539 sub label_long {
 540   my $self = shift;
 541   my $label = $self->label(@_);
 542   my $finger = $self->finger;
 543   return $label unless $finger =~ /\S/;
 544   my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
 545   $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
 546   "$finger <$label>";
 547 }
 548
 549 =item insert [ , OPTION => VALUE ... ]
 550
 551 Adds this account to the database.  If there is an error, returns the error,
 552 otherwise returns false.
 553
 554 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 555 defined.  An FS::cust_svc record will be created and inserted.
 556
 557 The additional field I<usergroup> can optionally be defined; if so it should
 558 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 559
 560 The additional field I<child_objects> can optionally be defined; if so it
 561 should contain an arrayref of FS::tablename objects.  They will have their
 562 svcnum fields set and will be inserted after this record, but before any
 563 exports are run.  Each element of the array can also optionally be a
 564 two-element array reference containing the child object and the name of an
 565 alternate field to be filled in with the newly-inserted svcnum, for example
 566 C<[ $svc_forward, 'srcsvc' ]>
 567
 568 Currently available options are: I<depend_jobnum>
 569
 570 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 571 jobnums), all provisioning jobs will have a dependancy on the supplied
 572 jobnum(s) (they will not run until the specific job(s) complete(s)).
 573
 574 (TODOC: L<FS::queue> and L<freeside-queued>)
 575
 576 (TODOC: new exports!)
 577
 578 =cut
 579
 580 sub insert {
 581   my $self = shift;
 582   my %options = @_;
 583
 584   if ( $DEBUG ) {
 585     warn "[$me] insert called on $self: ". Dumper($self).
 586          "\nwith options: ". Dumper(%options);
 587   }
 588
 589   local $SIG{HUP} = 'IGNORE';
 590   local $SIG{INT} = 'IGNORE';
 591   local $SIG{QUIT} = 'IGNORE';
 592   local $SIG{TERM} = 'IGNORE';
 593   local $SIG{TSTP} = 'IGNORE';
 594   local $SIG{PIPE} = 'IGNORE';
 595
 596   my $oldAutoCommit = $FS::UID::AutoCommit;
 597   local $FS::UID::AutoCommit = 0;
 598   my $dbh = dbh;
 599
 600   my @jobnums;
 601   my $error = $self->SUPER::insert(
 602     'jobnums'       => \@jobnums,
 603     'child_objects' => $self->child_objects,
 604     %options,
 605   );
 606   if ( $error ) {
 607     $dbh->rollback if $oldAutoCommit;
 608     return $error;
 609   }
 610
 611   if ( $self->usergroup ) {
 612     foreach my $groupname ( @{$self->usergroup} ) {
 613       my $radius_usergroup = new FS::radius_usergroup ( {
 614         svcnum    => $self->svcnum,
 615         groupname => $groupname,
 616       } );
 617       my $error = $radius_usergroup->insert;
 618       if ( $error ) {
 619         $dbh->rollback if $oldAutoCommit;
 620         return $error;
 621       }
 622     }
 623   }
 624
 625   unless ( $skip_fuzzyfiles ) {
 626     $error = $self->queue_fuzzyfiles_update;
 627     if ( $error ) {
 628       $dbh->rollback if $oldAutoCommit;
 629       return "updating fuzzy search cache: $error";
 630     }
 631   }
 632
 633   my $cust_pkg = $self->cust_svc->cust_pkg;
 634
 635   if ( $cust_pkg ) {
 636     my $cust_main = $cust_pkg->cust_main;
 637     my $agentnum = $cust_main->agentnum;
 638
 639     if (   $conf->exists('emailinvoiceautoalways')
 640         || $conf->exists('emailinvoiceauto')
 641         && ! $cust_main->invoicing_list_emailonly
 642        ) {
 643       my @invoicing_list = $cust_main->invoicing_list;
 644       push @invoicing_list, $self->email;
 645       $cust_main->invoicing_list(\@invoicing_list);
 646     }
 647
 648     #welcome email
 649     my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
 650       = ('','','','','','');
 651
 652     if ( $conf->exists('welcome_email', $agentnum) ) {
 653       $welcome_template = new Text::Template (
 654         TYPE   => 'ARRAY',
 655         SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
 656       ) or warn "can't create welcome email template: $Text::Template::ERROR";
 657       $welcome_from = $conf->config('welcome_email-from', $agentnum);
 658         # || 'your-isp-is-dum'
 659       $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
 660         || 'Welcome';
 661       $welcome_subject_template = new Text::Template (
 662         TYPE   => 'STRING',
 663         SOURCE => $welcome_subject,
 664       ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
 665       $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
 666         || 'text/plain';
 667     }
 668     if ( $welcome_template && $cust_pkg ) {
 669       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 670       if ( $to ) {
 671
 672         my %hash = (
 673                      'custnum'  => $self->custnum,
 674                      'username' => $self->username,
 675                      'password' => $self->_password,
 676                      'first'    => $cust_main->first,
 677                      'last'     => $cust_main->getfield('last'),
 678                      'pkg'      => $cust_pkg->part_pkg->pkg,
 679                    );
 680         my $wqueue = new FS::queue {
 681           'svcnum' => $self->svcnum,
 682           'job'    => 'FS::svc_acct::send_email'
 683         };
 684         my $error = $wqueue->insert(
 685           'to'       => $to,
 686           'from'     => $welcome_from,
 687           'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 688           'mimetype' => $welcome_mimetype,
 689           'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 690         );
 691         if ( $error ) {
 692           $dbh->rollback if $oldAutoCommit;
 693           return "error queuing welcome email: $error";
 694         }
 695
 696         if ( $options{'depend_jobnum'} ) {
 697           warn "$me depend_jobnum found; adding to welcome email dependancies"
 698             if $DEBUG;
 699           if ( ref($options{'depend_jobnum'}) ) {
 700             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 701                  "to welcome email dependancies"
 702               if $DEBUG;
 703             push @jobnums, @{ $options{'depend_jobnum'} };
 704           } else {
 705             warn "$me adding job $options{'depend_jobnum'} ".
 706                  "to welcome email dependancies"
 707               if $DEBUG;
 708             push @jobnums, $options{'depend_jobnum'};
 709           }
 710         }
 711
 712         foreach my $jobnum ( @jobnums ) {
 713           my $error = $wqueue->depend_insert($jobnum);
 714           if ( $error ) {
 715             $dbh->rollback if $oldAutoCommit;
 716             return "error queuing welcome email job dependancy: $error";
 717           }
 718         }
 719
 720       }
 721
 722     }
 723
 724   } # if ( $cust_pkg )
 725
 726   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 727   ''; #no error
 728 }
 729
 730 # set usage fields and thresholds if unset but set in a package def
 731 # AND the package already has a last bill date (otherwise they get double added)
 732 sub preinsert_hook_first {
 733   my $self = shift;
 734
 735   return '' unless $self->pkgnum;
 736
 737   my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 738   return '' unless $cust_pkg && $cust_pkg->last_bill;
 739
 740   my $part_pkg = $cust_pkg->part_pkg;
 741   return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
 742
 743   my %values = $part_pkg->usage_valuehash;
 744   my $multiplier = $conf->exists('svc_acct-usage_threshold')
 745                      ? 1 - $conf->config('svc_acct-usage_threshold')/100
 746                      : 0.20; #doesn't matter
 747
 748   foreach ( keys %values ) {
 749     next if $self->getfield($_);
 750     $self->setfield( $_, $values{$_} );
 751     $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
 752       if $conf->exists('svc_acct-usage_threshold');
 753   }
 754
 755   ''; #no error
 756 }
 757
 758 =item delete
 759
 760 Deletes this account from the database.  If there is an error, returns the
 761 error, otherwise returns false.
 762
 763 The corresponding FS::cust_svc record will be deleted as well.
 764
 765 (TODOC: new exports!)
 766
 767 =cut
 768
 769 sub delete {
 770   my $self = shift;
 771
 772   return "can't delete system account" if $self->_check_system;
 773
 774   return "Can't delete an account which is a (svc_forward) source!"
 775     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 776
 777   return "Can't delete an account which is a (svc_forward) destination!"
 778     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 779
 780   return "Can't delete an account with (svc_www) web service!"
 781     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 782
 783   # what about records in session ? (they should refer to history table)
 784
 785   local $SIG{HUP} = 'IGNORE';
 786   local $SIG{INT} = 'IGNORE';
 787   local $SIG{QUIT} = 'IGNORE';
 788   local $SIG{TERM} = 'IGNORE';
 789   local $SIG{TSTP} = 'IGNORE';
 790   local $SIG{PIPE} = 'IGNORE';
 791
 792   my $oldAutoCommit = $FS::UID::AutoCommit;
 793   local $FS::UID::AutoCommit = 0;
 794   my $dbh = dbh;
 795
 796   foreach my $cust_main_invoice (
 797     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 798   ) {
 799     unless ( defined($cust_main_invoice) ) {
 800       warn "WARNING: something's wrong with qsearch";
 801       next;
 802     }
 803     my %hash = $cust_main_invoice->hash;
 804     $hash{'dest'} = $self->email;
 805     my $new = new FS::cust_main_invoice \%hash;
 806     my $error = $new->replace($cust_main_invoice);
 807     if ( $error ) {
 808       $dbh->rollback if $oldAutoCommit;
 809       return $error;
 810     }
 811   }
 812
 813   foreach my $svc_domain (
 814     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 815   ) {
 816     my %hash = new FS::svc_domain->hash;
 817     $hash{'catchall'} = '';
 818     my $new = new FS::svc_domain \%hash;
 819     my $error = $new->replace($svc_domain);
 820     if ( $error ) {
 821       $dbh->rollback if $oldAutoCommit;
 822       return $error;
 823     }
 824   }
 825
 826   my $error = $self->SUPER::delete;
 827   if ( $error ) {
 828     $dbh->rollback if $oldAutoCommit;
 829     return $error;
 830   }
 831
 832   foreach my $radius_usergroup (
 833     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 834   ) {
 835     my $error = $radius_usergroup->delete;
 836     if ( $error ) {
 837       $dbh->rollback if $oldAutoCommit;
 838       return $error;
 839     }
 840   }
 841
 842   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 843   '';
 844 }
 845
 846 =item replace OLD_RECORD
 847
 848 Replaces OLD_RECORD with this one in the database.  If there is an error,
 849 returns the error, otherwise returns false.
 850
 851 The additional field I<usergroup> can optionally be defined; if so it should
 852 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 853
 854
 855 =cut
 856
 857 sub replace {
 858   my $new = shift;
 859
 860   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 861               ? shift
 862               : $new->replace_old;
 863
 864   warn "$me replacing $old with $new\n" if $DEBUG;
 865
 866   my $error;
 867
 868   return "can't modify system account" if $old->_check_system;
 869
 870   {
 871     #no warnings 'numeric';  #alas, a 5.006-ism
 872     local($^W) = 0;
 873
 874     foreach my $xid (qw( uid gid )) {
 875
 876       return "Can't change $xid!"
 877         if ! $conf->exists("svc_acct-edit_$xid")
 878            && $old->$xid() != $new->$xid()
 879            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 880     }
 881
 882   }
 883
 884   #change homdir when we change username
 885   $new->setfield('dir', '') if $old->username ne $new->username;
 886
 887   local $SIG{HUP} = 'IGNORE';
 888   local $SIG{INT} = 'IGNORE';
 889   local $SIG{QUIT} = 'IGNORE';
 890   local $SIG{TERM} = 'IGNORE';
 891   local $SIG{TSTP} = 'IGNORE';
 892   local $SIG{PIPE} = 'IGNORE';
 893
 894   my $oldAutoCommit = $FS::UID::AutoCommit;
 895   local $FS::UID::AutoCommit = 0;
 896   my $dbh = dbh;
 897
 898   # redundant, but so $new->usergroup gets set
 899   $error = $new->check;
 900   return $error if $error;
 901
 902   $old->usergroup( [ $old->radius_groups ] );
 903   if ( $DEBUG ) {
 904     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 905     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 906   }
 907   if ( $new->usergroup ) {
 908     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 909     my @newgroups = @{$new->usergroup};
 910     foreach my $oldgroup ( @{$old->usergroup} ) {
 911       if ( grep { $oldgroup eq $_ } @newgroups ) {
 912         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 913         next;
 914       }
 915       my $radius_usergroup = qsearchs('radius_usergroup', {
 916         svcnum    => $old->svcnum,
 917         groupname => $oldgroup,
 918       } );
 919       my $error = $radius_usergroup->delete;
 920       if ( $error ) {
 921         $dbh->rollback if $oldAutoCommit;
 922         return "error deleting radius_usergroup $oldgroup: $error";
 923       }
 924     }
 925
 926     foreach my $newgroup ( @newgroups ) {
 927       my $radius_usergroup = new FS::radius_usergroup ( {
 928         svcnum    => $new->svcnum,
 929         groupname => $newgroup,
 930       } );
 931       my $error = $radius_usergroup->insert;
 932       if ( $error ) {
 933         $dbh->rollback if $oldAutoCommit;
 934         return "error adding radius_usergroup $newgroup: $error";
 935       }
 936     }
 937
 938   }
 939
 940   $error = $new->SUPER::replace($old, @_);
 941   if ( $error ) {
 942     $dbh->rollback if $oldAutoCommit;
 943     return $error if $error;
 944   }
 945
 946   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 947     $error = $new->queue_fuzzyfiles_update;
 948     if ( $error ) {
 949       $dbh->rollback if $oldAutoCommit;
 950       return "updating fuzzy search cache: $error";
 951     }
 952   }
 953
 954   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 955   ''; #no error
 956 }
 957
 958 =item queue_fuzzyfiles_update
 959
 960 Used by insert & replace to update the fuzzy search cache
 961
 962 =cut
 963
 964 sub queue_fuzzyfiles_update {
 965   my $self = shift;
 966
 967   local $SIG{HUP} = 'IGNORE';
 968   local $SIG{INT} = 'IGNORE';
 969   local $SIG{QUIT} = 'IGNORE';
 970   local $SIG{TERM} = 'IGNORE';
 971   local $SIG{TSTP} = 'IGNORE';
 972   local $SIG{PIPE} = 'IGNORE';
 973
 974   my $oldAutoCommit = $FS::UID::AutoCommit;
 975   local $FS::UID::AutoCommit = 0;
 976   my $dbh = dbh;
 977
 978   my $queue = new FS::queue {
 979     'svcnum' => $self->svcnum,
 980     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 981   };
 982   my $error = $queue->insert($self->username);
 983   if ( $error ) {
 984     $dbh->rollback if $oldAutoCommit;
 985     return "queueing job (transaction rolled back): $error";
 986   }
 987
 988   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 989   '';
 990
 991 }
 992
 993
 994 =item suspend
 995
 996 Suspends this account by calling export-specific suspend hooks.  If there is
 997 an error, returns the error, otherwise returns false.
 998
 999 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1000
1001 =cut
1002
1003 sub suspend {
1004   my $self = shift;
1005   return "can't suspend system account" if $self->_check_system;
1006   $self->SUPER::suspend(@_);
1007 }
1008
1009 =item unsuspend
1010
1011 Unsuspends this account by by calling export-specific suspend hooks.  If there
1012 is an error, returns the error, otherwise returns false.
1013
1014 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1015
1016 =cut
1017
1018 sub unsuspend {
1019   my $self = shift;
1020   my %hash = $self->hash;
1021   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1022     $hash{_password} = $1;
1023     my $new = new FS::svc_acct ( \%hash );
1024     my $error = $new->replace($self);
1025     return $error if $error;
1026   }
1027
1028   $self->SUPER::unsuspend(@_);
1029 }
1030
1031 =item cancel
1032
1033 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1034
1035 If the B<auto_unset_catchall> configuration option is set, this method will
1036 automatically remove any references to the canceled service in the catchall
1037 field of svc_domain.  This allows packages that contain both a svc_domain and
1038 its catchall svc_acct to be canceled in one step.
1039
1040 =cut
1041
1042 sub cancel {
1043   # Only one thing to do at this level
1044   my $self = shift;
1045   foreach my $svc_domain (
1046       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1047     if($conf->exists('auto_unset_catchall')) {
1048       my %hash = $svc_domain->hash;
1049       $hash{catchall} = '';
1050       my $new = new FS::svc_domain ( \%hash );
1051       my $error = $new->replace($svc_domain);
1052       return $error if $error;
1053     } else {
1054       return "cannot unprovision svc_acct #".$self->svcnum.
1055           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1056     }
1057   }
1058
1059   $self->SUPER::cancel(@_);
1060 }
1061
1062
1063 =item check
1064
1065 Checks all fields to make sure this is a valid service.  If there is an error,
1066 returns the error, otherwise returns false.  Called by the insert and replace
1067 methods.
1068
1069 Sets any fixed values; see L<FS::part_svc>.
1070
1071 =cut
1072
1073 sub check {
1074   my $self = shift;
1075
1076   my($recref) = $self->hashref;
1077
1078   my $x = $self->setfixed( $self->_fieldhandlers );
1079   return $x unless ref($x);
1080   my $part_svc = $x;
1081
1082   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1083     $self->usergroup(
1084       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1085   }
1086
1087   my $error = $self->ut_numbern('svcnum')
1088               #|| $self->ut_number('domsvc')
1089               || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1090               || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx',    'svcnum' )
1091               || $self->ut_textn('sec_phrase')
1092               || $self->ut_snumbern('seconds')
1093               || $self->ut_snumbern('upbytes')
1094               || $self->ut_snumbern('downbytes')
1095               || $self->ut_snumbern('totalbytes')
1096               || $self->ut_enum( '_password_encoding',
1097                                  [ '', qw( plain crypt ldap ) ]
1098                                )
1099               || $self->ut_enum( 'password_selfchange', [ '', 'Y' ] )
1100               || $self->ut_enum( 'password_recover',    [ '', 'Y' ] )
1101               || $self->ut_textn( 'cgp_accessmodes' )
1102               || $self->ut_alphan( 'cgp_type' )
1103               || $self->ut_textn( 'cgp_aliases' ) #well
1104   ;
1105   return $error if $error;
1106
1107   my $cust_pkg;
1108   local $username_letter = $username_letter;
1109   if ($self->svcnum) {
1110     my $cust_svc = $self->cust_svc
1111       or return "no cust_svc record found for svcnum ". $self->svcnum;
1112     my $cust_pkg = $cust_svc->cust_pkg;
1113   }
1114   if ($self->pkgnum) {
1115     $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1116   }
1117   if ($cust_pkg) {
1118     $username_letter =
1119       $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1120   }
1121
1122   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1123   if ( $username_uppercase ) {
1124     $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1125       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1126     $recref->{username} = $1;
1127   } else {
1128     $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1129       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1130     $recref->{username} = $1;
1131   }
1132
1133   if ( $username_letterfirst ) {
1134     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1135   } elsif ( $username_letter ) {
1136     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1137   }
1138   if ( $username_noperiod ) {
1139     $recref->{username} =~ /\./ and return gettext('illegal_username');
1140   }
1141   if ( $username_nounderscore ) {
1142     $recref->{username} =~ /_/ and return gettext('illegal_username');
1143   }
1144   if ( $username_nodash ) {
1145     $recref->{username} =~ /\-/ and return gettext('illegal_username');
1146   }
1147   unless ( $username_ampersand ) {
1148     $recref->{username} =~ /\&/ and return gettext('illegal_username');
1149   }
1150   unless ( $username_percent ) {
1151     $recref->{username} =~ /\%/ and return gettext('illegal_username');
1152   }
1153   unless ( $username_colon ) {
1154     $recref->{username} =~ /\:/ and return gettext('illegal_username');
1155   }
1156
1157   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1158   $recref->{popnum} = $1;
1159   return "Unknown popnum" unless
1160     ! $recref->{popnum} ||
1161     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1162
1163   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1164
1165     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1166     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1167
1168     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1169     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1170     #not all systems use gid=uid
1171     #you can set a fixed gid in part_svc
1172
1173     return "Only root can have uid 0"
1174       if $recref->{uid} == 0
1175          && $recref->{username} !~ /^(root|toor|smtp)$/;
1176
1177     unless ( $recref->{username} eq 'sync' ) {
1178       if ( grep $_ eq $recref->{shell}, @shells ) {
1179         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1180       } else {
1181         return "Illegal shell \`". $self->shell. "\'; ".
1182                "shells configuration value contains: @shells";
1183       }
1184     } else {
1185       $recref->{shell} = '/bin/sync';
1186     }
1187
1188   } else {
1189     $recref->{gid} ne '' ?
1190       return "Can't have gid without uid" : ( $recref->{gid}='' );
1191     #$recref->{dir} ne '' ?
1192     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1193     $recref->{shell} ne '' ?
1194       return "Can't have shell without uid" : ( $recref->{shell}='' );
1195   }
1196
1197   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1198
1199     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1200       or return "Illegal directory: ". $recref->{dir};
1201     $recref->{dir} = $1;
1202     return "Illegal directory"
1203       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1204     return "Illegal directory"
1205       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1206     unless ( $recref->{dir} ) {
1207       $recref->{dir} = $dir_prefix . '/';
1208       if ( $dirhash > 0 ) {
1209         for my $h ( 1 .. $dirhash ) {
1210           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1211         }
1212       } elsif ( $dirhash < 0 ) {
1213         for my $h ( reverse $dirhash .. -1 ) {
1214           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1215         }
1216       }
1217       $recref->{dir} .= $recref->{username};
1218     ;
1219     }
1220
1221   }
1222
1223   #  $error = $self->ut_textn('finger');
1224   #  return $error if $error;
1225   if ( $self->getfield('finger') eq '' ) {
1226     my $cust_pkg = $self->svcnum
1227       ? $self->cust_svc->cust_pkg
1228       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1229     if ( $cust_pkg ) {
1230       my $cust_main = $cust_pkg->cust_main;
1231       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1232     }
1233   }
1234   $self->getfield('finger') =~
1235     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1236       or return "Illegal finger: ". $self->getfield('finger');
1237   $self->setfield('finger', $1);
1238
1239   for (qw( quota file_quota file_maxsize )) {
1240     $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1241     $recref->{$_} = $1;
1242   }
1243   $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1244   $recref->{file_maxnum} = $1;
1245
1246   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1247     if ( $recref->{slipip} eq '' ) {
1248       $recref->{slipip} = '';
1249     } elsif ( $recref->{slipip} eq '0e0' ) {
1250       $recref->{slipip} = '0e0';
1251     } else {
1252       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1253         or return "Illegal slipip: ". $self->slipip;
1254       $recref->{slipip} = $1;
1255     }
1256
1257   }
1258
1259   #arbitrary RADIUS stuff; allow ut_textn for now
1260   foreach ( grep /^radius_/, fields('svc_acct') ) {
1261     $self->ut_textn($_);
1262   }
1263
1264   # First, if _password is blank, generate one and set default encoding.
1265   if ( ! $recref->{_password} ) {
1266     $error = $self->set_password('');
1267   }
1268   # But if there's a _password but no encoding, assume it's plaintext and
1269   # set it to default encoding.
1270   elsif ( ! $recref->{_password_encoding} ) {
1271     $error = $self->set_password($recref->{_password});
1272   }
1273   return $error if $error;
1274
1275   # Next, check _password to ensure compliance with the encoding.
1276   if ( $recref->{_password_encoding} eq 'ldap' ) {
1277
1278     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1279       $recref->{_password} = uc($1).$2;
1280     } else {
1281       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1282     }
1283
1284   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1285
1286     if ( $recref->{_password} =~
1287            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1288            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1289        ) {
1290
1291       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1292
1293     } else {
1294       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1295     }
1296
1297   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1298     # Password randomization is now in set_password.
1299     # Strip whitespace characters, check length requirements, etc.
1300     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1301       $recref->{_password} = $1;
1302     } else {
1303       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1304              FS::Msgcat::_gettext('illegal_password_characters').
1305              ": ". $recref->{_password};
1306     }
1307
1308     if ( $password_noampersand ) {
1309       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1310     }
1311     if ( $password_noexclamation ) {
1312       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1313     }
1314   }
1315   else {
1316     return "invalid password encoding ('".$recref->{_password_encoding}."'";
1317   }
1318   $self->SUPER::check;
1319
1320 }
1321
1322
1323 sub _password_encryption {
1324   my $self = shift;
1325   my $encoding = lc($self->_password_encoding);
1326   return if !$encoding;
1327   return 'plain' if $encoding eq 'plain';
1328   if($encoding eq 'crypt') {
1329     my $pass = $self->_password;
1330     $pass =~ s/^\*SUSPENDED\* //;
1331     $pass =~ s/^!!?//;
1332     return 'md5' if $pass =~ /^\$1\$/;
1333     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1334     return 'des' if length($pass) == 13;
1335     return;
1336   }
1337   if($encoding eq 'ldap') {
1338     uc($self->_password) =~ /^\{([\w-]+)\}/;
1339     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1340     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1341     return 'md5' if $1 eq 'MD5';
1342     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1343
1344     return;
1345   }
1346   return;
1347 }
1348
1349 sub get_cleartext_password {
1350   my $self = shift;
1351   if($self->_password_encryption eq 'plain') {
1352     if($self->_password_encoding eq 'ldap') {
1353       $self->_password =~ /\{\w+\}(.*)$/;
1354       return $1;
1355     }
1356     else {
1357       return $self->_password;
1358     }
1359   }
1360   return;
1361 }
1362
1363
1364 =item set_password
1365
1366 Set the cleartext password for the account.  If _password_encoding is set, the
1367 new password will be encoded according to the existing method (including
1368 encryption mode, if it can be determined).  Otherwise,
1369 config('default-password-encoding') is used.
1370
1371 If no password is supplied (or a zero-length password when minimum password length
1372 is >0), one will be generated randomly.
1373
1374 =cut
1375
1376 sub set_password {
1377   my( $self, $pass ) = ( shift, shift );
1378
1379   warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1380      if $DEBUG;
1381
1382   my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1383                 FS::Msgcat::_gettext('illegal_password_characters').
1384                 ": ". $pass;
1385
1386   my( $encoding, $encryption ) = ('', '');
1387
1388   if ( $self->_password_encoding ) {
1389     $encoding = $self->_password_encoding;
1390     # identify existing encryption method, try to use it.
1391     $encryption = $self->_password_encryption;
1392     if (!$encryption) {
1393       # use the system default
1394       undef $encoding;
1395     }
1396   }
1397
1398   if ( !$encoding ) {
1399     # set encoding to system default
1400     ($encoding, $encryption) =
1401       split(/-/, lc($conf->config('default-password-encoding')));
1402     $encoding ||= 'legacy';
1403     $self->_password_encoding($encoding);
1404   }
1405
1406   if ( $encoding eq 'legacy' ) {
1407
1408     # The legacy behavior from check():
1409     # If the password is blank, randomize it and set encoding to 'plain'.
1410     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1411       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1412       $self->_password_encoding('plain');
1413     } else {
1414       # Prefix + valid-length password
1415       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1416         $pass = $1.$3;
1417         $self->_password_encoding('plain');
1418       # Prefix + crypt string
1419       } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1420         $pass = $1.$3;
1421         $self->_password_encoding('crypt');
1422       # Various disabled crypt passwords
1423       } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1424         $self->_password_encoding('crypt');
1425       } else {
1426         return $failure;
1427       }
1428     }
1429
1430     $self->_password($pass);
1431     return;
1432
1433   }
1434
1435   return $failure
1436     if $passwordmin && length($pass) < $passwordmin
1437     or $passwordmax && length($pass) > $passwordmax;
1438
1439   if ( $encoding eq 'crypt' ) {
1440     if ($encryption eq 'md5') {
1441       $pass = unix_md5_crypt($pass);
1442     } elsif ($encryption eq 'des') {
1443       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1444     }
1445
1446   } elsif ( $encoding eq 'ldap' ) {
1447     if ($encryption eq 'md5') {
1448       $pass = md5_base64($pass);
1449     } elsif ($encryption eq 'sha1') {
1450       $pass = sha1_base64($pass);
1451     } elsif ($encryption eq 'crypt') {
1452       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1453     }
1454     # else $encryption eq 'plain', do nothing
1455     $pass = '{'.uc($encryption).'}'.$pass;
1456   }
1457   # else encoding eq 'plain'
1458
1459   $self->_password($pass);
1460   return;
1461 }
1462
1463 =item _check_system
1464
1465 Internal function to check the username against the list of system usernames
1466 from the I<system_usernames> configuration value.  Returns true if the username
1467 is listed on the system username list.
1468
1469 =cut
1470
1471 sub _check_system {
1472   my $self = shift;
1473   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1474                $conf->config('system_usernames')
1475         );
1476 }
1477
1478 =item _check_duplicate
1479
1480 Internal method to check for duplicates usernames, username@domain pairs and
1481 uids.
1482
1483 If the I<global_unique-username> configuration value is set to B<username> or
1484 B<username@domain>, enforces global username or username@domain uniqueness.
1485
1486 In all cases, check for duplicate uids and usernames or username@domain pairs
1487 per export and with identical I<svcpart> values.
1488
1489 =cut
1490
1491 sub _check_duplicate {
1492   my $self = shift;
1493
1494   my $global_unique = $conf->config('global_unique-username') || 'none';
1495   return '' if $global_unique eq 'disabled';
1496
1497   $self->lock_table;
1498
1499   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1500   unless ( $part_svc ) {
1501     return 'unknown svcpart '. $self->svcpart;
1502   }
1503
1504   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1505                  qsearch( 'svc_acct', { 'username' => $self->username } );
1506   return gettext('username_in_use')
1507     if $global_unique eq 'username' && @dup_user;
1508
1509   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1510                        qsearch( 'svc_acct', { 'username' => $self->username,
1511                                               'domsvc'   => $self->domsvc } );
1512   return gettext('username_in_use')
1513     if $global_unique eq 'username@domain' && @dup_userdomain;
1514
1515   my @dup_uid;
1516   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1517        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1518     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1519                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1520   } else {
1521     @dup_uid = ();
1522   }
1523
1524   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1525     my $exports = FS::part_export::export_info('svc_acct');
1526     my %conflict_user_svcpart;
1527     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1528
1529     foreach my $part_export ( $part_svc->part_export ) {
1530
1531       #this will catch to the same exact export
1532       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1533
1534       #this will catch to exports w/same exporthost+type ???
1535       #my @other_part_export = qsearch('part_export', {
1536       #  'machine'    => $part_export->machine,
1537       #  'exporttype' => $part_export->exporttype,
1538       #} );
1539       #foreach my $other_part_export ( @other_part_export ) {
1540       #  push @svcparts, map { $_->svcpart }
1541       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1542       #}
1543
1544       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1545       #silly kludge to avoid uninitialized value errors
1546       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1547                      ? $exports->{$part_export->exporttype}{'nodomain'}
1548                      : '';
1549       if ( $nodomain =~ /^Y/i ) {
1550         $conflict_user_svcpart{$_} = $part_export->exportnum
1551           foreach @svcparts;
1552       } else {
1553         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1554           foreach @svcparts;
1555       }
1556     }
1557
1558     foreach my $dup_user ( @dup_user ) {
1559       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1560       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1561         return "duplicate username ". $self->username.
1562                ": conflicts with svcnum ". $dup_user->svcnum.
1563                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1564       }
1565     }
1566
1567     foreach my $dup_userdomain ( @dup_userdomain ) {
1568       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1569       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1570         return "duplicate username\@domain ". $self->email.
1571                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1572                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1573       }
1574     }
1575
1576     foreach my $dup_uid ( @dup_uid ) {
1577       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1578       if ( exists($conflict_user_svcpart{$dup_svcpart})
1579            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1580         return "duplicate uid ". $self->uid.
1581                ": conflicts with svcnum ". $dup_uid->svcnum.
1582                " via exportnum ".
1583                ( $conflict_user_svcpart{$dup_svcpart}
1584                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1585       }
1586     }
1587
1588   }
1589
1590   return '';
1591
1592 }
1593
1594 =item radius
1595
1596 Depriciated, use radius_reply instead.
1597
1598 =cut
1599
1600 sub radius {
1601   carp "FS::svc_acct::radius depriciated, use radius_reply";
1602   $_[0]->radius_reply;
1603 }
1604
1605 =item radius_reply
1606
1607 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1608 reply attributes of this record.
1609
1610 Note that this is now the preferred method for reading RADIUS attributes -
1611 accessing the columns directly is discouraged, as the column names are
1612 expected to change in the future.
1613
1614 =cut
1615
1616 sub radius_reply {
1617   my $self = shift;
1618
1619   return %{ $self->{'radius_reply'} }
1620     if exists $self->{'radius_reply'};
1621
1622   my %reply =
1623     map {
1624       /^(radius_(.*))$/;
1625       my($column, $attrib) = ($1, $2);
1626       #$attrib =~ s/_/\-/g;
1627       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1628     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1629
1630   if ( $self->slipip && $self->slipip ne '0e0' ) {
1631     $reply{$radius_ip} = $self->slipip;
1632   }
1633
1634   if ( $self->seconds !~ /^$/ ) {
1635     $reply{'Session-Timeout'} = $self->seconds;
1636   }
1637
1638   if ( $conf->exists('radius-chillispot-max') ) {
1639     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1640
1641     #hmm.  just because sqlradius.pm says so?
1642     my %whatis = (
1643       'input'  => 'up',
1644       'output' => 'down',
1645       'total'  => 'total',
1646     );
1647
1648     foreach my $what (qw( input output total )) {
1649       my $is = $whatis{$what}.'bytes';
1650       if ( $self->$is() =~ /\d/ ) {
1651         my $big = new Math::BigInt $self->$is();
1652         $big = new Math::BigInt '0' if $big->is_neg();
1653         my $att = "Chillispot-Max-\u$what";
1654         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1655         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1656       }
1657     }
1658
1659   }
1660
1661   %reply;
1662 }
1663
1664 =item radius_check
1665
1666 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1667 check attributes of this record.
1668
1669 Note that this is now the preferred method for reading RADIUS attributes -
1670 accessing the columns directly is discouraged, as the column names are
1671 expected to change in the future.
1672
1673 =cut
1674
1675 sub radius_check {
1676   my $self = shift;
1677
1678   return %{ $self->{'radius_check'} }
1679     if exists $self->{'radius_check'};
1680
1681   my %check =
1682     map {
1683       /^(rc_(.*))$/;
1684       my($column, $attrib) = ($1, $2);
1685       #$attrib =~ s/_/\-/g;
1686       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1687     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1688
1689
1690   my($pw_attrib, $password) = $self->radius_password;
1691   $check{$pw_attrib} = $password;
1692
1693   my $cust_svc = $self->cust_svc;
1694   if ( $cust_svc ) {
1695     my $cust_pkg = $cust_svc->cust_pkg;
1696     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1697       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1698     }
1699   } else {
1700     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1701          "; can't set Expiration\n"
1702       unless $cust_svc;
1703   }
1704
1705   %check;
1706
1707 }
1708
1709 =item radius_password
1710
1711 Returns a key/value pair containing the RADIUS attribute name and value
1712 for the password.
1713
1714 =cut
1715
1716 sub radius_password {
1717   my $self = shift;
1718
1719   my $pw_attrib;
1720   if ( $self->_password_encoding eq 'ldap' ) {
1721     $pw_attrib = 'Password-With-Header';
1722   } elsif ( $self->_password_encoding eq 'crypt' ) {
1723     $pw_attrib = 'Crypt-Password';
1724   } elsif ( $self->_password_encoding eq 'plain' ) {
1725     $pw_attrib = $radius_password;
1726   } else {
1727     $pw_attrib = length($self->_password) <= 12
1728                    ? $radius_password
1729                    : 'Crypt-Password';
1730   }
1731
1732   ($pw_attrib, $self->_password);
1733
1734 }
1735
1736 =item snapshot
1737
1738 This method instructs the object to "snapshot" or freeze RADIUS check and
1739 reply attributes to the current values.
1740
1741 =cut
1742
1743 #bah, my english is too broken this morning
1744 #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
1745 #the FS::cust_pkg's replace method to trigger the correct export updates when
1746 #package dates change)
1747
1748 sub snapshot {
1749   my $self = shift;
1750
1751   $self->{$_} = { $self->$_() }
1752     foreach qw( radius_reply radius_check );
1753
1754 }
1755
1756 =item forget_snapshot
1757
1758 This methos instructs the object to forget any previously snapshotted
1759 RADIUS check and reply attributes.
1760
1761 =cut
1762
1763 sub forget_snapshot {
1764   my $self = shift;
1765
1766   delete $self->{$_}
1767     foreach qw( radius_reply radius_check );
1768
1769 }
1770
1771 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1772
1773 Returns the domain associated with this account.
1774
1775 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1776 history records.
1777
1778 =cut
1779
1780 sub domain {
1781   my $self = shift;
1782   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1783   my $svc_domain = $self->svc_domain(@_)
1784     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1785   $svc_domain->domain;
1786 }
1787
1788 =item svc_domain
1789
1790 Returns the FS::svc_domain record for this account's domain (see
1791 L<FS::svc_domain>).
1792
1793 =cut
1794
1795 # FS::h_svc_acct has a history-aware svc_domain override
1796
1797 sub svc_domain {
1798   my $self = shift;
1799   $self->{'_domsvc'}
1800     ? $self->{'_domsvc'}
1801     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
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 =item domain_select_hash %OPTIONS
3126
3127 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
3128 may at present purchase.
3129
3130 Currently available options are: I<pkgnum> I<svcpart>
3131
3132 =cut
3133
3134 sub domain_select_hash {
3135   my ($self, %options) = @_;
3136   my %domains = ();
3137   my $part_svc;
3138   my $cust_pkg;
3139
3140   if (ref($self)) {
3141     $part_svc = $self->part_svc;
3142     $cust_pkg = $self->cust_svc->cust_pkg
3143       if $self->cust_svc;
3144   }
3145
3146   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
3147     if $options{'svcpart'};
3148
3149   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
3150     if $options{'pkgnum'};
3151
3152   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
3153                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
3154     %domains = map { $_->svcnum => $_->domain }
3155                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
3156                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
3157   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
3158     %domains = map { $_->svcnum => $_->domain }
3159                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
3160                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
3161                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
3162   }else{
3163     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
3164   }
3165
3166   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
3167     my $svc_domain = qsearchs('svc_domain',
3168       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
3169     if ( $svc_domain ) {
3170       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
3171     }else{
3172       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
3173            $part_svc->part_svc_column('domsvc')->columnvalue;
3174
3175     }
3176   }
3177
3178   (%domains);
3179 }
3180
3181 1;
3182