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