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         my $att = "Chillispot-Max-\u$what";
1412         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1413         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1414       }
1415     }
1416
1417   }
1418
1419   %reply;
1420 }
1421
1422 =item radius_check
1423
1424 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1425 check attributes of this record.
1426
1427 Note that this is now the preferred method for reading RADIUS attributes -
1428 accessing the columns directly is discouraged, as the column names are
1429 expected to change in the future.
1430
1431 =cut
1432
1433 sub radius_check {
1434   my $self = shift;
1435
1436   return %{ $self->{'radius_check'} }
1437     if exists $self->{'radius_check'};
1438
1439   my %check =
1440     map {
1441       /^(rc_(.*))$/;
1442       my($column, $attrib) = ($1, $2);
1443       #$attrib =~ s/_/\-/g;
1444       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1445     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1446
1447   my $password = $self->_password;
1448   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1449
1450   my $cust_svc = $self->cust_svc;
1451   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1452     unless $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
1458   %check;
1459
1460 }
1461
1462 =item snapshot
1463
1464 This method instructs the object to "snapshot" or freeze RADIUS check and
1465 reply attributes to the current values.
1466
1467 =cut
1468
1469 #bah, my english is too broken this morning
1470 #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
1471 #the FS::cust_pkg's replace method to trigger the correct export updates when
1472 #package dates change)
1473
1474 sub snapshot {
1475   my $self = shift;
1476
1477   $self->{$_} = { $self->$_() }
1478     foreach qw( radius_reply radius_check );
1479
1480 }
1481
1482 =item forget_snapshot
1483
1484 This methos instructs the object to forget any previously snapshotted
1485 RADIUS check and reply attributes.
1486
1487 =cut
1488
1489 sub forget_snapshot {
1490   my $self = shift;
1491
1492   delete $self->{$_}
1493     foreach qw( radius_reply radius_check );
1494
1495 }
1496
1497 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1498
1499 Returns the domain associated with this account.
1500
1501 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1502 history records.
1503
1504 =cut
1505
1506 sub domain {
1507   my $self = shift;
1508   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1509   my $svc_domain = $self->svc_domain(@_)
1510     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1511   $svc_domain->domain;
1512 }
1513
1514 =item svc_domain
1515
1516 Returns the FS::svc_domain record for this account's domain (see
1517 L<FS::svc_domain>).
1518
1519 =cut
1520
1521 # FS::h_svc_acct has a history-aware svc_domain override
1522
1523 sub svc_domain {
1524   my $self = shift;
1525   $self->{'_domsvc'}
1526     ? $self->{'_domsvc'}
1527     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1528 }
1529
1530 =item cust_svc
1531
1532 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1533
1534 =cut
1535
1536 #inherited from svc_Common
1537
1538 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1539
1540 Returns an email address associated with the account.
1541
1542 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1543 history records.
1544
1545 =cut
1546
1547 sub email {
1548   my $self = shift;
1549   $self->username. '@'. $self->domain(@_);
1550 }
1551
1552 =item acct_snarf
1553
1554 Returns an array of FS::acct_snarf records associated with the account.
1555 If the acct_snarf table does not exist or there are no associated records,
1556 an empty list is returned
1557
1558 =cut
1559
1560 sub acct_snarf {
1561   my $self = shift;
1562   return () unless dbdef->table('acct_snarf');
1563   eval "use FS::acct_snarf;";
1564   die $@ if $@;
1565   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1566 }
1567
1568 =item decrement_upbytes OCTETS
1569
1570 Decrements the I<upbytes> field of this record by the given amount.  If there
1571 is an error, returns the error, otherwise returns false.
1572
1573 =cut
1574
1575 sub decrement_upbytes {
1576   shift->_op_usage('-', 'upbytes', @_);
1577 }
1578
1579 =item increment_upbytes OCTETS
1580
1581 Increments the I<upbytes> field of this record by the given amount.  If there
1582 is an error, returns the error, otherwise returns false.
1583
1584 =cut
1585
1586 sub increment_upbytes {
1587   shift->_op_usage('+', 'upbytes', @_);
1588 }
1589
1590 =item decrement_downbytes OCTETS
1591
1592 Decrements the I<downbytes> field of this record by the given amount.  If there
1593 is an error, returns the error, otherwise returns false.
1594
1595 =cut
1596
1597 sub decrement_downbytes {
1598   shift->_op_usage('-', 'downbytes', @_);
1599 }
1600
1601 =item increment_downbytes OCTETS
1602
1603 Increments the I<downbytes> field of this record by the given amount.  If there
1604 is an error, returns the error, otherwise returns false.
1605
1606 =cut
1607
1608 sub increment_downbytes {
1609   shift->_op_usage('+', 'downbytes', @_);
1610 }
1611
1612 =item decrement_totalbytes OCTETS
1613
1614 Decrements the I<totalbytes> field of this record by the given amount.  If there
1615 is an error, returns the error, otherwise returns false.
1616
1617 =cut
1618
1619 sub decrement_totalbytes {
1620   shift->_op_usage('-', 'totalbytes', @_);
1621 }
1622
1623 =item increment_totalbytes OCTETS
1624
1625 Increments the I<totalbytes> field of this record by the given amount.  If there
1626 is an error, returns the error, otherwise returns false.
1627
1628 =cut
1629
1630 sub increment_totalbytes {
1631   shift->_op_usage('+', 'totalbytes', @_);
1632 }
1633
1634 =item decrement_seconds SECONDS
1635
1636 Decrements the I<seconds> field of this record by the given amount.  If there
1637 is an error, returns the error, otherwise returns false.
1638
1639 =cut
1640
1641 sub decrement_seconds {
1642   shift->_op_usage('-', 'seconds', @_);
1643 }
1644
1645 =item increment_seconds SECONDS
1646
1647 Increments the I<seconds> field of this record by the given amount.  If there
1648 is an error, returns the error, otherwise returns false.
1649
1650 =cut
1651
1652 sub increment_seconds {
1653   shift->_op_usage('+', 'seconds', @_);
1654 }
1655
1656
1657 my %op2action = (
1658   '-' => 'suspend',
1659   '+' => 'unsuspend',
1660 );
1661 my %op2condition = (
1662   '-' => sub { my($self, $column, $amount) = @_;
1663                $self->$column - $amount <= 0;
1664              },
1665   '+' => sub { my($self, $column, $amount) = @_;
1666                ($self->$column || 0) + $amount > 0;
1667              },
1668 );
1669 my %op2warncondition = (
1670   '-' => sub { my($self, $column, $amount) = @_;
1671                my $threshold = $column . '_threshold';
1672                $self->$column - $amount <= $self->$threshold + 0;
1673              },
1674   '+' => sub { my($self, $column, $amount) = @_;
1675                ($self->$column || 0) + $amount > 0;
1676              },
1677 );
1678
1679 sub _op_usage {
1680   my( $self, $op, $column, $amount ) = @_;
1681
1682   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1683        ' ('. $self->email. "): $op $amount\n"
1684     if $DEBUG;
1685
1686   return '' unless $amount;
1687
1688   local $SIG{HUP} = 'IGNORE';
1689   local $SIG{INT} = 'IGNORE';
1690   local $SIG{QUIT} = 'IGNORE';
1691   local $SIG{TERM} = 'IGNORE';
1692   local $SIG{TSTP} = 'IGNORE';
1693   local $SIG{PIPE} = 'IGNORE';
1694
1695   my $oldAutoCommit = $FS::UID::AutoCommit;
1696   local $FS::UID::AutoCommit = 0;
1697   my $dbh = dbh;
1698
1699   my $sql = "UPDATE svc_acct SET $column = ".
1700             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1701             " $op ? WHERE svcnum = ?";
1702   warn "$me $sql\n"
1703     if $DEBUG;
1704
1705   my $sth = $dbh->prepare( $sql )
1706     or die "Error preparing $sql: ". $dbh->errstr;
1707   my $rv = $sth->execute($amount, $self->svcnum);
1708   die "Error executing $sql: ". $sth->errstr
1709     unless defined($rv);
1710   die "Can't update $column for svcnum". $self->svcnum
1711     if $rv == 0;
1712
1713   #$self->snapshot; #not necessary, we retain the old values
1714   #create an object with the updated usage values
1715   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1716   #call exports
1717   my $error = $new->replace($self);
1718   if ( $error ) {
1719     $dbh->rollback if $oldAutoCommit;
1720     return "Error replacing: $error";
1721   }
1722
1723   #overlimit_action eq 'cancel' handling
1724   my $cust_pkg = $self->cust_svc->cust_pkg;
1725   if ( $cust_pkg
1726        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1727        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1728      )
1729   {
1730
1731     my $error = $cust_pkg->cancel; #XXX should have a reason
1732     if ( $error ) {
1733       $dbh->rollback if $oldAutoCommit;
1734       return "Error cancelling: $error";
1735     }
1736
1737     #nothing else is relevant if we're cancelling, so commit & return success
1738     warn "$me update successful; committing\n"
1739       if $DEBUG;
1740     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1741     return '';
1742
1743   }
1744
1745   my $action = $op2action{$op};
1746
1747   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1748         ( $action eq 'suspend'   && !$self->overlimit
1749        || $action eq 'unsuspend' &&  $self->overlimit )
1750      ) {
1751     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1752       if ($part_export->option('overlimit_groups')) {
1753         my ($new,$old);
1754         my $other = new FS::svc_acct $self->hashref;
1755         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1756                        ($self, $part_export->option('overlimit_groups'));
1757         $other->usergroup( $groups );
1758         if ($action eq 'suspend'){
1759           $new = $other; $old = $self;
1760         }else{
1761           $new = $self; $old = $other;
1762         }
1763         my $error = $part_export->export_replace($new, $old);
1764         $error ||= $self->overlimit($action);
1765         if ( $error ) {
1766           $dbh->rollback if $oldAutoCommit;
1767           return "Error replacing radius groups in export, ${op}: $error";
1768         }
1769       }
1770     }
1771   }
1772
1773   if ( $conf->exists("svc_acct-usage_$action")
1774        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1775     #my $error = $self->$action();
1776     my $error = $self->cust_svc->cust_pkg->$action();
1777     # $error ||= $self->overlimit($action);
1778     if ( $error ) {
1779       $dbh->rollback if $oldAutoCommit;
1780       return "Error ${action}ing: $error";
1781     }
1782   }
1783
1784   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1785     my $wqueue = new FS::queue {
1786       'svcnum' => $self->svcnum,
1787       'job'    => 'FS::svc_acct::reached_threshold',
1788     };
1789
1790     my $to = '';
1791     if ($op eq '-'){
1792       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1793     }
1794
1795     # x_threshold race
1796     my $error = $wqueue->insert(
1797       'svcnum' => $self->svcnum,
1798       'op'     => $op,
1799       'column' => $column,
1800       'to'     => $to,
1801     );
1802     if ( $error ) {
1803       $dbh->rollback if $oldAutoCommit;
1804       return "Error queuing threshold activity: $error";
1805     }
1806   }
1807
1808   warn "$me update successful; committing\n"
1809     if $DEBUG;
1810   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1811   '';
1812
1813 }
1814
1815 sub set_usage {
1816   my( $self, $valueref, %options ) = @_;
1817
1818   warn "$me set_usage called for svcnum ". $self->svcnum.
1819        ' ('. $self->email. "): ".
1820        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1821     if $DEBUG;
1822
1823   local $SIG{HUP} = 'IGNORE';
1824   local $SIG{INT} = 'IGNORE';
1825   local $SIG{QUIT} = 'IGNORE';
1826   local $SIG{TERM} = 'IGNORE';
1827   local $SIG{TSTP} = 'IGNORE';
1828   local $SIG{PIPE} = 'IGNORE';
1829
1830   local $FS::svc_Common::noexport_hack = 1;
1831   my $oldAutoCommit = $FS::UID::AutoCommit;
1832   local $FS::UID::AutoCommit = 0;
1833   my $dbh = dbh;
1834
1835   my $reset = 0;
1836   my %handyhash = ();
1837   if ( $options{null} ) {
1838     %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1839                    qw( seconds upbytes downbytes totalbytes )
1840                  );
1841   }
1842   foreach my $field (keys %$valueref){
1843     $reset = 1 if $valueref->{$field};
1844     $self->setfield($field, $valueref->{$field});
1845     $self->setfield( $field.'_threshold',
1846                      int($self->getfield($field)
1847                          * ( $conf->exists('svc_acct-usage_threshold')
1848                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1849                              : 0.20
1850                            )
1851                        )
1852                      );
1853     $handyhash{$field} = $self->getfield($field);
1854     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1855   }
1856   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1857   #die $error if $error;         #services not explicity changed via the UI
1858
1859   my $sql = "UPDATE svc_acct SET " .
1860     join (',', map { "$_ =  $handyhash{$_}" } (keys %handyhash) ).
1861     " WHERE svcnum = ". $self->svcnum;
1862
1863   warn "$me $sql\n"
1864     if $DEBUG;
1865
1866   if (scalar(keys %handyhash)) {
1867     my $sth = $dbh->prepare( $sql )
1868       or die "Error preparing $sql: ". $dbh->errstr;
1869     my $rv = $sth->execute();
1870     die "Error executing $sql: ". $sth->errstr
1871       unless defined($rv);
1872     die "Can't update usage for svcnum ". $self->svcnum
1873       if $rv == 0;
1874   }
1875
1876   #$self->snapshot; #not necessary, we retain the old values
1877   #create an object with the updated usage values
1878   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1879   #call exports
1880   my $error = $new->replace($self);
1881   if ( $error ) {
1882     $dbh->rollback if $oldAutoCommit;
1883     return "Error replacing: $error";
1884   }
1885
1886   if ( $reset ) {
1887     my $error;
1888
1889     if ($self->overlimit) {
1890       $error = $self->overlimit('unsuspend');
1891       foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1892         if ($part_export->option('overlimit_groups')) {
1893           my $old = new FS::svc_acct $self->hashref;
1894           my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1895                          ($self, $part_export->option('overlimit_groups'));
1896           $old->usergroup( $groups );
1897           $error ||= $part_export->export_replace($self, $old);
1898         }
1899       }
1900     }
1901
1902     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1903       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1904     }
1905     if ( $error ) {
1906       $dbh->rollback if $oldAutoCommit;
1907       return "Error unsuspending: $error";
1908     }
1909   }
1910
1911   warn "$me update successful; committing\n"
1912     if $DEBUG;
1913   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1914   '';
1915
1916 }
1917
1918
1919 =item recharge HASHREF
1920
1921   Increments usage columns by the amount specified in HASHREF as
1922   column=>amount pairs.
1923
1924 =cut
1925
1926 sub recharge {
1927   my ($self, $vhash) = @_;
1928
1929   if ( $DEBUG ) {
1930     warn "[$me] recharge called on $self: ". Dumper($self).
1931          "\nwith vhash: ". Dumper($vhash);
1932   }
1933
1934   my $oldAutoCommit = $FS::UID::AutoCommit;
1935   local $FS::UID::AutoCommit = 0;
1936   my $dbh = dbh;
1937   my $error = '';
1938
1939   foreach my $column (keys %$vhash){
1940     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1941   }
1942
1943   if ( $error ) {
1944     $dbh->rollback if $oldAutoCommit;
1945   }else{
1946     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1947   }
1948   return $error;
1949 }
1950
1951 =item is_rechargeable
1952
1953 Returns true if this svc_account can be "recharged" and false otherwise.
1954
1955 =cut
1956
1957 sub is_rechargable {
1958   my $self = shift;
1959   $self->seconds ne ''
1960     || $self->upbytes ne ''
1961     || $self->downbytes ne ''
1962     || $self->totalbytes ne '';
1963 }
1964
1965 =item seconds_since TIMESTAMP
1966
1967 Returns the number of seconds this account has been online since TIMESTAMP,
1968 according to the session monitor (see L<FS::Session>).
1969
1970 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1971 L<Time::Local> and L<Date::Parse> for conversion functions.
1972
1973 =cut
1974
1975 #note: POD here, implementation in FS::cust_svc
1976 sub seconds_since {
1977   my $self = shift;
1978   $self->cust_svc->seconds_since(@_);
1979 }
1980
1981 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1982
1983 Returns the numbers of seconds this account has been online between
1984 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1985 external SQL radacct table, specified via sqlradius export.  Sessions which
1986 started in the specified range but are still open are counted from session
1987 start to the end of the range (unless they are over 1 day old, in which case
1988 they are presumed missing their stop record and not counted).  Also, sessions
1989 which end in the range but started earlier are counted from the start of the
1990 range to session end.  Finally, sessions which start before the range but end
1991 after are counted for the entire range.
1992
1993 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1994 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1995 functions.
1996
1997 =cut
1998
1999 #note: POD here, implementation in FS::cust_svc
2000 sub seconds_since_sqlradacct {
2001   my $self = shift;
2002   $self->cust_svc->seconds_since_sqlradacct(@_);
2003 }
2004
2005 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2006
2007 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2008 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2009 TIMESTAMP_END (exclusive).
2010
2011 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2012 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2013 functions.
2014
2015 =cut
2016
2017 #note: POD here, implementation in FS::cust_svc
2018 sub attribute_since_sqlradacct {
2019   my $self = shift;
2020   $self->cust_svc->attribute_since_sqlradacct(@_);
2021 }
2022
2023 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2024
2025 Returns an array of hash references of this customers login history for the
2026 given time range.  (document this better)
2027
2028 =cut
2029
2030 sub get_session_history {
2031   my $self = shift;
2032   $self->cust_svc->get_session_history(@_);
2033 }
2034
2035 =item last_login_text
2036
2037 Returns text describing the time of last login.
2038
2039 =cut
2040
2041 sub last_login_text {
2042   my $self = shift;
2043   $self->last_login ? ctime($self->last_login) : 'unknown';
2044 }
2045
2046 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2047
2048 =cut
2049
2050 sub get_cdrs {
2051   my($self, $start, $end, %opt ) = @_;
2052
2053   my $did = $self->username; #yup
2054
2055   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2056
2057   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2058
2059   #SELECT $for_update * FROM cdr
2060   #  WHERE calldate >= $start #need a conversion
2061   #    AND calldate <  $end   #ditto
2062   #    AND (    charged_party = "$did"
2063   #          OR charged_party = "$prefix$did" #if length($prefix);
2064   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2065   #               AND
2066   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2067   #             )
2068   #        )
2069   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2070
2071   my $charged_or_src;
2072   if ( length($prefix) ) {
2073     $charged_or_src =
2074       " AND (    charged_party = '$did'
2075               OR charged_party = '$prefix$did'
2076               OR ( ( charged_party IS NULL OR charged_party = '' )
2077                    AND
2078                    ( src = '$did' OR src = '$prefix$did' )
2079                  )
2080             )
2081       ";
2082   } else {
2083     $charged_or_src =
2084       " AND (    charged_party = '$did'
2085               OR ( ( charged_party IS NULL OR charged_party = '' )
2086                    AND
2087                    src = '$did'
2088                  )
2089             )
2090       ";
2091
2092   }
2093
2094   qsearch(
2095     'select'    => "$for_update *",
2096     'table'     => 'cdr',
2097     'hashref'   => {
2098                      #( freesidestatus IS NULL OR freesidestatus = '' )
2099                      'freesidestatus' => '',
2100                    },
2101     'extra_sql' => $charged_or_src,
2102
2103   );
2104
2105 }
2106
2107 =item radius_groups
2108
2109 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2110
2111 =cut
2112
2113 sub radius_groups {
2114   my $self = shift;
2115   if ( $self->usergroup ) {
2116     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2117       unless ref($self->usergroup) eq 'ARRAY';
2118     #when provisioning records, export callback runs in svc_Common.pm before
2119     #radius_usergroup records can be inserted...
2120     @{$self->usergroup};
2121   } else {
2122     map { $_->groupname }
2123       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2124   }
2125 }
2126
2127 =item clone_suspended
2128
2129 Constructor used by FS::part_export::_export_suspend fallback.  Document
2130 better.
2131
2132 =cut
2133
2134 sub clone_suspended {
2135   my $self = shift;
2136   my %hash = $self->hash;
2137   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2138   new FS::svc_acct \%hash;
2139 }
2140
2141 =item clone_kludge_unsuspend
2142
2143 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2144 better.
2145
2146 =cut
2147
2148 sub clone_kludge_unsuspend {
2149   my $self = shift;
2150   my %hash = $self->hash;
2151   $hash{_password} = '';
2152   new FS::svc_acct \%hash;
2153 }
2154
2155 =item check_password
2156
2157 Checks the supplied password against the (possibly encrypted) password in the
2158 database.  Returns true for a successful authentication, false for no match.
2159
2160 Currently supported encryptions are: classic DES crypt() and MD5
2161
2162 =cut
2163
2164 sub check_password {
2165   my($self, $check_password) = @_;
2166
2167   #remove old-style SUSPENDED kludge, they should be allowed to login to
2168   #self-service and pay up
2169   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2170
2171   #eventually should check a "password-encoding" field
2172   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2173     return 0;
2174   } elsif ( length($password) < 13 ) { #plaintext
2175     $check_password eq $password;
2176   } elsif ( length($password) == 13 ) { #traditional DES crypt
2177     crypt($check_password, $password) eq $password;
2178   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2179     unix_md5_crypt($check_password, $password) eq $password;
2180   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2181     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
2182          $self->svcnum. "\n";
2183     0;
2184   } else {
2185     warn "Can't check password: Unrecognized encryption for svcnum ".
2186          $self->svcnum. "\n";
2187     0;
2188   }
2189
2190 }
2191
2192 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2193
2194 Returns an encrypted password, either by passing through an encrypted password
2195 in the database or by encrypting a plaintext password from the database.
2196
2197 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2198 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2199 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2200 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2201 encryption type is only used if the password is not already encrypted in the
2202 database.
2203
2204 =cut
2205
2206 sub crypt_password {
2207   my $self = shift;
2208   #eventually should check a "password-encoding" field
2209   if ( length($self->_password) == 13
2210        || $self->_password =~ /^\$(1|2a?)\$/
2211        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2212      )
2213   {
2214     $self->_password;
2215   } else {
2216     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2217     if ( $encryption eq 'crypt' ) {
2218       crypt(
2219         $self->_password,
2220         $saltset[int(rand(64))].$saltset[int(rand(64))]
2221       );
2222     } elsif ( $encryption eq 'md5' ) {
2223       unix_md5_crypt( $self->_password );
2224     } elsif ( $encryption eq 'blowfish' ) {
2225       croak "unknown encryption method $encryption";
2226     } else {
2227       croak "unknown encryption method $encryption";
2228     }
2229   }
2230 }
2231
2232 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2233
2234 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2235 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
2236 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
2237
2238 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2239 to work the same as the B</crypt_password> method.
2240
2241 =cut
2242
2243 sub ldap_password {
2244   my $self = shift;
2245   #eventually should check a "password-encoding" field
2246   if ( length($self->_password) == 13 ) { #crypt
2247     return '{CRYPT}'. $self->_password;
2248   } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2249     return '{MD5}'. $1;
2250   } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2251     warn "Blowfish encryption not supported in this context, svcnum ".
2252          $self->svcnum. "\n";
2253     return '{CRYPT}*'; #unsupported, should not auth
2254   } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2255     return '{SSHA}'. $1;
2256   } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2257     return '{NS-MTA-MD5}'. $1;
2258   } else { #plaintext
2259     return '{PLAIN}'. $self->_password;
2260     #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2261     #if ( $encryption eq 'crypt' ) {
2262     #  return '{CRYPT}'. crypt(
2263     #    $self->_password,
2264     #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2265     #  );
2266     #} elsif ( $encryption eq 'md5' ) {
2267     #  unix_md5_crypt( $self->_password );
2268     #} elsif ( $encryption eq 'blowfish' ) {
2269     #  croak "unknown encryption method $encryption";
2270     #} else {
2271     #  croak "unknown encryption method $encryption";
2272     #}
2273   }
2274 }
2275
2276 =item domain_slash_username
2277
2278 Returns $domain/$username/
2279
2280 =cut
2281
2282 sub domain_slash_username {
2283   my $self = shift;
2284   $self->domain. '/'. $self->username. '/';
2285 }
2286
2287 =item virtual_maildir
2288
2289 Returns $domain/maildirs/$username/
2290
2291 =cut
2292
2293 sub virtual_maildir {
2294   my $self = shift;
2295   $self->domain. '/maildirs/'. $self->username. '/';
2296 }
2297
2298 =back
2299
2300 =head1 SUBROUTINES
2301
2302 =over 4
2303
2304 =item send_email
2305
2306 This is the FS::svc_acct job-queue-able version.  It still uses
2307 FS::Misc::send_email under-the-hood.
2308
2309 =cut
2310
2311 sub send_email {
2312   my %opt = @_;
2313
2314   eval "use FS::Misc qw(send_email)";
2315   die $@ if $@;
2316
2317   $opt{mimetype} ||= 'text/plain';
2318   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2319
2320   my $error = send_email(
2321     'from'         => $opt{from},
2322     'to'           => $opt{to},
2323     'subject'      => $opt{subject},
2324     'content-type' => $opt{mimetype},
2325     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2326   );
2327   die $error if $error;
2328 }
2329
2330 =item check_and_rebuild_fuzzyfiles
2331
2332 =cut
2333
2334 sub check_and_rebuild_fuzzyfiles {
2335   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2336   -e "$dir/svc_acct.username"
2337     or &rebuild_fuzzyfiles;
2338 }
2339
2340 =item rebuild_fuzzyfiles
2341
2342 =cut
2343
2344 sub rebuild_fuzzyfiles {
2345
2346   use Fcntl qw(:flock);
2347
2348   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2349
2350   #username
2351
2352   open(USERNAMELOCK,">>$dir/svc_acct.username")
2353     or die "can't open $dir/svc_acct.username: $!";
2354   flock(USERNAMELOCK,LOCK_EX)
2355     or die "can't lock $dir/svc_acct.username: $!";
2356
2357   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2358
2359   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2360     or die "can't open $dir/svc_acct.username.tmp: $!";
2361   print USERNAMECACHE join("\n", @all_username), "\n";
2362   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2363
2364   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2365   close USERNAMELOCK;
2366
2367 }
2368
2369 =item all_username
2370
2371 =cut
2372
2373 sub all_username {
2374   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2375   open(USERNAMECACHE,"<$dir/svc_acct.username")
2376     or die "can't open $dir/svc_acct.username: $!";
2377   my @array = map { chomp; $_; } <USERNAMECACHE>;
2378   close USERNAMECACHE;
2379   \@array;
2380 }
2381
2382 =item append_fuzzyfiles USERNAME
2383
2384 =cut
2385
2386 sub append_fuzzyfiles {
2387   my $username = shift;
2388
2389   &check_and_rebuild_fuzzyfiles;
2390
2391   use Fcntl qw(:flock);
2392
2393   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2394
2395   open(USERNAME,">>$dir/svc_acct.username")
2396     or die "can't open $dir/svc_acct.username: $!";
2397   flock(USERNAME,LOCK_EX)
2398     or die "can't lock $dir/svc_acct.username: $!";
2399
2400   print USERNAME "$username\n";
2401
2402   flock(USERNAME,LOCK_UN)
2403     or die "can't unlock $dir/svc_acct.username: $!";
2404   close USERNAME;
2405
2406   1;
2407 }
2408
2409
2410
2411 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2412
2413 =cut
2414
2415 sub radius_usergroup_selector {
2416   my $sel_groups = shift;
2417   my %sel_groups = map { $_=>1 } @$sel_groups;
2418
2419   my $selectname = shift || 'radius_usergroup';
2420
2421   my $dbh = dbh;
2422   my $sth = $dbh->prepare(
2423     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2424   ) or die $dbh->errstr;
2425   $sth->execute() or die $sth->errstr;
2426   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2427
2428   my $html = <<END;
2429     <SCRIPT>
2430     function ${selectname}_doadd(object) {
2431       var myvalue = object.${selectname}_add.value;
2432       var optionName = new Option(myvalue,myvalue,false,true);
2433       var length = object.$selectname.length;
2434       object.$selectname.options[length] = optionName;
2435       object.${selectname}_add.value = "";
2436     }
2437     </SCRIPT>
2438     <SELECT MULTIPLE NAME="$selectname">
2439 END
2440
2441   foreach my $group ( @all_groups ) {
2442     $html .= qq(<OPTION VALUE="$group");
2443     if ( $sel_groups{$group} ) {
2444       $html .= ' SELECTED';
2445       $sel_groups{$group} = 0;
2446     }
2447     $html .= ">$group</OPTION>\n";
2448   }
2449   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2450     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2451   };
2452   $html .= '</SELECT>';
2453
2454   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2455            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2456
2457   $html;
2458 }
2459
2460 =item reached_threshold
2461
2462 Performs some activities when svc_acct thresholds (such as number of seconds
2463 remaining) are reached.
2464
2465 =cut
2466
2467 sub reached_threshold {
2468   my %opt = @_;
2469
2470   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2471   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2472
2473   if ( $opt{'op'} eq '+' ){
2474     $svc_acct->setfield( $opt{'column'}.'_threshold',
2475                          int($svc_acct->getfield($opt{'column'})
2476                              * ( $conf->exists('svc_acct-usage_threshold')
2477                                  ? $conf->config('svc_acct-usage_threshold')/100
2478                                  : 0.80
2479                                )
2480                          )
2481                        );
2482     my $error = $svc_acct->replace;
2483     die $error if $error;
2484   }elsif ( $opt{'op'} eq '-' ){
2485
2486     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2487     return '' if ($threshold eq '' );
2488
2489     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2490     my $error = $svc_acct->replace;
2491     die $error if $error; # email next time, i guess
2492
2493     if ( $warning_template ) {
2494       eval "use FS::Misc qw(send_email)";
2495       die $@ if $@;
2496
2497       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2498       my $cust_main = $cust_pkg->cust_main;
2499
2500       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2501                                $cust_main->invoicing_list,
2502                                ($opt{'to'} ? $opt{'to'} : ())
2503                    );
2504
2505       my $mimetype = $warning_mimetype;
2506       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2507
2508       my $body       =  $warning_template->fill_in( HASH => {
2509                         'custnum'   => $cust_main->custnum,
2510                         'username'  => $svc_acct->username,
2511                         'password'  => $svc_acct->_password,
2512                         'first'     => $cust_main->first,
2513                         'last'      => $cust_main->getfield('last'),
2514                         'pkg'       => $cust_pkg->part_pkg->pkg,
2515                         'column'    => $opt{'column'},
2516                         'amount'    => $opt{'column'} =~/bytes/
2517                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2518                                        : $svc_acct->getfield($opt{'column'}),
2519                         'threshold' => $opt{'column'} =~/bytes/
2520                                        ? FS::UI::bytecount::display_bytecount($threshold)
2521                                        : $threshold,
2522                       } );
2523
2524
2525       my $error = send_email(
2526         'from'         => $warning_from,
2527         'to'           => $to,
2528         'subject'      => $warning_subject,
2529         'content-type' => $mimetype,
2530         'body'         => [ map "$_\n", split("\n", $body) ],
2531       );
2532       die $error if $error;
2533     }
2534   }else{
2535     die "unknown op: " . $opt{'op'};
2536   }
2537 }
2538
2539 =back
2540
2541 =head1 BUGS
2542
2543 The $recref stuff in sub check should be cleaned up.
2544
2545 The suspend, unsuspend and cancel methods update the database, but not the
2546 current object.  This is probably a bug as it's unexpected and
2547 counterintuitive.
2548
2549 radius_usergroup_selector?  putting web ui components in here?  they should
2550 probably live somewhere else...
2551
2552 insertion of RADIUS group stuff in insert could be done with child_objects now
2553 (would probably clean up export of them too)
2554
2555 _op_usage and set_usage bypass the history... maybe they shouldn't
2556
2557 =head1 SEE ALSO
2558
2559 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2560 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2561 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2562 L<freeside-queued>), L<FS::svc_acct_pop>,
2563 schema.html from the base documentation.
2564
2565 =cut
2566
2567 =item domain_select_hash %OPTIONS
2568
2569 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
2570 may at present purchase.
2571
2572 Currently available options are: I<pkgnum> I<svcpart>
2573
2574 =cut
2575
2576 sub domain_select_hash {
2577   my ($self, %options) = @_;
2578   my %domains = ();
2579   my $part_svc;
2580   my $cust_pkg;
2581
2582   if (ref($self)) {
2583     $part_svc = $self->part_svc;
2584     $cust_pkg = $self->cust_svc->cust_pkg
2585       if $self->cust_svc;
2586   }
2587
2588   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2589     if $options{'svcpart'};
2590
2591   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2592     if $options{'pkgnum'};
2593
2594   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2595                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2596     %domains = map { $_->svcnum => $_->domain }
2597                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2598                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2599   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2600     %domains = map { $_->svcnum => $_->domain }
2601                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2602                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2603                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2604   }else{
2605     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2606   }
2607
2608   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2609     my $svc_domain = qsearchs('svc_domain',
2610       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2611     if ( $svc_domain ) {
2612       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
2613     }else{
2614       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2615            $part_svc->part_svc_column('domsvc')->columnvalue;
2616
2617     }
2618   }
2619
2620   (%domains);
2621 }
2622
2623 1;
2624