FS/FS/cust_main.pm

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