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 { $_->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 ) {
1187         $dbh->rollback if $oldAutoCommit;
1188         return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
1189       }
1190       if ( $recur < 0 ) {
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           # maybe eliminate this entirely, along with all the 0% records
1224           unless ( @taxes ) {
1225             $dbh->rollback if $oldAutoCommit;
1226             return
1227               "fatal: can't find tax rate for state/county/country/taxclass ".
1228               join('/', ( map $self->$_(), qw(state county country) ),
1229                         $part_pkg->taxclass ).  "\n";
1230           }
1231
1232           foreach my $tax ( @taxes ) {
1233
1234             my $taxable_charged = 0;
1235             $taxable_charged += $setup
1236               unless $part_pkg->setuptax =~ /^Y$/i
1237                   || $tax->setuptax =~ /^Y$/i;
1238             $taxable_charged += $recur
1239               unless $part_pkg->recurtax =~ /^Y$/i
1240                   || $tax->recurtax =~ /^Y$/i;
1241             next unless $taxable_charged;
1242
1243             if ( $tax->exempt_amount > 0 ) {
1244               my ($mon,$year) = (localtime($sdate) )[4,5];
1245               $mon++;
1246               my $freq = $part_pkg->freq || 1;
1247               if ( $freq !~ /(\d+)$/ ) {
1248                 $dbh->rollback if $oldAutoCommit;
1249                 return "daily/weekly package definitions not (yet?)".
1250                        " compatible with monthly tax exemptions";
1251               }
1252               my $taxable_per_month = sprintf("%.2f", $taxable_charged / $freq );
1253               foreach my $which_month ( 1 .. $freq ) {
1254                 my %hash = (
1255                   'custnum' => $self->custnum,
1256                   'taxnum'  => $tax->taxnum,
1257                   'year'    => 1900+$year,
1258                   'month'   => $mon++,
1259                 );
1260                 #until ( $mon < 12 ) { $mon -= 12; $year++; }
1261                 until ( $mon < 13 ) { $mon -= 12; $year++; }
1262                 my $cust_tax_exempt =
1263                   qsearchs('cust_tax_exempt', \%hash)
1264                   || new FS::cust_tax_exempt( { %hash, 'amount' => 0 } );
1265                 my $remaining_exemption = sprintf("%.2f",
1266                   $tax->exempt_amount - $cust_tax_exempt->amount );
1267                 if ( $remaining_exemption > 0 ) {
1268                   my $addl = $remaining_exemption > $taxable_per_month
1269                     ? $taxable_per_month
1270                     : $remaining_exemption;
1271                   $taxable_charged -= $addl;
1272                   my $new_cust_tax_exempt = new FS::cust_tax_exempt ( {
1273                     $cust_tax_exempt->hash,
1274                     'amount' =>
1275                       sprintf("%.2f", $cust_tax_exempt->amount + $addl),
1276                   } );
1277                   $error = $new_cust_tax_exempt->exemptnum
1278                     ? $new_cust_tax_exempt->replace($cust_tax_exempt)
1279                     : $new_cust_tax_exempt->insert;
1280                   if ( $error ) {
1281                     $dbh->rollback if $oldAutoCommit;
1282                     return "fatal: can't update cust_tax_exempt: $error";
1283                   }
1284
1285                 } # if $remaining_exemption > 0
1286
1287               } #foreach $which_month
1288
1289             } #if $tax->exempt_amount
1290
1291             $taxable_charged = sprintf( "%.2f", $taxable_charged);
1292
1293             #$tax += $taxable_charged * $cust_main_county->tax / 100
1294             $tax{ $tax->taxname || 'Tax' } +=
1295               $taxable_charged * $tax->tax / 100
1296
1297           } #foreach my $tax ( @taxes )
1298
1299         } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
1300
1301       } #if $setup > 0 || $recur > 0
1302
1303     } #if $cust_pkg_mod_flag
1304
1305   } #foreach my $cust_pkg
1306
1307   my $charged = sprintf( "%.2f", $total_setup + $total_recur );
1308 #  my $taxable_charged = sprintf( "%.2f", $taxable_setup + $taxable_recur );
1309
1310   unless ( @cust_bill_pkg ) { #don't create invoices with no line items
1311     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1312     return '';
1313   }
1314
1315 #  unless ( $self->tax =~ /Y/i
1316 #           || $self->payby eq 'COMP'
1317 #           || $taxable_charged == 0 ) {
1318 #    my $cust_main_county = qsearchs('cust_main_county',{
1319 #        'state'   => $self->state,
1320 #        'county'  => $self->county,
1321 #        'country' => $self->country,
1322 #    } ) or die "fatal: can't find tax rate for state/county/country ".
1323 #               $self->state. "/". $self->county. "/". $self->country. "\n";
1324 #    my $tax = sprintf( "%.2f",
1325 #      $taxable_charged * ( $cust_main_county->getfield('tax') / 100 )
1326 #    );
1327
1328   if ( dbdef->table('cust_bill_pkg')->column('itemdesc') ) { #1.5 schema
1329
1330     foreach my $taxname ( grep { $tax{$_} > 0 } keys %tax ) {
1331       my $tax = sprintf("%.2f", $tax{$taxname} );
1332       $charged = sprintf( "%.2f", $charged+$tax );
1333
1334       my $cust_bill_pkg = new FS::cust_bill_pkg ({
1335         'pkgnum'   => 0,
1336         'setup'    => $tax,
1337         'recur'    => 0,
1338         'sdate'    => '',
1339         'edate'    => '',
1340         'itemdesc' => $taxname,
1341       });
1342       push @cust_bill_pkg, $cust_bill_pkg;
1343     }
1344
1345   } else { #1.4 schema
1346
1347     my $tax = 0;
1348     foreach ( values %tax ) { $tax += $_ };
1349     $tax = sprintf("%.2f", $tax);
1350     if ( $tax > 0 ) {
1351       $charged = sprintf( "%.2f", $charged+$tax );
1352
1353       my $cust_bill_pkg = new FS::cust_bill_pkg ({
1354         'pkgnum' => 0,
1355         'setup'  => $tax,
1356         'recur'  => 0,
1357         'sdate'  => '',
1358         'edate'  => '',
1359       });
1360       push @cust_bill_pkg, $cust_bill_pkg;
1361     }
1362
1363   }
1364
1365   my $cust_bill = new FS::cust_bill ( {
1366     'custnum' => $self->custnum,
1367     '_date'   => $time,
1368     'charged' => $charged,
1369   } );
1370   $error = $cust_bill->insert;
1371   if ( $error ) {
1372     $dbh->rollback if $oldAutoCommit;
1373     return "can't create invoice for customer #". $self->custnum. ": $error";
1374   }
1375
1376   my $invnum = $cust_bill->invnum;
1377   my $cust_bill_pkg;
1378   foreach $cust_bill_pkg ( @cust_bill_pkg ) {
1379     #warn $invnum;
1380     $cust_bill_pkg->invnum($invnum);
1381     $error = $cust_bill_pkg->insert;
1382     if ( $error ) {
1383       $dbh->rollback if $oldAutoCommit;
1384       return "can't create invoice line item for customer #". $self->custnum.
1385              ": $error";
1386     }
1387   }
1388
1389   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1390   ''; #no error
1391 }
1392
1393 =item collect OPTIONS
1394
1395 (Attempt to) collect money for this customer's outstanding invoices (see
1396 L<FS::cust_bill>).  Usually used after the bill method.
1397
1398 Depending on the value of `payby', this may print an invoice (`BILL'), charge
1399 a credit card (`CARD'), or just add any necessary (pseudo-)payment (`COMP').
1400
1401 Most actions are now triggered by invoice events; see L<FS::part_bill_event>
1402 and the invoice events web interface.
1403
1404 If there is an error, returns the error, otherwise returns false.
1405
1406 Options are passed as name-value pairs.
1407
1408 Currently available options are:
1409
1410 invoice_time - Use this time when deciding when to print invoices and
1411 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>
1412 for conversion functions.
1413
1414 retry - Retry card/echeck/LEC transactions even when not scheduled by invoice
1415 events.
1416
1417 retry_card - Deprecated alias for 'retry'
1418
1419 batch_card - This option is deprecated.  See the invoice events web interface
1420 to control whether cards are batched or run against a realtime gateway.
1421
1422 report_badcard - This option is deprecated.
1423
1424 force_print - This option is deprecated; see the invoice events web interface.
1425
1426 quiet - set true to surpress email card/ACH decline notices.
1427
1428 =cut
1429
1430 sub collect {
1431   my( $self, %options ) = @_;
1432   my $invoice_time = $options{'invoice_time'} || time;
1433
1434   #put below somehow?
1435   local $SIG{HUP} = 'IGNORE';
1436   local $SIG{INT} = 'IGNORE';
1437   local $SIG{QUIT} = 'IGNORE';
1438   local $SIG{TERM} = 'IGNORE';
1439   local $SIG{TSTP} = 'IGNORE';
1440   local $SIG{PIPE} = 'IGNORE';
1441
1442   my $oldAutoCommit = $FS::UID::AutoCommit;
1443   local $FS::UID::AutoCommit = 0;
1444   my $dbh = dbh;
1445
1446   my $balance = $self->balance;
1447   warn "collect customer". $self->custnum. ": balance $balance" if $Debug;
1448   unless ( $balance > 0 ) { #redundant?????
1449     $dbh->rollback if $oldAutoCommit; #hmm
1450     return '';
1451   }
1452
1453   if ( exists($options{'retry_card'}) ) {
1454     carp 'retry_card option passed to collect is deprecated; use retry';
1455     $options{'retry'} ||= $options{'retry_card'};
1456   }
1457   if ( exists($options{'retry'}) && $options{'retry'} ) {
1458     my $error = $self->retry_realtime;
1459     if ( $error ) {
1460       $dbh->rollback if $oldAutoCommit;
1461       return $error;
1462     }
1463   }
1464
1465   foreach my $cust_bill ( $self->open_cust_bill ) {
1466
1467     # don't try to charge for the same invoice if it's already in a batch
1468     #next if qsearchs( 'cust_pay_batch', { 'invnum' => $cust_bill->invnum } );
1469
1470     last if $self->balance <= 0;
1471
1472     warn "invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ")"
1473       if $Debug;
1474
1475     foreach my $part_bill_event (
1476       sort {    $a->seconds   <=> $b->seconds
1477              || $a->weight    <=> $b->weight
1478              || $a->eventpart <=> $b->eventpart }
1479         grep { $_->seconds <= ( $invoice_time - $cust_bill->_date )
1480                && ! qsearchs( 'cust_bill_event', {
1481                                 'invnum'    => $cust_bill->invnum,
1482                                 'eventpart' => $_->eventpart,
1483                                 'status'    => 'done',
1484                                                                    } )
1485              }
1486           qsearch('part_bill_event', { 'payby'    => $self->payby,
1487                                        'disabled' => '',           } )
1488     ) {
1489
1490       last if $cust_bill->owed <= 0  # don't run subsequent events if owed<=0
1491            || $self->balance   <= 0; # or if balance<=0
1492
1493       warn "calling invoice event (". $part_bill_event->eventcode. ")\n"
1494         if $Debug;
1495       my $cust_main = $self; #for callback
1496
1497       my $error;
1498       {
1499         #supress "used only once" warning
1500         $FS::cust_bill::realtime_bop_decline_quiet += 0;
1501         local $FS::cust_bill::realtime_bop_decline_quiet = 1
1502           if $options{'quiet'};
1503         $error = eval $part_bill_event->eventcode;
1504       }
1505
1506       my $status = '';
1507       my $statustext = '';
1508       if ( $@ ) {
1509         $status = 'failed';
1510         $statustext = $@;
1511       } elsif ( $error ) {
1512         $status = 'done';
1513         $statustext = $error;
1514       } else {
1515         $status = 'done'
1516       }
1517
1518       #add cust_bill_event
1519       my $cust_bill_event = new FS::cust_bill_event {
1520         'invnum'     => $cust_bill->invnum,
1521         'eventpart'  => $part_bill_event->eventpart,
1522         #'_date'      => $invoice_time,
1523         '_date'      => time,
1524         'status'     => $status,
1525         'statustext' => $statustext,
1526       };
1527       $error = $cust_bill_event->insert;
1528       if ( $error ) {
1529         #$dbh->rollback if $oldAutoCommit;
1530         #return "error: $error";
1531
1532         # gah, even with transactions.
1533         $dbh->commit if $oldAutoCommit; #well.
1534         my $e = 'WARNING: Event run but database not updated - '.
1535                 'error inserting cust_bill_event, invnum #'. $cust_bill->invnum.
1536                 ', eventpart '. $part_bill_event->eventpart.
1537                 ": $error";
1538         warn $e;
1539         return $e;
1540       }
1541
1542
1543     }
1544
1545   }
1546
1547   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1548   '';
1549
1550 }
1551
1552 =item retry_realtime
1553
1554 Schedules realtime credit card / electronic check / LEC billing events for
1555 for retry.  Useful if card information has changed or manual retry is desired.
1556 The 'collect' method must be called to actually retry the transaction.
1557
1558 Implementation details: For each of this customer's open invoices, changes
1559 the status of the first "done" (with statustext error) realtime processing
1560 event to "failed".
1561
1562 =cut
1563
1564 sub retry_realtime {
1565   my $self = shift;
1566
1567   local $SIG{HUP} = 'IGNORE';
1568   local $SIG{INT} = 'IGNORE';
1569   local $SIG{QUIT} = 'IGNORE';
1570   local $SIG{TERM} = 'IGNORE';
1571   local $SIG{TSTP} = 'IGNORE';
1572   local $SIG{PIPE} = 'IGNORE';
1573
1574   my $oldAutoCommit = $FS::UID::AutoCommit;
1575   local $FS::UID::AutoCommit = 0;
1576   my $dbh = dbh;
1577
1578   foreach my $cust_bill (
1579     grep { $_->cust_bill_event }
1580       $self->open_cust_bill
1581   ) {
1582     my @cust_bill_event =
1583       sort { $a->part_bill_event->seconds <=> $b->part_bill_event->seconds }
1584         grep {
1585                #$_->part_bill_event->plan eq 'realtime-card'
1586                $_->part_bill_event->eventcode =~
1587                    /\$cust_bill\->realtime_(card|ach|lec)/
1588                  && $_->status eq 'done'
1589                  && $_->statustext
1590              }
1591           $cust_bill->cust_bill_event;
1592     next unless @cust_bill_event;
1593     my $error = $cust_bill_event[0]->retry;
1594     if ( $error ) {
1595       $dbh->rollback if $oldAutoCommit;
1596       return "error scheduling invoice event for retry: $error";
1597     }
1598
1599   }
1600
1601   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1602   '';
1603
1604 }
1605
1606 =item total_owed
1607
1608 Returns the total owed for this customer on all invoices
1609 (see L<FS::cust_bill/owed>).
1610
1611 =cut
1612
1613 sub total_owed {
1614   my $self = shift;
1615   $self->total_owed_date(2145859200); #12/31/2037
1616 }
1617
1618 =item total_owed_date TIME
1619
1620 Returns the total owed for this customer on all invoices with date earlier than
1621 TIME.  TIME is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also
1622 see L<Time::Local> and L<Date::Parse> for conversion functions.
1623
1624 =cut
1625
1626 sub total_owed_date {
1627   my $self = shift;
1628   my $time = shift;
1629   my $total_bill = 0;
1630   foreach my $cust_bill (
1631     grep { $_->_date <= $time }
1632       qsearch('cust_bill', { 'custnum' => $self->custnum, } )
1633   ) {
1634     $total_bill += $cust_bill->owed;
1635   }
1636   sprintf( "%.2f", $total_bill );
1637 }
1638
1639 =item apply_credits
1640
1641 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
1642 to outstanding invoice balances in chronological order and returns the value
1643 of any remaining unapplied credits available for refund
1644 (see L<FS::cust_refund>).
1645
1646 =cut
1647
1648 sub apply_credits {
1649   my $self = shift;
1650
1651   return 0 unless $self->total_credited;
1652
1653   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
1654       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
1655
1656   my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
1657       qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
1658
1659   my $credit;
1660
1661   foreach my $cust_bill ( @invoices ) {
1662     my $amount;
1663
1664     if ( !defined($credit) || $credit->credited == 0) {
1665       $credit = pop @credits or last;
1666     }
1667
1668     if ($cust_bill->owed >= $credit->credited) {
1669       $amount=$credit->credited;
1670     }else{
1671       $amount=$cust_bill->owed;
1672     }
1673
1674     my $cust_credit_bill = new FS::cust_credit_bill ( {
1675       'crednum' => $credit->crednum,
1676       'invnum'  => $cust_bill->invnum,
1677       'amount'  => $amount,
1678     } );
1679     my $error = $cust_credit_bill->insert;
1680     die $error if $error;
1681
1682     redo if ($cust_bill->owed > 0);
1683
1684   }
1685
1686   return $self->total_credited;
1687 }
1688
1689 =item apply_payments
1690
1691 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
1692 to outstanding invoice balances in chronological order.
1693
1694  #and returns the value of any remaining unapplied payments.
1695
1696 =cut
1697
1698 sub apply_payments {
1699   my $self = shift;
1700
1701   #return 0 unless
1702
1703   my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
1704       qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
1705
1706   my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
1707       qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
1708
1709   my $payment;
1710
1711   foreach my $cust_bill ( @invoices ) {
1712     my $amount;
1713
1714     if ( !defined($payment) || $payment->unapplied == 0 ) {
1715       $payment = pop @payments or last;
1716     }
1717
1718     if ( $cust_bill->owed >= $payment->unapplied ) {
1719       $amount = $payment->unapplied;
1720     } else {
1721       $amount = $cust_bill->owed;
1722     }
1723
1724     my $cust_bill_pay = new FS::cust_bill_pay ( {
1725       'paynum' => $payment->paynum,
1726       'invnum' => $cust_bill->invnum,
1727       'amount' => $amount,
1728     } );
1729     my $error = $cust_bill_pay->insert;
1730     die $error if $error;
1731
1732     redo if ( $cust_bill->owed > 0);
1733
1734   }
1735
1736   return $self->total_unapplied_payments;
1737 }
1738
1739 =item total_credited
1740
1741 Returns the total outstanding credit (see L<FS::cust_credit>) for this
1742 customer.  See L<FS::cust_credit/credited>.
1743
1744 =cut
1745
1746 sub total_credited {
1747   my $self = shift;
1748   my $total_credit = 0;
1749   foreach my $cust_credit ( qsearch('cust_credit', {
1750     'custnum' => $self->custnum,
1751   } ) ) {
1752     $total_credit += $cust_credit->credited;
1753   }
1754   sprintf( "%.2f", $total_credit );
1755 }
1756
1757 =item total_unapplied_payments
1758
1759 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
1760 See L<FS::cust_pay/unapplied>.
1761
1762 =cut
1763
1764 sub total_unapplied_payments {
1765   my $self = shift;
1766   my $total_unapplied = 0;
1767   foreach my $cust_pay ( qsearch('cust_pay', {
1768     'custnum' => $self->custnum,
1769   } ) ) {
1770     $total_unapplied += $cust_pay->unapplied;
1771   }
1772   sprintf( "%.2f", $total_unapplied );
1773 }
1774
1775 =item balance
1776
1777 Returns the balance for this customer (total_owed minus total_credited
1778 minus total_unapplied_payments).
1779
1780 =cut
1781
1782 sub balance {
1783   my $self = shift;
1784   sprintf( "%.2f",
1785     $self->total_owed - $self->total_credited - $self->total_unapplied_payments
1786   );
1787 }
1788
1789 =item balance_date TIME
1790
1791 Returns the balance for this customer, only considering invoices with date
1792 earlier than TIME (total_owed_date minus total_credited minus
1793 total_unapplied_payments).  TIME is specified as a UNIX timestamp; see
1794 L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion
1795 functions.
1796
1797 =cut
1798
1799 sub balance_date {
1800   my $self = shift;
1801   my $time = shift;
1802   sprintf( "%.2f",
1803     $self->total_owed_date($time)
1804       - $self->total_credited
1805       - $self->total_unapplied_payments
1806   );
1807 }
1808
1809 =item invoicing_list [ ARRAYREF ]
1810
1811 If an arguement is given, sets these email addresses as invoice recipients
1812 (see L<FS::cust_main_invoice>).  Errors are not fatal and are not reported
1813 (except as warnings), so use check_invoicing_list first.
1814
1815 Returns a list of email addresses (with svcnum entries expanded).
1816
1817 Note: You can clear the invoicing list by passing an empty ARRAYREF.  You can
1818 check it without disturbing anything by passing nothing.
1819
1820 This interface may change in the future.
1821
1822 =cut
1823
1824 sub invoicing_list {
1825   my( $self, $arrayref ) = @_;
1826   if ( $arrayref ) {
1827     my @cust_main_invoice;
1828     if ( $self->custnum ) {
1829       @cust_main_invoice =
1830         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
1831     } else {
1832       @cust_main_invoice = ();
1833     }
1834     foreach my $cust_main_invoice ( @cust_main_invoice ) {
1835       #warn $cust_main_invoice->destnum;
1836       unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
1837         #warn $cust_main_invoice->destnum;
1838         my $error = $cust_main_invoice->delete;
1839         warn $error if $error;
1840       }
1841     }
1842     if ( $self->custnum ) {
1843       @cust_main_invoice =
1844         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
1845     } else {
1846       @cust_main_invoice = ();
1847     }
1848     my %seen = map { $_->address => 1 } @cust_main_invoice;
1849     foreach my $address ( @{$arrayref} ) {
1850       next if exists $seen{$address} && $seen{$address};
1851       $seen{$address} = 1;
1852       my $cust_main_invoice = new FS::cust_main_invoice ( {
1853         'custnum' => $self->custnum,
1854         'dest'    => $address,
1855       } );
1856       my $error = $cust_main_invoice->insert;
1857       warn $error if $error;
1858     }
1859   }
1860   if ( $self->custnum ) {
1861     map { $_->address }
1862       qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
1863   } else {
1864     ();
1865   }
1866 }
1867
1868 =item check_invoicing_list ARRAYREF
1869
1870 Checks these arguements as valid input for the invoicing_list method.  If there
1871 is an error, returns the error, otherwise returns false.
1872
1873 =cut
1874
1875 sub check_invoicing_list {
1876   my( $self, $arrayref ) = @_;
1877   foreach my $address ( @{$arrayref} ) {
1878     my $cust_main_invoice = new FS::cust_main_invoice ( {
1879       'custnum' => $self->custnum,
1880       'dest'    => $address,
1881     } );
1882     my $error = $self->custnum
1883                 ? $cust_main_invoice->check
1884                 : $cust_main_invoice->checkdest
1885     ;
1886     return $error if $error;
1887   }
1888   '';
1889 }
1890
1891 =item set_default_invoicing_list
1892
1893 Sets the invoicing list to all accounts associated with this customer,
1894 overwriting any previous invoicing list.
1895
1896 =cut
1897
1898 sub set_default_invoicing_list {
1899   my $self = shift;
1900   $self->invoicing_list($self->all_emails);
1901 }
1902
1903 =item all_emails
1904
1905 Returns the email addresses of all accounts provisioned for this customer.
1906
1907 =cut
1908
1909 sub all_emails {
1910   my $self = shift;
1911   my %list;
1912   foreach my $cust_pkg ( $self->all_pkgs ) {
1913     my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
1914     my @svc_acct =
1915       map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
1916         grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
1917           @cust_svc;
1918     $list{$_}=1 foreach map { $_->email } @svc_acct;
1919   }
1920   keys %list;
1921 }
1922
1923 =item invoicing_list_addpost
1924
1925 Adds postal invoicing to this customer.  If this customer is already configured
1926 to receive postal invoices, does nothing.
1927
1928 =cut
1929
1930 sub invoicing_list_addpost {
1931   my $self = shift;
1932   return if grep { $_ eq 'POST' } $self->invoicing_list;
1933   my @invoicing_list = $self->invoicing_list;
1934   push @invoicing_list, 'POST';
1935   $self->invoicing_list(\@invoicing_list);
1936 }
1937
1938 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
1939
1940 Returns an array of customers referred by this customer (referral_custnum set
1941 to this custnum).  If DEPTH is given, recurses up to the given depth, returning
1942 customers referred by customers referred by this customer and so on, inclusive.
1943 The default behavior is DEPTH 1 (no recursion).
1944
1945 =cut
1946
1947 sub referral_cust_main {
1948   my $self = shift;
1949   my $depth = @_ ? shift : 1;
1950   my $exclude = @_ ? shift : {};
1951
1952   my @cust_main =
1953     map { $exclude->{$_->custnum}++; $_; }
1954       grep { ! $exclude->{ $_->custnum } }
1955         qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
1956
1957   if ( $depth > 1 ) {
1958     push @cust_main,
1959       map { $_->referral_cust_main($depth-1, $exclude) }
1960         @cust_main;
1961   }
1962
1963   @cust_main;
1964 }
1965
1966 =item referral_cust_main_ncancelled
1967
1968 Same as referral_cust_main, except only returns customers with uncancelled
1969 packages.
1970
1971 =cut
1972
1973 sub referral_cust_main_ncancelled {
1974   my $self = shift;
1975   grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
1976 }
1977
1978 =item referral_cust_pkg [ DEPTH ]
1979
1980 Like referral_cust_main, except returns a flat list of all unsuspended (and
1981 uncancelled) packages for each customer.  The number of items in this list may
1982 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
1983
1984 =cut
1985
1986 sub referral_cust_pkg {
1987   my $self = shift;
1988   my $depth = @_ ? shift : 1;
1989
1990   map { $_->unsuspended_pkgs }
1991     grep { $_->unsuspended_pkgs }
1992       $self->referral_cust_main($depth);
1993 }
1994
1995 =item credit AMOUNT, REASON
1996
1997 Applies a credit to this customer.  If there is an error, returns the error,
1998 otherwise returns false.
1999
2000 =cut
2001
2002 sub credit {
2003   my( $self, $amount, $reason ) = @_;
2004   my $cust_credit = new FS::cust_credit {
2005     'custnum' => $self->custnum,
2006     'amount'  => $amount,
2007     'reason'  => $reason,
2008   };
2009   $cust_credit->insert;
2010 }
2011
2012 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
2013
2014 Creates a one-time charge for this customer.  If there is an error, returns
2015 the error, otherwise returns false.
2016
2017 =cut
2018
2019 sub charge {
2020   my ( $self, $amount ) = ( shift, shift );
2021   my $pkg      = @_ ? shift : 'One-time charge';
2022   my $comment  = @_ ? shift : '$'. sprintf("%.2f",$amount);
2023   my $taxclass = @_ ? shift : '';
2024
2025   local $SIG{HUP} = 'IGNORE';
2026   local $SIG{INT} = 'IGNORE';
2027   local $SIG{QUIT} = 'IGNORE';
2028   local $SIG{TERM} = 'IGNORE';
2029   local $SIG{TSTP} = 'IGNORE';
2030   local $SIG{PIPE} = 'IGNORE';
2031
2032   my $oldAutoCommit = $FS::UID::AutoCommit;
2033   local $FS::UID::AutoCommit = 0;
2034   my $dbh = dbh;
2035
2036   my $part_pkg = new FS::part_pkg ( {
2037     'pkg'      => $pkg,
2038     'comment'  => $comment,
2039     'setup'    => $amount,
2040     'freq'     => 0,
2041     'recur'    => '0',
2042     'disabled' => 'Y',
2043     'taxclass' => $taxclass,
2044   } );
2045
2046   my $error = $part_pkg->insert;
2047   if ( $error ) {
2048     $dbh->rollback if $oldAutoCommit;
2049     return $error;
2050   }
2051
2052   my $pkgpart = $part_pkg->pkgpart;
2053   my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
2054   unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
2055     my $type_pkgs = new FS::type_pkgs \%type_pkgs;
2056     $error = $type_pkgs->insert;
2057     if ( $error ) {
2058       $dbh->rollback if $oldAutoCommit;
2059       return $error;
2060     }
2061   }
2062
2063   my $cust_pkg = new FS::cust_pkg ( {
2064     'custnum' => $self->custnum,
2065     'pkgpart' => $pkgpart,
2066   } );
2067
2068   $error = $cust_pkg->insert;
2069   if ( $error ) {
2070     $dbh->rollback if $oldAutoCommit;
2071     return $error;
2072   }
2073
2074   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2075   '';
2076
2077 }
2078
2079 =item cust_bill
2080
2081 Returns all the invoices (see L<FS::cust_bill>) for this customer.
2082
2083 =cut
2084
2085 sub cust_bill {
2086   my $self = shift;
2087   sort { $a->_date <=> $b->_date }
2088     qsearch('cust_bill', { 'custnum' => $self->custnum, } )
2089 }
2090
2091 =item open_cust_bill
2092
2093 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
2094 customer.
2095
2096 =cut
2097
2098 sub open_cust_bill {
2099   my $self = shift;
2100   grep { $_->owed > 0 } $self->cust_bill;
2101 }
2102
2103 =item cust_credit
2104
2105 Returns all the credits (see L<FS::cust_credit>) for this customer.
2106
2107 =cut
2108
2109 sub cust_credit {
2110   my $self = shift;
2111   sort { $a->_date <=> $b->_date }
2112     qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
2113 }
2114
2115 =item cust_pay
2116
2117 Returns all the payments (see L<FS::cust_pay>) for this customer.
2118
2119 =cut
2120
2121 sub cust_pay {
2122   my $self = shift;
2123   sort { $a->_date <=> $b->_date }
2124     qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
2125 }
2126
2127 =item cust_refund
2128
2129 Returns all the refunds (see L<FS::cust_refund>) for this customer.
2130
2131 =cut
2132
2133 sub cust_refund {
2134   my $self = shift;
2135   sort { $a->_date <=> $b->_date }
2136     qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
2137 }
2138
2139 =back
2140
2141 =head1 SUBROUTINES
2142
2143 =over 4
2144
2145 =item check_and_rebuild_fuzzyfiles
2146
2147 =cut
2148
2149 sub check_and_rebuild_fuzzyfiles {
2150   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2151   -e "$dir/cust_main.last" && -e "$dir/cust_main.company"
2152     or &rebuild_fuzzyfiles;
2153 }
2154
2155 =item rebuild_fuzzyfiles
2156
2157 =cut
2158
2159 sub rebuild_fuzzyfiles {
2160
2161   use Fcntl qw(:flock);
2162
2163   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2164
2165   #last
2166
2167   open(LASTLOCK,">>$dir/cust_main.last")
2168     or die "can't open $dir/cust_main.last: $!";
2169   flock(LASTLOCK,LOCK_EX)
2170     or die "can't lock $dir/cust_main.last: $!";
2171
2172   my @all_last = map $_->getfield('last'), qsearch('cust_main', {});
2173   push @all_last,
2174                  grep $_, map $_->getfield('ship_last'), qsearch('cust_main',{})
2175     if defined dbdef->table('cust_main')->column('ship_last');
2176
2177   open (LASTCACHE,">$dir/cust_main.last.tmp")
2178     or die "can't open $dir/cust_main.last.tmp: $!";
2179   print LASTCACHE join("\n", @all_last), "\n";
2180   close LASTCACHE or die "can't close $dir/cust_main.last.tmp: $!";
2181
2182   rename "$dir/cust_main.last.tmp", "$dir/cust_main.last";
2183   close LASTLOCK;
2184
2185   #company
2186
2187   open(COMPANYLOCK,">>$dir/cust_main.company")
2188     or die "can't open $dir/cust_main.company: $!";
2189   flock(COMPANYLOCK,LOCK_EX)
2190     or die "can't lock $dir/cust_main.company: $!";
2191
2192   my @all_company = grep $_ ne '', map $_->company, qsearch('cust_main',{});
2193   push @all_company,
2194        grep $_ ne '', map $_->ship_company, qsearch('cust_main', {})
2195     if defined dbdef->table('cust_main')->column('ship_last');
2196
2197   open (COMPANYCACHE,">$dir/cust_main.company.tmp")
2198     or die "can't open $dir/cust_main.company.tmp: $!";
2199   print COMPANYCACHE join("\n", @all_company), "\n";
2200   close COMPANYCACHE or die "can't close $dir/cust_main.company.tmp: $!";
2201
2202   rename "$dir/cust_main.company.tmp", "$dir/cust_main.company";
2203   close COMPANYLOCK;
2204
2205 }
2206
2207 =item all_last
2208
2209 =cut
2210
2211 sub all_last {
2212   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2213   open(LASTCACHE,"<$dir/cust_main.last")
2214     or die "can't open $dir/cust_main.last: $!";
2215   my @array = map { chomp; $_; } <LASTCACHE>;
2216   close LASTCACHE;
2217   \@array;
2218 }
2219
2220 =item all_company
2221
2222 =cut
2223
2224 sub all_company {
2225   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2226   open(COMPANYCACHE,"<$dir/cust_main.company")
2227     or die "can't open $dir/cust_main.last: $!";
2228   my @array = map { chomp; $_; } <COMPANYCACHE>;
2229   close COMPANYCACHE;
2230   \@array;
2231 }
2232
2233 =item append_fuzzyfiles LASTNAME COMPANY
2234
2235 =cut
2236
2237 sub append_fuzzyfiles {
2238   my( $last, $company ) = @_;
2239
2240   &check_and_rebuild_fuzzyfiles;
2241
2242   use Fcntl qw(:flock);
2243
2244   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2245
2246   if ( $last ) {
2247
2248     open(LAST,">>$dir/cust_main.last")
2249       or die "can't open $dir/cust_main.last: $!";
2250     flock(LAST,LOCK_EX)
2251       or die "can't lock $dir/cust_main.last: $!";
2252
2253     print LAST "$last\n";
2254
2255     flock(LAST,LOCK_UN)
2256       or die "can't unlock $dir/cust_main.last: $!";
2257     close LAST;
2258   }
2259
2260   if ( $company ) {
2261
2262     open(COMPANY,">>$dir/cust_main.company")
2263       or die "can't open $dir/cust_main.company: $!";
2264     flock(COMPANY,LOCK_EX)
2265       or die "can't lock $dir/cust_main.company: $!";
2266
2267     print COMPANY "$company\n";
2268
2269     flock(COMPANY,LOCK_UN)
2270       or die "can't unlock $dir/cust_main.company: $!";
2271
2272     close COMPANY;
2273   }
2274
2275   1;
2276 }
2277
2278 =item batch_import
2279
2280 =cut
2281
2282 sub batch_import {
2283   my $param = shift;
2284   #warn join('-',keys %$param);
2285   my $fh = $param->{filehandle};
2286   my $agentnum = $param->{agentnum};
2287   my $refnum = $param->{refnum};
2288   my $pkgpart = $param->{pkgpart};
2289   my @fields = @{$param->{fields}};
2290
2291   eval "use Date::Parse;";
2292   die $@ if $@;
2293   eval "use Text::CSV_XS;";
2294   die $@ if $@;
2295
2296   my $csv = new Text::CSV_XS;
2297   #warn $csv;
2298   #warn $fh;
2299
2300   my $imported = 0;
2301   #my $columns;
2302
2303   local $SIG{HUP} = 'IGNORE';
2304   local $SIG{INT} = 'IGNORE';
2305   local $SIG{QUIT} = 'IGNORE';
2306   local $SIG{TERM} = 'IGNORE';
2307   local $SIG{TSTP} = 'IGNORE';
2308   local $SIG{PIPE} = 'IGNORE';
2309
2310   my $oldAutoCommit = $FS::UID::AutoCommit;
2311   local $FS::UID::AutoCommit = 0;
2312   my $dbh = dbh;
2313
2314   #while ( $columns = $csv->getline($fh) ) {
2315   my $line;
2316   while ( defined($line=<$fh>) ) {
2317
2318     $csv->parse($line) or do {
2319       $dbh->rollback if $oldAutoCommit;
2320       return "can't parse: ". $csv->error_input();
2321     };
2322
2323     my @columns = $csv->fields();
2324     #warn join('-',@columns);
2325
2326     my %cust_main = (
2327       agentnum => $agentnum,
2328       refnum   => $refnum,
2329       country  => 'US', #default
2330       payby    => 'BILL', #default
2331       paydate  => '12/2037', #default
2332     );
2333     my $billtime = time;
2334     my %cust_pkg = ( pkgpart => $pkgpart );
2335     foreach my $field ( @fields ) {
2336       if ( $field =~ /^cust_pkg\.(setup|bill|susp|expire|cancel)$/ ) {
2337         #$cust_pkg{$1} = str2time( shift @$columns );
2338         if ( $1 eq 'setup' ) {
2339           $billtime = str2time(shift @columns);
2340         } else {
2341           $cust_pkg{$1} = str2time( shift @columns );
2342         }
2343       } else {
2344         #$cust_main{$field} = shift @$columns;
2345         $cust_main{$field} = shift @columns;
2346       }
2347     }
2348
2349     my $cust_pkg = new FS::cust_pkg ( \%cust_pkg ) if $pkgpart;
2350     my $cust_main = new FS::cust_main ( \%cust_main );
2351     use Tie::RefHash;
2352     tie my %hash, 'Tie::RefHash'; #this part is important
2353     $hash{$cust_pkg} = [] if $pkgpart;
2354     my $error = $cust_main->insert( \%hash );
2355
2356     if ( $error ) {
2357       $dbh->rollback if $oldAutoCommit;
2358       return "can't insert customer for $line: $error";
2359     }
2360
2361     #false laziness w/bill.cgi
2362     $error = $cust_main->bill( 'time' => $billtime );
2363     if ( $error ) {
2364       $dbh->rollback if $oldAutoCommit;
2365       return "can't bill customer for $line: $error";
2366     }
2367
2368     $cust_main->apply_payments;
2369     $cust_main->apply_credits;
2370
2371     $error = $cust_main->collect();
2372     if ( $error ) {
2373       $dbh->rollback if $oldAutoCommit;
2374       return "can't collect customer for $line: $error";
2375     }
2376
2377     $imported++;
2378   }
2379
2380   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2381
2382   return "Empty file!" unless $imported;
2383
2384   ''; #no error
2385
2386 }
2387
2388 =item batch_charge
2389
2390 =cut
2391
2392 sub batch_charge {
2393   my $param = shift;
2394   #warn join('-',keys %$param);
2395   my $fh = $param->{filehandle};
2396   my @fields = @{$param->{fields}};
2397
2398   eval "use Date::Parse;";
2399   die $@ if $@;
2400   eval "use Text::CSV_XS;";
2401   die $@ if $@;
2402
2403   my $csv = new Text::CSV_XS;
2404   #warn $csv;
2405   #warn $fh;
2406
2407   my $imported = 0;
2408   #my $columns;
2409
2410   local $SIG{HUP} = 'IGNORE';
2411   local $SIG{INT} = 'IGNORE';
2412   local $SIG{QUIT} = 'IGNORE';
2413   local $SIG{TERM} = 'IGNORE';
2414   local $SIG{TSTP} = 'IGNORE';
2415   local $SIG{PIPE} = 'IGNORE';
2416
2417   my $oldAutoCommit = $FS::UID::AutoCommit;
2418   local $FS::UID::AutoCommit = 0;
2419   my $dbh = dbh;
2420
2421   #while ( $columns = $csv->getline($fh) ) {
2422   my $line;
2423   while ( defined($line=<$fh>) ) {
2424
2425     $csv->parse($line) or do {
2426       $dbh->rollback if $oldAutoCommit;
2427       return "can't parse: ". $csv->error_input();
2428     };
2429
2430     my @columns = $csv->fields();
2431     #warn join('-',@columns);
2432
2433     my %row = ();
2434     foreach my $field ( @fields ) {
2435       $row{$field} = shift @columns;
2436     }
2437
2438     my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
2439     unless ( $cust_main ) {
2440       $dbh->rollback if $oldAutoCommit;
2441       return "unknown custnum $row{'custnum'}";
2442     }
2443
2444     if ( $row{'amount'} > 0 ) {
2445       my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
2446       if ( $error ) {
2447         $dbh->rollback if $oldAutoCommit;
2448         return $error;
2449       }
2450       $imported++;
2451     } elsif ( $row{'amount'} < 0 ) {
2452       my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
2453                                       $row{'pkg'}                         );
2454       if ( $error ) {
2455         $dbh->rollback if $oldAutoCommit;
2456         return $error;
2457       }
2458       $imported++;
2459     } else {
2460       #hmm?
2461     }
2462
2463   }
2464
2465   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2466
2467   return "Empty file!" unless $imported;
2468
2469   ''; #no error
2470
2471 }
2472
2473 =back
2474
2475 =head1 BUGS
2476
2477 The delete method.
2478
2479 The delete method should possibly take an FS::cust_main object reference
2480 instead of a scalar customer number.
2481
2482 Bill and collect options should probably be passed as references instead of a
2483 list.
2484
2485 There should probably be a configuration file with a list of allowed credit
2486 card types.
2487
2488 No multiple currency support (probably a larger project than just this module).
2489
2490 =head1 SEE ALSO
2491
2492 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
2493 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
2494 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.
2495
2496 =cut
2497
2498 1;
2499