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