FS/FS/svc_acct.pm

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