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