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