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