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