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