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