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