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