FS/FS/cust_main.pm

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