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