FS/FS/svc_acct.pm

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