FS/FS/svc_acct.pm

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