FS/FS/cust_main.pm

   1 package FS::cust_main;
   2
   3 use strict;
   4 use vars qw( @ISA $conf $DEBUG $import );
   5 use Safe;
   6 use Carp;
   7 BEGIN {
   8   eval "use Time::Local;";
   9   die "Time::Local minimum version 1.05 required with Perl versions before 5.6"
  10     if $] < 5.006 && !defined($Time::Local::VERSION);
  11   eval "use Time::Local qw(timelocal timelocal_nocheck);";
  12 }
  13 use Date::Format;
  14 #use Date::Manip;
  15 use Business::CreditCard;
  16 use FS::UID qw( getotaker dbh );
  17 use FS::Record qw( qsearchs qsearch dbdef );
  18 use FS::cust_pkg;
  19 use FS::cust_bill;
  20 use FS::cust_bill_pkg;
  21 use FS::cust_pay;
  22 use FS::cust_credit;
  23 use FS::cust_refund;
  24 use FS::part_referral;
  25 use FS::cust_main_county;
  26 use FS::agent;
  27 use FS::cust_main_invoice;
  28 use FS::cust_credit_bill;
  29 use FS::cust_bill_pay;
  30 use FS::prepay_credit;
  31 use FS::queue;
  32 use FS::part_pkg;
  33 use FS::part_bill_event;
  34 use FS::cust_bill_event;
  35 use FS::cust_tax_exempt;
  36 use FS::type_pkgs;
  37 use FS::Msgcat qw(gettext);
  38
  39 @ISA = qw( FS::Record );
  40
  41 $DEBUG = 0;
  42 #$DEBUG = 1;
  43
  44 $import = 0;
  45
  46 #ask FS::UID to run this stuff for us later
  47 $FS::UID::callback{'FS::cust_main'} = sub {
  48   $conf = new FS::Conf;
  49   #yes, need it for stuff below (prolly should be cached)
  50 };
  51
  52 sub _cache {
  53   my $self = shift;
  54   my ( $hashref, $cache ) = @_;
  55   if ( exists $hashref->{'pkgnum'} ) {
  56 #    #@{ $self->{'_pkgnum'} } = ();
  57     my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum});
  58     $self->{'_pkgnum'} = $subcache;
  59     #push @{ $self->{'_pkgnum'} },
  60     FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum};
  61   }
  62 }
  63
  64 =head1 NAME
  65
  66 FS::cust_main - Object methods for cust_main records
  67
  68 =head1 SYNOPSIS
  69
  70   use FS::cust_main;
  71
  72   $record = new FS::cust_main \%hash;
  73   $record = new FS::cust_main { 'column' => 'value' };
  74
  75   $error = $record->insert;
  76
  77   $error = $new_record->replace($old_record);
  78
  79   $error = $record->delete;
  80
  81   $error = $record->check;
  82
  83   @cust_pkg = $record->all_pkgs;
  84
  85   @cust_pkg = $record->ncancelled_pkgs;
  86
  87   @cust_pkg = $record->suspended_pkgs;
  88
  89   $error = $record->bill;
  90   $error = $record->bill %options;
  91   $error = $record->bill 'time' => $time;
  92
  93   $error = $record->collect;
  94   $error = $record->collect %options;
  95   $error = $record->collect 'invoice_time'   => $time,
  96                             'batch_card'     => 'yes',
  97                             'report_badcard' => 'yes',
  98                           ;
  99
 100 =head1 DESCRIPTION
 101
 102 An FS::cust_main object represents a customer.  FS::cust_main inherits from
 103 FS::Record.  The following fields are currently supported:
 104
 105 =over 4
 106
 107 =item custnum - primary key (assigned automatically for new customers)
 108
 109 =item agentnum - agent (see L<FS::agent>)
 110
 111 =item refnum - Advertising source (see L<FS::part_referral>)
 112
 113 =item first - name
 114
 115 =item last - name
 116
 117 =item ss - social security number (optional)
 118
 119 =item company - (optional)
 120
 121 =item address1
 122
 123 =item address2 - (optional)
 124
 125 =item city
 126
 127 =item county - (optional, see L<FS::cust_main_county>)
 128
 129 =item state - (see L<FS::cust_main_county>)
 130
 131 =item zip
 132
 133 =item country - (see L<FS::cust_main_county>)
 134
 135 =item daytime - phone (optional)
 136
 137 =item night - phone (optional)
 138
 139 =item fax - phone (optional)
 140
 141 =item ship_first - name
 142
 143 =item ship_last - name
 144
 145 =item ship_company - (optional)
 146
 147 =item ship_address1
 148
 149 =item ship_address2 - (optional)
 150
 151 =item ship_city
 152
 153 =item ship_county - (optional, see L<FS::cust_main_county>)
 154
 155 =item ship_state - (see L<FS::cust_main_county>)
 156
 157 =item ship_zip
 158
 159 =item ship_country - (see L<FS::cust_main_county>)
 160
 161 =item ship_daytime - phone (optional)
 162
 163 =item ship_night - phone (optional)
 164
 165 =item ship_fax - phone (optional)
 166
 167 =item payby - `CARD' (credit cards), `CHEK' (electronic check), `LECB' (Phone bill billing), `BILL' (billing), `COMP' (free), or `PREPAY' (special billing type: applies a credit - see L<FS::prepay_credit> and sets billing type to BILL)
 168
 169 =item payinfo - card number, P.O., comp issuer (4-8 lowercase alphanumerics; think username) or prepayment identifier (see L<FS::prepay_credit>)
 170
 171 =item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy
 172
 173 =item payname - name on card or billing name
 174
 175 =item tax - tax exempt, empty or `Y'
 176
 177 =item otaker - order taker (assigned automatically, see L<FS::UID>)
 178
 179 =item comments - comments (optional)
 180
 181 =back
 182
 183 =head1 METHODS
 184
 185 =over 4
 186
 187 =item new HASHREF
 188
 189 Creates a new customer.  To add the customer to the database, see L<"insert">.
 190
 191 Note that this stores the hash reference, not a distinct copy of the hash it
 192 points to.  You can ask the object for a copy with the I<hash> method.
 193
 194 =cut
 195
 196 sub table { 'cust_main'; }
 197
 198 =item insert [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
 199
 200 Adds this customer to the database.  If there is an error, returns the error,
 201 otherwise returns false.
 202
 203 CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert
 204 method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records
 205 are inserted atomicly, or the transaction is rolled back.  Passing an empty
 206 hash reference is equivalent to not supplying this parameter.  There should be
 207 a better explanation of this, but until then, here's an example:
 208
 209   use Tie::RefHash;
 210   tie %hash, 'Tie::RefHash'; #this part is important
 211   %hash = (
 212     $cust_pkg => [ $svc_acct ],
 213     ...
 214   );
 215   $cust_main->insert( \%hash );
 216
 217 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
 218 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
 219 expected and rollback the entire transaction; it is not necessary to call
 220 check_invoicing_list first.  The invoicing_list is set after the records in the
 221 CUST_PKG_HASHREF above are inserted, so it is now possible to set an
 222 invoicing_list destination to the newly-created svc_acct.  Here's an example:
 223
 224   $cust_main->insert( {}, [ $email, 'POST' ] );
 225
 226 Currently available options are: I<depend_jobnum> and I<noexport>.
 227
 228 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 229 on the supplied jobnum (they will not run until the specific job completes).
 230 This can be used to defer provisioning until some action completes (such
 231 as running the customer's credit card sucessfully).
 232
 233 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 234 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 235 the B<reexport> method.)
 236
 237 =cut
 238
 239 sub insert {
 240   my $self = shift;
 241   my $cust_pkgs = @_ ? shift : {};
 242   my $invoicing_list = @_ ? shift : '';
 243   my %options = @_;
 244   warn "FS::cust_main::insert called with options ".
 245        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 246     if $DEBUG;
 247
 248   local $SIG{HUP} = 'IGNORE';
 249   local $SIG{INT} = 'IGNORE';
 250   local $SIG{QUIT} = 'IGNORE';
 251   local $SIG{TERM} = 'IGNORE';
 252   local $SIG{TSTP} = 'IGNORE';
 253   local $SIG{PIPE} = 'IGNORE';
 254
 255   my $oldAutoCommit = $FS::UID::AutoCommit;
 256   local $FS::UID::AutoCommit = 0;
 257   my $dbh = dbh;
 258
 259   my $amount = 0;
 260   my $seconds = 0;
 261   if ( $self->payby eq 'PREPAY' ) {
 262     $self->payby('BILL');
 263     my $prepay_credit = qsearchs(
 264       'prepay_credit',
 265       { 'identifier' => $self->payinfo },
 266       '',
 267       'FOR UPDATE'
 268     );
 269     warn "WARNING: can't find pre-found prepay_credit: ". $self->payinfo
 270       unless $prepay_credit;
 271     $amount = $prepay_credit->amount;
 272     $seconds = $prepay_credit->seconds;
 273     my $error = $prepay_credit->delete;
 274     if ( $error ) {
 275       $dbh->rollback if $oldAutoCommit;
 276       return "removing prepay_credit (transaction rolled back): $error";
 277     }
 278   }
 279
 280   my $error = $self->SUPER::insert;
 281   if ( $error ) {
 282     $dbh->rollback if $oldAutoCommit;
 283     #return "inserting cust_main record (transaction rolled back): $error";
 284     return $error;
 285   }
 286
 287   # invoicing list
 288   if ( $invoicing_list ) {
 289     $error = $self->check_invoicing_list( $invoicing_list );
 290     if ( $error ) {
 291       $dbh->rollback if $oldAutoCommit;
 292       return "checking invoicing_list (transaction rolled back): $error";
 293     }
 294     $self->invoicing_list( $invoicing_list );
 295   }
 296
 297   # packages
 298   $error = $self->order_pkgs($cust_pkgs, \$seconds, %options);
 299   if ( $error ) {
 300     $dbh->rollback if $oldAutoCommit;
 301     return $error;
 302   }
 303
 304   if ( $seconds ) {
 305     $dbh->rollback if $oldAutoCommit;
 306     return "No svc_acct record to apply pre-paid time";
 307   }
 308
 309   if ( $amount ) {
 310     my $cust_credit = new FS::cust_credit {
 311       'custnum' => $self->custnum,
 312       'amount'  => $amount,
 313     };
 314     $error = $cust_credit->insert;
 315     if ( $error ) {
 316       $dbh->rollback if $oldAutoCommit;
 317       return "inserting credit (transaction rolled back): $error";
 318     }
 319   }
 320
 321   $error = $self->queue_fuzzyfiles_update;
 322   if ( $error ) {
 323     $dbh->rollback if $oldAutoCommit;
 324     return "updating fuzzy search cache: $error";
 325   }
 326
 327   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 328   '';
 329
 330 }
 331
 332 =item order_pkgs HASHREF, [ SECONDSREF, [ , OPTION => VALUE ... ] ]
 333
 334 Like the insert method on an existing record, this method orders a package
 335 and included services atomicaly.  Pass a Tie::RefHash data structure to this
 336 method containing FS::cust_pkg and FS::svc_I<tablename> objects.  There should
 337 be a better explanation of this, but until then, here's an example:
 338
 339   use Tie::RefHash;
 340   tie %hash, 'Tie::RefHash'; #this part is important
 341   %hash = (
 342     $cust_pkg => [ $svc_acct ],
 343     ...
 344   );
 345   $cust_main->order_pkgs( \%hash, \'0', 'noexport'=>1 );
 346
 347 Currently available options are: I<depend_jobnum> and I<noexport>.
 348
 349 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 350 on the supplied jobnum (they will not run until the specific job completes).
 351 This can be used to defer provisioning until some action completes (such
 352 as running the customer's credit card sucessfully).
 353
 354 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 355 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 356 the B<reexport> method for each cust_pkg object.  Using the B<reexport> method
 357 on the cust_main object is not recommended, as existing services will also be
 358 reexported.)
 359
 360 =cut
 361
 362 sub order_pkgs {
 363   my $self = shift;
 364   my $cust_pkgs = shift;
 365   my $seconds = shift;
 366   my %options = @_;
 367   my %svc_options = ();
 368   $svc_options{'depend_jobnum'} = $options{'depend_jobnum'}
 369     if exists $options{'depend_jobnum'};
 370   warn "FS::cust_main::order_pkgs called with options ".
 371        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 372     if $DEBUG;
 373
 374   local $SIG{HUP} = 'IGNORE';
 375   local $SIG{INT} = 'IGNORE';
 376   local $SIG{QUIT} = 'IGNORE';
 377   local $SIG{TERM} = 'IGNORE';
 378   local $SIG{TSTP} = 'IGNORE';
 379   local $SIG{PIPE} = 'IGNORE';
 380
 381   my $oldAutoCommit = $FS::UID::AutoCommit;
 382   local $FS::UID::AutoCommit = 0;
 383   my $dbh = dbh;
 384
 385   local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
 386
 387   foreach my $cust_pkg ( keys %$cust_pkgs ) {
 388     $cust_pkg->custnum( $self->custnum );
 389     my $error = $cust_pkg->insert;
 390     if ( $error ) {
 391       $dbh->rollback if $oldAutoCommit;
 392       return "inserting cust_pkg (transaction rolled back): $error";
 393     }
 394     foreach my $svc_something ( @{$cust_pkgs->{$cust_pkg}} ) {
 395       $svc_something->pkgnum( $cust_pkg->pkgnum );
 396       if ( $seconds && $$seconds && $svc_something->isa('FS::svc_acct') ) {
 397         $svc_something->seconds( $svc_something->seconds + $$seconds );
 398         $$seconds = 0;
 399       }
 400       $error = $svc_something->insert(%svc_options);
 401       if ( $error ) {
 402         $dbh->rollback if $oldAutoCommit;
 403         #return "inserting svc_ (transaction rolled back): $error";
 404         return $error;
 405       }
 406     }
 407   }
 408
 409   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 410   ''; #no error
 411 }
 412
 413 =item reexport
 414
 415 This method is deprecated.  See the I<depend_jobnum> option to the insert and
 416 order_pkgs methods for a better way to defer provisioning.
 417
 418 Re-schedules all exports by calling the B<reexport> method of all associated
 419 packages (see L<FS::cust_pkg>).  If there is an error, returns the error;
 420 otherwise returns false.
 421
 422 =cut
 423
 424 sub reexport {
 425   my $self = shift;
 426
 427   carp "warning: FS::cust_main::reexport is deprectated; ".
 428        "use the depend_jobnum option to insert or order_pkgs to delay export";
 429
 430   local $SIG{HUP} = 'IGNORE';
 431   local $SIG{INT} = 'IGNORE';
 432   local $SIG{QUIT} = 'IGNORE';
 433   local $SIG{TERM} = 'IGNORE';
 434   local $SIG{TSTP} = 'IGNORE';
 435   local $SIG{PIPE} = 'IGNORE';
 436
 437   my $oldAutoCommit = $FS::UID::AutoCommit;
 438   local $FS::UID::AutoCommit = 0;
 439   my $dbh = dbh;
 440
 441   foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
 442     my $error = $cust_pkg->reexport;
 443     if ( $error ) {
 444       $dbh->rollback if $oldAutoCommit;
 445       return $error;
 446     }
 447   }
 448
 449   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 450   '';
 451
 452 }
 453
 454 =item delete NEW_CUSTNUM
 455
 456 This deletes the customer.  If there is an error, returns the error, otherwise
 457 returns false.
 458
 459 This will completely remove all traces of the customer record.  This is not
 460 what you want when a customer cancels service; for that, cancel all of the
 461 customer's packages (see L</cancel>).
 462
 463 If the customer has any uncancelled packages, you need to pass a new (valid)
 464 customer number for those packages to be transferred to.  Cancelled packages
 465 will be deleted.  Did I mention that this is NOT what you want when a customer
 466 cancels service and that you really should be looking see L<FS::cust_pkg/cancel>?
 467
 468 You can't delete a customer with invoices (see L<FS::cust_bill>),
 469 or credits (see L<FS::cust_credit>), payments (see L<FS::cust_pay>) or
 470 refunds (see L<FS::cust_refund>).
 471
 472 =cut
 473
 474 sub delete {
 475   my $self = shift;
 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   if ( $self->cust_bill ) {
 489     $dbh->rollback if $oldAutoCommit;
 490     return "Can't delete a customer with invoices";
 491   }
 492   if ( $self->cust_credit ) {
 493     $dbh->rollback if $oldAutoCommit;
 494     return "Can't delete a customer with credits";
 495   }
 496   if ( $self->cust_pay ) {
 497     $dbh->rollback if $oldAutoCommit;
 498     return "Can't delete a customer with payments";
 499   }
 500   if ( $self->cust_refund ) {
 501     $dbh->rollback if $oldAutoCommit;
 502     return "Can't delete a customer with refunds";
 503   }
 504
 505   my @cust_pkg = $self->ncancelled_pkgs;
 506   if ( @cust_pkg ) {
 507     my $new_custnum = shift;
 508     unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) {
 509       $dbh->rollback if $oldAutoCommit;
 510       return "Invalid new customer number: $new_custnum";
 511     }
 512     foreach my $cust_pkg ( @cust_pkg ) {
 513       my %hash = $cust_pkg->hash;
 514       $hash{'custnum'} = $new_custnum;
 515       my $new_cust_pkg = new FS::cust_pkg ( \%hash );
 516       my $error = $new_cust_pkg->replace($cust_pkg);
 517       if ( $error ) {
 518         $dbh->rollback if $oldAutoCommit;
 519         return $error;
 520       }
 521     }
 522   }
 523   my @cancelled_cust_pkg = $self->all_pkgs;
 524   foreach my $cust_pkg ( @cancelled_cust_pkg ) {
 525     my $error = $cust_pkg->delete;
 526     if ( $error ) {
 527       $dbh->rollback if $oldAutoCommit;
 528       return $error;
 529     }
 530   }
 531
 532   foreach my $cust_main_invoice ( #(email invoice destinations, not invoices)
 533     qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } )
 534   ) {
 535     my $error = $cust_main_invoice->delete;
 536     if ( $error ) {
 537       $dbh->rollback if $oldAutoCommit;
 538       return $error;
 539     }
 540   }
 541
 542   my $error = $self->SUPER::delete;
 543   if ( $error ) {
 544     $dbh->rollback if $oldAutoCommit;
 545     return $error;
 546   }
 547
 548   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 549   '';
 550
 551 }
 552
 553 =item replace OLD_RECORD [ INVOICING_LIST_ARYREF ]
 554
 555 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 556 returns the error, otherwise returns false.
 557
 558 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
 559 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
 560 expected and rollback the entire transaction; it is not necessary to call
 561 check_invoicing_list first.  Here's an example:
 562
 563   $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
 564
 565 =cut
 566
 567 sub replace {
 568   my $self = shift;
 569   my $old = shift;
 570   my @param = @_;
 571
 572   local $SIG{HUP} = 'IGNORE';
 573   local $SIG{INT} = 'IGNORE';
 574   local $SIG{QUIT} = 'IGNORE';
 575   local $SIG{TERM} = 'IGNORE';
 576   local $SIG{TSTP} = 'IGNORE';
 577   local $SIG{PIPE} = 'IGNORE';
 578
 579   if ( $self->payby eq 'COMP' && $self->payby ne $old->payby
 580        && $conf->config('users-allow_comp')                  ) {
 581     return "You are not permitted to create complimentary accounts."
 582       unless grep { $_ eq getotaker } $conf->config('users-allow_comp');
 583   }
 584
 585   my $oldAutoCommit = $FS::UID::AutoCommit;
 586   local $FS::UID::AutoCommit = 0;
 587   my $dbh = dbh;
 588
 589   my $error = $self->SUPER::replace($old);
 590
 591   if ( $error ) {
 592     $dbh->rollback if $oldAutoCommit;
 593     return $error;
 594   }
 595
 596   if ( @param ) { # INVOICING_LIST_ARYREF
 597     my $invoicing_list = shift @param;
 598     $error = $self->check_invoicing_list( $invoicing_list );
 599     if ( $error ) {
 600       $dbh->rollback if $oldAutoCommit;
 601       return $error;
 602     }
 603     $self->invoicing_list( $invoicing_list );
 604   }
 605
 606   if ( $self->payby =~ /^(CARD|CHEK|LECB)$/ &&
 607        grep { $self->get($_) ne $old->get($_) } qw(payinfo paydate payname) ) {
 608     # card/check/lec info has changed, want to retry realtime_ invoice events
 609     my $error = $self->retry_realtime;
 610     if ( $error ) {
 611       $dbh->rollback if $oldAutoCommit;
 612       return $error;
 613     }
 614   }
 615
 616   $error = $self->queue_fuzzyfiles_update;
 617   if ( $error ) {
 618     $dbh->rollback if $oldAutoCommit;
 619     return "updating fuzzy search cache: $error";
 620   }
 621
 622   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 623   '';
 624
 625 }
 626
 627 =item queue_fuzzyfiles_update
 628
 629 Used by insert & replace to update the fuzzy search cache
 630
 631 =cut
 632
 633 sub queue_fuzzyfiles_update {
 634   my $self = shift;
 635
 636   local $SIG{HUP} = 'IGNORE';
 637   local $SIG{INT} = 'IGNORE';
 638   local $SIG{QUIT} = 'IGNORE';
 639   local $SIG{TERM} = 'IGNORE';
 640   local $SIG{TSTP} = 'IGNORE';
 641   local $SIG{PIPE} = 'IGNORE';
 642
 643   my $oldAutoCommit = $FS::UID::AutoCommit;
 644   local $FS::UID::AutoCommit = 0;
 645   my $dbh = dbh;
 646
 647   my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
 648   my $error = $queue->insert($self->getfield('last'), $self->company);
 649   if ( $error ) {
 650     $dbh->rollback if $oldAutoCommit;
 651     return "queueing job (transaction rolled back): $error";
 652   }
 653
 654   if ( defined $self->dbdef_table->column('ship_last') && $self->ship_last ) {
 655     $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
 656     $error = $queue->insert($self->getfield('ship_last'), $self->ship_company);
 657     if ( $error ) {
 658       $dbh->rollback if $oldAutoCommit;
 659       return "queueing job (transaction rolled back): $error";
 660     }
 661   }
 662
 663   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 664   '';
 665
 666 }
 667
 668 =item check
 669
 670 Checks all fields to make sure this is a valid customer record.  If there is
 671 an error, returns the error, otherwise returns false.  Called by the insert
 672 and repalce methods.
 673
 674 =cut
 675
 676 sub check {
 677   my $self = shift;
 678
 679   #warn "BEFORE: \n". $self->_dump;
 680
 681   my $error =
 682     $self->ut_numbern('custnum')
 683     || $self->ut_number('agentnum')
 684     || $self->ut_number('refnum')
 685     || $self->ut_name('last')
 686     || $self->ut_name('first')
 687     || $self->ut_textn('company')
 688     || $self->ut_text('address1')
 689     || $self->ut_textn('address2')
 690     || $self->ut_text('city')
 691     || $self->ut_textn('county')
 692     || $self->ut_textn('state')
 693     || $self->ut_country('country')
 694     || $self->ut_anything('comments')
 695     || $self->ut_numbern('referral_custnum')
 696   ;
 697   #barf.  need message catalogs.  i18n.  etc.
 698   $error .= "Please select an advertising source."
 699     if $error =~ /^Illegal or empty \(numeric\) refnum: /;
 700   return $error if $error;
 701
 702   return "Unknown agent"
 703     unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
 704
 705   return "Unknown refnum"
 706     unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } );
 707
 708   return "Unknown referring custnum ". $self->referral_custnum
 709     unless ! $self->referral_custnum
 710            || qsearchs( 'cust_main', { 'custnum' => $self->referral_custnum } );
 711
 712   if ( $self->ss eq '' ) {
 713     $self->ss('');
 714   } else {
 715     my $ss = $self->ss;
 716     $ss =~ s/\D//g;
 717     $ss =~ /^(\d{3})(\d{2})(\d{4})$/
 718       or return "Illegal social security number: ". $self->ss;
 719     $self->ss("$1-$2-$3");
 720   }
 721
 722
 723 # bad idea to disable, causes billing to fail because of no tax rates later
 724 #  unless ( $import ) {
 725     unless ( qsearch('cust_main_county', {
 726       'country' => $self->country,
 727       'state'   => '',
 728      } ) ) {
 729       return "Unknown state/county/country: ".
 730         $self->state. "/". $self->county. "/". $self->country
 731         unless qsearch('cust_main_county',{
 732           'state'   => $self->state,
 733           'county'  => $self->county,
 734           'country' => $self->country,
 735         } );
 736     }
 737 #  }
 738
 739   $error =
 740     $self->ut_phonen('daytime', $self->country)
 741     || $self->ut_phonen('night', $self->country)
 742     || $self->ut_phonen('fax', $self->country)
 743     || $self->ut_zip('zip', $self->country)
 744   ;
 745   return $error if $error;
 746
 747   my @addfields = qw(
 748     last first company address1 address2 city county state zip
 749     country daytime night fax
 750   );
 751
 752   if ( defined $self->dbdef_table->column('ship_last') ) {
 753     if ( scalar ( grep { $self->getfield($_) ne $self->getfield("ship_$_") }
 754                        @addfields )
 755          && scalar ( grep { $self->getfield("ship_$_") ne '' } @addfields )
 756        )
 757     {
 758       my $error =
 759         $self->ut_name('ship_last')
 760         || $self->ut_name('ship_first')
 761         || $self->ut_textn('ship_company')
 762         || $self->ut_text('ship_address1')
 763         || $self->ut_textn('ship_address2')
 764         || $self->ut_text('ship_city')
 765         || $self->ut_textn('ship_county')
 766         || $self->ut_textn('ship_state')
 767         || $self->ut_country('ship_country')
 768       ;
 769       return $error if $error;
 770
 771       #false laziness with above
 772       unless ( qsearchs('cust_main_county', {
 773         'country' => $self->ship_country,
 774         'state'   => '',
 775        } ) ) {
 776         return "Unknown ship_state/ship_county/ship_country: ".
 777           $self->ship_state. "/". $self->ship_county. "/". $self->ship_country
 778           unless qsearchs('cust_main_county',{
 779             'state'   => $self->ship_state,
 780             'county'  => $self->ship_county,
 781             'country' => $self->ship_country,
 782           } );
 783       }
 784       #eofalse
 785
 786       $error =
 787         $self->ut_phonen('ship_daytime', $self->ship_country)
 788         || $self->ut_phonen('ship_night', $self->ship_country)
 789         || $self->ut_phonen('ship_fax', $self->ship_country)
 790         || $self->ut_zip('ship_zip', $self->ship_country)
 791       ;
 792       return $error if $error;
 793
 794     } else { # ship_ info eq billing info, so don't store dup info in database
 795       $self->setfield("ship_$_", '')
 796         foreach qw( last first company address1 address2 city county state zip
 797                     country daytime night fax );
 798     }
 799   }
 800
 801   $self->payby =~ /^(CARD|CHEK|LECB|BILL|COMP|PREPAY)$/
 802     or return "Illegal payby: ". $self->payby;
 803   $self->payby($1);
 804
 805   if ( $self->payby eq 'CARD' ) {
 806
 807     my $payinfo = $self->payinfo;
 808     $payinfo =~ s/\D//g;
 809     $payinfo =~ /^(\d{13,16})$/
 810       or return gettext('invalid_card'); # . ": ". $self->payinfo;
 811     $payinfo = $1;
 812     $self->payinfo($payinfo);
 813     validate($payinfo)
 814       or return gettext('invalid_card'); # . ": ". $self->payinfo;
 815     return gettext('unknown_card_type')
 816       if cardtype($self->payinfo) eq "Unknown";
 817     if ( defined $self->dbdef_table->column('paycvv') ) {
 818       if ( length($self->paycvv) ) {
 819         if ( cardtype($self->payinfo) eq 'American Express card' ) {
 820           $self->paycvv =~ /^(\d{4})$/
 821             or return "CVV2 (CID) for American Express cards is four digits.";
 822           $self->paycvv($1);
 823         } else {
 824           $self->paycvv =~ /^(\d{3})$/
 825             or return "CVV2 (CVC2/CID) is three digits.";
 826           $self->paycvv($1);
 827         }
 828       } else {
 829         $self->paycvv('');
 830       }
 831     }
 832
 833   } elsif ( $self->payby eq 'CHEK' ) {
 834
 835     my $payinfo = $self->payinfo;
 836     $payinfo =~ s/[^\d\@]//g;
 837     $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba';
 838     $payinfo = "$1\@$2";
 839     $self->payinfo($payinfo);
 840     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 841
 842   } elsif ( $self->payby eq 'LECB' ) {
 843
 844     my $payinfo = $self->payinfo;
 845     $payinfo =~ s/\D//g;
 846     $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number';
 847     $payinfo = $1;
 848     $self->payinfo($payinfo);
 849     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 850
 851   } elsif ( $self->payby eq 'BILL' ) {
 852
 853     $error = $self->ut_textn('payinfo');
 854     return "Illegal P.O. number: ". $self->payinfo if $error;
 855     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 856
 857   } elsif ( $self->payby eq 'COMP' ) {
 858
 859     if ( !$self->custnum && $conf->config('users-allow_comp') ) {
 860       return "You are not permitted to create complimentary accounts."
 861         unless grep { $_ eq getotaker } $conf->config('users-allow_comp');
 862     }
 863
 864     $error = $self->ut_textn('payinfo');
 865     return "Illegal comp account issuer: ". $self->payinfo if $error;
 866     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 867
 868   } elsif ( $self->payby eq 'PREPAY' ) {
 869
 870     my $payinfo = $self->payinfo;
 871     $payinfo =~ s/\W//g; #anything else would just confuse things
 872     $self->payinfo($payinfo);
 873     $error = $self->ut_alpha('payinfo');
 874     return "Illegal prepayment identifier: ". $self->payinfo if $error;
 875     return "Unknown prepayment identifier"
 876       unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } );
 877     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 878
 879   }
 880
 881   if ( $self->paydate eq '' || $self->paydate eq '-' ) {
 882     return "Expriation date required"
 883       unless $self->payby =~ /^(BILL|PREPAY|CHEK|LECB)$/;
 884     $self->paydate('');
 885   } else {
 886     $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/
 887       or return "Illegal expiration date: ". $self->paydate;
 888     my $y = length($2) == 4 ? $2 : "20$2";
 889     $self->paydate("$y-$1-01");
 890     my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
 891     return gettext('expired_card')
 892       if !$import && ( $y<$nowy || ( $y==$nowy && $1<$nowm ) );
 893   }
 894
 895   if ( $self->payname eq '' && $self->payby ne 'CHEK' &&
 896        ( ! $conf->exists('require_cardname') || $self->payby ne 'CARD' ) ) {
 897     $self->payname( $self->first. " ". $self->getfield('last') );
 898   } else {
 899     $self->payname =~ /^([\w \,\.\-\']+)$/
 900       or return gettext('illegal_name'). " payname: ". $self->payname;
 901     $self->payname($1);
 902   }
 903
 904   $self->tax =~ /^(Y?)$/ or return "Illegal tax: ". $self->tax;
 905   $self->tax($1);
 906
 907   $self->otaker(getotaker) unless $self->otaker;
 908
 909   #warn "AFTER: \n". $self->_dump;
 910
 911   ''; #no error
 912 }
 913
 914 =item all_pkgs
 915
 916 Returns all packages (see L<FS::cust_pkg>) for this customer.
 917
 918 =cut
 919
 920 sub all_pkgs {
 921   my $self = shift;
 922   if ( $self->{'_pkgnum'} ) {
 923     values %{ $self->{'_pkgnum'}->cache };
 924   } else {
 925     qsearch( 'cust_pkg', { 'custnum' => $self->custnum });
 926   }
 927 }
 928
 929 =item ncancelled_pkgs
 930
 931 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
 932
 933 =cut
 934
 935 sub ncancelled_pkgs {
 936   my $self = shift;
 937   if ( $self->{'_pkgnum'} ) {
 938     grep { ! $_->getfield('cancel') } values %{ $self->{'_pkgnum'}->cache };
 939   } else {
 940     @{ [ # force list context
 941       qsearch( 'cust_pkg', {
 942         'custnum' => $self->custnum,
 943         'cancel'  => '',
 944       }),
 945       qsearch( 'cust_pkg', {
 946         'custnum' => $self->custnum,
 947         'cancel'  => 0,
 948       }),
 949     ] };
 950   }
 951 }
 952
 953 =item suspended_pkgs
 954
 955 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
 956
 957 =cut
 958
 959 sub suspended_pkgs {
 960   my $self = shift;
 961   grep { $_->susp } $self->ncancelled_pkgs;
 962 }
 963
 964 =item unflagged_suspended_pkgs
 965
 966 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
 967 customer (thouse packages without the `manual_flag' set).
 968
 969 =cut
 970
 971 sub unflagged_suspended_pkgs {
 972   my $self = shift;
 973   return $self->suspended_pkgs
 974     unless dbdef->table('cust_pkg')->column('manual_flag');
 975   grep { ! $_->manual_flag } $self->suspended_pkgs;
 976 }
 977
 978 =item unsuspended_pkgs
 979
 980 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
 981 this customer.
 982
 983 =cut
 984
 985 sub unsuspended_pkgs {
 986   my $self = shift;
 987   grep { ! $_->susp } $self->ncancelled_pkgs;
 988 }
 989
 990 =item unsuspend
 991
 992 Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
 993 and L<FS::cust_pkg>) for this customer.  Always returns a list: an empty list
 994 on success or a list of errors.
 995
 996 =cut
 997
 998 sub unsuspend {
 999   my $self = shift;
1000   grep { $_->unsuspend } $self->suspended_pkgs;
1001 }
1002
1003 =item suspend
1004
1005 Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
1006 Always returns a list: an empty list on success or a list of errors.
1007
1008 =cut
1009
1010 sub suspend {
1011   my $self = shift;
1012   grep { $_->suspend } $self->unsuspended_pkgs;
1013 }
1014
1015 =item suspend_if_pkgpart PKGPART [ , PKGPART ... ]
1016
1017 Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
1018 PKGPARTs (see L<FS::part_pkg>).  Always returns a list: an empty list on
1019 success or a list of errors.
1020
1021 =cut
1022
1023 sub suspend_if_pkgpart {
1024   my $self = shift;
1025   my @pkgparts = @_;
1026   grep { $_->suspend }
1027     grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
1028       $self->unsuspended_pkgs;
1029 }
1030
1031 =item suspend_unless_pkgpart PKGPART [ , PKGPART ... ]
1032
1033 Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
1034 listed PKGPARTs (see L<FS::part_pkg>).  Always returns a list: an empty list
1035 on success or a list of errors.
1036
1037 =cut
1038
1039 sub suspend_unless_pkgpart {
1040   my $self = shift;
1041   my @pkgparts = @_;
1042   grep { $_->suspend }
1043     grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
1044       $self->unsuspended_pkgs;
1045 }
1046
1047 =item cancel [ OPTION => VALUE ... ]
1048
1049 Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
1050
1051 Available options are: I<quiet>
1052
1053 I<quiet> can be set true to supress email cancellation notices.
1054
1055 Always returns a list: an empty list on success or a list of errors.
1056
1057 =cut
1058
1059 sub cancel {
1060   my $self = shift;
1061   grep { $_ } map { $_->cancel(@_) } $self->ncancelled_pkgs;
1062 }
1063
1064 =item agent
1065
1066 Returns the agent (see L<FS::agent>) for this customer.
1067
1068 =cut
1069
1070 sub agent {
1071   my $self = shift;
1072   qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1073 }
1074
1075 =item bill OPTIONS
1076
1077 Generates invoices (see L<FS::cust_bill>) for this customer.  Usually used in
1078 conjunction with the collect method.
1079
1080 Options are passed as name-value pairs.
1081
1082 Currently available options are:
1083
1084 resetup - if set true, re-charges setup fees.
1085
1086 time - bills the customer as if it were that time.  Specified as a UNIX
1087 timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and
1088 L<Date::Parse> for conversion functions.  For example:
1089
1090  use Date::Parse;
1091  ...
1092  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
1093
1094
1095 If there is an error, returns the error, otherwise returns false.
1096
1097 =cut
1098
1099 sub bill {
1100   my( $self, %options ) = @_;
1101   my $time = $options{'time'} || time;
1102
1103   my $error;
1104
1105   #put below somehow?
1106   local $SIG{HUP} = 'IGNORE';
1107   local $SIG{INT} = 'IGNORE';
1108   local $SIG{QUIT} = 'IGNORE';
1109   local $SIG{TERM} = 'IGNORE';
1110   local $SIG{TSTP} = 'IGNORE';
1111   local $SIG{PIPE} = 'IGNORE';
1112
1113   my $oldAutoCommit = $FS::UID::AutoCommit;
1114   local $FS::UID::AutoCommit = 0;
1115   my $dbh = dbh;
1116
1117   $self->select_for_update; #mutex
1118
1119   # find the packages which are due for billing, find out how much they are
1120   # & generate invoice database.
1121
1122   my( $total_setup, $total_recur ) = ( 0, 0 );
1123   #my( $taxable_setup, $taxable_recur ) = ( 0, 0 );
1124   my @cust_bill_pkg = ();
1125   #my $tax = 0;##
1126   #my $taxable_charged = 0;##
1127   #my $charged = 0;##
1128
1129   my %tax;
1130
1131   foreach my $cust_pkg (
1132     qsearch('cust_pkg', { 'custnum' => $self->custnum } )
1133   ) {
1134
1135     #NO!! next if $cust_pkg->cancel;
1136     next if $cust_pkg->getfield('cancel');
1137
1138     #? to avoid use of uninitialized value errors... ?
1139     $cust_pkg->setfield('bill', '')
1140       unless defined($cust_pkg->bill);
1141
1142     my $part_pkg = $cust_pkg->part_pkg;
1143
1144     #so we don't modify cust_pkg record unnecessarily
1145     my $cust_pkg_mod_flag = 0;
1146     my %hash = $cust_pkg->hash;
1147     my $old_cust_pkg = new FS::cust_pkg \%hash;
1148
1149     # bill setup
1150     my $setup = 0;
1151     if ( !$cust_pkg->setup || $options{'resetup'} ) {
1152       my $setup_prog = $part_pkg->getfield('setup');
1153       $setup_prog =~ /^(.*)$/ or do {
1154         $dbh->rollback if $oldAutoCommit;
1155         return "Illegal setup for pkgpart ". $part_pkg->pkgpart.
1156                ": $setup_prog";
1157       };
1158       $setup_prog = $1;
1159       $setup_prog = '0' if $setup_prog =~ /^\s*$/;
1160
1161         #my $cpt = new Safe;
1162         ##$cpt->permit(); #what is necessary?
1163         #$cpt->share(qw( $cust_pkg )); #can $cpt now use $cust_pkg methods?
1164         #$setup = $cpt->reval($setup_prog);
1165       $setup = eval $setup_prog;
1166       unless ( defined($setup) ) {
1167         $dbh->rollback if $oldAutoCommit;
1168         return "Error eval-ing part_pkg->setup pkgpart ". $part_pkg->pkgpart.
1169                "(expression $setup_prog): $@";
1170       }
1171       $cust_pkg->setfield('setup', $time) unless $cust_pkg->setup;
1172       $cust_pkg_mod_flag=1;
1173     }
1174
1175     #bill recurring fee
1176     my $recur = 0;
1177     my $sdate;
1178     if ( $part_pkg->getfield('freq') ne '0' &&
1179          ! $cust_pkg->getfield('susp') &&
1180          ( $cust_pkg->getfield('bill') || 0 ) <= $time
1181     ) {
1182       my $recur_prog = $part_pkg->getfield('recur');
1183       $recur_prog =~ /^(.*)$/ or do {
1184         $dbh->rollback if $oldAutoCommit;
1185         return "Illegal recur for pkgpart ". $part_pkg->pkgpart.
1186                ": $recur_prog";
1187       };
1188       $recur_prog = $1;
1189       $recur_prog = '0' if $recur_prog =~ /^\s*$/;
1190
1191       # shared with $recur_prog
1192       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
1193
1194         #my $cpt = new Safe;
1195         ##$cpt->permit(); #what is necessary?
1196         #$cpt->share(qw( $cust_pkg )); #can $cpt now use $cust_pkg methods?
1197         #$recur = $cpt->reval($recur_prog);
1198       $recur = eval $recur_prog;
1199       unless ( defined($recur) ) {
1200         $dbh->rollback if $oldAutoCommit;
1201         return "Error eval-ing part_pkg->recur pkgpart ".  $part_pkg->pkgpart.
1202                "(expression $recur_prog): $@";
1203       }
1204       #change this bit to use Date::Manip? CAREFUL with timezones (see
1205       # mailing list archive)
1206       my ($sec,$min,$hour,$mday,$mon,$year) =
1207         (localtime($sdate) )[0,1,2,3,4,5];
1208
1209       #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
1210       # only for figuring next bill date, nothing else, so, reset $sdate again
1211       # here
1212       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
1213       $cust_pkg->last_bill($sdate)
1214         if $cust_pkg->dbdef_table->column('last_bill');
1215
1216       if ( $part_pkg->freq =~ /^\d+$/ ) {
1217         $mon += $part_pkg->freq;
1218         until ( $mon < 12 ) { $mon -= 12; $year++; }
1219       } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
1220         my $weeks = $1;
1221         $mday += $weeks * 7;
1222       } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
1223         my $days = $1;
1224         $mday += $days;
1225       } else {
1226         $dbh->rollback if $oldAutoCommit;
1227         return "unparsable frequency: ". $part_pkg->freq;
1228       }
1229       $cust_pkg->setfield('bill',
1230         timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
1231       $cust_pkg_mod_flag = 1;
1232     }
1233
1234     warn "\$setup is undefined" unless defined($setup);
1235     warn "\$recur is undefined" unless defined($recur);
1236     warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
1237
1238     if ( $cust_pkg_mod_flag ) {
1239       $error=$cust_pkg->replace($old_cust_pkg);
1240       if ( $error ) { #just in case
1241         $dbh->rollback if $oldAutoCommit;
1242         return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error";
1243       }
1244       $setup = sprintf( "%.2f", $setup );
1245       $recur = sprintf( "%.2f", $recur );
1246       if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
1247         $dbh->rollback if $oldAutoCommit;
1248         return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
1249       }
1250       if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
1251         $dbh->rollback if $oldAutoCommit;
1252         return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
1253       }
1254       if ( $setup != 0 || $recur != 0 ) {
1255         my $cust_bill_pkg = new FS::cust_bill_pkg ({
1256           'pkgnum' => $cust_pkg->pkgnum,
1257           'setup'  => $setup,
1258           'recur'  => $recur,
1259           'sdate'  => $sdate,
1260           'edate'  => $cust_pkg->bill,
1261         });
1262         push @cust_bill_pkg, $cust_bill_pkg;
1263         $total_setup += $setup;
1264         $total_recur += $recur;
1265
1266         unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
1267
1268           my @taxes = qsearch( 'cust_main_county', {
1269                                  'state'    => $self->state,
1270                                  'county'   => $self->county,
1271                                  'country'  => $self->country,
1272                                  'taxclass' => $part_pkg->taxclass,
1273                                                                       } );
1274           unless ( @taxes ) {
1275             @taxes =  qsearch( 'cust_main_county', {
1276                                   'state'    => $self->state,
1277                                   'county'   => $self->county,
1278                                   'country'  => $self->country,
1279                                   'taxclass' => '',
1280                                                                       } );
1281           }
1282
1283           #one more try at a whole-country tax rate
1284           unless ( @taxes ) {
1285             @taxes =  qsearch( 'cust_main_county', {
1286                                   'state'    => '',
1287                                   'county'   => '',
1288                                   'country'  => $self->country,
1289                                   'taxclass' => '',
1290                                                                       } );
1291           }
1292
1293           # maybe eliminate this entirely, along with all the 0% records
1294           unless ( @taxes ) {
1295             $dbh->rollback if $oldAutoCommit;
1296             return
1297               "fatal: can't find tax rate for state/county/country/taxclass ".
1298               join('/', ( map $self->$_(), qw(state county country) ),
1299                         $part_pkg->taxclass ).  "\n";
1300           }
1301
1302           foreach my $tax ( @taxes ) {
1303
1304             my $taxable_charged = 0;
1305             $taxable_charged += $setup
1306               unless $part_pkg->setuptax =~ /^Y$/i
1307                   || $tax->setuptax =~ /^Y$/i;
1308             $taxable_charged += $recur
1309               unless $part_pkg->recurtax =~ /^Y$/i
1310                   || $tax->recurtax =~ /^Y$/i;
1311             next unless $taxable_charged;
1312
1313             if ( $tax->exempt_amount > 0 ) {
1314               my ($mon,$year) = (localtime($sdate) )[4,5];
1315               $mon++;
1316               my $freq = $part_pkg->freq || 1;
1317               if ( $freq !~ /(\d+)$/ ) {
1318                 $dbh->rollback if $oldAutoCommit;
1319                 return "daily/weekly package definitions not (yet?)".
1320                        " compatible with monthly tax exemptions";
1321               }
1322               my $taxable_per_month = sprintf("%.2f", $taxable_charged / $freq );
1323               foreach my $which_month ( 1 .. $freq ) {
1324                 my %hash = (
1325                   'custnum' => $self->custnum,
1326                   'taxnum'  => $tax->taxnum,
1327                   'year'    => 1900+$year,
1328                   'month'   => $mon++,
1329                 );
1330                 #until ( $mon < 12 ) { $mon -= 12; $year++; }
1331                 until ( $mon < 13 ) { $mon -= 12; $year++; }
1332                 my $cust_tax_exempt =
1333                   qsearchs('cust_tax_exempt', \%hash)
1334                   || new FS::cust_tax_exempt( { %hash, 'amount' => 0 } );
1335                 my $remaining_exemption = sprintf("%.2f",
1336                   $tax->exempt_amount - $cust_tax_exempt->amount );
1337                 if ( $remaining_exemption > 0 ) {
1338                   my $addl = $remaining_exemption > $taxable_per_month
1339                     ? $taxable_per_month
1340                     : $remaining_exemption;
1341                   $taxable_charged -= $addl;
1342                   my $new_cust_tax_exempt = new FS::cust_tax_exempt ( {
1343                     $cust_tax_exempt->hash,
1344                     'amount' =>
1345                       sprintf("%.2f", $cust_tax_exempt->amount + $addl),
1346                   } );
1347                   $error = $new_cust_tax_exempt->exemptnum
1348                     ? $new_cust_tax_exempt->replace($cust_tax_exempt)
1349                     : $new_cust_tax_exempt->insert;
1350                   if ( $error ) {
1351                     $dbh->rollback if $oldAutoCommit;
1352                     return "fatal: can't update cust_tax_exempt: $error";
1353                   }
1354
1355                 } # if $remaining_exemption > 0
1356
1357               } #foreach $which_month
1358
1359             } #if $tax->exempt_amount
1360
1361             $taxable_charged = sprintf( "%.2f", $taxable_charged);
1362
1363             #$tax += $taxable_charged * $cust_main_county->tax / 100
1364             $tax{ $tax->taxname || 'Tax' } +=
1365               $taxable_charged * $tax->tax / 100
1366
1367           } #foreach my $tax ( @taxes )
1368
1369         } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
1370
1371       } #if $setup != 0 || $recur != 0
1372
1373     } #if $cust_pkg_mod_flag
1374
1375   } #foreach my $cust_pkg
1376
1377   my $charged = sprintf( "%.2f", $total_setup + $total_recur );
1378 #  my $taxable_charged = sprintf( "%.2f", $taxable_setup + $taxable_recur );
1379
1380   unless ( @cust_bill_pkg ) { #don't create invoices with no line items
1381     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1382     return '';
1383   }
1384
1385 #  unless ( $self->tax =~ /Y/i
1386 #           || $self->payby eq 'COMP'
1387 #           || $taxable_charged == 0 ) {
1388 #    my $cust_main_county = qsearchs('cust_main_county',{
1389 #        'state'   => $self->state,
1390 #        'county'  => $self->county,
1391 #        'country' => $self->country,
1392 #    } ) or die "fatal: can't find tax rate for state/county/country ".
1393 #               $self->state. "/". $self->county. "/". $self->country. "\n";
1394 #    my $tax = sprintf( "%.2f",
1395 #      $taxable_charged * ( $cust_main_county->getfield('tax') / 100 )
1396 #    );
1397
1398   if ( dbdef->table('cust_bill_pkg')->column('itemdesc') ) { #1.5 schema
1399
1400     foreach my $taxname ( grep { $tax{$_} > 0 } keys %tax ) {
1401       my $tax = sprintf("%.2f", $tax{$taxname} );
1402       $charged = sprintf( "%.2f", $charged+$tax );
1403
1404       my $cust_bill_pkg = new FS::cust_bill_pkg ({
1405         'pkgnum'   => 0,
1406         'setup'    => $tax,
1407         'recur'    => 0,
1408         'sdate'    => '',
1409         'edate'    => '',
1410         'itemdesc' => $taxname,
1411       });
1412       push @cust_bill_pkg, $cust_bill_pkg;
1413     }
1414
1415   } else { #1.4 schema
1416
1417     my $tax = 0;
1418     foreach ( values %tax ) { $tax += $_ };
1419     $tax = sprintf("%.2f", $tax);
1420     if ( $tax > 0 ) {
1421       $charged = sprintf( "%.2f", $charged+$tax );
1422
1423       my $cust_bill_pkg = new FS::cust_bill_pkg ({
1424         'pkgnum' => 0,
1425         'setup'  => $tax,
1426         'recur'  => 0,
1427         'sdate'  => '',
1428         'edate'  => '',
1429       });
1430       push @cust_bill_pkg, $cust_bill_pkg;
1431     }
1432
1433   }
1434
1435   my $cust_bill = new FS::cust_bill ( {
1436     'custnum' => $self->custnum,
1437     '_date'   => $time,
1438     'charged' => $charged,
1439   } );
1440   $error = $cust_bill->insert;
1441   if ( $error ) {
1442     $dbh->rollback if $oldAutoCommit;
1443     return "can't create invoice for customer #". $self->custnum. ": $error";
1444   }
1445
1446   my $invnum = $cust_bill->invnum;
1447   my $cust_bill_pkg;
1448   foreach $cust_bill_pkg ( @cust_bill_pkg ) {
1449     #warn $invnum;
1450     $cust_bill_pkg->invnum($invnum);
1451     $error = $cust_bill_pkg->insert;
1452     if ( $error ) {
1453       $dbh->rollback if $oldAutoCommit;
1454       return "can't create invoice line item for customer #". $self->custnum.
1455              ": $error";
1456     }
1457   }
1458
1459   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1460   ''; #no error
1461 }
1462
1463 =item collect OPTIONS
1464
1465 (Attempt to) collect money for this customer's outstanding invoices (see
1466 L<FS::cust_bill>).  Usually used after the bill method.
1467
1468 Depending on the value of `payby', this may print an invoice (`BILL'), charge
1469 a credit card (`CARD'), or just add any necessary (pseudo-)payment (`COMP').
1470
1471 Most actions are now triggered by invoice events; see L<FS::part_bill_event>
1472 and the invoice events web interface.
1473
1474 If there is an error, returns the error, otherwise returns false.
1475
1476 Options are passed as name-value pairs.
1477
1478 Currently available options are:
1479
1480 invoice_time - Use this time when deciding when to print invoices and
1481 late notices on those invoices.  The default is now.  It is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse>
1482 for conversion functions.
1483
1484 retry - Retry card/echeck/LEC transactions even when not scheduled by invoice
1485 events.
1486
1487 retry_card - Deprecated alias for 'retry'
1488
1489 batch_card - This option is deprecated.  See the invoice events web interface
1490 to control whether cards are batched or run against a realtime gateway.
1491
1492 report_badcard - This option is deprecated.
1493
1494 force_print - This option is deprecated; see the invoice events web interface.
1495
1496 quiet - set true to surpress email card/ACH decline notices.
1497
1498 =cut
1499
1500 sub collect {
1501   my( $self, %options ) = @_;
1502   my $invoice_time = $options{'invoice_time'} || time;
1503
1504   #put below somehow?
1505   local $SIG{HUP} = 'IGNORE';
1506   local $SIG{INT} = 'IGNORE';
1507   local $SIG{QUIT} = 'IGNORE';
1508   local $SIG{TERM} = 'IGNORE';
1509   local $SIG{TSTP} = 'IGNORE';
1510   local $SIG{PIPE} = 'IGNORE';
1511
1512   my $oldAutoCommit = $FS::UID::AutoCommit;
1513   local $FS::UID::AutoCommit = 0;
1514   my $dbh = dbh;
1515
1516   $self->select_for_update; #mutex
1517
1518   my $balance = $self->balance;
1519   warn "collect customer". $self->custnum. ": balance $balance" if $DEBUG;
1520   unless ( $balance > 0 ) { #redundant?????
1521     $dbh->rollback if $oldAutoCommit; #hmm
1522     return '';
1523   }
1524
1525   if ( exists($options{'retry_card'}) ) {
1526     carp 'retry_card option passed to collect is deprecated; use retry';
1527     $options{'retry'} ||= $options{'retry_card'};
1528   }
1529   if ( exists($options{'retry'}) && $options{'retry'} ) {
1530     my $error = $self->retry_realtime;
1531     if ( $error ) {
1532       $dbh->rollback if $oldAutoCommit;
1533       return $error;
1534     }
1535   }
1536
1537   foreach my $cust_bill ( $self->open_cust_bill ) {
1538
1539     # don't try to charge for the same invoice if it's already in a batch
1540     #next if qsearchs( 'cust_pay_batch', { 'invnum' => $cust_bill->invnum } );
1541
1542     last if $self->balance <= 0;
1543
1544     warn "invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ")"
1545       if $DEBUG;
1546
1547     foreach my $part_bill_event (
1548       sort {    $a->seconds   <=> $b->seconds
1549              || $a->weight    <=> $b->weight
1550              || $a->eventpart <=> $b->eventpart }
1551         grep { $_->seconds <= ( $invoice_time - $cust_bill->_date )
1552                && ! qsearch( 'cust_bill_event', {
1553                                 'invnum'    => $cust_bill->invnum,
1554                                 'eventpart' => $_->eventpart,
1555                                 'status'    => 'done',
1556                                                                    } )
1557              }
1558           qsearch('part_bill_event', { 'payby'    => $self->payby,
1559                                        'disabled' => '',           } )
1560     ) {
1561
1562       last if $cust_bill->owed <= 0  # don't run subsequent events if owed<=0
1563            || $self->balance   <= 0; # or if balance<=0
1564
1565       warn "calling invoice event (". $part_bill_event->eventcode. ")\n"
1566         if $DEBUG;
1567       my $cust_main = $self; #for callback
1568
1569       my $error;
1570       {
1571         #supress "used only once" warning
1572         $FS::cust_bill::realtime_bop_decline_quiet += 0;
1573         local $FS::cust_bill::realtime_bop_decline_quiet = 1
1574           if $options{'quiet'};
1575         $error = eval $part_bill_event->eventcode;
1576       }
1577
1578       my $status = '';
1579       my $statustext = '';
1580       if ( $@ ) {
1581         $status = 'failed';
1582         $statustext = $@;
1583       } elsif ( $error ) {
1584         $status = 'done';
1585         $statustext = $error;
1586       } else {
1587         $status = 'done'
1588       }
1589
1590       #add cust_bill_event
1591       my $cust_bill_event = new FS::cust_bill_event {
1592         'invnum'     => $cust_bill->invnum,
1593         'eventpart'  => $part_bill_event->eventpart,
1594         #'_date'      => $invoice_time,
1595         '_date'      => time,
1596         'status'     => $status,
1597         'statustext' => $statustext,
1598       };
1599       $error = $cust_bill_event->insert;
1600       if ( $error ) {
1601         #$dbh->rollback if $oldAutoCommit;
1602         #return "error: $error";
1603
1604         # gah, even with transactions.
1605         $dbh->commit if $oldAutoCommit; #well.
1606         my $e = 'WARNING: Event run but database not updated - '.
1607                 'error inserting cust_bill_event, invnum #'. $cust_bill->invnum.
1608                 ', eventpart '. $part_bill_event->eventpart.
1609                 ": $error";
1610         warn $e;
1611         return $e;
1612       }
1613
1614
1615     }
1616
1617   }
1618
1619   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1620   '';
1621
1622 }
1623
1624 =item retry_realtime
1625
1626 Schedules realtime credit card / electronic check / LEC billing events for
1627 for retry.  Useful if card information has changed or manual retry is desired.
1628 The 'collect' method must be called to actually retry the transaction.
1629
1630 Implementation details: For each of this customer's open invoices, changes
1631 the status of the first "done" (with statustext error) realtime processing
1632 event to "failed".
1633
1634 =cut
1635
1636 sub retry_realtime {
1637   my $self = shift;
1638
1639   local $SIG{HUP} = 'IGNORE';
1640   local $SIG{INT} = 'IGNORE';
1641   local $SIG{QUIT} = 'IGNORE';
1642   local $SIG{TERM} = 'IGNORE';
1643   local $SIG{TSTP} = 'IGNORE';
1644   local $SIG{PIPE} = 'IGNORE';
1645
1646   my $oldAutoCommit = $FS::UID::AutoCommit;
1647   local $FS::UID::AutoCommit = 0;
1648   my $dbh = dbh;
1649
1650   foreach my $cust_bill (
1651     grep { $_->cust_bill_event }
1652       $self->open_cust_bill
1653   ) {
1654     my @cust_bill_event =
1655       sort { $a->part_bill_event->seconds <=> $b->part_bill_event->seconds }
1656         grep {
1657                #$_->part_bill_event->plan eq 'realtime-card'
1658                $_->part_bill_event->eventcode =~
1659                    /\$cust_bill\->realtime_(card|ach|lec)/
1660                  && $_->status eq 'done'
1661                  && $_->statustext
1662              }
1663           $cust_bill->cust_bill_event;
1664     next unless @cust_bill_event;
1665     my $error = $cust_bill_event[0]->retry;
1666     if ( $error ) {
1667       $dbh->rollback if $oldAutoCommit;
1668       return "error scheduling invoice event for retry: $error";
1669     }
1670
1671   }
1672
1673   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1674   '';
1675
1676 }
1677
1678 =item total_owed
1679
1680 Returns the total owed for this customer on all invoices
1681 (see L<FS::cust_bill/owed>).
1682
1683 =cut
1684
1685 sub total_owed {
1686   my $self = shift;
1687   $self->total_owed_date(2145859200); #12/31/2037
1688 }
1689
1690 =item total_owed_date TIME
1691
1692 Returns the total owed for this customer on all invoices with date earlier than
1693 TIME.  TIME is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also
1694 see L<Time::Local> and L<Date::Parse> for conversion functions.
1695
1696 =cut
1697
1698 sub total_owed_date {
1699   my $self = shift;
1700   my $time = shift;
1701   my $total_bill = 0;
1702   foreach my $cust_bill (
1703     grep { $_->_date <= $time }
1704       qsearch('cust_bill', { 'custnum' => $self->custnum, } )
1705   ) {
1706     $total_bill += $cust_bill->owed;
1707   }
1708   sprintf( "%.2f", $total_bill );
1709 }
1710
1711 =item apply_credits
1712
1713 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
1714 to outstanding invoice balances in chronological order and returns the value
1715 of any remaining unapplied credits available for refund
1716 (see L<FS::cust_refund>).
1717
1718 =cut
1719
1720 sub apply_credits {
1721   my $self = shift;
1722
1723   return 0 unless $self->total_credited;
1724
1725   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
1726       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
1727
1728   my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
1729       qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
1730
1731   my $credit;
1732
1733   foreach my $cust_bill ( @invoices ) {
1734     my $amount;
1735
1736     if ( !defined($credit) || $credit->credited == 0) {
1737       $credit = pop @credits or last;
1738     }
1739
1740     if ($cust_bill->owed >= $credit->credited) {
1741       $amount=$credit->credited;
1742     }else{
1743       $amount=$cust_bill->owed;
1744     }
1745
1746     my $cust_credit_bill = new FS::cust_credit_bill ( {
1747       'crednum' => $credit->crednum,
1748       'invnum'  => $cust_bill->invnum,
1749       'amount'  => $amount,
1750     } );
1751     my $error = $cust_credit_bill->insert;
1752     die $error if $error;
1753
1754     redo if ($cust_bill->owed > 0);
1755
1756   }
1757
1758   return $self->total_credited;
1759 }
1760
1761 =item apply_payments
1762
1763 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
1764 to outstanding invoice balances in chronological order.
1765
1766  #and returns the value of any remaining unapplied payments.
1767
1768 =cut
1769
1770 sub apply_payments {
1771   my $self = shift;
1772
1773   #return 0 unless
1774
1775   my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
1776       qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
1777
1778   my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
1779       qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
1780
1781   my $payment;
1782
1783   foreach my $cust_bill ( @invoices ) {
1784     my $amount;
1785
1786     if ( !defined($payment) || $payment->unapplied == 0 ) {
1787       $payment = pop @payments or last;
1788     }
1789
1790     if ( $cust_bill->owed >= $payment->unapplied ) {
1791       $amount = $payment->unapplied;
1792     } else {
1793       $amount = $cust_bill->owed;
1794     }
1795
1796     my $cust_bill_pay = new FS::cust_bill_pay ( {
1797       'paynum' => $payment->paynum,
1798       'invnum' => $cust_bill->invnum,
1799       'amount' => $amount,
1800     } );
1801     my $error = $cust_bill_pay->insert;
1802     die $error if $error;
1803
1804     redo if ( $cust_bill->owed > 0);
1805
1806   }
1807
1808   return $self->total_unapplied_payments;
1809 }
1810
1811 =item total_credited
1812
1813 Returns the total outstanding credit (see L<FS::cust_credit>) for this
1814 customer.  See L<FS::cust_credit/credited>.
1815
1816 =cut
1817
1818 sub total_credited {
1819   my $self = shift;
1820   my $total_credit = 0;
1821   foreach my $cust_credit ( qsearch('cust_credit', {
1822     'custnum' => $self->custnum,
1823   } ) ) {
1824     $total_credit += $cust_credit->credited;
1825   }
1826   sprintf( "%.2f", $total_credit );
1827 }
1828
1829 =item total_unapplied_payments
1830
1831 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
1832 See L<FS::cust_pay/unapplied>.
1833
1834 =cut
1835
1836 sub total_unapplied_payments {
1837   my $self = shift;
1838   my $total_unapplied = 0;
1839   foreach my $cust_pay ( qsearch('cust_pay', {
1840     'custnum' => $self->custnum,
1841   } ) ) {
1842     $total_unapplied += $cust_pay->unapplied;
1843   }
1844   sprintf( "%.2f", $total_unapplied );
1845 }
1846
1847 =item balance
1848
1849 Returns the balance for this customer (total_owed minus total_credited
1850 minus total_unapplied_payments).
1851
1852 =cut
1853
1854 sub balance {
1855   my $self = shift;
1856   sprintf( "%.2f",
1857     $self->total_owed - $self->total_credited - $self->total_unapplied_payments
1858   );
1859 }
1860
1861 =item balance_date TIME
1862
1863 Returns the balance for this customer, only considering invoices with date
1864 earlier than TIME (total_owed_date minus total_credited minus
1865 total_unapplied_payments).  TIME is specified as a UNIX timestamp; see
1866 L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion
1867 functions.
1868
1869 =cut
1870
1871 sub balance_date {
1872   my $self = shift;
1873   my $time = shift;
1874   sprintf( "%.2f",
1875     $self->total_owed_date($time)
1876       - $self->total_credited
1877       - $self->total_unapplied_payments
1878   );
1879 }
1880
1881 =item invoicing_list [ ARRAYREF ]
1882
1883 If an arguement is given, sets these email addresses as invoice recipients
1884 (see L<FS::cust_main_invoice>).  Errors are not fatal and are not reported
1885 (except as warnings), so use check_invoicing_list first.
1886
1887 Returns a list of email addresses (with svcnum entries expanded).
1888
1889 Note: You can clear the invoicing list by passing an empty ARRAYREF.  You can
1890 check it without disturbing anything by passing nothing.
1891
1892 This interface may change in the future.
1893
1894 =cut
1895
1896 sub invoicing_list {
1897   my( $self, $arrayref ) = @_;
1898   if ( $arrayref ) {
1899     my @cust_main_invoice;
1900     if ( $self->custnum ) {
1901       @cust_main_invoice =
1902         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
1903     } else {
1904       @cust_main_invoice = ();
1905     }
1906     foreach my $cust_main_invoice ( @cust_main_invoice ) {
1907       #warn $cust_main_invoice->destnum;
1908       unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
1909         #warn $cust_main_invoice->destnum;
1910         my $error = $cust_main_invoice->delete;
1911         warn $error if $error;
1912       }
1913     }
1914     if ( $self->custnum ) {
1915       @cust_main_invoice =
1916         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
1917     } else {
1918       @cust_main_invoice = ();
1919     }
1920     my %seen = map { $_->address => 1 } @cust_main_invoice;
1921     foreach my $address ( @{$arrayref} ) {
1922       next if exists $seen{$address} && $seen{$address};
1923       $seen{$address} = 1;
1924       my $cust_main_invoice = new FS::cust_main_invoice ( {
1925         'custnum' => $self->custnum,
1926         'dest'    => $address,
1927       } );
1928       my $error = $cust_main_invoice->insert;
1929       warn $error if $error;
1930     }
1931   }
1932   if ( $self->custnum ) {
1933     map { $_->address }
1934       qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
1935   } else {
1936     ();
1937   }
1938 }
1939
1940 =item check_invoicing_list ARRAYREF
1941
1942 Checks these arguements as valid input for the invoicing_list method.  If there
1943 is an error, returns the error, otherwise returns false.
1944
1945 =cut
1946
1947 sub check_invoicing_list {
1948   my( $self, $arrayref ) = @_;
1949   foreach my $address ( @{$arrayref} ) {
1950     my $cust_main_invoice = new FS::cust_main_invoice ( {
1951       'custnum' => $self->custnum,
1952       'dest'    => $address,
1953     } );
1954     my $error = $self->custnum
1955                 ? $cust_main_invoice->check
1956                 : $cust_main_invoice->checkdest
1957     ;
1958     return $error if $error;
1959   }
1960   '';
1961 }
1962
1963 =item set_default_invoicing_list
1964
1965 Sets the invoicing list to all accounts associated with this customer,
1966 overwriting any previous invoicing list.
1967
1968 =cut
1969
1970 sub set_default_invoicing_list {
1971   my $self = shift;
1972   $self->invoicing_list($self->all_emails);
1973 }
1974
1975 =item all_emails
1976
1977 Returns the email addresses of all accounts provisioned for this customer.
1978
1979 =cut
1980
1981 sub all_emails {
1982   my $self = shift;
1983   my %list;
1984   foreach my $cust_pkg ( $self->all_pkgs ) {
1985     my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
1986     my @svc_acct =
1987       map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
1988         grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
1989           @cust_svc;
1990     $list{$_}=1 foreach map { $_->email } @svc_acct;
1991   }
1992   keys %list;
1993 }
1994
1995 =item invoicing_list_addpost
1996
1997 Adds postal invoicing to this customer.  If this customer is already configured
1998 to receive postal invoices, does nothing.
1999
2000 =cut
2001
2002 sub invoicing_list_addpost {
2003   my $self = shift;
2004   return if grep { $_ eq 'POST' } $self->invoicing_list;
2005   my @invoicing_list = $self->invoicing_list;
2006   push @invoicing_list, 'POST';
2007   $self->invoicing_list(\@invoicing_list);
2008 }
2009
2010 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
2011
2012 Returns an array of customers referred by this customer (referral_custnum set
2013 to this custnum).  If DEPTH is given, recurses up to the given depth, returning
2014 customers referred by customers referred by this customer and so on, inclusive.
2015 The default behavior is DEPTH 1 (no recursion).
2016
2017 =cut
2018
2019 sub referral_cust_main {
2020   my $self = shift;
2021   my $depth = @_ ? shift : 1;
2022   my $exclude = @_ ? shift : {};
2023
2024   my @cust_main =
2025     map { $exclude->{$_->custnum}++; $_; }
2026       grep { ! $exclude->{ $_->custnum } }
2027         qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
2028
2029   if ( $depth > 1 ) {
2030     push @cust_main,
2031       map { $_->referral_cust_main($depth-1, $exclude) }
2032         @cust_main;
2033   }
2034
2035   @cust_main;
2036 }
2037
2038 =item referral_cust_main_ncancelled
2039
2040 Same as referral_cust_main, except only returns customers with uncancelled
2041 packages.
2042
2043 =cut
2044
2045 sub referral_cust_main_ncancelled {
2046   my $self = shift;
2047   grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
2048 }
2049
2050 =item referral_cust_pkg [ DEPTH ]
2051
2052 Like referral_cust_main, except returns a flat list of all unsuspended (and
2053 uncancelled) packages for each customer.  The number of items in this list may
2054 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
2055
2056 =cut
2057
2058 sub referral_cust_pkg {
2059   my $self = shift;
2060   my $depth = @_ ? shift : 1;
2061
2062   map { $_->unsuspended_pkgs }
2063     grep { $_->unsuspended_pkgs }
2064       $self->referral_cust_main($depth);
2065 }
2066
2067 =item credit AMOUNT, REASON
2068
2069 Applies a credit to this customer.  If there is an error, returns the error,
2070 otherwise returns false.
2071
2072 =cut
2073
2074 sub credit {
2075   my( $self, $amount, $reason ) = @_;
2076   my $cust_credit = new FS::cust_credit {
2077     'custnum' => $self->custnum,
2078     'amount'  => $amount,
2079     'reason'  => $reason,
2080   };
2081   $cust_credit->insert;
2082 }
2083
2084 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
2085
2086 Creates a one-time charge for this customer.  If there is an error, returns
2087 the error, otherwise returns false.
2088
2089 =cut
2090
2091 sub charge {
2092   my ( $self, $amount ) = ( shift, shift );
2093   my $pkg      = @_ ? shift : 'One-time charge';
2094   my $comment  = @_ ? shift : '$'. sprintf("%.2f",$amount);
2095   my $taxclass = @_ ? shift : '';
2096
2097   local $SIG{HUP} = 'IGNORE';
2098   local $SIG{INT} = 'IGNORE';
2099   local $SIG{QUIT} = 'IGNORE';
2100   local $SIG{TERM} = 'IGNORE';
2101   local $SIG{TSTP} = 'IGNORE';
2102   local $SIG{PIPE} = 'IGNORE';
2103
2104   my $oldAutoCommit = $FS::UID::AutoCommit;
2105   local $FS::UID::AutoCommit = 0;
2106   my $dbh = dbh;
2107
2108   my $part_pkg = new FS::part_pkg ( {
2109     'pkg'      => $pkg,
2110     'comment'  => $comment,
2111     'setup'    => $amount,
2112     'freq'     => 0,
2113     'recur'    => '0',
2114     'disabled' => 'Y',
2115     'taxclass' => $taxclass,
2116   } );
2117
2118   my $error = $part_pkg->insert;
2119   if ( $error ) {
2120     $dbh->rollback if $oldAutoCommit;
2121     return $error;
2122   }
2123
2124   my $pkgpart = $part_pkg->pkgpart;
2125   my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
2126   unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
2127     my $type_pkgs = new FS::type_pkgs \%type_pkgs;
2128     $error = $type_pkgs->insert;
2129     if ( $error ) {
2130       $dbh->rollback if $oldAutoCommit;
2131       return $error;
2132     }
2133   }
2134
2135   my $cust_pkg = new FS::cust_pkg ( {
2136     'custnum' => $self->custnum,
2137     'pkgpart' => $pkgpart,
2138   } );
2139
2140   $error = $cust_pkg->insert;
2141   if ( $error ) {
2142     $dbh->rollback if $oldAutoCommit;
2143     return $error;
2144   }
2145
2146   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2147   '';
2148
2149 }
2150
2151 =item cust_bill
2152
2153 Returns all the invoices (see L<FS::cust_bill>) for this customer.
2154
2155 =cut
2156
2157 sub cust_bill {
2158   my $self = shift;
2159   sort { $a->_date <=> $b->_date }
2160     qsearch('cust_bill', { 'custnum' => $self->custnum, } )
2161 }
2162
2163 =item open_cust_bill
2164
2165 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
2166 customer.
2167
2168 =cut
2169
2170 sub open_cust_bill {
2171   my $self = shift;
2172   grep { $_->owed > 0 } $self->cust_bill;
2173 }
2174
2175 =item cust_credit
2176
2177 Returns all the credits (see L<FS::cust_credit>) for this customer.
2178
2179 =cut
2180
2181 sub cust_credit {
2182   my $self = shift;
2183   sort { $a->_date <=> $b->_date }
2184     qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
2185 }
2186
2187 =item cust_pay
2188
2189 Returns all the payments (see L<FS::cust_pay>) for this customer.
2190
2191 =cut
2192
2193 sub cust_pay {
2194   my $self = shift;
2195   sort { $a->_date <=> $b->_date }
2196     qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
2197 }
2198
2199 =item cust_refund
2200
2201 Returns all the refunds (see L<FS::cust_refund>) for this customer.
2202
2203 =cut
2204
2205 sub cust_refund {
2206   my $self = shift;
2207   sort { $a->_date <=> $b->_date }
2208     qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
2209 }
2210
2211 =item select_for_update
2212
2213 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
2214 a mutex.
2215
2216 =cut
2217
2218 sub select_for_update {
2219   my $self = shift;
2220   qsearch('cust_main', { 'custnum' => $self->custnum }, '*', 'FOR UPDATE' );
2221 }
2222
2223 =back
2224
2225 =head1 SUBROUTINES
2226
2227 =over 4
2228
2229 =item check_and_rebuild_fuzzyfiles
2230
2231 =cut
2232
2233 sub check_and_rebuild_fuzzyfiles {
2234   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2235   -e "$dir/cust_main.last" && -e "$dir/cust_main.company"
2236     or &rebuild_fuzzyfiles;
2237 }
2238
2239 =item rebuild_fuzzyfiles
2240
2241 =cut
2242
2243 sub rebuild_fuzzyfiles {
2244
2245   use Fcntl qw(:flock);
2246
2247   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2248
2249   #last
2250
2251   open(LASTLOCK,">>$dir/cust_main.last")
2252     or die "can't open $dir/cust_main.last: $!";
2253   flock(LASTLOCK,LOCK_EX)
2254     or die "can't lock $dir/cust_main.last: $!";
2255
2256   my @all_last = map $_->getfield('last'), qsearch('cust_main', {});
2257   push @all_last,
2258                  grep $_, map $_->getfield('ship_last'), qsearch('cust_main',{})
2259     if defined dbdef->table('cust_main')->column('ship_last');
2260
2261   open (LASTCACHE,">$dir/cust_main.last.tmp")
2262     or die "can't open $dir/cust_main.last.tmp: $!";
2263   print LASTCACHE join("\n", @all_last), "\n";
2264   close LASTCACHE or die "can't close $dir/cust_main.last.tmp: $!";
2265
2266   rename "$dir/cust_main.last.tmp", "$dir/cust_main.last";
2267   close LASTLOCK;
2268
2269   #company
2270
2271   open(COMPANYLOCK,">>$dir/cust_main.company")
2272     or die "can't open $dir/cust_main.company: $!";
2273   flock(COMPANYLOCK,LOCK_EX)
2274     or die "can't lock $dir/cust_main.company: $!";
2275
2276   my @all_company = grep $_ ne '', map $_->company, qsearch('cust_main',{});
2277   push @all_company,
2278        grep $_ ne '', map $_->ship_company, qsearch('cust_main', {})
2279     if defined dbdef->table('cust_main')->column('ship_last');
2280
2281   open (COMPANYCACHE,">$dir/cust_main.company.tmp")
2282     or die "can't open $dir/cust_main.company.tmp: $!";
2283   print COMPANYCACHE join("\n", @all_company), "\n";
2284   close COMPANYCACHE or die "can't close $dir/cust_main.company.tmp: $!";
2285
2286   rename "$dir/cust_main.company.tmp", "$dir/cust_main.company";
2287   close COMPANYLOCK;
2288
2289 }
2290
2291 =item all_last
2292
2293 =cut
2294
2295 sub all_last {
2296   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2297   open(LASTCACHE,"<$dir/cust_main.last")
2298     or die "can't open $dir/cust_main.last: $!";
2299   my @array = map { chomp; $_; } <LASTCACHE>;
2300   close LASTCACHE;
2301   \@array;
2302 }
2303
2304 =item all_company
2305
2306 =cut
2307
2308 sub all_company {
2309   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2310   open(COMPANYCACHE,"<$dir/cust_main.company")
2311     or die "can't open $dir/cust_main.last: $!";
2312   my @array = map { chomp; $_; } <COMPANYCACHE>;
2313   close COMPANYCACHE;
2314   \@array;
2315 }
2316
2317 =item append_fuzzyfiles LASTNAME COMPANY
2318
2319 =cut
2320
2321 sub append_fuzzyfiles {
2322   my( $last, $company ) = @_;
2323
2324   &check_and_rebuild_fuzzyfiles;
2325
2326   use Fcntl qw(:flock);
2327
2328   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2329
2330   if ( $last ) {
2331
2332     open(LAST,">>$dir/cust_main.last")
2333       or die "can't open $dir/cust_main.last: $!";
2334     flock(LAST,LOCK_EX)
2335       or die "can't lock $dir/cust_main.last: $!";
2336
2337     print LAST "$last\n";
2338
2339     flock(LAST,LOCK_UN)
2340       or die "can't unlock $dir/cust_main.last: $!";
2341     close LAST;
2342   }
2343
2344   if ( $company ) {
2345
2346     open(COMPANY,">>$dir/cust_main.company")
2347       or die "can't open $dir/cust_main.company: $!";
2348     flock(COMPANY,LOCK_EX)
2349       or die "can't lock $dir/cust_main.company: $!";
2350
2351     print COMPANY "$company\n";
2352
2353     flock(COMPANY,LOCK_UN)
2354       or die "can't unlock $dir/cust_main.company: $!";
2355
2356     close COMPANY;
2357   }
2358
2359   1;
2360 }
2361
2362 =item batch_import
2363
2364 =cut
2365
2366 sub batch_import {
2367   my $param = shift;
2368   #warn join('-',keys %$param);
2369   my $fh = $param->{filehandle};
2370   my $agentnum = $param->{agentnum};
2371   my $refnum = $param->{refnum};
2372   my $pkgpart = $param->{pkgpart};
2373   my @fields = @{$param->{fields}};
2374
2375   eval "use Date::Parse;";
2376   die $@ if $@;
2377   eval "use Text::CSV_XS;";
2378   die $@ if $@;
2379
2380   my $csv = new Text::CSV_XS;
2381   #warn $csv;
2382   #warn $fh;
2383
2384   my $imported = 0;
2385   #my $columns;
2386
2387   local $SIG{HUP} = 'IGNORE';
2388   local $SIG{INT} = 'IGNORE';
2389   local $SIG{QUIT} = 'IGNORE';
2390   local $SIG{TERM} = 'IGNORE';
2391   local $SIG{TSTP} = 'IGNORE';
2392   local $SIG{PIPE} = 'IGNORE';
2393
2394   my $oldAutoCommit = $FS::UID::AutoCommit;
2395   local $FS::UID::AutoCommit = 0;
2396   my $dbh = dbh;
2397
2398   #while ( $columns = $csv->getline($fh) ) {
2399   my $line;
2400   while ( defined($line=<$fh>) ) {
2401
2402     $csv->parse($line) or do {
2403       $dbh->rollback if $oldAutoCommit;
2404       return "can't parse: ". $csv->error_input();
2405     };
2406
2407     my @columns = $csv->fields();
2408     #warn join('-',@columns);
2409
2410     my %cust_main = (
2411       agentnum => $agentnum,
2412       refnum   => $refnum,
2413       country  => $conf->config('countrydefault') || 'US',
2414       payby    => 'BILL', #default
2415       paydate  => '12/2037', #default
2416     );
2417     my $billtime = time;
2418     my %cust_pkg = ( pkgpart => $pkgpart );
2419     foreach my $field ( @fields ) {
2420       if ( $field =~ /^cust_pkg\.(setup|bill|susp|expire|cancel)$/ ) {
2421         #$cust_pkg{$1} = str2time( shift @$columns );
2422         if ( $1 eq 'setup' ) {
2423           $billtime = str2time(shift @columns);
2424         } else {
2425           $cust_pkg{$1} = str2time( shift @columns );
2426         }
2427       } else {
2428         #$cust_main{$field} = shift @$columns;
2429         $cust_main{$field} = shift @columns;
2430       }
2431     }
2432
2433     my $cust_pkg = new FS::cust_pkg ( \%cust_pkg ) if $pkgpart;
2434     my $cust_main = new FS::cust_main ( \%cust_main );
2435     use Tie::RefHash;
2436     tie my %hash, 'Tie::RefHash'; #this part is important
2437     $hash{$cust_pkg} = [] if $pkgpart;
2438     my $error = $cust_main->insert( \%hash );
2439
2440     if ( $error ) {
2441       $dbh->rollback if $oldAutoCommit;
2442       return "can't insert customer for $line: $error";
2443     }
2444
2445     #false laziness w/bill.cgi
2446     $error = $cust_main->bill( 'time' => $billtime );
2447     if ( $error ) {
2448       $dbh->rollback if $oldAutoCommit;
2449       return "can't bill customer for $line: $error";
2450     }
2451
2452     $cust_main->apply_payments;
2453     $cust_main->apply_credits;
2454
2455     $error = $cust_main->collect();
2456     if ( $error ) {
2457       $dbh->rollback if $oldAutoCommit;
2458       return "can't collect customer for $line: $error";
2459     }
2460
2461     $imported++;
2462   }
2463
2464   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2465
2466   return "Empty file!" unless $imported;
2467
2468   ''; #no error
2469
2470 }
2471
2472 =item batch_charge
2473
2474 =cut
2475
2476 sub batch_charge {
2477   my $param = shift;
2478   #warn join('-',keys %$param);
2479   my $fh = $param->{filehandle};
2480   my @fields = @{$param->{fields}};
2481
2482   eval "use Date::Parse;";
2483   die $@ if $@;
2484   eval "use Text::CSV_XS;";
2485   die $@ if $@;
2486
2487   my $csv = new Text::CSV_XS;
2488   #warn $csv;
2489   #warn $fh;
2490
2491   my $imported = 0;
2492   #my $columns;
2493
2494   local $SIG{HUP} = 'IGNORE';
2495   local $SIG{INT} = 'IGNORE';
2496   local $SIG{QUIT} = 'IGNORE';
2497   local $SIG{TERM} = 'IGNORE';
2498   local $SIG{TSTP} = 'IGNORE';
2499   local $SIG{PIPE} = 'IGNORE';
2500
2501   my $oldAutoCommit = $FS::UID::AutoCommit;
2502   local $FS::UID::AutoCommit = 0;
2503   my $dbh = dbh;
2504
2505   #while ( $columns = $csv->getline($fh) ) {
2506   my $line;
2507   while ( defined($line=<$fh>) ) {
2508
2509     $csv->parse($line) or do {
2510       $dbh->rollback if $oldAutoCommit;
2511       return "can't parse: ". $csv->error_input();
2512     };
2513
2514     my @columns = $csv->fields();
2515     #warn join('-',@columns);
2516
2517     my %row = ();
2518     foreach my $field ( @fields ) {
2519       $row{$field} = shift @columns;
2520     }
2521
2522     my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
2523     unless ( $cust_main ) {
2524       $dbh->rollback if $oldAutoCommit;
2525       return "unknown custnum $row{'custnum'}";
2526     }
2527
2528     if ( $row{'amount'} > 0 ) {
2529       my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
2530       if ( $error ) {
2531         $dbh->rollback if $oldAutoCommit;
2532         return $error;
2533       }
2534       $imported++;
2535     } elsif ( $row{'amount'} < 0 ) {
2536       my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
2537                                       $row{'pkg'}                         );
2538       if ( $error ) {
2539         $dbh->rollback if $oldAutoCommit;
2540         return $error;
2541       }
2542       $imported++;
2543     } else {
2544       #hmm?
2545     }
2546
2547   }
2548
2549   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2550
2551   return "Empty file!" unless $imported;
2552
2553   ''; #no error
2554
2555 }
2556
2557 =back
2558
2559 =head1 BUGS
2560
2561 The delete method.
2562
2563 The delete method should possibly take an FS::cust_main object reference
2564 instead of a scalar customer number.
2565
2566 Bill and collect options should probably be passed as references instead of a
2567 list.
2568
2569 There should probably be a configuration file with a list of allowed credit
2570 card types.
2571
2572 No multiple currency support (probably a larger project than just this module).
2573
2574 =head1 SEE ALSO
2575
2576 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
2577 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
2578 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.
2579
2580 =cut
2581
2582 1;
2583