FS/FS/svc_acct.pm

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