FS/FS/cust_main.pm

   1 package FS::cust_main;
   2
   3 use strict;
   4 use vars qw( @ISA $conf $DEBUG $import );
   5 use vars qw( $realtime_bop_decline_quiet ); #ugh
   6 use Safe;
   7 use Carp;
   8 BEGIN {
   9   eval "use Time::Local;";
  10   die "Time::Local minimum version 1.05 required with Perl versions before 5.6"
  11     if $] < 5.006 && !defined($Time::Local::VERSION);
  12   eval "use Time::Local qw(timelocal timelocal_nocheck);";
  13 }
  14 use Date::Format;
  15 #use Date::Manip;
  16 use String::Approx qw(amatch);
  17 use Business::CreditCard;
  18 use FS::UID qw( getotaker dbh );
  19 use FS::Record qw( qsearchs qsearch dbdef );
  20 use FS::Misc qw( send_email );
  21 use FS::cust_pkg;
  22 use FS::cust_bill;
  23 use FS::cust_bill_pkg;
  24 use FS::cust_pay;
  25 use FS::cust_pay_void;
  26 use FS::cust_credit;
  27 use FS::cust_refund;
  28 use FS::part_referral;
  29 use FS::cust_main_county;
  30 use FS::agent;
  31 use FS::cust_main_invoice;
  32 use FS::cust_credit_bill;
  33 use FS::cust_bill_pay;
  34 use FS::prepay_credit;
  35 use FS::queue;
  36 use FS::part_pkg;
  37 use FS::part_bill_event;
  38 use FS::cust_bill_event;
  39 use FS::cust_tax_exempt;
  40 use FS::type_pkgs;
  41 use FS::Msgcat qw(gettext);
  42
  43 @ISA = qw( FS::Record );
  44
  45 $realtime_bop_decline_quiet = 0;
  46
  47 $DEBUG = 0;
  48 #$DEBUG = 1;
  49
  50 $import = 0;
  51
  52 #ask FS::UID to run this stuff for us later
  53 #$FS::UID::callback{'FS::cust_main'} = sub {
  54 install_callback FS::UID sub {
  55   $conf = new FS::Conf;
  56   #yes, need it for stuff below (prolly should be cached)
  57 };
  58
  59 sub _cache {
  60   my $self = shift;
  61   my ( $hashref, $cache ) = @_;
  62   if ( exists $hashref->{'pkgnum'} ) {
  63 #    #@{ $self->{'_pkgnum'} } = ();
  64     my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum});
  65     $self->{'_pkgnum'} = $subcache;
  66     #push @{ $self->{'_pkgnum'} },
  67     FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum};
  68   }
  69 }
  70
  71 =head1 NAME
  72
  73 FS::cust_main - Object methods for cust_main records
  74
  75 =head1 SYNOPSIS
  76
  77   use FS::cust_main;
  78
  79   $record = new FS::cust_main \%hash;
  80   $record = new FS::cust_main { 'column' => 'value' };
  81
  82   $error = $record->insert;
  83
  84   $error = $new_record->replace($old_record);
  85
  86   $error = $record->delete;
  87
  88   $error = $record->check;
  89
  90   @cust_pkg = $record->all_pkgs;
  91
  92   @cust_pkg = $record->ncancelled_pkgs;
  93
  94   @cust_pkg = $record->suspended_pkgs;
  95
  96   $error = $record->bill;
  97   $error = $record->bill %options;
  98   $error = $record->bill 'time' => $time;
  99
 100   $error = $record->collect;
 101   $error = $record->collect %options;
 102   $error = $record->collect 'invoice_time'   => $time,
 103                             'batch_card'     => 'yes',
 104                             'report_badcard' => 'yes',
 105                           ;
 106
 107 =head1 DESCRIPTION
 108
 109 An FS::cust_main object represents a customer.  FS::cust_main inherits from
 110 FS::Record.  The following fields are currently supported:
 111
 112 =over 4
 113
 114 =item custnum - primary key (assigned automatically for new customers)
 115
 116 =item agentnum - agent (see L<FS::agent>)
 117
 118 =item refnum - Advertising source (see L<FS::part_referral>)
 119
 120 =item first - name
 121
 122 =item last - name
 123
 124 =item ss - social security number (optional)
 125
 126 =item company - (optional)
 127
 128 =item address1
 129
 130 =item address2 - (optional)
 131
 132 =item city
 133
 134 =item county - (optional, see L<FS::cust_main_county>)
 135
 136 =item state - (see L<FS::cust_main_county>)
 137
 138 =item zip
 139
 140 =item country - (see L<FS::cust_main_county>)
 141
 142 =item daytime - phone (optional)
 143
 144 =item night - phone (optional)
 145
 146 =item fax - phone (optional)
 147
 148 =item ship_first - name
 149
 150 =item ship_last - name
 151
 152 =item ship_company - (optional)
 153
 154 =item ship_address1
 155
 156 =item ship_address2 - (optional)
 157
 158 =item ship_city
 159
 160 =item ship_county - (optional, see L<FS::cust_main_county>)
 161
 162 =item ship_state - (see L<FS::cust_main_county>)
 163
 164 =item ship_zip
 165
 166 =item ship_country - (see L<FS::cust_main_county>)
 167
 168 =item ship_daytime - phone (optional)
 169
 170 =item ship_night - phone (optional)
 171
 172 =item ship_fax - phone (optional)
 173
 174 =item payby - I<CARD> (credit card - automatic), I<DCRD> (credit card - on-demand), I<CHEK> (electronic check - automatic), I<DCHK> (electronic check - on-demand), I<LECB> (Phone bill billing), I<BILL> (billing), I<COMP> (free), or I<PREPAY> (special billing type: applies a credit - see L<FS::prepay_credit> and sets billing type to I<BILL>)
 175
 176 =item payinfo - card number, P.O., comp issuer (4-8 lowercase alphanumerics; think username) or prepayment identifier (see L<FS::prepay_credit>)
 177
 178 =item paycvv - Card Verification Value, "CVV2" (also known as CVC2 or CID), the 3 or 4 digit number on the back (or front, for American Express) of the credit card
 179
 180 =item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy
 181
 182 =item payname - name on card or billing name
 183
 184 =item tax - tax exempt, empty or `Y'
 185
 186 =item otaker - order taker (assigned automatically, see L<FS::UID>)
 187
 188 =item comments - comments (optional)
 189
 190 =item referral_custnum - referring customer number
 191
 192 =back
 193
 194 =head1 METHODS
 195
 196 =over 4
 197
 198 =item new HASHREF
 199
 200 Creates a new customer.  To add the customer to the database, see L<"insert">.
 201
 202 Note that this stores the hash reference, not a distinct copy of the hash it
 203 points to.  You can ask the object for a copy with the I<hash> method.
 204
 205 =cut
 206
 207 sub table { 'cust_main'; }
 208
 209 =item insert [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
 210
 211 Adds this customer to the database.  If there is an error, returns the error,
 212 otherwise returns false.
 213
 214 CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert
 215 method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records
 216 are inserted atomicly, or the transaction is rolled back.  Passing an empty
 217 hash reference is equivalent to not supplying this parameter.  There should be
 218 a better explanation of this, but until then, here's an example:
 219
 220   use Tie::RefHash;
 221   tie %hash, 'Tie::RefHash'; #this part is important
 222   %hash = (
 223     $cust_pkg => [ $svc_acct ],
 224     ...
 225   );
 226   $cust_main->insert( \%hash );
 227
 228 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
 229 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
 230 expected and rollback the entire transaction; it is not necessary to call
 231 check_invoicing_list first.  The invoicing_list is set after the records in the
 232 CUST_PKG_HASHREF above are inserted, so it is now possible to set an
 233 invoicing_list destination to the newly-created svc_acct.  Here's an example:
 234
 235   $cust_main->insert( {}, [ $email, 'POST' ] );
 236
 237 Currently available options are: I<depend_jobnum> and I<noexport>.
 238
 239 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 240 on the supplied jobnum (they will not run until the specific job completes).
 241 This can be used to defer provisioning until some action completes (such
 242 as running the customer's credit card sucessfully).
 243
 244 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 245 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 246 the B<reexport> method.)
 247
 248 =cut
 249
 250 sub insert {
 251   my $self = shift;
 252   my $cust_pkgs = @_ ? shift : {};
 253   my $invoicing_list = @_ ? shift : '';
 254   my %options = @_;
 255   warn "FS::cust_main::insert called with options ".
 256        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 257     if $DEBUG;
 258
 259   local $SIG{HUP} = 'IGNORE';
 260   local $SIG{INT} = 'IGNORE';
 261   local $SIG{QUIT} = 'IGNORE';
 262   local $SIG{TERM} = 'IGNORE';
 263   local $SIG{TSTP} = 'IGNORE';
 264   local $SIG{PIPE} = 'IGNORE';
 265
 266   my $oldAutoCommit = $FS::UID::AutoCommit;
 267   local $FS::UID::AutoCommit = 0;
 268   my $dbh = dbh;
 269
 270   my $amount = 0;
 271   my $seconds = 0;
 272   if ( $self->payby eq 'PREPAY' ) {
 273     $self->payby('BILL');
 274     my $prepay_credit = qsearchs(
 275       'prepay_credit',
 276       { 'identifier' => $self->payinfo },
 277       '',
 278       'FOR UPDATE'
 279     );
 280     warn "WARNING: can't find pre-found prepay_credit: ". $self->payinfo
 281       unless $prepay_credit;
 282     $amount = $prepay_credit->amount;
 283     $seconds = $prepay_credit->seconds;
 284     my $error = $prepay_credit->delete;
 285     if ( $error ) {
 286       $dbh->rollback if $oldAutoCommit;
 287       return "removing prepay_credit (transaction rolled back): $error";
 288     }
 289   }
 290
 291   my $error = $self->SUPER::insert;
 292   if ( $error ) {
 293     $dbh->rollback if $oldAutoCommit;
 294     #return "inserting cust_main record (transaction rolled back): $error";
 295     return $error;
 296   }
 297
 298   # invoicing list
 299   if ( $invoicing_list ) {
 300     $error = $self->check_invoicing_list( $invoicing_list );
 301     if ( $error ) {
 302       $dbh->rollback if $oldAutoCommit;
 303       return "checking invoicing_list (transaction rolled back): $error";
 304     }
 305     $self->invoicing_list( $invoicing_list );
 306   }
 307
 308   # packages
 309   $error = $self->order_pkgs($cust_pkgs, \$seconds, %options);
 310   if ( $error ) {
 311     $dbh->rollback if $oldAutoCommit;
 312     return $error;
 313   }
 314
 315   if ( $seconds ) {
 316     $dbh->rollback if $oldAutoCommit;
 317     return "No svc_acct record to apply pre-paid time";
 318   }
 319
 320   if ( $amount ) {
 321     my $cust_credit = new FS::cust_credit {
 322       'custnum' => $self->custnum,
 323       'amount'  => $amount,
 324     };
 325     $error = $cust_credit->insert;
 326     if ( $error ) {
 327       $dbh->rollback if $oldAutoCommit;
 328       return "inserting credit (transaction rolled back): $error";
 329     }
 330   }
 331
 332   $error = $self->queue_fuzzyfiles_update;
 333   if ( $error ) {
 334     $dbh->rollback if $oldAutoCommit;
 335     return "updating fuzzy search cache: $error";
 336   }
 337
 338   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 339   '';
 340
 341 }
 342
 343 =item order_pkgs HASHREF, [ SECONDSREF, [ , OPTION => VALUE ... ] ]
 344
 345 Like the insert method on an existing record, this method orders a package
 346 and included services atomicaly.  Pass a Tie::RefHash data structure to this
 347 method containing FS::cust_pkg and FS::svc_I<tablename> objects.  There should
 348 be a better explanation of this, but until then, here's an example:
 349
 350   use Tie::RefHash;
 351   tie %hash, 'Tie::RefHash'; #this part is important
 352   %hash = (
 353     $cust_pkg => [ $svc_acct ],
 354     ...
 355   );
 356   $cust_main->order_pkgs( \%hash, \'0', 'noexport'=>1 );
 357
 358 Currently available options are: I<depend_jobnum> and I<noexport>.
 359
 360 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 361 on the supplied jobnum (they will not run until the specific job completes).
 362 This can be used to defer provisioning until some action completes (such
 363 as running the customer's credit card sucessfully).
 364
 365 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 366 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 367 the B<reexport> method for each cust_pkg object.  Using the B<reexport> method
 368 on the cust_main object is not recommended, as existing services will also be
 369 reexported.)
 370
 371 =cut
 372
 373 sub order_pkgs {
 374   my $self = shift;
 375   my $cust_pkgs = shift;
 376   my $seconds = shift;
 377   my %options = @_;
 378   my %svc_options = ();
 379   $svc_options{'depend_jobnum'} = $options{'depend_jobnum'}
 380     if exists $options{'depend_jobnum'};
 381   warn "FS::cust_main::order_pkgs called with options ".
 382        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 383     if $DEBUG;
 384
 385   local $SIG{HUP} = 'IGNORE';
 386   local $SIG{INT} = 'IGNORE';
 387   local $SIG{QUIT} = 'IGNORE';
 388   local $SIG{TERM} = 'IGNORE';
 389   local $SIG{TSTP} = 'IGNORE';
 390   local $SIG{PIPE} = 'IGNORE';
 391
 392   my $oldAutoCommit = $FS::UID::AutoCommit;
 393   local $FS::UID::AutoCommit = 0;
 394   my $dbh = dbh;
 395
 396   local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
 397
 398   foreach my $cust_pkg ( keys %$cust_pkgs ) {
 399     $cust_pkg->custnum( $self->custnum );
 400     my $error = $cust_pkg->insert;
 401     if ( $error ) {
 402       $dbh->rollback if $oldAutoCommit;
 403       return "inserting cust_pkg (transaction rolled back): $error";
 404     }
 405     foreach my $svc_something ( @{$cust_pkgs->{$cust_pkg}} ) {
 406       $svc_something->pkgnum( $cust_pkg->pkgnum );
 407       if ( $seconds && $$seconds && $svc_something->isa('FS::svc_acct') ) {
 408         $svc_something->seconds( $svc_something->seconds + $$seconds );
 409         $$seconds = 0;
 410       }
 411       $error = $svc_something->insert(%svc_options);
 412       if ( $error ) {
 413         $dbh->rollback if $oldAutoCommit;
 414         #return "inserting svc_ (transaction rolled back): $error";
 415         return $error;
 416       }
 417     }
 418   }
 419
 420   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 421   ''; #no error
 422 }
 423
 424 =item reexport
 425
 426 This method is deprecated.  See the I<depend_jobnum> option to the insert and
 427 order_pkgs methods for a better way to defer provisioning.
 428
 429 Re-schedules all exports by calling the B<reexport> method of all associated
 430 packages (see L<FS::cust_pkg>).  If there is an error, returns the error;
 431 otherwise returns false.
 432
 433 =cut
 434
 435 sub reexport {
 436   my $self = shift;
 437
 438   carp "warning: FS::cust_main::reexport is deprectated; ".
 439        "use the depend_jobnum option to insert or order_pkgs to delay export";
 440
 441   local $SIG{HUP} = 'IGNORE';
 442   local $SIG{INT} = 'IGNORE';
 443   local $SIG{QUIT} = 'IGNORE';
 444   local $SIG{TERM} = 'IGNORE';
 445   local $SIG{TSTP} = 'IGNORE';
 446   local $SIG{PIPE} = 'IGNORE';
 447
 448   my $oldAutoCommit = $FS::UID::AutoCommit;
 449   local $FS::UID::AutoCommit = 0;
 450   my $dbh = dbh;
 451
 452   foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
 453     my $error = $cust_pkg->reexport;
 454     if ( $error ) {
 455       $dbh->rollback if $oldAutoCommit;
 456       return $error;
 457     }
 458   }
 459
 460   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 461   '';
 462
 463 }
 464
 465 =item delete NEW_CUSTNUM
 466
 467 This deletes the customer.  If there is an error, returns the error, otherwise
 468 returns false.
 469
 470 This will completely remove all traces of the customer record.  This is not
 471 what you want when a customer cancels service; for that, cancel all of the
 472 customer's packages (see L</cancel>).
 473
 474 If the customer has any uncancelled packages, you need to pass a new (valid)
 475 customer number for those packages to be transferred to.  Cancelled packages
 476 will be deleted.  Did I mention that this is NOT what you want when a customer
 477 cancels service and that you really should be looking see L<FS::cust_pkg/cancel>?
 478
 479 You can't delete a customer with invoices (see L<FS::cust_bill>),
 480 or credits (see L<FS::cust_credit>), payments (see L<FS::cust_pay>) or
 481 refunds (see L<FS::cust_refund>).
 482
 483 =cut
 484
 485 sub delete {
 486   my $self = shift;
 487
 488   local $SIG{HUP} = 'IGNORE';
 489   local $SIG{INT} = 'IGNORE';
 490   local $SIG{QUIT} = 'IGNORE';
 491   local $SIG{TERM} = 'IGNORE';
 492   local $SIG{TSTP} = 'IGNORE';
 493   local $SIG{PIPE} = 'IGNORE';
 494
 495   my $oldAutoCommit = $FS::UID::AutoCommit;
 496   local $FS::UID::AutoCommit = 0;
 497   my $dbh = dbh;
 498
 499   if ( $self->cust_bill ) {
 500     $dbh->rollback if $oldAutoCommit;
 501     return "Can't delete a customer with invoices";
 502   }
 503   if ( $self->cust_credit ) {
 504     $dbh->rollback if $oldAutoCommit;
 505     return "Can't delete a customer with credits";
 506   }
 507   if ( $self->cust_pay ) {
 508     $dbh->rollback if $oldAutoCommit;
 509     return "Can't delete a customer with payments";
 510   }
 511   if ( $self->cust_refund ) {
 512     $dbh->rollback if $oldAutoCommit;
 513     return "Can't delete a customer with refunds";
 514   }
 515
 516   my @cust_pkg = $self->ncancelled_pkgs;
 517   if ( @cust_pkg ) {
 518     my $new_custnum = shift;
 519     unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) {
 520       $dbh->rollback if $oldAutoCommit;
 521       return "Invalid new customer number: $new_custnum";
 522     }
 523     foreach my $cust_pkg ( @cust_pkg ) {
 524       my %hash = $cust_pkg->hash;
 525       $hash{'custnum'} = $new_custnum;
 526       my $new_cust_pkg = new FS::cust_pkg ( \%hash );
 527       my $error = $new_cust_pkg->replace($cust_pkg);
 528       if ( $error ) {
 529         $dbh->rollback if $oldAutoCommit;
 530         return $error;
 531       }
 532     }
 533   }
 534   my @cancelled_cust_pkg = $self->all_pkgs;
 535   foreach my $cust_pkg ( @cancelled_cust_pkg ) {
 536     my $error = $cust_pkg->delete;
 537     if ( $error ) {
 538       $dbh->rollback if $oldAutoCommit;
 539       return $error;
 540     }
 541   }
 542
 543   foreach my $cust_main_invoice ( #(email invoice destinations, not invoices)
 544     qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } )
 545   ) {
 546     my $error = $cust_main_invoice->delete;
 547     if ( $error ) {
 548       $dbh->rollback if $oldAutoCommit;
 549       return $error;
 550     }
 551   }
 552
 553   my $error = $self->SUPER::delete;
 554   if ( $error ) {
 555     $dbh->rollback if $oldAutoCommit;
 556     return $error;
 557   }
 558
 559   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 560   '';
 561
 562 }
 563
 564 =item replace OLD_RECORD [ INVOICING_LIST_ARYREF ]
 565
 566 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 567 returns the error, otherwise returns false.
 568
 569 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
 570 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
 571 expected and rollback the entire transaction; it is not necessary to call
 572 check_invoicing_list first.  Here's an example:
 573
 574   $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
 575
 576 =cut
 577
 578 sub replace {
 579   my $self = shift;
 580   my $old = shift;
 581   my @param = @_;
 582
 583   local $SIG{HUP} = 'IGNORE';
 584   local $SIG{INT} = 'IGNORE';
 585   local $SIG{QUIT} = 'IGNORE';
 586   local $SIG{TERM} = 'IGNORE';
 587   local $SIG{TSTP} = 'IGNORE';
 588   local $SIG{PIPE} = 'IGNORE';
 589
 590   if ( $self->payby eq 'COMP' && $self->payby ne $old->payby
 591        && $conf->config('users-allow_comp')                  ) {
 592     return "You are not permitted to create complimentary accounts."
 593       unless grep { $_ eq getotaker } $conf->config('users-allow_comp');
 594   }
 595
 596   my $oldAutoCommit = $FS::UID::AutoCommit;
 597   local $FS::UID::AutoCommit = 0;
 598   my $dbh = dbh;
 599
 600   my $error = $self->SUPER::replace($old);
 601
 602   if ( $error ) {
 603     $dbh->rollback if $oldAutoCommit;
 604     return $error;
 605   }
 606
 607   if ( @param ) { # INVOICING_LIST_ARYREF
 608     my $invoicing_list = shift @param;
 609     $error = $self->check_invoicing_list( $invoicing_list );
 610     if ( $error ) {
 611       $dbh->rollback if $oldAutoCommit;
 612       return $error;
 613     }
 614     $self->invoicing_list( $invoicing_list );
 615   }
 616
 617   if ( $self->payby =~ /^(CARD|CHEK|LECB)$/ &&
 618        grep { $self->get($_) ne $old->get($_) } qw(payinfo paydate payname) ) {
 619     # card/check/lec info has changed, want to retry realtime_ invoice events
 620     my $error = $self->retry_realtime;
 621     if ( $error ) {
 622       $dbh->rollback if $oldAutoCommit;
 623       return $error;
 624     }
 625   }
 626
 627   $error = $self->queue_fuzzyfiles_update;
 628   if ( $error ) {
 629     $dbh->rollback if $oldAutoCommit;
 630     return "updating fuzzy search cache: $error";
 631   }
 632
 633   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 634   '';
 635
 636 }
 637
 638 =item queue_fuzzyfiles_update
 639
 640 Used by insert & replace to update the fuzzy search cache
 641
 642 =cut
 643
 644 sub queue_fuzzyfiles_update {
 645   my $self = shift;
 646
 647   local $SIG{HUP} = 'IGNORE';
 648   local $SIG{INT} = 'IGNORE';
 649   local $SIG{QUIT} = 'IGNORE';
 650   local $SIG{TERM} = 'IGNORE';
 651   local $SIG{TSTP} = 'IGNORE';
 652   local $SIG{PIPE} = 'IGNORE';
 653
 654   my $oldAutoCommit = $FS::UID::AutoCommit;
 655   local $FS::UID::AutoCommit = 0;
 656   my $dbh = dbh;
 657
 658   my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
 659   my $error = $queue->insert($self->getfield('last'), $self->company);
 660   if ( $error ) {
 661     $dbh->rollback if $oldAutoCommit;
 662     return "queueing job (transaction rolled back): $error";
 663   }
 664
 665   if ( defined $self->dbdef_table->column('ship_last') && $self->ship_last ) {
 666     $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
 667     $error = $queue->insert($self->getfield('ship_last'), $self->ship_company);
 668     if ( $error ) {
 669       $dbh->rollback if $oldAutoCommit;
 670       return "queueing job (transaction rolled back): $error";
 671     }
 672   }
 673
 674   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 675   '';
 676
 677 }
 678
 679 =item check
 680
 681 Checks all fields to make sure this is a valid customer record.  If there is
 682 an error, returns the error, otherwise returns false.  Called by the insert
 683 and repalce methods.
 684
 685 =cut
 686
 687 sub check {
 688   my $self = shift;
 689
 690   #warn "BEFORE: \n". $self->_dump;
 691
 692   my $error =
 693     $self->ut_numbern('custnum')
 694     || $self->ut_number('agentnum')
 695     || $self->ut_number('refnum')
 696     || $self->ut_name('last')
 697     || $self->ut_name('first')
 698     || $self->ut_textn('company')
 699     || $self->ut_text('address1')
 700     || $self->ut_textn('address2')
 701     || $self->ut_text('city')
 702     || $self->ut_textn('county')
 703     || $self->ut_textn('state')
 704     || $self->ut_country('country')
 705     || $self->ut_anything('comments')
 706     || $self->ut_numbern('referral_custnum')
 707   ;
 708   #barf.  need message catalogs.  i18n.  etc.
 709   $error .= "Please select an advertising source."
 710     if $error =~ /^Illegal or empty \(numeric\) refnum: /;
 711   return $error if $error;
 712
 713   return "Unknown agent"
 714     unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
 715
 716   return "Unknown refnum"
 717     unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } );
 718
 719   return "Unknown referring custnum ". $self->referral_custnum
 720     unless ! $self->referral_custnum
 721            || qsearchs( 'cust_main', { 'custnum' => $self->referral_custnum } );
 722
 723   if ( $self->ss eq '' ) {
 724     $self->ss('');
 725   } else {
 726     my $ss = $self->ss;
 727     $ss =~ s/\D//g;
 728     $ss =~ /^(\d{3})(\d{2})(\d{4})$/
 729       or return "Illegal social security number: ". $self->ss;
 730     $self->ss("$1-$2-$3");
 731   }
 732
 733
 734 # bad idea to disable, causes billing to fail because of no tax rates later
 735 #  unless ( $import ) {
 736     unless ( qsearch('cust_main_county', {
 737       'country' => $self->country,
 738       'state'   => '',
 739      } ) ) {
 740       return "Unknown state/county/country: ".
 741         $self->state. "/". $self->county. "/". $self->country
 742         unless qsearch('cust_main_county',{
 743           'state'   => $self->state,
 744           'county'  => $self->county,
 745           'country' => $self->country,
 746         } );
 747     }
 748 #  }
 749
 750   $error =
 751     $self->ut_phonen('daytime', $self->country)
 752     || $self->ut_phonen('night', $self->country)
 753     || $self->ut_phonen('fax', $self->country)
 754     || $self->ut_zip('zip', $self->country)
 755   ;
 756   return $error if $error;
 757
 758   my @addfields = qw(
 759     last first company address1 address2 city county state zip
 760     country daytime night fax
 761   );
 762
 763   if ( defined $self->dbdef_table->column('ship_last') ) {
 764     if ( scalar ( grep { $self->getfield($_) ne $self->getfield("ship_$_") }
 765                        @addfields )
 766          && scalar ( grep { $self->getfield("ship_$_") ne '' } @addfields )
 767        )
 768     {
 769       my $error =
 770         $self->ut_name('ship_last')
 771         || $self->ut_name('ship_first')
 772         || $self->ut_textn('ship_company')
 773         || $self->ut_text('ship_address1')
 774         || $self->ut_textn('ship_address2')
 775         || $self->ut_text('ship_city')
 776         || $self->ut_textn('ship_county')
 777         || $self->ut_textn('ship_state')
 778         || $self->ut_country('ship_country')
 779       ;
 780       return $error if $error;
 781
 782       #false laziness with above
 783       unless ( qsearchs('cust_main_county', {
 784         'country' => $self->ship_country,
 785         'state'   => '',
 786        } ) ) {
 787         return "Unknown ship_state/ship_county/ship_country: ".
 788           $self->ship_state. "/". $self->ship_county. "/". $self->ship_country
 789           unless qsearchs('cust_main_county',{
 790             'state'   => $self->ship_state,
 791             'county'  => $self->ship_county,
 792             'country' => $self->ship_country,
 793           } );
 794       }
 795       #eofalse
 796
 797       $error =
 798         $self->ut_phonen('ship_daytime', $self->ship_country)
 799         || $self->ut_phonen('ship_night', $self->ship_country)
 800         || $self->ut_phonen('ship_fax', $self->ship_country)
 801         || $self->ut_zip('ship_zip', $self->ship_country)
 802       ;
 803       return $error if $error;
 804
 805     } else { # ship_ info eq billing info, so don't store dup info in database
 806       $self->setfield("ship_$_", '')
 807         foreach qw( last first company address1 address2 city county state zip
 808                     country daytime night fax );
 809     }
 810   }
 811
 812   $self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY)$/
 813     or return "Illegal payby: ". $self->payby;
 814   $self->payby($1);
 815
 816   if ( $self->payby eq 'CARD' || $self->payby eq 'DCRD' ) {
 817
 818     my $payinfo = $self->payinfo;
 819     $payinfo =~ s/\D//g;
 820     $payinfo =~ /^(\d{13,16})$/
 821       or return gettext('invalid_card'); # . ": ". $self->payinfo;
 822     $payinfo = $1;
 823     $self->payinfo($payinfo);
 824     validate($payinfo)
 825       or return gettext('invalid_card'); # . ": ". $self->payinfo;
 826     return gettext('unknown_card_type')
 827       if cardtype($self->payinfo) eq "Unknown";
 828     if ( defined $self->dbdef_table->column('paycvv') ) {
 829       if ( length($self->paycvv) ) {
 830         if ( cardtype($self->payinfo) eq 'American Express card' ) {
 831           $self->paycvv =~ /^(\d{4})$/
 832             or return "CVV2 (CID) for American Express cards is four digits.";
 833           $self->paycvv($1);
 834         } else {
 835           $self->paycvv =~ /^(\d{3})$/
 836             or return "CVV2 (CVC2/CID) is three digits.";
 837           $self->paycvv($1);
 838         }
 839       } else {
 840         $self->paycvv('');
 841       }
 842     }
 843
 844   } elsif ( $self->payby eq 'CHEK' || $self->payby eq 'DCHK' ) {
 845
 846     my $payinfo = $self->payinfo;
 847     $payinfo =~ s/[^\d\@]//g;
 848     $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba';
 849     $payinfo = "$1\@$2";
 850     $self->payinfo($payinfo);
 851     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 852
 853   } elsif ( $self->payby eq 'LECB' ) {
 854
 855     my $payinfo = $self->payinfo;
 856     $payinfo =~ s/\D//g;
 857     $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number';
 858     $payinfo = $1;
 859     $self->payinfo($payinfo);
 860     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 861
 862   } elsif ( $self->payby eq 'BILL' ) {
 863
 864     $error = $self->ut_textn('payinfo');
 865     return "Illegal P.O. number: ". $self->payinfo if $error;
 866     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 867
 868   } elsif ( $self->payby eq 'COMP' ) {
 869
 870     if ( !$self->custnum && $conf->config('users-allow_comp') ) {
 871       return "You are not permitted to create complimentary accounts."
 872         unless grep { $_ eq getotaker } $conf->config('users-allow_comp');
 873     }
 874
 875     $error = $self->ut_textn('payinfo');
 876     return "Illegal comp account issuer: ". $self->payinfo if $error;
 877     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 878
 879   } elsif ( $self->payby eq 'PREPAY' ) {
 880
 881     my $payinfo = $self->payinfo;
 882     $payinfo =~ s/\W//g; #anything else would just confuse things
 883     $self->payinfo($payinfo);
 884     $error = $self->ut_alpha('payinfo');
 885     return "Illegal prepayment identifier: ". $self->payinfo if $error;
 886     return "Unknown prepayment identifier"
 887       unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } );
 888     $self->paycvv('') if $self->dbdef_table->column('paycvv');
 889
 890   }
 891
 892   if ( $self->paydate eq '' || $self->paydate eq '-' ) {
 893     return "Expriation date required"
 894       unless $self->payby =~ /^(BILL|PREPAY|CHEK|LECB)$/;
 895     $self->paydate('');
 896   } else {
 897     my( $m, $y );
 898     if ( $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) {
 899       ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" );
 900     } elsif ( $self->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) {
 901       ( $m, $y ) = ( $3, "20$2" );
 902     } else {
 903       return "Illegal expiration date: ". $self->paydate;
 904     }
 905     $self->paydate("$y-$m-01");
 906     my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
 907     return gettext('expired_card')
 908       if !$import && ( $y<$nowy || ( $y==$nowy && $1<$nowm ) );
 909   }
 910
 911   if ( $self->payname eq '' && $self->payby !~ /^(CHEK|DCHK)$/ &&
 912        ( ! $conf->exists('require_cardname')
 913          || $self->payby !~ /^(CARD|DCRD)$/  )
 914   ) {
 915     $self->payname( $self->first. " ". $self->getfield('last') );
 916   } else {
 917     $self->payname =~ /^([\w \,\.\-\']+)$/
 918       or return gettext('illegal_name'). " payname: ". $self->payname;
 919     $self->payname($1);
 920   }
 921
 922   $self->tax =~ /^(Y?)$/ or return "Illegal tax: ". $self->tax;
 923   $self->tax($1);
 924
 925   $self->otaker(getotaker) unless $self->otaker;
 926
 927   #warn "AFTER: \n". $self->_dump;
 928
 929   $self->SUPER::check;
 930 }
 931
 932 =item all_pkgs
 933
 934 Returns all packages (see L<FS::cust_pkg>) for this customer.
 935
 936 =cut
 937
 938 sub all_pkgs {
 939   my $self = shift;
 940   if ( $self->{'_pkgnum'} ) {
 941     values %{ $self->{'_pkgnum'}->cache };
 942   } else {
 943     qsearch( 'cust_pkg', { 'custnum' => $self->custnum });
 944   }
 945 }
 946
 947 =item ncancelled_pkgs
 948
 949 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
 950
 951 =cut
 952
 953 sub ncancelled_pkgs {
 954   my $self = shift;
 955   if ( $self->{'_pkgnum'} ) {
 956     grep { ! $_->getfield('cancel') } values %{ $self->{'_pkgnum'}->cache };
 957   } else {
 958     @{ [ # force list context
 959       qsearch( 'cust_pkg', {
 960         'custnum' => $self->custnum,
 961         'cancel'  => '',
 962       }),
 963       qsearch( 'cust_pkg', {
 964         'custnum' => $self->custnum,
 965         'cancel'  => 0,
 966       }),
 967     ] };
 968   }
 969 }
 970
 971 =item suspended_pkgs
 972
 973 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
 974
 975 =cut
 976
 977 sub suspended_pkgs {
 978   my $self = shift;
 979   grep { $_->susp } $self->ncancelled_pkgs;
 980 }
 981
 982 =item unflagged_suspended_pkgs
 983
 984 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
 985 customer (thouse packages without the `manual_flag' set).
 986
 987 =cut
 988
 989 sub unflagged_suspended_pkgs {
 990   my $self = shift;
 991   return $self->suspended_pkgs
 992     unless dbdef->table('cust_pkg')->column('manual_flag');
 993   grep { ! $_->manual_flag } $self->suspended_pkgs;
 994 }
 995
 996 =item unsuspended_pkgs
 997
 998 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
 999 this customer.
1000
1001 =cut
1002
1003 sub unsuspended_pkgs {
1004   my $self = shift;
1005   grep { ! $_->susp } $self->ncancelled_pkgs;
1006 }
1007
1008 =item unsuspend
1009
1010 Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
1011 and L<FS::cust_pkg>) for this customer.  Always returns a list: an empty list
1012 on success or a list of errors.
1013
1014 =cut
1015
1016 sub unsuspend {
1017   my $self = shift;
1018   grep { $_->unsuspend } $self->suspended_pkgs;
1019 }
1020
1021 =item suspend
1022
1023 Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
1024 Always returns a list: an empty list on success or a list of errors.
1025
1026 =cut
1027
1028 sub suspend {
1029   my $self = shift;
1030   grep { $_->suspend } $self->unsuspended_pkgs;
1031 }
1032
1033 =item suspend_if_pkgpart PKGPART [ , PKGPART ... ]
1034
1035 Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
1036 PKGPARTs (see L<FS::part_pkg>).  Always returns a list: an empty list on
1037 success or a list of errors.
1038
1039 =cut
1040
1041 sub suspend_if_pkgpart {
1042   my $self = shift;
1043   my @pkgparts = @_;
1044   grep { $_->suspend }
1045     grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
1046       $self->unsuspended_pkgs;
1047 }
1048
1049 =item suspend_unless_pkgpart PKGPART [ , PKGPART ... ]
1050
1051 Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
1052 listed PKGPARTs (see L<FS::part_pkg>).  Always returns a list: an empty list
1053 on success or a list of errors.
1054
1055 =cut
1056
1057 sub suspend_unless_pkgpart {
1058   my $self = shift;
1059   my @pkgparts = @_;
1060   grep { $_->suspend }
1061     grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
1062       $self->unsuspended_pkgs;
1063 }
1064
1065 =item cancel [ OPTION => VALUE ... ]
1066
1067 Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
1068
1069 Available options are: I<quiet>
1070
1071 I<quiet> can be set true to supress email cancellation notices.
1072
1073 Always returns a list: an empty list on success or a list of errors.
1074
1075 =cut
1076
1077 sub cancel {
1078   my $self = shift;
1079   grep { $_ } map { $_->cancel(@_) } $self->ncancelled_pkgs;
1080 }
1081
1082 =item agent
1083
1084 Returns the agent (see L<FS::agent>) for this customer.
1085
1086 =cut
1087
1088 sub agent {
1089   my $self = shift;
1090   qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1091 }
1092
1093 =item bill OPTIONS
1094
1095 Generates invoices (see L<FS::cust_bill>) for this customer.  Usually used in
1096 conjunction with the collect method.
1097
1098 Options are passed as name-value pairs.
1099
1100 Currently available options are:
1101
1102 resetup - if set true, re-charges setup fees.
1103
1104 time - bills the customer as if it were that time.  Specified as a UNIX
1105 timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and
1106 L<Date::Parse> for conversion functions.  For example:
1107
1108  use Date::Parse;
1109  ...
1110  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
1111
1112
1113 If there is an error, returns the error, otherwise returns false.
1114
1115 =cut
1116
1117 sub bill {
1118   my( $self, %options ) = @_;
1119   my $time = $options{'time'} || time;
1120
1121   my $error;
1122
1123   #put below somehow?
1124   local $SIG{HUP} = 'IGNORE';
1125   local $SIG{INT} = 'IGNORE';
1126   local $SIG{QUIT} = 'IGNORE';
1127   local $SIG{TERM} = 'IGNORE';
1128   local $SIG{TSTP} = 'IGNORE';
1129   local $SIG{PIPE} = 'IGNORE';
1130
1131   my $oldAutoCommit = $FS::UID::AutoCommit;
1132   local $FS::UID::AutoCommit = 0;
1133   my $dbh = dbh;
1134
1135   $self->select_for_update; #mutex
1136
1137   # find the packages which are due for billing, find out how much they are
1138   # & generate invoice database.
1139
1140   my( $total_setup, $total_recur ) = ( 0, 0 );
1141   #my( $taxable_setup, $taxable_recur ) = ( 0, 0 );
1142   my @cust_bill_pkg = ();
1143   #my $tax = 0;##
1144   #my $taxable_charged = 0;##
1145   #my $charged = 0;##
1146
1147   my %tax;
1148
1149   foreach my $cust_pkg (
1150     qsearch('cust_pkg', { 'custnum' => $self->custnum } )
1151   ) {
1152
1153     #NO!! next if $cust_pkg->cancel;
1154     next if $cust_pkg->getfield('cancel');
1155
1156     #? to avoid use of uninitialized value errors... ?
1157     $cust_pkg->setfield('bill', '')
1158       unless defined($cust_pkg->bill);
1159
1160     my $part_pkg = $cust_pkg->part_pkg;
1161
1162     #so we don't modify cust_pkg record unnecessarily
1163     my $cust_pkg_mod_flag = 0;
1164     my %hash = $cust_pkg->hash;
1165     my $old_cust_pkg = new FS::cust_pkg \%hash;
1166
1167     my @details = ();
1168
1169     # bill setup
1170     my $setup = 0;
1171     if ( !$cust_pkg->setup || $options{'resetup'} ) {
1172       my $setup_prog = $part_pkg->getfield('setup');
1173       $setup_prog =~ /^(.*)$/ or do {
1174         $dbh->rollback if $oldAutoCommit;
1175         return "Illegal setup for pkgpart ". $part_pkg->pkgpart.
1176                ": $setup_prog";
1177       };
1178       $setup_prog = $1;
1179       $setup_prog = '0' if $setup_prog =~ /^\s*$/;
1180
1181         #my $cpt = new Safe;
1182         ##$cpt->permit(); #what is necessary?
1183         #$cpt->share(qw( $cust_pkg )); #can $cpt now use $cust_pkg methods?
1184         #$setup = $cpt->reval($setup_prog);
1185       $setup = eval $setup_prog;
1186       unless ( defined($setup) ) {
1187         $dbh->rollback if $oldAutoCommit;
1188         return "Error eval-ing part_pkg->setup pkgpart ". $part_pkg->pkgpart.
1189                "(expression $setup_prog): $@";
1190       }
1191       $cust_pkg->setfield('setup', $time) unless $cust_pkg->setup;
1192       $cust_pkg_mod_flag=1;
1193     }
1194
1195     #bill recurring fee
1196     my $recur = 0;
1197     my $sdate;
1198     if ( $part_pkg->getfield('freq') ne '0' &&
1199          ! $cust_pkg->getfield('susp') &&
1200          ( $cust_pkg->getfield('bill') || 0 ) <= $time
1201     ) {
1202       my $recur_prog = $part_pkg->getfield('recur');
1203       $recur_prog =~ /^(.*)$/ or do {
1204         $dbh->rollback if $oldAutoCommit;
1205         return "Illegal recur for pkgpart ". $part_pkg->pkgpart.
1206                ": $recur_prog";
1207       };
1208       $recur_prog = $1;
1209       $recur_prog = '0' if $recur_prog =~ /^\s*$/;
1210
1211       # shared with $recur_prog
1212       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
1213
1214         #my $cpt = new Safe;
1215         ##$cpt->permit(); #what is necessary?
1216         #$cpt->share(qw( $cust_pkg )); #can $cpt now use $cust_pkg methods?
1217         #$recur = $cpt->reval($recur_prog);
1218       $recur = eval $recur_prog;
1219       unless ( defined($recur) ) {
1220         $dbh->rollback if $oldAutoCommit;
1221         return "Error eval-ing part_pkg->recur pkgpart ".  $part_pkg->pkgpart.
1222                "(expression $recur_prog): $@";
1223       }
1224       #change this bit to use Date::Manip? CAREFUL with timezones (see
1225       # mailing list archive)
1226       my ($sec,$min,$hour,$mday,$mon,$year) =
1227         (localtime($sdate) )[0,1,2,3,4,5];
1228
1229       #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
1230       # only for figuring next bill date, nothing else, so, reset $sdate again
1231       # here
1232       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
1233       $cust_pkg->last_bill($sdate)
1234         if $cust_pkg->dbdef_table->column('last_bill');
1235
1236       if ( $part_pkg->freq =~ /^\d+$/ ) {
1237         $mon += $part_pkg->freq;
1238         until ( $mon < 12 ) { $mon -= 12; $year++; }
1239       } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
1240         my $weeks = $1;
1241         $mday += $weeks * 7;
1242       } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
1243         my $days = $1;
1244         $mday += $days;
1245       } else {
1246         $dbh->rollback if $oldAutoCommit;
1247         return "unparsable frequency: ". $part_pkg->freq;
1248       }
1249       $cust_pkg->setfield('bill',
1250         timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
1251       $cust_pkg_mod_flag = 1;
1252     }
1253
1254     warn "\$setup is undefined" unless defined($setup);
1255     warn "\$recur is undefined" unless defined($recur);
1256     warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
1257
1258     if ( $cust_pkg_mod_flag ) {
1259       $error=$cust_pkg->replace($old_cust_pkg);
1260       if ( $error ) { #just in case
1261         $dbh->rollback if $oldAutoCommit;
1262         return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error";
1263       }
1264       $setup = sprintf( "%.2f", $setup );
1265       $recur = sprintf( "%.2f", $recur );
1266       if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
1267         $dbh->rollback if $oldAutoCommit;
1268         return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
1269       }
1270       if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
1271         $dbh->rollback if $oldAutoCommit;
1272         return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
1273       }
1274       if ( $setup != 0 || $recur != 0 ) {
1275         my $cust_bill_pkg = new FS::cust_bill_pkg ({
1276           'pkgnum'  => $cust_pkg->pkgnum,
1277           'setup'   => $setup,
1278           'recur'   => $recur,
1279           'sdate'   => $sdate,
1280           'edate'   => $cust_pkg->bill,
1281           'details' => \@details,
1282         });
1283         push @cust_bill_pkg, $cust_bill_pkg;
1284         $total_setup += $setup;
1285         $total_recur += $recur;
1286
1287         unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
1288
1289           my @taxes = qsearch( 'cust_main_county', {
1290                                  'state'    => $self->state,
1291                                  'county'   => $self->county,
1292                                  'country'  => $self->country,
1293                                  'taxclass' => $part_pkg->taxclass,
1294                                                                       } );
1295           unless ( @taxes ) {
1296             @taxes =  qsearch( 'cust_main_county', {
1297                                   'state'    => $self->state,
1298                                   'county'   => $self->county,
1299                                   'country'  => $self->country,
1300                                   'taxclass' => '',
1301                                                                       } );
1302           }
1303
1304           #one more try at a whole-country tax rate
1305           unless ( @taxes ) {
1306             @taxes =  qsearch( 'cust_main_county', {
1307                                   'state'    => '',
1308                                   'county'   => '',
1309                                   'country'  => $self->country,
1310                                   'taxclass' => '',
1311                                                                       } );
1312           }
1313
1314           # maybe eliminate this entirely, along with all the 0% records
1315           unless ( @taxes ) {
1316             $dbh->rollback if $oldAutoCommit;
1317             return
1318               "fatal: can't find tax rate for state/county/country/taxclass ".
1319               join('/', ( map $self->$_(), qw(state county country) ),
1320                         $part_pkg->taxclass ).  "\n";
1321           }
1322
1323           foreach my $tax ( @taxes ) {
1324
1325             my $taxable_charged = 0;
1326             $taxable_charged += $setup
1327               unless $part_pkg->setuptax =~ /^Y$/i
1328                   || $tax->setuptax =~ /^Y$/i;
1329             $taxable_charged += $recur
1330               unless $part_pkg->recurtax =~ /^Y$/i
1331                   || $tax->recurtax =~ /^Y$/i;
1332             next unless $taxable_charged;
1333
1334             if ( $tax->exempt_amount > 0 ) {
1335               my ($mon,$year) = (localtime($sdate) )[4,5];
1336               $mon++;
1337               my $freq = $part_pkg->freq || 1;
1338               if ( $freq !~ /(\d+)$/ ) {
1339                 $dbh->rollback if $oldAutoCommit;
1340                 return "daily/weekly package definitions not (yet?)".
1341                        " compatible with monthly tax exemptions";
1342               }
1343               my $taxable_per_month = sprintf("%.2f", $taxable_charged / $freq );
1344               foreach my $which_month ( 1 .. $freq ) {
1345                 my %hash = (
1346                   'custnum' => $self->custnum,
1347                   'taxnum'  => $tax->taxnum,
1348                   'year'    => 1900+$year,
1349                   'month'   => $mon++,
1350                 );
1351                 #until ( $mon < 12 ) { $mon -= 12; $year++; }
1352                 until ( $mon < 13 ) { $mon -= 12; $year++; }
1353                 my $cust_tax_exempt =
1354                   qsearchs('cust_tax_exempt', \%hash)
1355                   || new FS::cust_tax_exempt( { %hash, 'amount' => 0 } );
1356                 my $remaining_exemption = sprintf("%.2f",
1357                   $tax->exempt_amount - $cust_tax_exempt->amount );
1358                 if ( $remaining_exemption > 0 ) {
1359                   my $addl = $remaining_exemption > $taxable_per_month
1360                     ? $taxable_per_month
1361                     : $remaining_exemption;
1362                   $taxable_charged -= $addl;
1363                   my $new_cust_tax_exempt = new FS::cust_tax_exempt ( {
1364                     $cust_tax_exempt->hash,
1365                     'amount' =>
1366                       sprintf("%.2f", $cust_tax_exempt->amount + $addl),
1367                   } );
1368                   $error = $new_cust_tax_exempt->exemptnum
1369                     ? $new_cust_tax_exempt->replace($cust_tax_exempt)
1370                     : $new_cust_tax_exempt->insert;
1371                   if ( $error ) {
1372                     $dbh->rollback if $oldAutoCommit;
1373                     return "fatal: can't update cust_tax_exempt: $error";
1374                   }
1375
1376                 } # if $remaining_exemption > 0
1377
1378               } #foreach $which_month
1379
1380             } #if $tax->exempt_amount
1381
1382             $taxable_charged = sprintf( "%.2f", $taxable_charged);
1383
1384             #$tax += $taxable_charged * $cust_main_county->tax / 100
1385             $tax{ $tax->taxname || 'Tax' } +=
1386               $taxable_charged * $tax->tax / 100
1387
1388           } #foreach my $tax ( @taxes )
1389
1390         } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
1391
1392       } #if $setup != 0 || $recur != 0
1393
1394     } #if $cust_pkg_mod_flag
1395
1396   } #foreach my $cust_pkg
1397
1398   my $charged = sprintf( "%.2f", $total_setup + $total_recur );
1399 #  my $taxable_charged = sprintf( "%.2f", $taxable_setup + $taxable_recur );
1400
1401   unless ( @cust_bill_pkg ) { #don't create invoices with no line items
1402     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1403     return '';
1404   }
1405
1406 #  unless ( $self->tax =~ /Y/i
1407 #           || $self->payby eq 'COMP'
1408 #           || $taxable_charged == 0 ) {
1409 #    my $cust_main_county = qsearchs('cust_main_county',{
1410 #        'state'   => $self->state,
1411 #        'county'  => $self->county,
1412 #        'country' => $self->country,
1413 #    } ) or die "fatal: can't find tax rate for state/county/country ".
1414 #               $self->state. "/". $self->county. "/". $self->country. "\n";
1415 #    my $tax = sprintf( "%.2f",
1416 #      $taxable_charged * ( $cust_main_county->getfield('tax') / 100 )
1417 #    );
1418
1419   if ( dbdef->table('cust_bill_pkg')->column('itemdesc') ) { #1.5 schema
1420
1421     foreach my $taxname ( grep { $tax{$_} > 0 } keys %tax ) {
1422       my $tax = sprintf("%.2f", $tax{$taxname} );
1423       $charged = sprintf( "%.2f", $charged+$tax );
1424
1425       my $cust_bill_pkg = new FS::cust_bill_pkg ({
1426         'pkgnum'   => 0,
1427         'setup'    => $tax,
1428         'recur'    => 0,
1429         'sdate'    => '',
1430         'edate'    => '',
1431         'itemdesc' => $taxname,
1432       });
1433       push @cust_bill_pkg, $cust_bill_pkg;
1434     }
1435
1436   } else { #1.4 schema
1437
1438     my $tax = 0;
1439     foreach ( values %tax ) { $tax += $_ };
1440     $tax = sprintf("%.2f", $tax);
1441     if ( $tax > 0 ) {
1442       $charged = sprintf( "%.2f", $charged+$tax );
1443
1444       my $cust_bill_pkg = new FS::cust_bill_pkg ({
1445         'pkgnum' => 0,
1446         'setup'  => $tax,
1447         'recur'  => 0,
1448         'sdate'  => '',
1449         'edate'  => '',
1450       });
1451       push @cust_bill_pkg, $cust_bill_pkg;
1452     }
1453
1454   }
1455
1456   my $cust_bill = new FS::cust_bill ( {
1457     'custnum' => $self->custnum,
1458     '_date'   => $time,
1459     'charged' => $charged,
1460   } );
1461   $error = $cust_bill->insert;
1462   if ( $error ) {
1463     $dbh->rollback if $oldAutoCommit;
1464     return "can't create invoice for customer #". $self->custnum. ": $error";
1465   }
1466
1467   my $invnum = $cust_bill->invnum;
1468   my $cust_bill_pkg;
1469   foreach $cust_bill_pkg ( @cust_bill_pkg ) {
1470     #warn $invnum;
1471     $cust_bill_pkg->invnum($invnum);
1472     $error = $cust_bill_pkg->insert;
1473     if ( $error ) {
1474       $dbh->rollback if $oldAutoCommit;
1475       return "can't create invoice line item for customer #". $self->custnum.
1476              ": $error";
1477     }
1478   }
1479
1480   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1481   ''; #no error
1482 }
1483
1484 =item collect OPTIONS
1485
1486 (Attempt to) collect money for this customer's outstanding invoices (see
1487 L<FS::cust_bill>).  Usually used after the bill method.
1488
1489 Depending on the value of `payby', this may print or email an invoice (I<BILL>,
1490 I<DCRD>, or I<DCHK>), charge a credit card (I<CARD>), charge via electronic
1491 check/ACH (I<CHEK>), or just add any necessary (pseudo-)payment (I<COMP>).
1492
1493 Most actions are now triggered by invoice events; see L<FS::part_bill_event>
1494 and the invoice events web interface.
1495
1496 If there is an error, returns the error, otherwise returns false.
1497
1498 Options are passed as name-value pairs.
1499
1500 Currently available options are:
1501
1502 invoice_time - Use this time when deciding when to print invoices and
1503 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>
1504 for conversion functions.
1505
1506 retry - Retry card/echeck/LEC transactions even when not scheduled by invoice
1507 events.
1508
1509 retry_card - Deprecated alias for 'retry'
1510
1511 batch_card - This option is deprecated.  See the invoice events web interface
1512 to control whether cards are batched or run against a realtime gateway.
1513
1514 report_badcard - This option is deprecated.
1515
1516 force_print - This option is deprecated; see the invoice events web interface.
1517
1518 quiet - set true to surpress email card/ACH decline notices.
1519
1520 =cut
1521
1522 sub collect {
1523   my( $self, %options ) = @_;
1524   my $invoice_time = $options{'invoice_time'} || time;
1525
1526   #put below somehow?
1527   local $SIG{HUP} = 'IGNORE';
1528   local $SIG{INT} = 'IGNORE';
1529   local $SIG{QUIT} = 'IGNORE';
1530   local $SIG{TERM} = 'IGNORE';
1531   local $SIG{TSTP} = 'IGNORE';
1532   local $SIG{PIPE} = 'IGNORE';
1533
1534   my $oldAutoCommit = $FS::UID::AutoCommit;
1535   local $FS::UID::AutoCommit = 0;
1536   my $dbh = dbh;
1537
1538   $self->select_for_update; #mutex
1539
1540   my $balance = $self->balance;
1541   warn "collect customer". $self->custnum. ": balance $balance" if $DEBUG;
1542   unless ( $balance > 0 ) { #redundant?????
1543     $dbh->rollback if $oldAutoCommit; #hmm
1544     return '';
1545   }
1546
1547   if ( exists($options{'retry_card'}) ) {
1548     carp 'retry_card option passed to collect is deprecated; use retry';
1549     $options{'retry'} ||= $options{'retry_card'};
1550   }
1551   if ( exists($options{'retry'}) && $options{'retry'} ) {
1552     my $error = $self->retry_realtime;
1553     if ( $error ) {
1554       $dbh->rollback if $oldAutoCommit;
1555       return $error;
1556     }
1557   }
1558
1559   foreach my $cust_bill ( $self->open_cust_bill ) {
1560
1561     # don't try to charge for the same invoice if it's already in a batch
1562     #next if qsearchs( 'cust_pay_batch', { 'invnum' => $cust_bill->invnum } );
1563
1564     last if $self->balance <= 0;
1565
1566     warn "invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ")"
1567       if $DEBUG;
1568
1569     foreach my $part_bill_event (
1570       sort {    $a->seconds   <=> $b->seconds
1571              || $a->weight    <=> $b->weight
1572              || $a->eventpart <=> $b->eventpart }
1573         grep { $_->seconds <= ( $invoice_time - $cust_bill->_date )
1574                && ! qsearch( 'cust_bill_event', {
1575                                 'invnum'    => $cust_bill->invnum,
1576                                 'eventpart' => $_->eventpart,
1577                                 'status'    => 'done',
1578                                                                    } )
1579              }
1580           qsearch('part_bill_event', { 'payby'    => $self->payby,
1581                                        'disabled' => '',           } )
1582     ) {
1583
1584       last if $cust_bill->owed <= 0  # don't run subsequent events if owed<=0
1585            || $self->balance   <= 0; # or if balance<=0
1586
1587       warn "calling invoice event (". $part_bill_event->eventcode. ")\n"
1588         if $DEBUG;
1589       my $cust_main = $self; #for callback
1590
1591       my $error;
1592       {
1593         local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
1594         $error = eval $part_bill_event->eventcode;
1595       }
1596
1597       my $status = '';
1598       my $statustext = '';
1599       if ( $@ ) {
1600         $status = 'failed';
1601         $statustext = $@;
1602       } elsif ( $error ) {
1603         $status = 'done';
1604         $statustext = $error;
1605       } else {
1606         $status = 'done'
1607       }
1608
1609       #add cust_bill_event
1610       my $cust_bill_event = new FS::cust_bill_event {
1611         'invnum'     => $cust_bill->invnum,
1612         'eventpart'  => $part_bill_event->eventpart,
1613         #'_date'      => $invoice_time,
1614         '_date'      => time,
1615         'status'     => $status,
1616         'statustext' => $statustext,
1617       };
1618       $error = $cust_bill_event->insert;
1619       if ( $error ) {
1620         #$dbh->rollback if $oldAutoCommit;
1621         #return "error: $error";
1622
1623         # gah, even with transactions.
1624         $dbh->commit if $oldAutoCommit; #well.
1625         my $e = 'WARNING: Event run but database not updated - '.
1626                 'error inserting cust_bill_event, invnum #'. $cust_bill->invnum.
1627                 ', eventpart '. $part_bill_event->eventpart.
1628                 ": $error";
1629         warn $e;
1630         return $e;
1631       }
1632
1633
1634     }
1635
1636   }
1637
1638   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1639   '';
1640
1641 }
1642
1643 =item retry_realtime
1644
1645 Schedules realtime credit card / electronic check / LEC billing events for
1646 for retry.  Useful if card information has changed or manual retry is desired.
1647 The 'collect' method must be called to actually retry the transaction.
1648
1649 Implementation details: For each of this customer's open invoices, changes
1650 the status of the first "done" (with statustext error) realtime processing
1651 event to "failed".
1652
1653 =cut
1654
1655 sub retry_realtime {
1656   my $self = shift;
1657
1658   local $SIG{HUP} = 'IGNORE';
1659   local $SIG{INT} = 'IGNORE';
1660   local $SIG{QUIT} = 'IGNORE';
1661   local $SIG{TERM} = 'IGNORE';
1662   local $SIG{TSTP} = 'IGNORE';
1663   local $SIG{PIPE} = 'IGNORE';
1664
1665   my $oldAutoCommit = $FS::UID::AutoCommit;
1666   local $FS::UID::AutoCommit = 0;
1667   my $dbh = dbh;
1668
1669   foreach my $cust_bill (
1670     grep { $_->cust_bill_event }
1671       $self->open_cust_bill
1672   ) {
1673     my @cust_bill_event =
1674       sort { $a->part_bill_event->seconds <=> $b->part_bill_event->seconds }
1675         grep {
1676                #$_->part_bill_event->plan eq 'realtime-card'
1677                $_->part_bill_event->eventcode =~
1678                    /\$cust_bill\->realtime_(card|ach|lec)/
1679                  && $_->status eq 'done'
1680                  && $_->statustext
1681              }
1682           $cust_bill->cust_bill_event;
1683     next unless @cust_bill_event;
1684     my $error = $cust_bill_event[0]->retry;
1685     if ( $error ) {
1686       $dbh->rollback if $oldAutoCommit;
1687       return "error scheduling invoice event for retry: $error";
1688     }
1689
1690   }
1691
1692   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1693   '';
1694
1695 }
1696
1697 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
1698
1699 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
1700 via a Business::OnlinePayment realtime gateway.  See
1701 L<http://420.am/business-onlinepayment> for supported gateways.
1702
1703 Available methods are: I<CC>, I<ECHECK> and I<LEC>
1704
1705 Available options are: I<description>, I<invnum>, I<quiet>
1706
1707 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
1708 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
1709 if set, will override the value from the customer record.
1710
1711 I<description> is a free-text field passed to the gateway.  It defaults to
1712 "Internet services".
1713
1714 If an I<invnum> is specified, this payment (if sucessful) is applied to the
1715 specified invoice.  If you don't specify an I<invnum> you might want to
1716 call the B<apply_payments> method.
1717
1718 I<quiet> can be set true to surpress email decline notices.
1719
1720 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
1721
1722 =cut
1723
1724 sub realtime_bop {
1725   my( $self, $method, $amount, %options ) = @_;
1726   if ( $DEBUG ) {
1727     warn "$self $method $amount\n";
1728     warn "  $_ => $options{$_}\n" foreach keys %options;
1729   }
1730
1731   $options{'description'} ||= 'Internet services';
1732
1733   #pre-requisites
1734   die "Real-time processing not enabled\n"
1735     unless $conf->exists('business-onlinepayment');
1736   eval "use Business::OnlinePayment";
1737   die $@ if $@;
1738
1739   #load up config
1740   my $bop_config = 'business-onlinepayment';
1741   $bop_config .= '-ach'
1742     if $method eq 'ECHECK' && $conf->exists($bop_config. '-ach');
1743   my ( $processor, $login, $password, $action, @bop_options ) =
1744     $conf->config($bop_config);
1745   $action ||= 'normal authorization';
1746   pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
1747   die "No real-time processor is enabled - ".
1748       "did you set the business-onlinepayment configuration value?\n"
1749     unless $processor;
1750
1751   #massage data
1752
1753   my $address = exists($options{'address1'})
1754                     ? $options{'address1'}
1755                     : $self->address1;
1756   my $address2 = exists($options{'address2'})
1757                     ? $options{'address2'}
1758                     : $self->address2;
1759   $address .= ", ". $address2 if length($address2);
1760
1761   my $o_payname = exists($options{'payname'})
1762                     ? $options{'payname'}
1763                     : $self->payname;
1764   my($payname, $payfirst, $paylast);
1765   if ( $o_payname && $method ne 'ECHECK' ) {
1766     ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
1767       or return "Illegal payname $payname";
1768     ($payfirst, $paylast) = ($1, $2);
1769   } else {
1770     $payfirst = $self->getfield('first');
1771     $paylast = $self->getfield('last');
1772     $payname =  "$payfirst $paylast";
1773   }
1774
1775   my @invoicing_list = grep { $_ ne 'POST' } $self->invoicing_list;
1776   if ( $conf->exists('emailinvoiceauto')
1777        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
1778     push @invoicing_list, $self->all_emails;
1779   }
1780   my $email = $invoicing_list[0];
1781
1782   my $payinfo = exists($options{'payinfo'})
1783                   ? $options{'payinfo'}
1784                   : $self->payinfo;
1785
1786   my %content = ();
1787   if ( $method eq 'CC' ) {
1788
1789     $content{card_number} = $payinfo;
1790     my $paydate = exists($options{'paydate'})
1791                     ? $options{'paydate'}
1792                     : $self->paydate;
1793     $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
1794     $content{expiration} = "$2/$1";
1795
1796     if ( defined $self->dbdef_table->column('paycvv') ) {
1797       my $paycvv = exists($options{'paycvv'})
1798                      ? $options{'paycvv'}
1799                      : $self->paycvv;
1800       $content{cvv2} = $self->paycvv
1801         if length($paycvv);
1802     }
1803
1804     $content{recurring_billing} = 'YES'
1805       if qsearch('cust_pay', { 'custnum' => $self->custnum,
1806                                'payby'   => 'CARD',
1807                                'payinfo' => $payinfo,
1808                              } );
1809
1810   } elsif ( $method eq 'ECHECK' ) {
1811     ( $content{account_number}, $content{routing_code} ) =
1812       split('@', $payinfo);
1813     $content{bank_name} = $o_payname;
1814     $content{account_type} = 'CHECKING';
1815     $content{account_name} = $payname;
1816     $content{customer_org} = $self->company ? 'B' : 'I';
1817     $content{customer_ssn} = exists($options{'ss'})
1818                                ? $options{'ss'}
1819                                : $self->ss;
1820   } elsif ( $method eq 'LEC' ) {
1821     $content{phone} = $payinfo;
1822   }
1823
1824   #transaction(s)
1825
1826   my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
1827
1828   my $transaction = new Business::OnlinePayment( $processor, @bop_options );
1829   $transaction->content(
1830     'type'           => $method,
1831     'login'          => $login,
1832     'password'       => $password,
1833     'action'         => $action1,
1834     'description'    => $options{'description'},
1835     'amount'         => $amount,
1836     'invoice_number' => $options{'invnum'},
1837     'customer_id'    => $self->custnum,
1838     'last_name'      => $paylast,
1839     'first_name'     => $payfirst,
1840     'name'           => $payname,
1841     'address'        => $address,
1842     'city'           => ( exists($options{'city'})
1843                             ? $options{'city'}
1844                             : $self->city          ),
1845     'state'          => ( exists($options{'state'})
1846                             ? $options{'state'}
1847                             : $self->state          ),
1848     'zip'            => ( exists($options{'zip'})
1849                             ? $options{'zip'}
1850                             : $self->zip          ),
1851     'country'        => ( exists($options{'country'})
1852                             ? $options{'country'}
1853                             : $self->country          ),
1854     'referer'        => 'http://cleanwhisker.420.am/',
1855     'email'          => $email,
1856     'phone'          => $self->daytime || $self->night,
1857     %content, #after
1858   );
1859   $transaction->submit();
1860
1861   if ( $transaction->is_success() && $action2 ) {
1862     my $auth = $transaction->authorization;
1863     my $ordernum = $transaction->can('order_number')
1864                    ? $transaction->order_number
1865                    : '';
1866
1867     my $capture =
1868       new Business::OnlinePayment( $processor, @bop_options );
1869
1870     my %capture = (
1871       %content,
1872       type           => $method,
1873       action         => $action2,
1874       login          => $login,
1875       password       => $password,
1876       order_number   => $ordernum,
1877       amount         => $amount,
1878       authorization  => $auth,
1879       description    => $options{'description'},
1880     );
1881
1882     foreach my $field (qw( authorization_source_code returned_ACI                                          transaction_identifier validation_code
1883                            transaction_sequence_num local_transaction_date
1884                            local_transaction_time AVS_result_code          )) {
1885       $capture{$field} = $transaction->$field() if $transaction->can($field);
1886     }
1887
1888     $capture->content( %capture );
1889
1890     $capture->submit();
1891
1892     unless ( $capture->is_success ) {
1893       my $e = "Authorization sucessful but capture failed, custnum #".
1894               $self->custnum. ': '.  $capture->result_code.
1895               ": ". $capture->error_message;
1896       warn $e;
1897       return $e;
1898     }
1899
1900   }
1901
1902   #remove paycvv after initial transaction
1903   #false laziness w/misc/process/payment.cgi - check both to make sure working
1904   # correctly
1905   if ( defined $self->dbdef_table->column('paycvv')
1906        && length($self->paycvv)
1907        && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
1908   ) {
1909     my $error = $self->remove_cvv;
1910     if ( $error ) {
1911       warn "error removing cvv: $error\n";
1912     }
1913   }
1914
1915   #result handling
1916   if ( $transaction->is_success() ) {
1917
1918     my %method2payby = (
1919       'CC'     => 'CARD',
1920       'ECHECK' => 'CHEK',
1921       'LEC'    => 'LECB',
1922     );
1923
1924     my $paybatch = "$processor:". $transaction->authorization;
1925     $paybatch .= ':'. $transaction->order_number
1926       if $transaction->can('order_number')
1927       && length($transaction->order_number);
1928
1929     my $cust_pay = new FS::cust_pay ( {
1930        'custnum'  => $self->custnum,
1931        'invnum'   => $options{'invnum'},
1932        'paid'     => $amount,
1933        '_date'     => '',
1934        'payby'    => $method2payby{$method},
1935        'payinfo'  => $payinfo,
1936        'paybatch' => $paybatch,
1937     } );
1938     my $error = $cust_pay->insert;
1939     if ( $error ) {
1940       $cust_pay->invnum(''); #try again with no specific invnum
1941       my $error2 = $cust_pay->insert;
1942       if ( $error2 ) {
1943         # gah, even with transactions.
1944         my $e = 'WARNING: Card/ACH debited but database not updated - '.
1945                 "error inserting payment ($processor): $error2".
1946                 " (previously tried insert with invnum #$options{'invnum'}" .
1947                 ": $error )";
1948         warn $e;
1949         return $e;
1950       }
1951     }
1952     return ''; #no error
1953
1954   } else {
1955
1956     my $perror = "$processor error: ". $transaction->error_message;
1957
1958     if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
1959          && $conf->exists('emaildecline')
1960          && grep { $_ ne 'POST' } $self->invoicing_list
1961          && ! grep { $transaction->error_message =~ /$_/ }
1962                    $conf->config('emaildecline-exclude')
1963     ) {
1964       my @templ = $conf->config('declinetemplate');
1965       my $template = new Text::Template (
1966         TYPE   => 'ARRAY',
1967         SOURCE => [ map "$_\n", @templ ],
1968       ) or return "($perror) can't create template: $Text::Template::ERROR";
1969       $template->compile()
1970         or return "($perror) can't compile template: $Text::Template::ERROR";
1971
1972       my $templ_hash = { error => $transaction->error_message };
1973
1974       my $error = send_email(
1975         'from'    => $conf->config('invoice_from'),
1976         'to'      => [ grep { $_ ne 'POST' } $self->invoicing_list ],
1977         'subject' => 'Your payment could not be processed',
1978         'body'    => [ $template->fill_in(HASH => $templ_hash) ],
1979       );
1980
1981       $perror .= " (also received error sending decline notification: $error)"
1982         if $error;
1983
1984     }
1985
1986     return $perror;
1987   }
1988
1989 }
1990
1991 =item remove_cvv
1992
1993 Removes the I<paycvv> field from the database directly.
1994
1995 If there is an error, returns the error, otherwise returns false.
1996
1997 =cut
1998
1999 sub remove_cvv {
2000   my $self = shift;
2001   my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
2002     or return dbh->errstr;
2003   $sth->execute($self->custnum)
2004     or return $sth->errstr;
2005   $self->paycvv('');
2006   '';
2007 }
2008
2009 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
2010
2011 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
2012 via a Business::OnlinePayment realtime gateway.  See
2013 L<http://420.am/business-onlinepayment> for supported gateways.
2014
2015 Available methods are: I<CC>, I<ECHECK> and I<LEC>
2016
2017 Available options are: I<amount>, I<reason>, I<paynum>
2018
2019 Most gateways require a reference to an original payment transaction to refund,
2020 so you probably need to specify a I<paynum>.
2021
2022 I<amount> defaults to the original amount of the payment if not specified.
2023
2024 I<reason> specifies a reason for the refund.
2025
2026 Implementation note: If I<amount> is unspecified or equal to the amount of the
2027 orignal payment, first an attempt is made to "void" the transaction via
2028 the gateway (to cancel a not-yet settled transaction) and then if that fails,
2029 the normal attempt is made to "refund" ("credit") the transaction via the
2030 gateway is attempted.
2031
2032 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
2033 #I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
2034 #if set, will override the value from the customer record.
2035
2036 #If an I<invnum> is specified, this payment (if sucessful) is applied to the
2037 #specified invoice.  If you don't specify an I<invnum> you might want to
2038 #call the B<apply_payments> method.
2039
2040 =cut
2041
2042 #some false laziness w/realtime_bop, not enough to make it worth merging
2043 #but some useful small subs should be pulled out
2044 sub realtime_refund_bop {
2045   my( $self, $method, %options ) = @_;
2046   if ( $DEBUG ) {
2047     warn "$self $method refund\n";
2048     warn "  $_ => $options{$_}\n" foreach keys %options;
2049   }
2050
2051   #pre-requisites
2052   die "Real-time processing not enabled\n"
2053     unless $conf->exists('business-onlinepayment');
2054   eval "use Business::OnlinePayment";
2055   die $@ if $@;
2056
2057   #load up config
2058   my $bop_config = 'business-onlinepayment';
2059   $bop_config .= '-ach'
2060     if $method eq 'ECHECK' && $conf->exists($bop_config. '-ach');
2061   my ( $processor, $login, $password, $unused_action, @bop_options ) =
2062     $conf->config($bop_config);
2063   #$action ||= 'normal authorization';
2064   pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
2065   die "No real-time processor is enabled - ".
2066       "did you set the business-onlinepayment configuration value?\n"
2067     unless $processor;
2068
2069   my $cust_pay = '';
2070   my $amount = $options{'amount'};
2071   my( $pay_processor, $auth, $order_number );
2072   if ( $options{'paynum'} ) {
2073     warn "FS::cust_main::realtime_bop: paynum: $options{paynum}\n" if $DEBUG;
2074     $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
2075       or return "Unknown paynum $options{'paynum'}";
2076     $amount ||= $cust_pay->paid;
2077     $cust_pay->paybatch =~ /^(\w+):(\w+)(:(\w+))?$/
2078       or return "Can't parse paybatch for paynum $options{'paynum'}: ".
2079                 $cust_pay->paybatch;
2080     ( $pay_processor, $auth, $order_number ) = ( $1, $2, $4 );
2081     return "processor of payment $options{'paynum'} $pay_processor does not".
2082            " match current processor $processor"
2083       unless $pay_processor eq $processor;
2084   }
2085   return "neither amount nor paynum specified" unless $amount;
2086
2087   #first try void if applicable
2088   if ( $cust_pay && $cust_pay->paid == $amount ) { #and check dates?
2089     my $void = new Business::OnlinePayment( $processor, @bop_options );
2090     $void->content(
2091       'type'           => $method,
2092       'action'         => 'void',
2093       'login'          => $login,
2094       'password'       => $password,
2095       'order_number'   => $order_number,
2096       'amount'         => $amount,
2097       'authorization'  => $auth,
2098       'referer'        => 'http://cleanwhisker.420.am/',
2099     );
2100     $void->submit();
2101     if ( $void->is_success ) {
2102       my $error = $cust_pay->void($options{'reason'});
2103       if ( $error ) {
2104         # gah, even with transactions.
2105         my $e = 'WARNING: Card/ACH voided but database not updated - '.
2106                 "error voiding payment: $error";
2107         warn $e;
2108         return $e;
2109       }
2110       return '';
2111     }
2112   }
2113
2114   #massage data
2115   my $address = $self->address1;
2116   $address .= ", ". $self->address2 if $self->address2;
2117
2118   my($payname, $payfirst, $paylast);
2119   if ( $self->payname && $method ne 'ECHECK' ) {
2120     $payname = $self->payname;
2121     $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
2122       or return "Illegal payname $payname";
2123     ($payfirst, $paylast) = ($1, $2);
2124   } else {
2125     $payfirst = $self->getfield('first');
2126     $paylast = $self->getfield('last');
2127     $payname =  "$payfirst $paylast";
2128   }
2129
2130   my %content = ();
2131   if ( $method eq 'CC' ) {
2132
2133     $content{card_number} = $self->payinfo;
2134     $self->paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
2135     $content{expiration} = "$2/$1";
2136
2137     #$content{cvv2} = $self->paycvv
2138     #  if defined $self->dbdef_table->column('paycvv')
2139     #     && length($self->paycvv);
2140
2141     #$content{recurring_billing} = 'YES'
2142     #  if qsearch('cust_pay', { 'custnum' => $self->custnum,
2143     #                           'payby'   => 'CARD',
2144     #                           'payinfo' => $self->payinfo, } );
2145
2146   } elsif ( $method eq 'ECHECK' ) {
2147     ( $content{account_number}, $content{routing_code} ) =
2148       split('@', $self->payinfo);
2149     $content{bank_name} = $self->payname;
2150     $content{account_type} = 'CHECKING';
2151     $content{account_name} = $payname;
2152     $content{customer_org} = $self->company ? 'B' : 'I';
2153     $content{customer_ssn} = $self->ss;
2154   } elsif ( $method eq 'LEC' ) {
2155     $content{phone} = $self->payinfo;
2156   }
2157
2158   #then try refund
2159   my $refund = new Business::OnlinePayment( $processor, @bop_options );
2160   $refund->content(
2161     'type'           => $method,
2162     'action'         => 'credit',
2163     'login'          => $login,
2164     'password'       => $password,
2165     'order_number'   => $order_number,
2166     'amount'         => $amount,
2167     'authorization'  => $auth,
2168     'customer_id'    => $self->custnum,
2169     'last_name'      => $paylast,
2170     'first_name'     => $payfirst,
2171     'name'           => $payname,
2172     'address'        => $address,
2173     'city'           => $self->city,
2174     'state'          => $self->state,
2175     'zip'            => $self->zip,
2176     'country'        => $self->country,
2177     'referer'        => 'http://cleanwhisker.420.am/',
2178     %content, #after
2179   );
2180   $refund->submit();
2181
2182   return "$processor error: ". $refund->error_message
2183     unless $refund->is_success();
2184
2185   my %method2payby = (
2186     'CC'     => 'CARD',
2187     'ECHECK' => 'CHEK',
2188     'LEC'    => 'LECB',
2189   );
2190
2191   my $paybatch = "$processor:". $refund->authorization;
2192   $paybatch .= ':'. $refund->order_number
2193     if $refund->can('order_number') && $refund->order_number;
2194
2195   while ( $cust_pay && $cust_pay->unappled < $amount ) {
2196     my @cust_bill_pay = $cust_pay->cust_bill_pay;
2197     last unless @cust_bill_pay;
2198     my $cust_bill_pay = pop @cust_bill_pay;
2199     my $error = $cust_bill_pay->delete;
2200     last if $error;
2201   }
2202
2203   my $cust_refund = new FS::cust_refund ( {
2204     'custnum'  => $self->custnum,
2205     'paynum'   => $options{'paynum'},
2206     'refund'   => $amount,
2207     '_date'    => '',
2208     'payby'    => $method2payby{$method},
2209     'payinfo'  => $self->payinfo,
2210     'paybatch' => $paybatch,
2211     'reason'   => $options{'reason'} || 'card or ACH refund',
2212   } );
2213   my $error = $cust_refund->insert;
2214   if ( $error ) {
2215     $cust_refund->paynum(''); #try again with no specific paynum
2216     my $error2 = $cust_refund->insert;
2217     if ( $error2 ) {
2218       # gah, even with transactions.
2219       my $e = 'WARNING: Card/ACH refunded but database not updated - '.
2220               "error inserting refund ($processor): $error2".
2221               " (previously tried insert with paynum #$options{'paynum'}" .
2222               ": $error )";
2223       warn $e;
2224       return $e;
2225     }
2226   }
2227
2228   ''; #no error
2229
2230 }
2231
2232 =item total_owed
2233
2234 Returns the total owed for this customer on all invoices
2235 (see L<FS::cust_bill/owed>).
2236
2237 =cut
2238
2239 sub total_owed {
2240   my $self = shift;
2241   $self->total_owed_date(2145859200); #12/31/2037
2242 }
2243
2244 =item total_owed_date TIME
2245
2246 Returns the total owed for this customer on all invoices with date earlier than
2247 TIME.  TIME is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also
2248 see L<Time::Local> and L<Date::Parse> for conversion functions.
2249
2250 =cut
2251
2252 sub total_owed_date {
2253   my $self = shift;
2254   my $time = shift;
2255   my $total_bill = 0;
2256   foreach my $cust_bill (
2257     grep { $_->_date <= $time }
2258       qsearch('cust_bill', { 'custnum' => $self->custnum, } )
2259   ) {
2260     $total_bill += $cust_bill->owed;
2261   }
2262   sprintf( "%.2f", $total_bill );
2263 }
2264
2265 =item apply_credits OPTION => VALUE ...
2266
2267 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
2268 to outstanding invoice balances in chronological order (or reverse
2269 chronological order if the I<order> option is set to B<newest>) and returns the
2270 value of any remaining unapplied credits available for refund (see
2271 L<FS::cust_refund>).
2272
2273 =cut
2274
2275 sub apply_credits {
2276   my $self = shift;
2277   my %opt = @_;
2278
2279   return 0 unless $self->total_credited;
2280
2281   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
2282       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
2283
2284   my @invoices = $self->open_cust_bill;
2285   @invoices = sort { $b->_date <=> $a->_date } @invoices
2286     if defined($opt{'order'}) && $opt{'order'} eq 'newest';
2287
2288   my $credit;
2289   foreach my $cust_bill ( @invoices ) {
2290     my $amount;
2291
2292     if ( !defined($credit) || $credit->credited == 0) {
2293       $credit = pop @credits or last;
2294     }
2295
2296     if ($cust_bill->owed >= $credit->credited) {
2297       $amount=$credit->credited;
2298     }else{
2299       $amount=$cust_bill->owed;
2300     }
2301
2302     my $cust_credit_bill = new FS::cust_credit_bill ( {
2303       'crednum' => $credit->crednum,
2304       'invnum'  => $cust_bill->invnum,
2305       'amount'  => $amount,
2306     } );
2307     my $error = $cust_credit_bill->insert;
2308     die $error if $error;
2309
2310     redo if ($cust_bill->owed > 0);
2311
2312   }
2313
2314   return $self->total_credited;
2315 }
2316
2317 =item apply_payments
2318
2319 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
2320 to outstanding invoice balances in chronological order.
2321
2322  #and returns the value of any remaining unapplied payments.
2323
2324 =cut
2325
2326 sub apply_payments {
2327   my $self = shift;
2328
2329   #return 0 unless
2330
2331   my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
2332       qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
2333
2334   my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
2335       qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
2336
2337   my $payment;
2338
2339   foreach my $cust_bill ( @invoices ) {
2340     my $amount;
2341
2342     if ( !defined($payment) || $payment->unapplied == 0 ) {
2343       $payment = pop @payments or last;
2344     }
2345
2346     if ( $cust_bill->owed >= $payment->unapplied ) {
2347       $amount = $payment->unapplied;
2348     } else {
2349       $amount = $cust_bill->owed;
2350     }
2351
2352     my $cust_bill_pay = new FS::cust_bill_pay ( {
2353       'paynum' => $payment->paynum,
2354       'invnum' => $cust_bill->invnum,
2355       'amount' => $amount,
2356     } );
2357     my $error = $cust_bill_pay->insert;
2358     die $error if $error;
2359
2360     redo if ( $cust_bill->owed > 0);
2361
2362   }
2363
2364   return $self->total_unapplied_payments;
2365 }
2366
2367 =item total_credited
2368
2369 Returns the total outstanding credit (see L<FS::cust_credit>) for this
2370 customer.  See L<FS::cust_credit/credited>.
2371
2372 =cut
2373
2374 sub total_credited {
2375   my $self = shift;
2376   my $total_credit = 0;
2377   foreach my $cust_credit ( qsearch('cust_credit', {
2378     'custnum' => $self->custnum,
2379   } ) ) {
2380     $total_credit += $cust_credit->credited;
2381   }
2382   sprintf( "%.2f", $total_credit );
2383 }
2384
2385 =item total_unapplied_payments
2386
2387 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
2388 See L<FS::cust_pay/unapplied>.
2389
2390 =cut
2391
2392 sub total_unapplied_payments {
2393   my $self = shift;
2394   my $total_unapplied = 0;
2395   foreach my $cust_pay ( qsearch('cust_pay', {
2396     'custnum' => $self->custnum,
2397   } ) ) {
2398     $total_unapplied += $cust_pay->unapplied;
2399   }
2400   sprintf( "%.2f", $total_unapplied );
2401 }
2402
2403 =item balance
2404
2405 Returns the balance for this customer (total_owed minus total_credited
2406 minus total_unapplied_payments).
2407
2408 =cut
2409
2410 sub balance {
2411   my $self = shift;
2412   sprintf( "%.2f",
2413     $self->total_owed - $self->total_credited - $self->total_unapplied_payments
2414   );
2415 }
2416
2417 =item balance_date TIME
2418
2419 Returns the balance for this customer, only considering invoices with date
2420 earlier than TIME (total_owed_date minus total_credited minus
2421 total_unapplied_payments).  TIME is specified as a UNIX timestamp; see
2422 L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion
2423 functions.
2424
2425 =cut
2426
2427 sub balance_date {
2428   my $self = shift;
2429   my $time = shift;
2430   sprintf( "%.2f",
2431     $self->total_owed_date($time)
2432       - $self->total_credited
2433       - $self->total_unapplied_payments
2434   );
2435 }
2436
2437 =item paydate_monthyear
2438
2439 Returns a two-element list consisting of the month and year of this customer's
2440 paydate (credit card expiration date for CARD customers)
2441
2442 =cut
2443
2444 sub paydate_monthyear {
2445   my $self = shift;
2446   if ( $self->paydate  =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
2447     ( $2, $1 );
2448   } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
2449     ( $1, $3 );
2450   } else {
2451     ('', '');
2452   }
2453 }
2454
2455 =item payinfo_masked
2456
2457 Returns a "masked" payinfo field with all but the last four characters replaced
2458 by 'x'es.  Useful for displaying credit cards.
2459
2460 =cut
2461
2462 sub payinfo_masked {
2463   my $self = shift;
2464   my $payinfo = $self->payinfo;
2465   'x'x(length($payinfo)-4). substr($payinfo,(length($payinfo)-4));
2466 }
2467
2468 =item invoicing_list [ ARRAYREF ]
2469
2470 If an arguement is given, sets these email addresses as invoice recipients
2471 (see L<FS::cust_main_invoice>).  Errors are not fatal and are not reported
2472 (except as warnings), so use check_invoicing_list first.
2473
2474 Returns a list of email addresses (with svcnum entries expanded).
2475
2476 Note: You can clear the invoicing list by passing an empty ARRAYREF.  You can
2477 check it without disturbing anything by passing nothing.
2478
2479 This interface may change in the future.
2480
2481 =cut
2482
2483 sub invoicing_list {
2484   my( $self, $arrayref ) = @_;
2485   if ( $arrayref ) {
2486     my @cust_main_invoice;
2487     if ( $self->custnum ) {
2488       @cust_main_invoice =
2489         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
2490     } else {
2491       @cust_main_invoice = ();
2492     }
2493     foreach my $cust_main_invoice ( @cust_main_invoice ) {
2494       #warn $cust_main_invoice->destnum;
2495       unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
2496         #warn $cust_main_invoice->destnum;
2497         my $error = $cust_main_invoice->delete;
2498         warn $error if $error;
2499       }
2500     }
2501     if ( $self->custnum ) {
2502       @cust_main_invoice =
2503         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
2504     } else {
2505       @cust_main_invoice = ();
2506     }
2507     my %seen = map { $_->address => 1 } @cust_main_invoice;
2508     foreach my $address ( @{$arrayref} ) {
2509       next if exists $seen{$address} && $seen{$address};
2510       $seen{$address} = 1;
2511       my $cust_main_invoice = new FS::cust_main_invoice ( {
2512         'custnum' => $self->custnum,
2513         'dest'    => $address,
2514       } );
2515       my $error = $cust_main_invoice->insert;
2516       warn $error if $error;
2517     }
2518   }
2519   if ( $self->custnum ) {
2520     map { $_->address }
2521       qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
2522   } else {
2523     ();
2524   }
2525 }
2526
2527 =item check_invoicing_list ARRAYREF
2528
2529 Checks these arguements as valid input for the invoicing_list method.  If there
2530 is an error, returns the error, otherwise returns false.
2531
2532 =cut
2533
2534 sub check_invoicing_list {
2535   my( $self, $arrayref ) = @_;
2536   foreach my $address ( @{$arrayref} ) {
2537     my $cust_main_invoice = new FS::cust_main_invoice ( {
2538       'custnum' => $self->custnum,
2539       'dest'    => $address,
2540     } );
2541     my $error = $self->custnum
2542                 ? $cust_main_invoice->check
2543                 : $cust_main_invoice->checkdest
2544     ;
2545     return $error if $error;
2546   }
2547   '';
2548 }
2549
2550 =item set_default_invoicing_list
2551
2552 Sets the invoicing list to all accounts associated with this customer,
2553 overwriting any previous invoicing list.
2554
2555 =cut
2556
2557 sub set_default_invoicing_list {
2558   my $self = shift;
2559   $self->invoicing_list($self->all_emails);
2560 }
2561
2562 =item all_emails
2563
2564 Returns the email addresses of all accounts provisioned for this customer.
2565
2566 =cut
2567
2568 sub all_emails {
2569   my $self = shift;
2570   my %list;
2571   foreach my $cust_pkg ( $self->all_pkgs ) {
2572     my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
2573     my @svc_acct =
2574       map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
2575         grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
2576           @cust_svc;
2577     $list{$_}=1 foreach map { $_->email } @svc_acct;
2578   }
2579   keys %list;
2580 }
2581
2582 =item invoicing_list_addpost
2583
2584 Adds postal invoicing to this customer.  If this customer is already configured
2585 to receive postal invoices, does nothing.
2586
2587 =cut
2588
2589 sub invoicing_list_addpost {
2590   my $self = shift;
2591   return if grep { $_ eq 'POST' } $self->invoicing_list;
2592   my @invoicing_list = $self->invoicing_list;
2593   push @invoicing_list, 'POST';
2594   $self->invoicing_list(\@invoicing_list);
2595 }
2596
2597 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
2598
2599 Returns an array of customers referred by this customer (referral_custnum set
2600 to this custnum).  If DEPTH is given, recurses up to the given depth, returning
2601 customers referred by customers referred by this customer and so on, inclusive.
2602 The default behavior is DEPTH 1 (no recursion).
2603
2604 =cut
2605
2606 sub referral_cust_main {
2607   my $self = shift;
2608   my $depth = @_ ? shift : 1;
2609   my $exclude = @_ ? shift : {};
2610
2611   my @cust_main =
2612     map { $exclude->{$_->custnum}++; $_; }
2613       grep { ! $exclude->{ $_->custnum } }
2614         qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
2615
2616   if ( $depth > 1 ) {
2617     push @cust_main,
2618       map { $_->referral_cust_main($depth-1, $exclude) }
2619         @cust_main;
2620   }
2621
2622   @cust_main;
2623 }
2624
2625 =item referral_cust_main_ncancelled
2626
2627 Same as referral_cust_main, except only returns customers with uncancelled
2628 packages.
2629
2630 =cut
2631
2632 sub referral_cust_main_ncancelled {
2633   my $self = shift;
2634   grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
2635 }
2636
2637 =item referral_cust_pkg [ DEPTH ]
2638
2639 Like referral_cust_main, except returns a flat list of all unsuspended (and
2640 uncancelled) packages for each customer.  The number of items in this list may
2641 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
2642
2643 =cut
2644
2645 sub referral_cust_pkg {
2646   my $self = shift;
2647   my $depth = @_ ? shift : 1;
2648
2649   map { $_->unsuspended_pkgs }
2650     grep { $_->unsuspended_pkgs }
2651       $self->referral_cust_main($depth);
2652 }
2653
2654 =item credit AMOUNT, REASON
2655
2656 Applies a credit to this customer.  If there is an error, returns the error,
2657 otherwise returns false.
2658
2659 =cut
2660
2661 sub credit {
2662   my( $self, $amount, $reason ) = @_;
2663   my $cust_credit = new FS::cust_credit {
2664     'custnum' => $self->custnum,
2665     'amount'  => $amount,
2666     'reason'  => $reason,
2667   };
2668   $cust_credit->insert;
2669 }
2670
2671 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
2672
2673 Creates a one-time charge for this customer.  If there is an error, returns
2674 the error, otherwise returns false.
2675
2676 =cut
2677
2678 sub charge {
2679   my ( $self, $amount ) = ( shift, shift );
2680   my $pkg      = @_ ? shift : 'One-time charge';
2681   my $comment  = @_ ? shift : '$'. sprintf("%.2f",$amount);
2682   my $taxclass = @_ ? shift : '';
2683
2684   local $SIG{HUP} = 'IGNORE';
2685   local $SIG{INT} = 'IGNORE';
2686   local $SIG{QUIT} = 'IGNORE';
2687   local $SIG{TERM} = 'IGNORE';
2688   local $SIG{TSTP} = 'IGNORE';
2689   local $SIG{PIPE} = 'IGNORE';
2690
2691   my $oldAutoCommit = $FS::UID::AutoCommit;
2692   local $FS::UID::AutoCommit = 0;
2693   my $dbh = dbh;
2694
2695   my $part_pkg = new FS::part_pkg ( {
2696     'pkg'      => $pkg,
2697     'comment'  => $comment,
2698     'setup'    => $amount,
2699     'freq'     => 0,
2700     'recur'    => '0',
2701     'disabled' => 'Y',
2702     'taxclass' => $taxclass,
2703   } );
2704
2705   my $error = $part_pkg->insert;
2706   if ( $error ) {
2707     $dbh->rollback if $oldAutoCommit;
2708     return $error;
2709   }
2710
2711   my $pkgpart = $part_pkg->pkgpart;
2712   my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
2713   unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
2714     my $type_pkgs = new FS::type_pkgs \%type_pkgs;
2715     $error = $type_pkgs->insert;
2716     if ( $error ) {
2717       $dbh->rollback if $oldAutoCommit;
2718       return $error;
2719     }
2720   }
2721
2722   my $cust_pkg = new FS::cust_pkg ( {
2723     'custnum' => $self->custnum,
2724     'pkgpart' => $pkgpart,
2725   } );
2726
2727   $error = $cust_pkg->insert;
2728   if ( $error ) {
2729     $dbh->rollback if $oldAutoCommit;
2730     return $error;
2731   }
2732
2733   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2734   '';
2735
2736 }
2737
2738 =item cust_bill
2739
2740 Returns all the invoices (see L<FS::cust_bill>) for this customer.
2741
2742 =cut
2743
2744 sub cust_bill {
2745   my $self = shift;
2746   sort { $a->_date <=> $b->_date }
2747     qsearch('cust_bill', { 'custnum' => $self->custnum, } )
2748 }
2749
2750 =item open_cust_bill
2751
2752 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
2753 customer.
2754
2755 =cut
2756
2757 sub open_cust_bill {
2758   my $self = shift;
2759   grep { $_->owed > 0 } $self->cust_bill;
2760 }
2761
2762 =item cust_credit
2763
2764 Returns all the credits (see L<FS::cust_credit>) for this customer.
2765
2766 =cut
2767
2768 sub cust_credit {
2769   my $self = shift;
2770   sort { $a->_date <=> $b->_date }
2771     qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
2772 }
2773
2774 =item cust_pay
2775
2776 Returns all the payments (see L<FS::cust_pay>) for this customer.
2777
2778 =cut
2779
2780 sub cust_pay {
2781   my $self = shift;
2782   sort { $a->_date <=> $b->_date }
2783     qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
2784 }
2785
2786 =item cust_pay_void
2787
2788 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
2789
2790 =cut
2791
2792 sub cust_pay_void {
2793   my $self = shift;
2794   sort { $a->_date <=> $b->_date }
2795     qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
2796 }
2797
2798
2799 =item cust_refund
2800
2801 Returns all the refunds (see L<FS::cust_refund>) for this customer.
2802
2803 =cut
2804
2805 sub cust_refund {
2806   my $self = shift;
2807   sort { $a->_date <=> $b->_date }
2808     qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
2809 }
2810
2811 =item select_for_update
2812
2813 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
2814 a mutex.
2815
2816 =cut
2817
2818 sub select_for_update {
2819   my $self = shift;
2820   qsearch('cust_main', { 'custnum' => $self->custnum }, '*', 'FOR UPDATE' );
2821 }
2822
2823 =item name
2824
2825 Returns a name string for this customer, either "Company (Last, First)" or
2826 "Last, First".
2827
2828 =cut
2829
2830 sub name {
2831   my $self = shift;
2832   my $name = $self->get('last'). ', '. $self->first;
2833   $name = $self->company. " ($name)" if $self->company;
2834   $name;
2835 }
2836
2837 =item status
2838
2839 Returns a status string for this customer, currently:
2840
2841 =over 4
2842
2843 =item prospect - No packages have ever been ordered
2844
2845 =item active - One or more recurring packages is active
2846
2847 =item suspended - All non-cancelled recurring packages are suspended
2848
2849 =item cancelled - All recurring packages are cancelled
2850
2851 =back
2852
2853 =cut
2854
2855 sub status {
2856   my $self = shift;
2857   for my $status (qw( prospect active suspended cancelled )) {
2858     my $method = $status.'_sql';
2859     my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
2860     my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
2861     $sth->execute( ($self->custnum) x $numnum ) or die $sth->errstr;
2862     return $status if $sth->fetchrow_arrayref->[0];
2863   }
2864 }
2865
2866 =item statuscolor
2867
2868 Returns a hex triplet color string for this customer's status.
2869
2870 =cut
2871
2872 my %statuscolor = (
2873   'prospect'  => '000000',
2874   'active'    => '00CC00',
2875   'suspended' => 'FF9900',
2876   'cancelled' => 'FF0000',
2877 );
2878 sub statuscolor {
2879   my $self = shift;
2880   $statuscolor{$self->status};
2881 }
2882
2883 =back
2884
2885 =head1 CLASS METHODS
2886
2887 =over 4
2888
2889 =item prospect_sql
2890
2891 Returns an SQL expression identifying prospective cust_main records (customers
2892 with no packages ever ordered)
2893
2894 =cut
2895
2896 sub prospect_sql { "
2897   0 = ( SELECT COUNT(*) FROM cust_pkg
2898           WHERE cust_pkg.custnum = cust_main.custnum
2899       )
2900 "; }
2901
2902 =item active_sql
2903
2904 Returns an SQL expression identifying active cust_main records.
2905
2906 =cut
2907
2908 sub active_sql { "
2909   0 < ( SELECT COUNT(*) FROM cust_pkg
2910           WHERE cust_pkg.custnum = cust_main.custnum
2911             AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2912             AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2913       )
2914 "; }
2915
2916 =item susp_sql
2917 =item suspended_sql
2918
2919 Returns an SQL expression identifying suspended cust_main records.
2920
2921 =cut
2922
2923 sub suspended_sql { susp_sql(@_); }
2924 sub susp_sql { "
2925     0 < ( SELECT COUNT(*) FROM cust_pkg
2926             WHERE cust_pkg.custnum = cust_main.custnum
2927               AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2928         )
2929     AND 0 = ( SELECT COUNT(*) FROM cust_pkg
2930                 WHERE cust_pkg.custnum = cust_main.custnum
2931                   AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2932             )
2933 "; }
2934
2935 =item cancel_sql
2936 =item cancelled_sql
2937
2938 Returns an SQL expression identifying cancelled cust_main records.
2939
2940 =cut
2941
2942 sub cancelled_sql { cancel_sql(@_); }
2943 sub cancel_sql { "
2944   0 < ( SELECT COUNT(*) FROM cust_pkg
2945           WHERE cust_pkg.custnum = cust_main.custnum
2946       )
2947   AND 0 = ( SELECT COUNT(*) FROM cust_pkg
2948               WHERE cust_pkg.custnum = cust_main.custnum
2949                 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2950           )
2951 "; }
2952
2953 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
2954
2955 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
2956 records.  Currently, only I<last> or I<company> may be specified (the
2957 appropriate ship_ field is also searched if applicable).
2958
2959 Additional options are the same as FS::Record::qsearch
2960
2961 =cut
2962
2963 sub fuzzy_search {
2964   my( $self, $fuzzy, $hash, @opt) = @_;
2965   #$self
2966   $hash ||= {};
2967   my @cust_main = ();
2968
2969   check_and_rebuild_fuzzyfiles();
2970   foreach my $field ( keys %$fuzzy ) {
2971     my $sub = \&{"all_$field"};
2972     my %match = ();
2973     $match{$_}=1 foreach ( amatch($fuzzy->{$field}, ['i'], @{ &$sub() } ) );
2974
2975     foreach ( keys %match ) {
2976       push @cust_main, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
2977       push @cust_main, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt)
2978         if defined dbdef->table('cust_main')->column('ship_last');
2979     }
2980   }
2981
2982   my %saw = ();
2983   @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
2984
2985   @cust_main;
2986
2987 }
2988
2989 =back
2990
2991 =head1 SUBROUTINES
2992
2993 =over 4
2994
2995 =item check_and_rebuild_fuzzyfiles
2996
2997 =cut
2998
2999 sub check_and_rebuild_fuzzyfiles {
3000   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
3001   -e "$dir/cust_main.last" && -e "$dir/cust_main.company"
3002     or &rebuild_fuzzyfiles;
3003 }
3004
3005 =item rebuild_fuzzyfiles
3006
3007 =cut
3008
3009 sub rebuild_fuzzyfiles {
3010
3011   use Fcntl qw(:flock);
3012
3013   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
3014
3015   #last
3016
3017   open(LASTLOCK,">>$dir/cust_main.last")
3018     or die "can't open $dir/cust_main.last: $!";
3019   flock(LASTLOCK,LOCK_EX)
3020     or die "can't lock $dir/cust_main.last: $!";
3021
3022   my @all_last = map $_->getfield('last'), qsearch('cust_main', {});
3023   push @all_last,
3024                  grep $_, map $_->getfield('ship_last'), qsearch('cust_main',{})
3025     if defined dbdef->table('cust_main')->column('ship_last');
3026
3027   open (LASTCACHE,">$dir/cust_main.last.tmp")
3028     or die "can't open $dir/cust_main.last.tmp: $!";
3029   print LASTCACHE join("\n", @all_last), "\n";
3030   close LASTCACHE or die "can't close $dir/cust_main.last.tmp: $!";
3031
3032   rename "$dir/cust_main.last.tmp", "$dir/cust_main.last";
3033   close LASTLOCK;
3034
3035   #company
3036
3037   open(COMPANYLOCK,">>$dir/cust_main.company")
3038     or die "can't open $dir/cust_main.company: $!";
3039   flock(COMPANYLOCK,LOCK_EX)
3040     or die "can't lock $dir/cust_main.company: $!";
3041
3042   my @all_company = grep $_ ne '', map $_->company, qsearch('cust_main',{});
3043   push @all_company,
3044        grep $_ ne '', map $_->ship_company, qsearch('cust_main', {})
3045     if defined dbdef->table('cust_main')->column('ship_last');
3046
3047   open (COMPANYCACHE,">$dir/cust_main.company.tmp")
3048     or die "can't open $dir/cust_main.company.tmp: $!";
3049   print COMPANYCACHE join("\n", @all_company), "\n";
3050   close COMPANYCACHE or die "can't close $dir/cust_main.company.tmp: $!";
3051
3052   rename "$dir/cust_main.company.tmp", "$dir/cust_main.company";
3053   close COMPANYLOCK;
3054
3055 }
3056
3057 =item all_last
3058
3059 =cut
3060
3061 sub all_last {
3062   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
3063   open(LASTCACHE,"<$dir/cust_main.last")
3064     or die "can't open $dir/cust_main.last: $!";
3065   my @array = map { chomp; $_; } <LASTCACHE>;
3066   close LASTCACHE;
3067   \@array;
3068 }
3069
3070 =item all_company
3071
3072 =cut
3073
3074 sub all_company {
3075   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
3076   open(COMPANYCACHE,"<$dir/cust_main.company")
3077     or die "can't open $dir/cust_main.last: $!";
3078   my @array = map { chomp; $_; } <COMPANYCACHE>;
3079   close COMPANYCACHE;
3080   \@array;
3081 }
3082
3083 =item append_fuzzyfiles LASTNAME COMPANY
3084
3085 =cut
3086
3087 sub append_fuzzyfiles {
3088   my( $last, $company ) = @_;
3089
3090   &check_and_rebuild_fuzzyfiles;
3091
3092   use Fcntl qw(:flock);
3093
3094   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
3095
3096   if ( $last ) {
3097
3098     open(LAST,">>$dir/cust_main.last")
3099       or die "can't open $dir/cust_main.last: $!";
3100     flock(LAST,LOCK_EX)
3101       or die "can't lock $dir/cust_main.last: $!";
3102
3103     print LAST "$last\n";
3104
3105     flock(LAST,LOCK_UN)
3106       or die "can't unlock $dir/cust_main.last: $!";
3107     close LAST;
3108   }
3109
3110   if ( $company ) {
3111
3112     open(COMPANY,">>$dir/cust_main.company")
3113       or die "can't open $dir/cust_main.company: $!";
3114     flock(COMPANY,LOCK_EX)
3115       or die "can't lock $dir/cust_main.company: $!";
3116
3117     print COMPANY "$company\n";
3118
3119     flock(COMPANY,LOCK_UN)
3120       or die "can't unlock $dir/cust_main.company: $!";
3121
3122     close COMPANY;
3123   }
3124
3125   1;
3126 }
3127
3128 =item batch_import
3129
3130 =cut
3131
3132 sub batch_import {
3133   my $param = shift;
3134   #warn join('-',keys %$param);
3135   my $fh = $param->{filehandle};
3136   my $agentnum = $param->{agentnum};
3137   my $refnum = $param->{refnum};
3138   my $pkgpart = $param->{pkgpart};
3139   my @fields = @{$param->{fields}};
3140
3141   eval "use Date::Parse;";
3142   die $@ if $@;
3143   eval "use Text::CSV_XS;";
3144   die $@ if $@;
3145
3146   my $csv = new Text::CSV_XS;
3147   #warn $csv;
3148   #warn $fh;
3149
3150   my $imported = 0;
3151   #my $columns;
3152
3153   local $SIG{HUP} = 'IGNORE';
3154   local $SIG{INT} = 'IGNORE';
3155   local $SIG{QUIT} = 'IGNORE';
3156   local $SIG{TERM} = 'IGNORE';
3157   local $SIG{TSTP} = 'IGNORE';
3158   local $SIG{PIPE} = 'IGNORE';
3159
3160   my $oldAutoCommit = $FS::UID::AutoCommit;
3161   local $FS::UID::AutoCommit = 0;
3162   my $dbh = dbh;
3163
3164   #while ( $columns = $csv->getline($fh) ) {
3165   my $line;
3166   while ( defined($line=<$fh>) ) {
3167
3168     $csv->parse($line) or do {
3169       $dbh->rollback if $oldAutoCommit;
3170       return "can't parse: ". $csv->error_input();
3171     };
3172
3173     my @columns = $csv->fields();
3174     #warn join('-',@columns);
3175
3176     my %cust_main = (
3177       agentnum => $agentnum,
3178       refnum   => $refnum,
3179       country  => $conf->config('countrydefault') || 'US',
3180       payby    => 'BILL', #default
3181       paydate  => '12/2037', #default
3182     );
3183     my $billtime = time;
3184     my %cust_pkg = ( pkgpart => $pkgpart );
3185     foreach my $field ( @fields ) {
3186       if ( $field =~ /^cust_pkg\.(setup|bill|susp|expire|cancel)$/ ) {
3187         #$cust_pkg{$1} = str2time( shift @$columns );
3188         if ( $1 eq 'setup' ) {
3189           $billtime = str2time(shift @columns);
3190         } else {
3191           $cust_pkg{$1} = str2time( shift @columns );
3192         }
3193       } else {
3194         #$cust_main{$field} = shift @$columns;
3195         $cust_main{$field} = shift @columns;
3196       }
3197     }
3198
3199     my $cust_pkg = new FS::cust_pkg ( \%cust_pkg ) if $pkgpart;
3200     my $cust_main = new FS::cust_main ( \%cust_main );
3201     use Tie::RefHash;
3202     tie my %hash, 'Tie::RefHash'; #this part is important
3203     $hash{$cust_pkg} = [] if $pkgpart;
3204     my $error = $cust_main->insert( \%hash );
3205
3206     if ( $error ) {
3207       $dbh->rollback if $oldAutoCommit;
3208       return "can't insert customer for $line: $error";
3209     }
3210
3211     #false laziness w/bill.cgi
3212     $error = $cust_main->bill( 'time' => $billtime );
3213     if ( $error ) {
3214       $dbh->rollback if $oldAutoCommit;
3215       return "can't bill customer for $line: $error";
3216     }
3217
3218     $cust_main->apply_payments;
3219     $cust_main->apply_credits;
3220
3221     $error = $cust_main->collect();
3222     if ( $error ) {
3223       $dbh->rollback if $oldAutoCommit;
3224       return "can't collect customer for $line: $error";
3225     }
3226
3227     $imported++;
3228   }
3229
3230   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3231
3232   return "Empty file!" unless $imported;
3233
3234   ''; #no error
3235
3236 }
3237
3238 =item batch_charge
3239
3240 =cut
3241
3242 sub batch_charge {
3243   my $param = shift;
3244   #warn join('-',keys %$param);
3245   my $fh = $param->{filehandle};
3246   my @fields = @{$param->{fields}};
3247
3248   eval "use Date::Parse;";
3249   die $@ if $@;
3250   eval "use Text::CSV_XS;";
3251   die $@ if $@;
3252
3253   my $csv = new Text::CSV_XS;
3254   #warn $csv;
3255   #warn $fh;
3256
3257   my $imported = 0;
3258   #my $columns;
3259
3260   local $SIG{HUP} = 'IGNORE';
3261   local $SIG{INT} = 'IGNORE';
3262   local $SIG{QUIT} = 'IGNORE';
3263   local $SIG{TERM} = 'IGNORE';
3264   local $SIG{TSTP} = 'IGNORE';
3265   local $SIG{PIPE} = 'IGNORE';
3266
3267   my $oldAutoCommit = $FS::UID::AutoCommit;
3268   local $FS::UID::AutoCommit = 0;
3269   my $dbh = dbh;
3270
3271   #while ( $columns = $csv->getline($fh) ) {
3272   my $line;
3273   while ( defined($line=<$fh>) ) {
3274
3275     $csv->parse($line) or do {
3276       $dbh->rollback if $oldAutoCommit;
3277       return "can't parse: ". $csv->error_input();
3278     };
3279
3280     my @columns = $csv->fields();
3281     #warn join('-',@columns);
3282
3283     my %row = ();
3284     foreach my $field ( @fields ) {
3285       $row{$field} = shift @columns;
3286     }
3287
3288     my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
3289     unless ( $cust_main ) {
3290       $dbh->rollback if $oldAutoCommit;
3291       return "unknown custnum $row{'custnum'}";
3292     }
3293
3294     if ( $row{'amount'} > 0 ) {
3295       my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
3296       if ( $error ) {
3297         $dbh->rollback if $oldAutoCommit;
3298         return $error;
3299       }
3300       $imported++;
3301     } elsif ( $row{'amount'} < 0 ) {
3302       my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
3303                                       $row{'pkg'}                         );
3304       if ( $error ) {
3305         $dbh->rollback if $oldAutoCommit;
3306         return $error;
3307       }
3308       $imported++;
3309     } else {
3310       #hmm?
3311     }
3312
3313   }
3314
3315   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3316
3317   return "Empty file!" unless $imported;
3318
3319   ''; #no error
3320
3321 }
3322
3323 =back
3324
3325 =head1 BUGS
3326
3327 The delete method.
3328
3329 The delete method should possibly take an FS::cust_main object reference
3330 instead of a scalar customer number.
3331
3332 Bill and collect options should probably be passed as references instead of a
3333 list.
3334
3335 There should probably be a configuration file with a list of allowed credit
3336 card types.
3337
3338 No multiple currency support (probably a larger project than just this module).
3339
3340 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
3341
3342 =head1 SEE ALSO
3343
3344 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
3345 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
3346 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.
3347
3348 =cut
3349
3350 1;
3351