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