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