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