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