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     $password = $self->_password;
1470
1471   } else {
1472
1473     $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1474     $password = $self->_password;
1475
1476   }
1477
1478   ($pw_attrib, $password);
1479
1480 }
1481
1482 =item snapshot
1483
1484 This method instructs the object to "snapshot" or freeze RADIUS check and
1485 reply attributes to the current values.
1486
1487 =cut
1488
1489 #bah, my english is too broken this morning
1490 #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
1491 #the FS::cust_pkg's replace method to trigger the correct export updates when
1492 #package dates change)
1493
1494 sub snapshot {
1495   my $self = shift;
1496
1497   $self->{$_} = { $self->$_() }
1498     foreach qw( radius_reply radius_check );
1499
1500 }
1501
1502 =item forget_snapshot
1503
1504 This methos instructs the object to forget any previously snapshotted
1505 RADIUS check and reply attributes.
1506
1507 =cut
1508
1509 sub forget_snapshot {
1510   my $self = shift;
1511
1512   delete $self->{$_}
1513     foreach qw( radius_reply radius_check );
1514
1515 }
1516
1517 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1518
1519 Returns the domain associated with this account.
1520
1521 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1522 history records.
1523
1524 =cut
1525
1526 sub domain {
1527   my $self = shift;
1528   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1529   my $svc_domain = $self->svc_domain(@_)
1530     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1531   $svc_domain->domain;
1532 }
1533
1534 =item svc_domain
1535
1536 Returns the FS::svc_domain record for this account's domain (see
1537 L<FS::svc_domain>).
1538
1539 =cut
1540
1541 # FS::h_svc_acct has a history-aware svc_domain override
1542
1543 sub svc_domain {
1544   my $self = shift;
1545   $self->{'_domsvc'}
1546     ? $self->{'_domsvc'}
1547     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1548 }
1549
1550 =item cust_svc
1551
1552 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1553
1554 =cut
1555
1556 #inherited from svc_Common
1557
1558 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1559
1560 Returns an email address associated with the account.
1561
1562 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1563 history records.
1564
1565 =cut
1566
1567 sub email {
1568   my $self = shift;
1569   $self->username. '@'. $self->domain(@_);
1570 }
1571
1572 =item acct_snarf
1573
1574 Returns an array of FS::acct_snarf records associated with the account.
1575 If the acct_snarf table does not exist or there are no associated records,
1576 an empty list is returned
1577
1578 =cut
1579
1580 sub acct_snarf {
1581   my $self = shift;
1582   return () unless dbdef->table('acct_snarf');
1583   eval "use FS::acct_snarf;";
1584   die $@ if $@;
1585   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1586 }
1587
1588 =item decrement_upbytes OCTETS
1589
1590 Decrements the I<upbytes> field of this record by the given amount.  If there
1591 is an error, returns the error, otherwise returns false.
1592
1593 =cut
1594
1595 sub decrement_upbytes {
1596   shift->_op_usage('-', 'upbytes', @_);
1597 }
1598
1599 =item increment_upbytes OCTETS
1600
1601 Increments the I<upbytes> field of this record by the given amount.  If there
1602 is an error, returns the error, otherwise returns false.
1603
1604 =cut
1605
1606 sub increment_upbytes {
1607   shift->_op_usage('+', 'upbytes', @_);
1608 }
1609
1610 =item decrement_downbytes OCTETS
1611
1612 Decrements the I<downbytes> field of this record by the given amount.  If there
1613 is an error, returns the error, otherwise returns false.
1614
1615 =cut
1616
1617 sub decrement_downbytes {
1618   shift->_op_usage('-', 'downbytes', @_);
1619 }
1620
1621 =item increment_downbytes OCTETS
1622
1623 Increments the I<downbytes> field of this record by the given amount.  If there
1624 is an error, returns the error, otherwise returns false.
1625
1626 =cut
1627
1628 sub increment_downbytes {
1629   shift->_op_usage('+', 'downbytes', @_);
1630 }
1631
1632 =item decrement_totalbytes OCTETS
1633
1634 Decrements the I<totalbytes> field of this record by the given amount.  If there
1635 is an error, returns the error, otherwise returns false.
1636
1637 =cut
1638
1639 sub decrement_totalbytes {
1640   shift->_op_usage('-', 'totalbytes', @_);
1641 }
1642
1643 =item increment_totalbytes OCTETS
1644
1645 Increments the I<totalbytes> field of this record by the given amount.  If there
1646 is an error, returns the error, otherwise returns false.
1647
1648 =cut
1649
1650 sub increment_totalbytes {
1651   shift->_op_usage('+', 'totalbytes', @_);
1652 }
1653
1654 =item decrement_seconds SECONDS
1655
1656 Decrements the I<seconds> field of this record by the given amount.  If there
1657 is an error, returns the error, otherwise returns false.
1658
1659 =cut
1660
1661 sub decrement_seconds {
1662   shift->_op_usage('-', 'seconds', @_);
1663 }
1664
1665 =item increment_seconds SECONDS
1666
1667 Increments the I<seconds> field of this record by the given amount.  If there
1668 is an error, returns the error, otherwise returns false.
1669
1670 =cut
1671
1672 sub increment_seconds {
1673   shift->_op_usage('+', 'seconds', @_);
1674 }
1675
1676
1677 my %op2action = (
1678   '-' => 'suspend',
1679   '+' => 'unsuspend',
1680 );
1681 my %op2condition = (
1682   '-' => sub { my($self, $column, $amount) = @_;
1683                $self->$column - $amount <= 0;
1684              },
1685   '+' => sub { my($self, $column, $amount) = @_;
1686                $self->$column + $amount > 0;
1687              },
1688 );
1689 my %op2warncondition = (
1690   '-' => sub { my($self, $column, $amount) = @_;
1691                my $threshold = $column . '_threshold';
1692                $self->$column - $amount <= $self->$threshold + 0;
1693              },
1694   '+' => sub { my($self, $column, $amount) = @_;
1695                $self->$column + $amount > 0;
1696              },
1697 );
1698
1699 sub _op_usage {
1700   my( $self, $op, $column, $amount ) = @_;
1701
1702   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1703        ' ('. $self->email. "): $op $amount\n"
1704     if $DEBUG;
1705
1706   return '' unless $amount;
1707
1708   local $SIG{HUP} = 'IGNORE';
1709   local $SIG{INT} = 'IGNORE';
1710   local $SIG{QUIT} = 'IGNORE';
1711   local $SIG{TERM} = 'IGNORE';
1712   local $SIG{TSTP} = 'IGNORE';
1713   local $SIG{PIPE} = 'IGNORE';
1714
1715   my $oldAutoCommit = $FS::UID::AutoCommit;
1716   local $FS::UID::AutoCommit = 0;
1717   my $dbh = dbh;
1718
1719   my $sql = "UPDATE svc_acct SET $column = ".
1720             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1721             " $op ? WHERE svcnum = ?";
1722   warn "$me $sql\n"
1723     if $DEBUG;
1724
1725   my $sth = $dbh->prepare( $sql )
1726     or die "Error preparing $sql: ". $dbh->errstr;
1727   my $rv = $sth->execute($amount, $self->svcnum);
1728   die "Error executing $sql: ". $sth->errstr
1729     unless defined($rv);
1730   die "Can't update $column for svcnum". $self->svcnum
1731     if $rv == 0;
1732
1733   my $action = $op2action{$op};
1734
1735   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1736         ( $action eq 'suspend'   && !$self->overlimit
1737        || $action eq 'unsuspend' &&  $self->overlimit )
1738      ) {
1739     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1740       if ($part_export->option('overlimit_groups')) {
1741         my ($new,$old);
1742         my $other = new FS::svc_acct $self->hashref;
1743         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1744                        ($self, $part_export->option('overlimit_groups'));
1745         $other->usergroup( $groups );
1746         if ($action eq 'suspend'){
1747           $new = $other; $old = $self;
1748         }else{
1749           $new = $self; $old = $other;
1750         }
1751         my $error = $part_export->export_replace($new, $old);
1752         $error ||= $self->overlimit($action);
1753         if ( $error ) {
1754           $dbh->rollback if $oldAutoCommit;
1755           return "Error replacing radius groups in export, ${op}: $error";
1756         }
1757       }
1758     }
1759   }
1760
1761   if ( $conf->exists("svc_acct-usage_$action")
1762        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1763     #my $error = $self->$action();
1764     my $error = $self->cust_svc->cust_pkg->$action();
1765     # $error ||= $self->overlimit($action);
1766     if ( $error ) {
1767       $dbh->rollback if $oldAutoCommit;
1768       return "Error ${action}ing: $error";
1769     }
1770   }
1771
1772   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1773     my $wqueue = new FS::queue {
1774       'svcnum' => $self->svcnum,
1775       'job'    => 'FS::svc_acct::reached_threshold',
1776     };
1777
1778     my $to = '';
1779     if ($op eq '-'){
1780       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1781     }
1782
1783     # x_threshold race
1784     my $error = $wqueue->insert(
1785       'svcnum' => $self->svcnum,
1786       'op'     => $op,
1787       'column' => $column,
1788       'to'     => $to,
1789     );
1790     if ( $error ) {
1791       $dbh->rollback if $oldAutoCommit;
1792       return "Error queuing threshold activity: $error";
1793     }
1794   }
1795
1796   warn "$me update successful; committing\n"
1797     if $DEBUG;
1798   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1799   '';
1800
1801 }
1802
1803 sub set_usage {
1804   my( $self, $valueref ) = @_;
1805
1806   warn "$me set_usage called for svcnum ". $self->svcnum.
1807        ' ('. $self->email. "): ".
1808        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1809     if $DEBUG;
1810
1811   local $SIG{HUP} = 'IGNORE';
1812   local $SIG{INT} = 'IGNORE';
1813   local $SIG{QUIT} = 'IGNORE';
1814   local $SIG{TERM} = 'IGNORE';
1815   local $SIG{TSTP} = 'IGNORE';
1816   local $SIG{PIPE} = 'IGNORE';
1817
1818   local $FS::svc_Common::noexport_hack = 1;
1819   my $oldAutoCommit = $FS::UID::AutoCommit;
1820   local $FS::UID::AutoCommit = 0;
1821   my $dbh = dbh;
1822
1823   my $reset = 0;
1824   my %handyhash = ();
1825   foreach my $field (keys %$valueref){
1826     $reset = 1 if $valueref->{$field};
1827     $self->setfield($field, $valueref->{$field});
1828     $self->setfield( $field.'_threshold',
1829                      int($self->getfield($field)
1830                          * ( $conf->exists('svc_acct-usage_threshold')
1831                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1832                              : 0.20
1833                            )
1834                        )
1835                      );
1836     $handyhash{$field} = $self->getfield($field);
1837     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1838   }
1839   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1840   #die $error if $error;         #services not explicity changed via the UI
1841
1842   my $sql = "UPDATE svc_acct SET " .
1843     join (',', map { "$_ =  ?" } (keys %handyhash) ).
1844     " WHERE svcnum = ?";
1845
1846   warn "$me $sql\n"
1847     if $DEBUG;
1848
1849   if (scalar(keys %handyhash)) {
1850     my $sth = $dbh->prepare( $sql )
1851       or die "Error preparing $sql: ". $dbh->errstr;
1852     my $rv = $sth->execute((values %handyhash), $self->svcnum);
1853     die "Error executing $sql: ". $sth->errstr
1854       unless defined($rv);
1855     die "Can't update usage for svcnum ". $self->svcnum
1856       if $rv == 0;
1857   }
1858
1859   if ( $reset ) {
1860     my $error;
1861
1862     if ($self->overlimit) {
1863       $error = $self->overlimit('unsuspend');
1864       foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1865         if ($part_export->option('overlimit_groups')) {
1866           my $old = new FS::svc_acct $self->hashref;
1867           my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1868                          ($self, $part_export->option('overlimit_groups'));
1869           $old->usergroup( $groups );
1870           $error ||= $part_export->export_replace($self, $old);
1871         }
1872       }
1873     }
1874
1875     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1876       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1877     }
1878     if ( $error ) {
1879       $dbh->rollback if $oldAutoCommit;
1880       return "Error unsuspending: $error";
1881     }
1882   }
1883
1884   warn "$me update successful; committing\n"
1885     if $DEBUG;
1886   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1887   '';
1888
1889 }
1890
1891
1892 =item recharge HASHREF
1893
1894   Increments usage columns by the amount specified in HASHREF as
1895   column=>amount pairs.
1896
1897 =cut
1898
1899 sub recharge {
1900   my ($self, $vhash) = @_;
1901
1902   if ( $DEBUG ) {
1903     warn "[$me] recharge called on $self: ". Dumper($self).
1904          "\nwith vhash: ". Dumper($vhash);
1905   }
1906
1907   my $oldAutoCommit = $FS::UID::AutoCommit;
1908   local $FS::UID::AutoCommit = 0;
1909   my $dbh = dbh;
1910   my $error = '';
1911
1912   foreach my $column (keys %$vhash){
1913     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1914   }
1915
1916   if ( $error ) {
1917     $dbh->rollback if $oldAutoCommit;
1918   }else{
1919     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1920   }
1921   return $error;
1922 }
1923
1924 =item is_rechargeable
1925
1926 Returns true if this svc_account can be "recharged" and false otherwise.
1927
1928 =cut
1929
1930 sub is_rechargable {
1931   my $self = shift;
1932   $self->seconds ne ''
1933     || $self->upbytes ne ''
1934     || $self->downbytes ne ''
1935     || $self->totalbytes ne '';
1936 }
1937
1938 =item seconds_since TIMESTAMP
1939
1940 Returns the number of seconds this account has been online since TIMESTAMP,
1941 according to the session monitor (see L<FS::Session>).
1942
1943 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1944 L<Time::Local> and L<Date::Parse> for conversion functions.
1945
1946 =cut
1947
1948 #note: POD here, implementation in FS::cust_svc
1949 sub seconds_since {
1950   my $self = shift;
1951   $self->cust_svc->seconds_since(@_);
1952 }
1953
1954 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1955
1956 Returns the numbers of seconds this account has been online between
1957 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1958 external SQL radacct table, specified via sqlradius export.  Sessions which
1959 started in the specified range but are still open are counted from session
1960 start to the end of the range (unless they are over 1 day old, in which case
1961 they are presumed missing their stop record and not counted).  Also, sessions
1962 which end in the range but started earlier are counted from the start of the
1963 range to session end.  Finally, sessions which start before the range but end
1964 after are counted for the entire range.
1965
1966 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1967 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1968 functions.
1969
1970 =cut
1971
1972 #note: POD here, implementation in FS::cust_svc
1973 sub seconds_since_sqlradacct {
1974   my $self = shift;
1975   $self->cust_svc->seconds_since_sqlradacct(@_);
1976 }
1977
1978 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1979
1980 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1981 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1982 TIMESTAMP_END (exclusive).
1983
1984 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1985 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1986 functions.
1987
1988 =cut
1989
1990 #note: POD here, implementation in FS::cust_svc
1991 sub attribute_since_sqlradacct {
1992   my $self = shift;
1993   $self->cust_svc->attribute_since_sqlradacct(@_);
1994 }
1995
1996 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1997
1998 Returns an array of hash references of this customers login history for the
1999 given time range.  (document this better)
2000
2001 =cut
2002
2003 sub get_session_history {
2004   my $self = shift;
2005   $self->cust_svc->get_session_history(@_);
2006 }
2007
2008 =item last_login_text
2009
2010 Returns text describing the time of last login.
2011
2012 =cut
2013
2014 sub last_login_text {
2015   my $self = shift;
2016   $self->last_login ? ctime($self->last_login) : 'unknown';
2017 }
2018
2019 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2020
2021 =cut
2022
2023 sub get_cdrs {
2024   my($self, $start, $end, %opt ) = @_;
2025
2026   my $did = $self->username; #yup
2027
2028   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2029
2030   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2031
2032   #SELECT $for_update * FROM cdr
2033   #  WHERE calldate >= $start #need a conversion
2034   #    AND calldate <  $end   #ditto
2035   #    AND (    charged_party = "$did"
2036   #          OR charged_party = "$prefix$did" #if length($prefix);
2037   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2038   #               AND
2039   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2040   #             )
2041   #        )
2042   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2043
2044   my $charged_or_src;
2045   if ( length($prefix) ) {
2046     $charged_or_src =
2047       " AND (    charged_party = '$did'
2048               OR charged_party = '$prefix$did'
2049               OR ( ( charged_party IS NULL OR charged_party = '' )
2050                    AND
2051                    ( src = '$did' OR src = '$prefix$did' )
2052                  )
2053             )
2054       ";
2055   } else {
2056     $charged_or_src =
2057       " AND (    charged_party = '$did'
2058               OR ( ( charged_party IS NULL OR charged_party = '' )
2059                    AND
2060                    src = '$did'
2061                  )
2062             )
2063       ";
2064
2065   }
2066
2067   qsearch(
2068     'select'    => "$for_update *",
2069     'table'     => 'cdr',
2070     'hashref'   => {
2071                      #( freesidestatus IS NULL OR freesidestatus = '' )
2072                      'freesidestatus' => '',
2073                    },
2074     'extra_sql' => $charged_or_src,
2075
2076   );
2077
2078 }
2079
2080 =item radius_groups
2081
2082 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2083
2084 =cut
2085
2086 sub radius_groups {
2087   my $self = shift;
2088   if ( $self->usergroup ) {
2089     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2090       unless ref($self->usergroup) eq 'ARRAY';
2091     #when provisioning records, export callback runs in svc_Common.pm before
2092     #radius_usergroup records can be inserted...
2093     @{$self->usergroup};
2094   } else {
2095     map { $_->groupname }
2096       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2097   }
2098 }
2099
2100 =item clone_suspended
2101
2102 Constructor used by FS::part_export::_export_suspend fallback.  Document
2103 better.
2104
2105 =cut
2106
2107 sub clone_suspended {
2108   my $self = shift;
2109   my %hash = $self->hash;
2110   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2111   new FS::svc_acct \%hash;
2112 }
2113
2114 =item clone_kludge_unsuspend
2115
2116 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2117 better.
2118
2119 =cut
2120
2121 sub clone_kludge_unsuspend {
2122   my $self = shift;
2123   my %hash = $self->hash;
2124   $hash{_password} = '';
2125   new FS::svc_acct \%hash;
2126 }
2127
2128 =item check_password
2129
2130 Checks the supplied password against the (possibly encrypted) password in the
2131 database.  Returns true for a successful authentication, false for no match.
2132
2133 Currently supported encryptions are: classic DES crypt() and MD5
2134
2135 =cut
2136
2137 sub check_password {
2138   my($self, $check_password) = @_;
2139
2140   #remove old-style SUSPENDED kludge, they should be allowed to login to
2141   #self-service and pay up
2142   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2143
2144   if ( $self->_password_encoding eq 'ldap' ) {
2145
2146     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2147     return $auth->match($check_password);
2148
2149   } elsif ( $self->_password_encoding eq 'crypt' ) {
2150
2151     my $auth = from_crypt Authen::Passphrase $self->_password;
2152     return $auth->match($check_password);
2153
2154   } elsif ( $self->_password_encoding eq 'plain' ) {
2155
2156     return $check_password eq $password;
2157
2158   } else {
2159
2160     #XXX this could be replaced with Authen::Passphrase stuff
2161
2162     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2163       return 0;
2164     } elsif ( length($password) < 13 ) { #plaintext
2165       $check_password eq $password;
2166     } elsif ( length($password) == 13 ) { #traditional DES crypt
2167       crypt($check_password, $password) eq $password;
2168     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2169       unix_md5_crypt($check_password, $password) eq $password;
2170     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2171       warn "Can't check password: Blowfish encryption not yet supported, ".
2172            "svcnum ".  $self->svcnum. "\n";
2173       0;
2174     } else {
2175       warn "Can't check password: Unrecognized encryption for svcnum ".
2176            $self->svcnum. "\n";
2177       0;
2178     }
2179
2180   }
2181
2182 }
2183
2184 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2185
2186 Returns an encrypted password, either by passing through an encrypted password
2187 in the database or by encrypting a plaintext password from the database.
2188
2189 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2190 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2191 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2192 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2193 encryption type is only used if the password is not already encrypted in the
2194 database.
2195
2196 =cut
2197
2198 sub crypt_password {
2199   my $self = shift;
2200
2201   if ( $self->_password_encoding eq 'ldap' ) {
2202
2203     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2204       my $plain = $2;
2205
2206       #XXX this could be replaced with Authen::Passphrase stuff
2207
2208       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2209       if ( $encryption eq 'crypt' ) {
2210         crypt(
2211           $self->_password,
2212           $saltset[int(rand(64))].$saltset[int(rand(64))]
2213         );
2214       } elsif ( $encryption eq 'md5' ) {
2215         unix_md5_crypt( $self->_password );
2216       } elsif ( $encryption eq 'blowfish' ) {
2217         croak "unknown encryption method $encryption";
2218       } else {
2219         croak "unknown encryption method $encryption";
2220       }
2221
2222     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2223       $1;
2224     }
2225
2226   } elsif ( $self->_password_encoding eq 'crypt' ) {
2227
2228     return $self->_password;
2229
2230   } elsif ( $self->_password_encoding eq 'plain' ) {
2231
2232     #XXX this could be replaced with Authen::Passphrase stuff
2233
2234     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2235     if ( $encryption eq 'crypt' ) {
2236       crypt(
2237         $self->_password,
2238         $saltset[int(rand(64))].$saltset[int(rand(64))]
2239       );
2240     } elsif ( $encryption eq 'md5' ) {
2241       unix_md5_crypt( $self->_password );
2242     } elsif ( $encryption eq 'blowfish' ) {
2243       croak "unknown encryption method $encryption";
2244     } else {
2245       croak "unknown encryption method $encryption";
2246     }
2247
2248   } else {
2249
2250     if ( length($self->_password) == 13
2251          || $self->_password =~ /^\$(1|2a?)\$/
2252          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2253        )
2254     {
2255       $self->_password;
2256     } else {
2257
2258       #XXX this could be replaced with Authen::Passphrase stuff
2259
2260       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2261       if ( $encryption eq 'crypt' ) {
2262         crypt(
2263           $self->_password,
2264           $saltset[int(rand(64))].$saltset[int(rand(64))]
2265         );
2266       } elsif ( $encryption eq 'md5' ) {
2267         unix_md5_crypt( $self->_password );
2268       } elsif ( $encryption eq 'blowfish' ) {
2269         croak "unknown encryption method $encryption";
2270       } else {
2271         croak "unknown encryption method $encryption";
2272       }
2273
2274     }
2275
2276   }
2277
2278 }
2279
2280 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2281
2282 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2283 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2284 "{MD5}5426824942db4253f87a1009fd5d2d4".
2285
2286 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2287 to work the same as the B</crypt_password> method.
2288
2289 =cut
2290
2291 sub ldap_password {
2292   my $self = shift;
2293   #eventually should check a "password-encoding" field
2294
2295   if ( $self->_password_encoding eq 'ldap' ) {
2296
2297     return $self->_password;
2298
2299   } elsif ( $self->_password_encoding eq 'crypt' ) {
2300
2301     if ( length($self->_password) == 13 ) { #crypt
2302       return '{CRYPT}'. $self->_password;
2303     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2304       return '{MD5}'. $1;
2305     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2306     #  die "Blowfish encryption not supported in this context, svcnum ".
2307     #      $self->svcnum. "\n";
2308     } else {
2309       warn "encryption method not (yet?) supported in LDAP context";
2310       return '{CRYPT}*'; #unsupported, should not auth
2311     }
2312
2313   } elsif ( $self->_password_encoding eq 'plain' ) {
2314
2315     return '{PLAIN}'. $self->_password;
2316
2317     #return '{CLEARTEXT}'. $self->_password; #?
2318
2319   } else {
2320
2321     if ( length($self->_password) == 13 ) { #crypt
2322       return '{CRYPT}'. $self->_password;
2323     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2324       return '{MD5}'. $1;
2325     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2326       warn "Blowfish encryption not supported in this context, svcnum ".
2327           $self->svcnum. "\n";
2328       return '{CRYPT}*';
2329
2330     #are these two necessary anymore?
2331     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2332       return '{SSHA}'. $1;
2333     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2334       return '{NS-MTA-MD5}'. $1;
2335
2336     } else { #plaintext
2337       return '{PLAIN}'. $self->_password;
2338
2339       #return '{CLEARTEXT}'. $self->_password; #?
2340
2341       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2342       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2343       #if ( $encryption eq 'crypt' ) {
2344       #  return '{CRYPT}'. crypt(
2345       #    $self->_password,
2346       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2347       #  );
2348       #} elsif ( $encryption eq 'md5' ) {
2349       #  unix_md5_crypt( $self->_password );
2350       #} elsif ( $encryption eq 'blowfish' ) {
2351       #  croak "unknown encryption method $encryption";
2352       #} else {
2353       #  croak "unknown encryption method $encryption";
2354       #}
2355     }
2356
2357   }
2358
2359 }
2360
2361 =item domain_slash_username
2362
2363 Returns $domain/$username/
2364
2365 =cut
2366
2367 sub domain_slash_username {
2368   my $self = shift;
2369   $self->domain. '/'. $self->username. '/';
2370 }
2371
2372 =item virtual_maildir
2373
2374 Returns $domain/maildirs/$username/
2375
2376 =cut
2377
2378 sub virtual_maildir {
2379   my $self = shift;
2380   $self->domain. '/maildirs/'. $self->username. '/';
2381 }
2382
2383 =back
2384
2385 =head1 SUBROUTINES
2386
2387 =over 4
2388
2389 =item send_email
2390
2391 This is the FS::svc_acct job-queue-able version.  It still uses
2392 FS::Misc::send_email under-the-hood.
2393
2394 =cut
2395
2396 sub send_email {
2397   my %opt = @_;
2398
2399   eval "use FS::Misc qw(send_email)";
2400   die $@ if $@;
2401
2402   $opt{mimetype} ||= 'text/plain';
2403   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2404
2405   my $error = send_email(
2406     'from'         => $opt{from},
2407     'to'           => $opt{to},
2408     'subject'      => $opt{subject},
2409     'content-type' => $opt{mimetype},
2410     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2411   );
2412   die $error if $error;
2413 }
2414
2415 =item check_and_rebuild_fuzzyfiles
2416
2417 =cut
2418
2419 sub check_and_rebuild_fuzzyfiles {
2420   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2421   -e "$dir/svc_acct.username"
2422     or &rebuild_fuzzyfiles;
2423 }
2424
2425 =item rebuild_fuzzyfiles
2426
2427 =cut
2428
2429 sub rebuild_fuzzyfiles {
2430
2431   use Fcntl qw(:flock);
2432
2433   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2434
2435   #username
2436
2437   open(USERNAMELOCK,">>$dir/svc_acct.username")
2438     or die "can't open $dir/svc_acct.username: $!";
2439   flock(USERNAMELOCK,LOCK_EX)
2440     or die "can't lock $dir/svc_acct.username: $!";
2441
2442   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2443
2444   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2445     or die "can't open $dir/svc_acct.username.tmp: $!";
2446   print USERNAMECACHE join("\n", @all_username), "\n";
2447   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2448
2449   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2450   close USERNAMELOCK;
2451
2452 }
2453
2454 =item all_username
2455
2456 =cut
2457
2458 sub all_username {
2459   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2460   open(USERNAMECACHE,"<$dir/svc_acct.username")
2461     or die "can't open $dir/svc_acct.username: $!";
2462   my @array = map { chomp; $_; } <USERNAMECACHE>;
2463   close USERNAMECACHE;
2464   \@array;
2465 }
2466
2467 =item append_fuzzyfiles USERNAME
2468
2469 =cut
2470
2471 sub append_fuzzyfiles {
2472   my $username = shift;
2473
2474   &check_and_rebuild_fuzzyfiles;
2475
2476   use Fcntl qw(:flock);
2477
2478   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2479
2480   open(USERNAME,">>$dir/svc_acct.username")
2481     or die "can't open $dir/svc_acct.username: $!";
2482   flock(USERNAME,LOCK_EX)
2483     or die "can't lock $dir/svc_acct.username: $!";
2484
2485   print USERNAME "$username\n";
2486
2487   flock(USERNAME,LOCK_UN)
2488     or die "can't unlock $dir/svc_acct.username: $!";
2489   close USERNAME;
2490
2491   1;
2492 }
2493
2494
2495
2496 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2497
2498 =cut
2499
2500 sub radius_usergroup_selector {
2501   my $sel_groups = shift;
2502   my %sel_groups = map { $_=>1 } @$sel_groups;
2503
2504   my $selectname = shift || 'radius_usergroup';
2505
2506   my $dbh = dbh;
2507   my $sth = $dbh->prepare(
2508     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2509   ) or die $dbh->errstr;
2510   $sth->execute() or die $sth->errstr;
2511   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2512
2513   my $html = <<END;
2514     <SCRIPT>
2515     function ${selectname}_doadd(object) {
2516       var myvalue = object.${selectname}_add.value;
2517       var optionName = new Option(myvalue,myvalue,false,true);
2518       var length = object.$selectname.length;
2519       object.$selectname.options[length] = optionName;
2520       object.${selectname}_add.value = "";
2521     }
2522     </SCRIPT>
2523     <SELECT MULTIPLE NAME="$selectname">
2524 END
2525
2526   foreach my $group ( @all_groups ) {
2527     $html .= qq(<OPTION VALUE="$group");
2528     if ( $sel_groups{$group} ) {
2529       $html .= ' SELECTED';
2530       $sel_groups{$group} = 0;
2531     }
2532     $html .= ">$group</OPTION>\n";
2533   }
2534   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2535     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2536   };
2537   $html .= '</SELECT>';
2538
2539   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2540            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2541
2542   $html;
2543 }
2544
2545 =item reached_threshold
2546
2547 Performs some activities when svc_acct thresholds (such as number of seconds
2548 remaining) are reached.
2549
2550 =cut
2551
2552 sub reached_threshold {
2553   my %opt = @_;
2554
2555   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2556   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2557
2558   if ( $opt{'op'} eq '+' ){
2559     $svc_acct->setfield( $opt{'column'}.'_threshold',
2560                          int($svc_acct->getfield($opt{'column'})
2561                              * ( $conf->exists('svc_acct-usage_threshold')
2562                                  ? $conf->config('svc_acct-usage_threshold')/100
2563                                  : 0.80
2564                                )
2565                          )
2566                        );
2567     my $error = $svc_acct->replace;
2568     die $error if $error;
2569   }elsif ( $opt{'op'} eq '-' ){
2570
2571     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2572     return '' if ($threshold eq '' );
2573
2574     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2575     my $error = $svc_acct->replace;
2576     die $error if $error; # email next time, i guess
2577
2578     if ( $warning_template ) {
2579       eval "use FS::Misc qw(send_email)";
2580       die $@ if $@;
2581
2582       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2583       my $cust_main = $cust_pkg->cust_main;
2584
2585       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2586                                $cust_main->invoicing_list,
2587                                ($opt{'to'} ? $opt{'to'} : ())
2588                    );
2589
2590       my $mimetype = $warning_mimetype;
2591       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2592
2593       my $body       =  $warning_template->fill_in( HASH => {
2594                         'custnum'   => $cust_main->custnum,
2595                         'username'  => $svc_acct->username,
2596                         'password'  => $svc_acct->_password,
2597                         'first'     => $cust_main->first,
2598                         'last'      => $cust_main->getfield('last'),
2599                         'pkg'       => $cust_pkg->part_pkg->pkg,
2600                         'column'    => $opt{'column'},
2601                         'amount'    => $opt{'column'} =~/bytes/
2602                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2603                                        : $svc_acct->getfield($opt{'column'}),
2604                         'threshold' => $opt{'column'} =~/bytes/
2605                                        ? FS::UI::bytecount::display_bytecount($threshold)
2606                                        : $threshold,
2607                       } );
2608
2609
2610       my $error = send_email(
2611         'from'         => $warning_from,
2612         'to'           => $to,
2613         'subject'      => $warning_subject,
2614         'content-type' => $mimetype,
2615         'body'         => [ map "$_\n", split("\n", $body) ],
2616       );
2617       die $error if $error;
2618     }
2619   }else{
2620     die "unknown op: " . $opt{'op'};
2621   }
2622 }
2623
2624 =back
2625
2626 =head1 BUGS
2627
2628 The $recref stuff in sub check should be cleaned up.
2629
2630 The suspend, unsuspend and cancel methods update the database, but not the
2631 current object.  This is probably a bug as it's unexpected and
2632 counterintuitive.
2633
2634 radius_usergroup_selector?  putting web ui components in here?  they should
2635 probably live somewhere else...
2636
2637 insertion of RADIUS group stuff in insert could be done with child_objects now
2638 (would probably clean up export of them too)
2639
2640 =head1 SEE ALSO
2641
2642 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2643 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2644 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2645 L<freeside-queued>), L<FS::svc_acct_pop>,
2646 schema.html from the base documentation.
2647
2648 =cut
2649
2650 =item domain_select_hash %OPTIONS
2651
2652 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
2653 may at present purchase.
2654
2655 Currently available options are: I<pkgnum> I<svcpart>
2656
2657 =cut
2658
2659 sub domain_select_hash {
2660   my ($self, %options) = @_;
2661   my %domains = ();
2662   my $part_svc;
2663   my $cust_pkg;
2664
2665   if (ref($self)) {
2666     $part_svc = $self->part_svc;
2667     $cust_pkg = $self->cust_svc->cust_pkg
2668       if $self->cust_svc;
2669   }
2670
2671   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2672     if $options{'svcpart'};
2673
2674   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2675     if $options{'pkgnum'};
2676
2677   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2678                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2679     %domains = map { $_->svcnum => $_->domain }
2680                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2681                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2682   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2683     %domains = map { $_->svcnum => $_->domain }
2684                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2685                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2686                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2687   }else{
2688     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2689   }
2690
2691   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2692     my $svc_domain = qsearchs('svc_domain',
2693       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2694     if ( $svc_domain ) {
2695       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
2696     }else{
2697       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2698            $part_svc->part_svc_column('domsvc')->columnvalue;
2699
2700     }
2701   }
2702
2703   (%domains);
2704 }
2705
2706 1;
2707