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