FS/FS/svc_acct.pm

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