FS/FS/cust_main.pm

   1 package FS::cust_main;
   2
   3 use strict;
   4 use vars qw( @ISA @EXPORT_OK $DEBUG $me $conf @encrypted_fields
   5              $import $skip_fuzzyfiles $ignore_expired_card );
   6 use vars qw( $realtime_bop_decline_quiet ); #ugh
   7 use Safe;
   8 use Carp;
   9 use Exporter;
  10 BEGIN {
  11   eval "use Time::Local;";
  12   die "Time::Local minimum version 1.05 required with Perl versions before 5.6"
  13     if $] < 5.006 && !defined($Time::Local::VERSION);
  14   #eval "use Time::Local qw(timelocal timelocal_nocheck);";
  15   eval "use Time::Local qw(timelocal_nocheck);";
  16 }
  17 use Digest::MD5 qw(md5_base64);
  18 use Date::Format;
  19 use Date::Parse;
  20 #use Date::Manip;
  21 use String::Approx qw(amatch);
  22 use Business::CreditCard 0.28;
  23 use Locale::Country;
  24 use FS::UID qw( getotaker dbh );
  25 use FS::Record qw( qsearchs qsearch dbdef );
  26 use FS::Misc qw( send_email );
  27 use FS::Msgcat qw(gettext);
  28 use FS::cust_pkg;
  29 use FS::cust_svc;
  30 use FS::cust_bill;
  31 use FS::cust_bill_pkg;
  32 use FS::cust_pay;
  33 use FS::cust_pay_void;
  34 use FS::cust_credit;
  35 use FS::cust_refund;
  36 use FS::part_referral;
  37 use FS::cust_main_county;
  38 use FS::agent;
  39 use FS::cust_main_invoice;
  40 use FS::cust_credit_bill;
  41 use FS::cust_bill_pay;
  42 use FS::prepay_credit;
  43 use FS::queue;
  44 use FS::part_pkg;
  45 use FS::part_bill_event;
  46 use FS::cust_bill_event;
  47 use FS::cust_tax_exempt;
  48 use FS::cust_tax_exempt_pkg;
  49 use FS::type_pkgs;
  50 use FS::payment_gateway;
  51 use FS::agent_payment_gateway;
  52 use FS::banned_pay;
  53
  54 @ISA = qw( FS::Record );
  55
  56 @EXPORT_OK = qw( smart_search );
  57
  58 $realtime_bop_decline_quiet = 0;
  59
  60 # 1 is mostly method/subroutine entry and options
  61 # 2 traces progress of some operations
  62 # 3 is even more information including possibly sensitive data
  63 $DEBUG = 0;
  64 $me = '[FS::cust_main]';
  65
  66 $import = 0;
  67 $skip_fuzzyfiles = 0;
  68 $ignore_expired_card = 0;
  69
  70 @encrypted_fields = ('payinfo', 'paycvv');
  71
  72 #ask FS::UID to run this stuff for us later
  73 #$FS::UID::callback{'FS::cust_main'} = sub {
  74 install_callback FS::UID sub {
  75   $conf = new FS::Conf;
  76   #yes, need it for stuff below (prolly should be cached)
  77 };
  78
  79 sub _cache {
  80   my $self = shift;
  81   my ( $hashref, $cache ) = @_;
  82   if ( exists $hashref->{'pkgnum'} ) {
  83     #@{ $self->{'_pkgnum'} } = ();
  84     my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum});
  85     $self->{'_pkgnum'} = $subcache;
  86     #push @{ $self->{'_pkgnum'} },
  87     FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum};
  88   }
  89 }
  90
  91 =head1 NAME
  92
  93 FS::cust_main - Object methods for cust_main records
  94
  95 =head1 SYNOPSIS
  96
  97   use FS::cust_main;
  98
  99   $record = new FS::cust_main \%hash;
 100   $record = new FS::cust_main { 'column' => 'value' };
 101
 102   $error = $record->insert;
 103
 104   $error = $new_record->replace($old_record);
 105
 106   $error = $record->delete;
 107
 108   $error = $record->check;
 109
 110   @cust_pkg = $record->all_pkgs;
 111
 112   @cust_pkg = $record->ncancelled_pkgs;
 113
 114   @cust_pkg = $record->suspended_pkgs;
 115
 116   $error = $record->bill;
 117   $error = $record->bill %options;
 118   $error = $record->bill 'time' => $time;
 119
 120   $error = $record->collect;
 121   $error = $record->collect %options;
 122   $error = $record->collect 'invoice_time'   => $time,
 123                           ;
 124
 125 =head1 DESCRIPTION
 126
 127 An FS::cust_main object represents a customer.  FS::cust_main inherits from
 128 FS::Record.  The following fields are currently supported:
 129
 130 =over 4
 131
 132 =item custnum - primary key (assigned automatically for new customers)
 133
 134 =item agentnum - agent (see L<FS::agent>)
 135
 136 =item refnum - Advertising source (see L<FS::part_referral>)
 137
 138 =item first - name
 139
 140 =item last - name
 141
 142 =item ss - social security number (optional)
 143
 144 =item company - (optional)
 145
 146 =item address1
 147
 148 =item address2 - (optional)
 149
 150 =item city
 151
 152 =item county - (optional, see L<FS::cust_main_county>)
 153
 154 =item state - (see L<FS::cust_main_county>)
 155
 156 =item zip
 157
 158 =item country - (see L<FS::cust_main_county>)
 159
 160 =item daytime - phone (optional)
 161
 162 =item night - phone (optional)
 163
 164 =item fax - phone (optional)
 165
 166 =item ship_first - name
 167
 168 =item ship_last - name
 169
 170 =item ship_company - (optional)
 171
 172 =item ship_address1
 173
 174 =item ship_address2 - (optional)
 175
 176 =item ship_city
 177
 178 =item ship_county - (optional, see L<FS::cust_main_county>)
 179
 180 =item ship_state - (see L<FS::cust_main_county>)
 181
 182 =item ship_zip
 183
 184 =item ship_country - (see L<FS::cust_main_county>)
 185
 186 =item ship_daytime - phone (optional)
 187
 188 =item ship_night - phone (optional)
 189
 190 =item ship_fax - phone (optional)
 191
 192 =item payby
 193
 194 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>)
 195
 196 =item payinfo
 197
 198 Card Number, P.O., comp issuer (4-8 lowercase alphanumerics; think username) or prepayment identifier (see L<FS::prepay_credit>)
 199
 200 =cut
 201
 202 sub payinfo {
 203   my($self,$payinfo) = @_;
 204   if ( defined($payinfo) ) {
 205     $self->paymask($payinfo);
 206     $self->setfield('payinfo', $payinfo); # This is okay since we are the 'setter'
 207   } else {
 208     $payinfo = $self->getfield('payinfo'); # This is okay since we are the 'getter'
 209     return $payinfo;
 210   }
 211 }
 212
 213
 214 =item paycvv
 215
 216 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
 217
 218 =cut
 219
 220 =item paymask - Masked payment type
 221
 222 =over 4
 223
 224 =item Credit Cards
 225
 226 Mask all but the last four characters.
 227
 228 =item Checks
 229
 230 Mask all but last 2 of account number and bank routing number.
 231
 232 =item Others
 233
 234 Do nothing, return the unmasked string.
 235
 236 =back
 237
 238 =cut
 239
 240 sub paymask {
 241   my($self,$value)=@_;
 242
 243   # If it doesn't exist then generate it
 244   my $paymask=$self->getfield('paymask');
 245   if (!defined($value) && (!defined($paymask) || $paymask eq '')) {
 246     $value = $self->payinfo;
 247   }
 248
 249   if ( defined($value) && !$self->is_encrypted($value)) {
 250     my $payinfo = $value;
 251     my $payby = $self->payby;
 252     if ($payby eq 'CARD' || $payby eq 'DCRD') { # Credit Cards (Show last four)
 253       $paymask = 'x'x(length($payinfo)-4). substr($payinfo,(length($payinfo)-4));
 254     } elsif ($payby eq 'CHEK' ||
 255              $payby eq 'DCHK' ) { # Checks (Show last 2 @ bank)
 256       my( $account, $aba ) = split('@', $payinfo );
 257       $paymask = 'x'x(length($account)-2). substr($account,(length($account)-2))."@".$aba;
 258     } else { # Tie up loose ends
 259       $paymask = $payinfo;
 260     }
 261     $self->setfield('paymask', $paymask); # This is okay since we are the 'setter'
 262   } elsif (defined($value) && $self->is_encrypted($value)) {
 263     $paymask = 'N/A';
 264   }
 265   return $paymask;
 266 }
 267
 268 =item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy
 269
 270 =item paystart_month - start date month (maestro/solo cards only)
 271
 272 =item paystart_year - start date year (maestro/solo cards only)
 273
 274 =item payissue - issue number (maestro/solo cards only)
 275
 276 =item payname - name on card or billing name
 277
 278 =item payip - IP address from which payment information was received
 279
 280 =item tax - tax exempt, empty or `Y'
 281
 282 =item otaker - order taker (assigned automatically, see L<FS::UID>)
 283
 284 =item comments - comments (optional)
 285
 286 =item referral_custnum - referring customer number
 287
 288 =item spool_cdr - Enable individual CDR spooling, empty or `Y'
 289
 290 =back
 291
 292 =head1 METHODS
 293
 294 =over 4
 295
 296 =item new HASHREF
 297
 298 Creates a new customer.  To add the customer to the database, see L<"insert">.
 299
 300 Note that this stores the hash reference, not a distinct copy of the hash it
 301 points to.  You can ask the object for a copy with the I<hash> method.
 302
 303 =cut
 304
 305 sub table { 'cust_main'; }
 306
 307 =item insert [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
 308
 309 Adds this customer to the database.  If there is an error, returns the error,
 310 otherwise returns false.
 311
 312 CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert
 313 method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records
 314 are inserted atomicly, or the transaction is rolled back.  Passing an empty
 315 hash reference is equivalent to not supplying this parameter.  There should be
 316 a better explanation of this, but until then, here's an example:
 317
 318   use Tie::RefHash;
 319   tie %hash, 'Tie::RefHash'; #this part is important
 320   %hash = (
 321     $cust_pkg => [ $svc_acct ],
 322     ...
 323   );
 324   $cust_main->insert( \%hash );
 325
 326 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
 327 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
 328 expected and rollback the entire transaction; it is not necessary to call
 329 check_invoicing_list first.  The invoicing_list is set after the records in the
 330 CUST_PKG_HASHREF above are inserted, so it is now possible to set an
 331 invoicing_list destination to the newly-created svc_acct.  Here's an example:
 332
 333   $cust_main->insert( {}, [ $email, 'POST' ] );
 334
 335 Currently available options are: I<depend_jobnum> and I<noexport>.
 336
 337 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 338 on the supplied jobnum (they will not run until the specific job completes).
 339 This can be used to defer provisioning until some action completes (such
 340 as running the customer's credit card successfully).
 341
 342 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 343 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 344 the B<reexport> method.)
 345
 346 =cut
 347
 348 sub insert {
 349   my $self = shift;
 350   my $cust_pkgs = @_ ? shift : {};
 351   my $invoicing_list = @_ ? shift : '';
 352   my %options = @_;
 353   warn "$me insert called with options ".
 354        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 355     if $DEBUG;
 356
 357   local $SIG{HUP} = 'IGNORE';
 358   local $SIG{INT} = 'IGNORE';
 359   local $SIG{QUIT} = 'IGNORE';
 360   local $SIG{TERM} = 'IGNORE';
 361   local $SIG{TSTP} = 'IGNORE';
 362   local $SIG{PIPE} = 'IGNORE';
 363
 364   my $oldAutoCommit = $FS::UID::AutoCommit;
 365   local $FS::UID::AutoCommit = 0;
 366   my $dbh = dbh;
 367
 368   my $prepay_identifier = '';
 369   my( $amount, $seconds ) = ( 0, 0 );
 370   my $payby = '';
 371   if ( $self->payby eq 'PREPAY' ) {
 372
 373     $self->payby('BILL');
 374     $prepay_identifier = $self->payinfo;
 375     $self->payinfo('');
 376
 377     warn "  looking up prepaid card $prepay_identifier\n"
 378       if $DEBUG > 1;
 379
 380     my $error = $self->get_prepay($prepay_identifier, \$amount, \$seconds);
 381     if ( $error ) {
 382       $dbh->rollback if $oldAutoCommit;
 383       #return "error applying prepaid card (transaction rolled back): $error";
 384       return $error;
 385     }
 386
 387     $payby = 'PREP' if $amount;
 388
 389   } elsif ( $self->payby =~ /^(CASH|WEST|MCRD)$/ ) {
 390
 391     $payby = $1;
 392     $self->payby('BILL');
 393     $amount = $self->paid;
 394
 395   }
 396
 397   warn "  inserting $self\n"
 398     if $DEBUG > 1;
 399
 400   my $error = $self->SUPER::insert;
 401   if ( $error ) {
 402     $dbh->rollback if $oldAutoCommit;
 403     #return "inserting cust_main record (transaction rolled back): $error";
 404     return $error;
 405   }
 406
 407   warn "  setting invoicing list\n"
 408     if $DEBUG > 1;
 409
 410   if ( $invoicing_list ) {
 411     $error = $self->check_invoicing_list( $invoicing_list );
 412     if ( $error ) {
 413       $dbh->rollback if $oldAutoCommit;
 414       return "checking invoicing_list (transaction rolled back): $error";
 415     }
 416     $self->invoicing_list( $invoicing_list );
 417   }
 418
 419   if (    $conf->config('cust_main-skeleton_tables')
 420        && $conf->config('cust_main-skeleton_custnum') ) {
 421
 422     warn "  inserting skeleton records\n"
 423       if $DEBUG > 1;
 424
 425     my $error = $self->start_copy_skel;
 426     if ( $error ) {
 427       $dbh->rollback if $oldAutoCommit;
 428       return $error;
 429     }
 430
 431   }
 432
 433   warn "  ordering packages\n"
 434     if $DEBUG > 1;
 435
 436   $error = $self->order_pkgs($cust_pkgs, \$seconds, %options);
 437   if ( $error ) {
 438     $dbh->rollback if $oldAutoCommit;
 439     return $error;
 440   }
 441
 442   if ( $seconds ) {
 443     $dbh->rollback if $oldAutoCommit;
 444     return "No svc_acct record to apply pre-paid time";
 445   }
 446
 447   if ( $amount ) {
 448     warn "  inserting initial $payby payment of $amount\n"
 449       if $DEBUG > 1;
 450     $error = $self->insert_cust_pay($payby, $amount, $prepay_identifier);
 451     if ( $error ) {
 452       $dbh->rollback if $oldAutoCommit;
 453       return "inserting payment (transaction rolled back): $error";
 454     }
 455   }
 456
 457   unless ( $import || $skip_fuzzyfiles ) {
 458     warn "  queueing fuzzyfiles update\n"
 459       if $DEBUG > 1;
 460     $error = $self->queue_fuzzyfiles_update;
 461     if ( $error ) {
 462       $dbh->rollback if $oldAutoCommit;
 463       return "updating fuzzy search cache: $error";
 464     }
 465   }
 466
 467   warn "  insert complete; committing transaction\n"
 468     if $DEBUG > 1;
 469
 470   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 471   '';
 472
 473 }
 474
 475 sub start_copy_skel {
 476   my $self = shift;
 477
 478   #'mg_user_preference' => {},
 479   #'mg_user_indicator_profile' => { 'mg_profile_indicator' => { 'mg_profile_details' }, },
 480   #'mg_watchlist_header' => { 'mg_watchlist_details' },
 481   #'mg_user_grid_header' => { 'mg_user_grid_details' },
 482   #'mg_portfolio_header' => { 'mg_portfolio_trades' => { 'mg_portfolio_trades_positions' } },
 483   my @tables = eval($conf->config('cust_main-skeleton_tables'));
 484   die $@ if $@;
 485
 486   _copy_skel( 'cust_main',                                 #tablename
 487               $conf->config('cust_main-skeleton_custnum'), #sourceid
 488               $self->custnum,                              #destid
 489               @tables,                                     #child tables
 490             );
 491 }
 492
 493 #recursive subroutine, not a method
 494 sub _copy_skel {
 495   my( $table, $sourceid, $destid, %child_tables ) = @_;
 496
 497   my $dbdef_table = dbdef->table($table);
 498   my $primary_key = $dbdef_table->primary_key
 499     or return "$table has no primary key".
 500               " (or do you need to run dbdef-create?)";
 501
 502   warn "  _copy_skel: $table.$primary_key $sourceid to $destid for ".
 503        join (', ', keys %child_tables). "\n"
 504     if $DEBUG > 2;
 505
 506   foreach my $child_table ( keys %child_tables ) {
 507
 508     my $child_pkey = dbdef->table($child_table)->primary_key;
 509     #  or return "$table has no primary key".
 510     #            " (or do you need to run dbdef-create?)\n";
 511     my $sequence = '';
 512     if ( keys %{ $child_tables{$child_table} } ) {
 513
 514       return "$child_table has no primary key\n" unless $child_pkey;
 515
 516       #false laziness w/Record::insert and only works on Pg
 517       #refactor the proper last-inserted-id stuff out of Record::insert if this
 518       # ever gets use for anything besides a quick kludge for one customer
 519       my $default = dbdef->table($child_table)->column($child_pkey)->default;
 520       $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i
 521         or return "can't parse $child_table.$child_pkey default value ".
 522                   " for sequence name: $default";
 523       $sequence = $1;
 524
 525     }
 526
 527     my @sel_columns = grep { $_ ne $primary_key }
 528                            dbdef->table($child_table)->columns;
 529     my $sel_columns = ' ( '. join(', ', @sel_columns ). ' ) ';
 530
 531     my @ins_columns = grep { $_ ne $child_pkey } @sel_columns;
 532     my $ins_columns = ' ( '. join(', ', $primary_key, @ins_columns ). ' ) ';
 533     my $placeholders = ' ( ?, '. join(', ', map '?', @ins_columns ). ' ) ';
 534
 535     my $sel_sth = dbh->prepare( "SELECT $sel_columns FROM $child_table".
 536                                 " WHERE $primary_key = $sourceid")
 537       or return dbh->errstr;
 538
 539     $sel_sth->execute or return $sel_sth->errstr;
 540
 541     while ( my $row = $sel_sth->fetchrow_hashref ) {
 542
 543       my $ins_sth =
 544         dbh->prepare("INSERT INTO $child_table $ins_columns".
 545                      " VALUES $placeholders")
 546           or return dbh->errstr;
 547       $ins_sth->execute( $destid, map $row->{$_}, @ins_columns )
 548         or return $ins_sth->errstr;
 549
 550       #next unless keys %{ $child_tables{$child_table} };
 551       next unless $sequence;
 552
 553       #another section of that laziness
 554       my $seq_sql = "SELECT currval('$sequence')";
 555       my $seq_sth = dbh->prepare($seq_sql) or return dbh->errstr;
 556       $seq_sth->execute or return $seq_sth->errstr;
 557       my $insertid = $seq_sth->fetchrow_arrayref->[0];
 558
 559       # don't drink soap!  recurse!  recurse!  okay!
 560       my $error =
 561         _copy_skel( $child_table,
 562                     $row->{$child_pkey}, #sourceid
 563                     $insertid, #destid
 564                     %{ $child_tables{$child_table} },
 565                   );
 566       return $error if $error;
 567
 568     }
 569
 570   }
 571
 572   return '';
 573
 574 }
 575
 576 =item order_pkgs HASHREF, [ SECONDSREF, [ , OPTION => VALUE ... ] ]
 577
 578 Like the insert method on an existing record, this method orders a package
 579 and included services atomicaly.  Pass a Tie::RefHash data structure to this
 580 method containing FS::cust_pkg and FS::svc_I<tablename> objects.  There should
 581 be a better explanation of this, but until then, here's an example:
 582
 583   use Tie::RefHash;
 584   tie %hash, 'Tie::RefHash'; #this part is important
 585   %hash = (
 586     $cust_pkg => [ $svc_acct ],
 587     ...
 588   );
 589   $cust_main->order_pkgs( \%hash, \'0', 'noexport'=>1 );
 590
 591 Services can be new, in which case they are inserted, or existing unaudited
 592 services, in which case they are linked to the newly-created package.
 593
 594 Currently available options are: I<depend_jobnum> and I<noexport>.
 595
 596 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 597 on the supplied jobnum (they will not run until the specific job completes).
 598 This can be used to defer provisioning until some action completes (such
 599 as running the customer's credit card successfully).
 600
 601 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 602 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 603 the B<reexport> method for each cust_pkg object.  Using the B<reexport> method
 604 on the cust_main object is not recommended, as existing services will also be
 605 reexported.)
 606
 607 =cut
 608
 609 sub order_pkgs {
 610   my $self = shift;
 611   my $cust_pkgs = shift;
 612   my $seconds = shift;
 613   my %options = @_;
 614   my %svc_options = ();
 615   $svc_options{'depend_jobnum'} = $options{'depend_jobnum'}
 616     if exists $options{'depend_jobnum'};
 617   warn "$me order_pkgs called with options ".
 618        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 619     if $DEBUG;
 620
 621   local $SIG{HUP} = 'IGNORE';
 622   local $SIG{INT} = 'IGNORE';
 623   local $SIG{QUIT} = 'IGNORE';
 624   local $SIG{TERM} = 'IGNORE';
 625   local $SIG{TSTP} = 'IGNORE';
 626   local $SIG{PIPE} = 'IGNORE';
 627
 628   my $oldAutoCommit = $FS::UID::AutoCommit;
 629   local $FS::UID::AutoCommit = 0;
 630   my $dbh = dbh;
 631
 632   local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
 633
 634   foreach my $cust_pkg ( keys %$cust_pkgs ) {
 635     $cust_pkg->custnum( $self->custnum );
 636     my $error = $cust_pkg->insert;
 637     if ( $error ) {
 638       $dbh->rollback if $oldAutoCommit;
 639       return "inserting cust_pkg (transaction rolled back): $error";
 640     }
 641     foreach my $svc_something ( @{$cust_pkgs->{$cust_pkg}} ) {
 642       if ( $svc_something->svcnum ) {
 643         my $old_cust_svc = $svc_something->cust_svc;
 644         my $new_cust_svc = new FS::cust_svc { $old_cust_svc->hash };
 645         $new_cust_svc->pkgnum( $cust_pkg->pkgnum);
 646         $error = $new_cust_svc->replace($old_cust_svc);
 647       } else {
 648         $svc_something->pkgnum( $cust_pkg->pkgnum );
 649         if ( $seconds && $$seconds && $svc_something->isa('FS::svc_acct') ) {
 650           $svc_something->seconds( $svc_something->seconds + $$seconds );
 651           $$seconds = 0;
 652         }
 653         $error = $svc_something->insert(%svc_options);
 654       }
 655       if ( $error ) {
 656         $dbh->rollback if $oldAutoCommit;
 657         #return "inserting svc_ (transaction rolled back): $error";
 658         return $error;
 659       }
 660     }
 661   }
 662
 663   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 664   ''; #no error
 665 }
 666
 667 =item recharge_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , AMOUNTREF, SECONDSREF ]
 668
 669 Recharges this (existing) customer with the specified prepaid card (see
 670 L<FS::prepay_credit>), specified either by I<identifier> or as an
 671 FS::prepay_credit object.  If there is an error, returns the error, otherwise
 672 returns false.
 673
 674 Optionally, two scalar references can be passed as well.  They will have their
 675 values filled in with the amount and number of seconds applied by this prepaid
 676 card.
 677
 678 =cut
 679
 680 sub recharge_prepay {
 681   my( $self, $prepay_credit, $amountref, $secondsref ) = @_;
 682
 683   local $SIG{HUP} = 'IGNORE';
 684   local $SIG{INT} = 'IGNORE';
 685   local $SIG{QUIT} = 'IGNORE';
 686   local $SIG{TERM} = 'IGNORE';
 687   local $SIG{TSTP} = 'IGNORE';
 688   local $SIG{PIPE} = 'IGNORE';
 689
 690   my $oldAutoCommit = $FS::UID::AutoCommit;
 691   local $FS::UID::AutoCommit = 0;
 692   my $dbh = dbh;
 693
 694   my( $amount, $seconds ) = ( 0, 0 );
 695
 696   my $error = $self->get_prepay($prepay_credit, \$amount, \$seconds)
 697            || $self->increment_seconds($seconds)
 698            || $self->insert_cust_pay_prepay( $amount,
 699                                              ref($prepay_credit)
 700                                                ? $prepay_credit->identifier
 701                                                : $prepay_credit
 702                                            );
 703
 704   if ( $error ) {
 705     $dbh->rollback if $oldAutoCommit;
 706     return $error;
 707   }
 708
 709   if ( defined($amountref)  ) { $$amountref  = $amount;  }
 710   if ( defined($secondsref) ) { $$secondsref = $seconds; }
 711
 712   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 713   '';
 714
 715 }
 716
 717 =item get_prepay IDENTIFIER | PREPAY_CREDIT_OBJ , AMOUNTREF, SECONDSREF
 718
 719 Looks up and deletes a prepaid card (see L<FS::prepay_credit>),
 720 specified either by I<identifier> or as an FS::prepay_credit object.
 721
 722 References to I<amount> and I<seconds> scalars should be passed as arguments
 723 and will be incremented by the values of the prepaid card.
 724
 725 If the prepaid card specifies an I<agentnum> (see L<FS::agent>), it is used to
 726 check or set this customer's I<agentnum>.
 727
 728 If there is an error, returns the error, otherwise returns false.
 729
 730 =cut
 731
 732
 733 sub get_prepay {
 734   my( $self, $prepay_credit, $amountref, $secondsref ) = @_;
 735
 736   local $SIG{HUP} = 'IGNORE';
 737   local $SIG{INT} = 'IGNORE';
 738   local $SIG{QUIT} = 'IGNORE';
 739   local $SIG{TERM} = 'IGNORE';
 740   local $SIG{TSTP} = 'IGNORE';
 741   local $SIG{PIPE} = 'IGNORE';
 742
 743   my $oldAutoCommit = $FS::UID::AutoCommit;
 744   local $FS::UID::AutoCommit = 0;
 745   my $dbh = dbh;
 746
 747   unless ( ref($prepay_credit) ) {
 748
 749     my $identifier = $prepay_credit;
 750
 751     $prepay_credit = qsearchs(
 752       'prepay_credit',
 753       { 'identifier' => $prepay_credit },
 754       '',
 755       'FOR UPDATE'
 756     );
 757
 758     unless ( $prepay_credit ) {
 759       $dbh->rollback if $oldAutoCommit;
 760       return "Invalid prepaid card: ". $identifier;
 761     }
 762
 763   }
 764
 765   if ( $prepay_credit->agentnum ) {
 766     if ( $self->agentnum && $self->agentnum != $prepay_credit->agentnum ) {
 767       $dbh->rollback if $oldAutoCommit;
 768       return "prepaid card not valid for agent ". $self->agentnum;
 769     }
 770     $self->agentnum($prepay_credit->agentnum);
 771   }
 772
 773   my $error = $prepay_credit->delete;
 774   if ( $error ) {
 775     $dbh->rollback if $oldAutoCommit;
 776     return "removing prepay_credit (transaction rolled back): $error";
 777   }
 778
 779   $$amountref  += $prepay_credit->amount;
 780   $$secondsref += $prepay_credit->seconds;
 781
 782   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 783   '';
 784
 785 }
 786
 787 =item increment_seconds SECONDS
 788
 789 Updates this customer's single or primary account (see L<FS::svc_acct>) by
 790 the specified number of seconds.  If there is an error, returns the error,
 791 otherwise returns false.
 792
 793 =cut
 794
 795 sub increment_seconds {
 796   my( $self, $seconds ) = @_;
 797   warn "$me increment_seconds called: $seconds seconds\n"
 798     if $DEBUG;
 799
 800   my @cust_pkg = grep { $_->part_pkg->svcpart('svc_acct') }
 801                       $self->ncancelled_pkgs;
 802
 803   if ( ! @cust_pkg ) {
 804     return 'No packages with primary or single services found'.
 805            ' to apply pre-paid time';
 806   } elsif ( scalar(@cust_pkg) > 1 ) {
 807     #maybe have a way to specify the package/account?
 808     return 'Multiple packages found to apply pre-paid time';
 809   }
 810
 811   my $cust_pkg = $cust_pkg[0];
 812   warn "  found package pkgnum ". $cust_pkg->pkgnum. "\n"
 813     if $DEBUG > 1;
 814
 815   my @cust_svc =
 816     $cust_pkg->cust_svc( $cust_pkg->part_pkg->svcpart('svc_acct') );
 817
 818   if ( ! @cust_svc ) {
 819     return 'No account found to apply pre-paid time';
 820   } elsif ( scalar(@cust_svc) > 1 ) {
 821     return 'Multiple accounts found to apply pre-paid time';
 822   }
 823
 824   my $svc_acct = $cust_svc[0]->svc_x;
 825   warn "  found service svcnum ". $svc_acct->pkgnum.
 826        ' ('. $svc_acct->email. ")\n"
 827     if $DEBUG > 1;
 828
 829   $svc_acct->increment_seconds($seconds);
 830
 831 }
 832
 833 =item insert_cust_pay_prepay AMOUNT [ PAYINFO ]
 834
 835 Inserts a prepayment in the specified amount for this customer.  An optional
 836 second argument can specify the prepayment identifier for tracking purposes.
 837 If there is an error, returns the error, otherwise returns false.
 838
 839 =cut
 840
 841 sub insert_cust_pay_prepay {
 842   shift->insert_cust_pay('PREP', @_);
 843 }
 844
 845 =item insert_cust_pay_cash AMOUNT [ PAYINFO ]
 846
 847 Inserts a cash payment in the specified amount for this customer.  An optional
 848 second argument can specify the payment identifier for tracking purposes.
 849 If there is an error, returns the error, otherwise returns false.
 850
 851 =cut
 852
 853 sub insert_cust_pay_cash {
 854   shift->insert_cust_pay('CASH', @_);
 855 }
 856
 857 =item insert_cust_pay_west AMOUNT [ PAYINFO ]
 858
 859 Inserts a Western Union payment in the specified amount for this customer.  An
 860 optional second argument can specify the prepayment identifier for tracking
 861 purposes.  If there is an error, returns the error, otherwise returns false.
 862
 863 =cut
 864
 865 sub insert_cust_pay_west {
 866   shift->insert_cust_pay('WEST', @_);
 867 }
 868
 869 sub insert_cust_pay {
 870   my( $self, $payby, $amount ) = splice(@_, 0, 3);
 871   my $payinfo = scalar(@_) ? shift : '';
 872
 873   my $cust_pay = new FS::cust_pay {
 874     'custnum' => $self->custnum,
 875     'paid'    => sprintf('%.2f', $amount),
 876     #'_date'   => #date the prepaid card was purchased???
 877     'payby'   => $payby,
 878     'payinfo' => $payinfo,
 879   };
 880   $cust_pay->insert;
 881
 882 }
 883
 884 =item reexport
 885
 886 This method is deprecated.  See the I<depend_jobnum> option to the insert and
 887 order_pkgs methods for a better way to defer provisioning.
 888
 889 Re-schedules all exports by calling the B<reexport> method of all associated
 890 packages (see L<FS::cust_pkg>).  If there is an error, returns the error;
 891 otherwise returns false.
 892
 893 =cut
 894
 895 sub reexport {
 896   my $self = shift;
 897
 898   carp "WARNING: FS::cust_main::reexport is deprectated; ".
 899        "use the depend_jobnum option to insert or order_pkgs to delay export";
 900
 901   local $SIG{HUP} = 'IGNORE';
 902   local $SIG{INT} = 'IGNORE';
 903   local $SIG{QUIT} = 'IGNORE';
 904   local $SIG{TERM} = 'IGNORE';
 905   local $SIG{TSTP} = 'IGNORE';
 906   local $SIG{PIPE} = 'IGNORE';
 907
 908   my $oldAutoCommit = $FS::UID::AutoCommit;
 909   local $FS::UID::AutoCommit = 0;
 910   my $dbh = dbh;
 911
 912   foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
 913     my $error = $cust_pkg->reexport;
 914     if ( $error ) {
 915       $dbh->rollback if $oldAutoCommit;
 916       return $error;
 917     }
 918   }
 919
 920   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 921   '';
 922
 923 }
 924
 925 =item delete NEW_CUSTNUM
 926
 927 This deletes the customer.  If there is an error, returns the error, otherwise
 928 returns false.
 929
 930 This will completely remove all traces of the customer record.  This is not
 931 what you want when a customer cancels service; for that, cancel all of the
 932 customer's packages (see L</cancel>).
 933
 934 If the customer has any uncancelled packages, you need to pass a new (valid)
 935 customer number for those packages to be transferred to.  Cancelled packages
 936 will be deleted.  Did I mention that this is NOT what you want when a customer
 937 cancels service and that you really should be looking see L<FS::cust_pkg/cancel>?
 938
 939 You can't delete a customer with invoices (see L<FS::cust_bill>),
 940 or credits (see L<FS::cust_credit>), payments (see L<FS::cust_pay>) or
 941 refunds (see L<FS::cust_refund>).
 942
 943 =cut
 944
 945 sub delete {
 946   my $self = shift;
 947
 948   local $SIG{HUP} = 'IGNORE';
 949   local $SIG{INT} = 'IGNORE';
 950   local $SIG{QUIT} = 'IGNORE';
 951   local $SIG{TERM} = 'IGNORE';
 952   local $SIG{TSTP} = 'IGNORE';
 953   local $SIG{PIPE} = 'IGNORE';
 954
 955   my $oldAutoCommit = $FS::UID::AutoCommit;
 956   local $FS::UID::AutoCommit = 0;
 957   my $dbh = dbh;
 958
 959   if ( $self->cust_bill ) {
 960     $dbh->rollback if $oldAutoCommit;
 961     return "Can't delete a customer with invoices";
 962   }
 963   if ( $self->cust_credit ) {
 964     $dbh->rollback if $oldAutoCommit;
 965     return "Can't delete a customer with credits";
 966   }
 967   if ( $self->cust_pay ) {
 968     $dbh->rollback if $oldAutoCommit;
 969     return "Can't delete a customer with payments";
 970   }
 971   if ( $self->cust_refund ) {
 972     $dbh->rollback if $oldAutoCommit;
 973     return "Can't delete a customer with refunds";
 974   }
 975
 976   my @cust_pkg = $self->ncancelled_pkgs;
 977   if ( @cust_pkg ) {
 978     my $new_custnum = shift;
 979     unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) {
 980       $dbh->rollback if $oldAutoCommit;
 981       return "Invalid new customer number: $new_custnum";
 982     }
 983     foreach my $cust_pkg ( @cust_pkg ) {
 984       my %hash = $cust_pkg->hash;
 985       $hash{'custnum'} = $new_custnum;
 986       my $new_cust_pkg = new FS::cust_pkg ( \%hash );
 987       my $error = $new_cust_pkg->replace($cust_pkg);
 988       if ( $error ) {
 989         $dbh->rollback if $oldAutoCommit;
 990         return $error;
 991       }
 992     }
 993   }
 994   my @cancelled_cust_pkg = $self->all_pkgs;
 995   foreach my $cust_pkg ( @cancelled_cust_pkg ) {
 996     my $error = $cust_pkg->delete;
 997     if ( $error ) {
 998       $dbh->rollback if $oldAutoCommit;
 999       return $error;
1000     }
1001   }
1002
1003   foreach my $cust_main_invoice ( #(email invoice destinations, not invoices)
1004     qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } )
1005   ) {
1006     my $error = $cust_main_invoice->delete;
1007     if ( $error ) {
1008       $dbh->rollback if $oldAutoCommit;
1009       return $error;
1010     }
1011   }
1012
1013   my $error = $self->SUPER::delete;
1014   if ( $error ) {
1015     $dbh->rollback if $oldAutoCommit;
1016     return $error;
1017   }
1018
1019   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1020   '';
1021
1022 }
1023
1024 =item replace OLD_RECORD [ INVOICING_LIST_ARYREF ]
1025
1026 Replaces the OLD_RECORD with this one in the database.  If there is an error,
1027 returns the error, otherwise returns false.
1028
1029 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
1030 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
1031 expected and rollback the entire transaction; it is not necessary to call
1032 check_invoicing_list first.  Here's an example:
1033
1034   $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
1035
1036 =cut
1037
1038 sub replace {
1039   my $self = shift;
1040   my $old = shift;
1041   my @param = @_;
1042   warn "$me replace called\n"
1043     if $DEBUG;
1044
1045   local $SIG{HUP} = 'IGNORE';
1046   local $SIG{INT} = 'IGNORE';
1047   local $SIG{QUIT} = 'IGNORE';
1048   local $SIG{TERM} = 'IGNORE';
1049   local $SIG{TSTP} = 'IGNORE';
1050   local $SIG{PIPE} = 'IGNORE';
1051
1052   # If the mask is blank then try to set it - if we can...
1053   if (!defined($self->getfield('paymask')) || $self->getfield('paymask') eq '') {
1054     $self->paymask($self->payinfo);
1055   }
1056
1057   # We absolutely have to have an old vs. new record to make this work.
1058   if (!defined($old)) {
1059     $old = qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1060   }
1061
1062   my $curuser = $FS::CurrentUser::CurrentUser;
1063   if (    $self->payby eq 'COMP'
1064        && $self->payby ne $old->payby
1065        && ! $curuser->access_right('Complimentary customer')
1066      )
1067   {
1068     return "You are not permitted to create complimentary accounts.";
1069   }
1070
1071   local($ignore_expired_card) = 1
1072     if $old->payby  =~ /^(CARD|DCRD)$/
1073     && $self->payby =~ /^(CARD|DCRD)$/
1074     && $old->payinfo eq $self->payinfo;
1075
1076   my $oldAutoCommit = $FS::UID::AutoCommit;
1077   local $FS::UID::AutoCommit = 0;
1078   my $dbh = dbh;
1079
1080   my $error = $self->SUPER::replace($old);
1081
1082   if ( $error ) {
1083     $dbh->rollback if $oldAutoCommit;
1084     return $error;
1085   }
1086
1087   if ( @param ) { # INVOICING_LIST_ARYREF
1088     my $invoicing_list = shift @param;
1089     $error = $self->check_invoicing_list( $invoicing_list );
1090     if ( $error ) {
1091       $dbh->rollback if $oldAutoCommit;
1092       return $error;
1093     }
1094     $self->invoicing_list( $invoicing_list );
1095   }
1096
1097   if ( $self->payby =~ /^(CARD|CHEK|LECB)$/ &&
1098        grep { $self->get($_) ne $old->get($_) } qw(payinfo paydate payname) ) {
1099     # card/check/lec info has changed, want to retry realtime_ invoice events
1100     my $error = $self->retry_realtime;
1101     if ( $error ) {
1102       $dbh->rollback if $oldAutoCommit;
1103       return $error;
1104     }
1105   }
1106
1107   unless ( $import || $skip_fuzzyfiles ) {
1108     $error = $self->queue_fuzzyfiles_update;
1109     if ( $error ) {
1110       $dbh->rollback if $oldAutoCommit;
1111       return "updating fuzzy search cache: $error";
1112     }
1113   }
1114
1115   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1116   '';
1117
1118 }
1119
1120 =item queue_fuzzyfiles_update
1121
1122 Used by insert & replace to update the fuzzy search cache
1123
1124 =cut
1125
1126 sub queue_fuzzyfiles_update {
1127   my $self = shift;
1128
1129   local $SIG{HUP} = 'IGNORE';
1130   local $SIG{INT} = 'IGNORE';
1131   local $SIG{QUIT} = 'IGNORE';
1132   local $SIG{TERM} = 'IGNORE';
1133   local $SIG{TSTP} = 'IGNORE';
1134   local $SIG{PIPE} = 'IGNORE';
1135
1136   my $oldAutoCommit = $FS::UID::AutoCommit;
1137   local $FS::UID::AutoCommit = 0;
1138   my $dbh = dbh;
1139
1140   my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1141   my $error = $queue->insert( map $self->getfield($_),
1142                                   qw(first last company)
1143                             );
1144   if ( $error ) {
1145     $dbh->rollback if $oldAutoCommit;
1146     return "queueing job (transaction rolled back): $error";
1147   }
1148
1149   if ( $self->ship_last ) {
1150     $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1151     $error = $queue->insert( map $self->getfield("ship_$_"),
1152                                  qw(first last company)
1153                            );
1154     if ( $error ) {
1155       $dbh->rollback if $oldAutoCommit;
1156       return "queueing job (transaction rolled back): $error";
1157     }
1158   }
1159
1160   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1161   '';
1162
1163 }
1164
1165 =item check
1166
1167 Checks all fields to make sure this is a valid customer record.  If there is
1168 an error, returns the error, otherwise returns false.  Called by the insert
1169 and replace methods.
1170
1171 =cut
1172
1173 sub check {
1174   my $self = shift;
1175
1176   warn "$me check BEFORE: \n". $self->_dump
1177     if $DEBUG > 2;
1178
1179   my $error =
1180     $self->ut_numbern('custnum')
1181     || $self->ut_number('agentnum')
1182     || $self->ut_textn('agent_custid')
1183     || $self->ut_number('refnum')
1184     || $self->ut_name('last')
1185     || $self->ut_name('first')
1186     || $self->ut_textn('company')
1187     || $self->ut_text('address1')
1188     || $self->ut_textn('address2')
1189     || $self->ut_text('city')
1190     || $self->ut_textn('county')
1191     || $self->ut_textn('state')
1192     || $self->ut_country('country')
1193     || $self->ut_anything('comments')
1194     || $self->ut_numbern('referral_custnum')
1195   ;
1196   #barf.  need message catalogs.  i18n.  etc.
1197   $error .= "Please select an advertising source."
1198     if $error =~ /^Illegal or empty \(numeric\) refnum: /;
1199   return $error if $error;
1200
1201   return "Unknown agent"
1202     unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1203
1204   return "Unknown refnum"
1205     unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } );
1206
1207   return "Unknown referring custnum: ". $self->referral_custnum
1208     unless ! $self->referral_custnum
1209            || qsearchs( 'cust_main', { 'custnum' => $self->referral_custnum } );
1210
1211   if ( $self->ss eq '' ) {
1212     $self->ss('');
1213   } else {
1214     my $ss = $self->ss;
1215     $ss =~ s/\D//g;
1216     $ss =~ /^(\d{3})(\d{2})(\d{4})$/
1217       or return "Illegal social security number: ". $self->ss;
1218     $self->ss("$1-$2-$3");
1219   }
1220
1221
1222 # bad idea to disable, causes billing to fail because of no tax rates later
1223 #  unless ( $import ) {
1224     unless ( qsearch('cust_main_county', {
1225       'country' => $self->country,
1226       'state'   => '',
1227      } ) ) {
1228       return "Unknown state/county/country: ".
1229         $self->state. "/". $self->county. "/". $self->country
1230         unless qsearch('cust_main_county',{
1231           'state'   => $self->state,
1232           'county'  => $self->county,
1233           'country' => $self->country,
1234         } );
1235     }
1236 #  }
1237
1238   $error =
1239     $self->ut_phonen('daytime', $self->country)
1240     || $self->ut_phonen('night', $self->country)
1241     || $self->ut_phonen('fax', $self->country)
1242     || $self->ut_zip('zip', $self->country)
1243   ;
1244   return $error if $error;
1245
1246   my @addfields = qw(
1247     last first company address1 address2 city county state zip
1248     country daytime night fax
1249   );
1250
1251   if ( defined $self->dbdef_table->column('ship_last') ) {
1252     if ( scalar ( grep { $self->getfield($_) ne $self->getfield("ship_$_") }
1253                        @addfields )
1254          && scalar ( grep { $self->getfield("ship_$_") ne '' } @addfields )
1255        )
1256     {
1257       my $error =
1258         $self->ut_name('ship_last')
1259         || $self->ut_name('ship_first')
1260         || $self->ut_textn('ship_company')
1261         || $self->ut_text('ship_address1')
1262         || $self->ut_textn('ship_address2')
1263         || $self->ut_text('ship_city')
1264         || $self->ut_textn('ship_county')
1265         || $self->ut_textn('ship_state')
1266         || $self->ut_country('ship_country')
1267       ;
1268       return $error if $error;
1269
1270       #false laziness with above
1271       unless ( qsearchs('cust_main_county', {
1272         'country' => $self->ship_country,
1273         'state'   => '',
1274        } ) ) {
1275         return "Unknown ship_state/ship_county/ship_country: ".
1276           $self->ship_state. "/". $self->ship_county. "/". $self->ship_country
1277           unless qsearch('cust_main_county',{
1278             'state'   => $self->ship_state,
1279             'county'  => $self->ship_county,
1280             'country' => $self->ship_country,
1281           } );
1282       }
1283       #eofalse
1284
1285       $error =
1286         $self->ut_phonen('ship_daytime', $self->ship_country)
1287         || $self->ut_phonen('ship_night', $self->ship_country)
1288         || $self->ut_phonen('ship_fax', $self->ship_country)
1289         || $self->ut_zip('ship_zip', $self->ship_country)
1290       ;
1291       return $error if $error;
1292
1293     } else { # ship_ info eq billing info, so don't store dup info in database
1294       $self->setfield("ship_$_", '')
1295         foreach qw( last first company address1 address2 city county state zip
1296                     country daytime night fax );
1297     }
1298   }
1299
1300   $self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY|CASH|WEST|MCRD)$/
1301     or return "Illegal payby: ". $self->payby;
1302
1303   $error =    $self->ut_numbern('paystart_month')
1304            || $self->ut_numbern('paystart_year')
1305            || $self->ut_numbern('payissue')
1306   ;
1307   return $error if $error;
1308
1309   if ( $self->payip eq '' ) {
1310     $self->payip('');
1311   } else {
1312     $error = $self->ut_ip('payip');
1313     return $error if $error;
1314   }
1315
1316   # If it is encrypted and the private key is not availaible then we can't
1317   # check the credit card.
1318
1319   my $check_payinfo = 1;
1320
1321   if ($self->is_encrypted($self->payinfo)) {
1322     $check_payinfo = 0;
1323   }
1324
1325   $self->payby($1);
1326
1327   if ( $check_payinfo && $self->payby =~ /^(CARD|DCRD)$/ ) {
1328
1329     my $payinfo = $self->payinfo;
1330     $payinfo =~ s/\D//g;
1331     $payinfo =~ /^(\d{13,16})$/
1332       or return gettext('invalid_card'); # . ": ". $self->payinfo;
1333     $payinfo = $1;
1334     $self->payinfo($payinfo);
1335     validate($payinfo)
1336       or return gettext('invalid_card'); # . ": ". $self->payinfo;
1337
1338     return gettext('unknown_card_type')
1339       if cardtype($self->payinfo) eq "Unknown";
1340
1341     my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1342     if ( $ban ) {
1343       return 'Banned credit card: banned on '.
1344              time2str('%a %h %o at %r', $ban->_date).
1345              ' by '. $ban->otaker.
1346              ' (ban# '. $ban->bannum. ')';
1347     }
1348
1349     if ( defined $self->dbdef_table->column('paycvv') ) {
1350       if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) {
1351         if ( cardtype($self->payinfo) eq 'American Express card' ) {
1352           $self->paycvv =~ /^(\d{4})$/
1353             or return "CVV2 (CID) for American Express cards is four digits.";
1354           $self->paycvv($1);
1355         } else {
1356           $self->paycvv =~ /^(\d{3})$/
1357             or return "CVV2 (CVC2/CID) is three digits.";
1358           $self->paycvv($1);
1359         }
1360       } else {
1361         $self->paycvv('');
1362       }
1363     }
1364
1365     my $cardtype = cardtype($payinfo);
1366     if ( $cardtype =~ /^(Switch|Solo)$/i ) {
1367
1368       return "Start date or issue number is required for $cardtype cards"
1369         unless $self->paystart_month && $self->paystart_year or $self->payissue;
1370
1371       return "Start month must be between 1 and 12"
1372         if $self->paystart_month
1373            and $self->paystart_month < 1 || $self->paystart_month > 12;
1374
1375       return "Start year must be 1990 or later"
1376         if $self->paystart_year
1377            and $self->paystart_year < 1990;
1378
1379       return "Issue number must be beween 1 and 99"
1380         if $self->payissue
1381           and $self->payissue < 1 || $self->payissue > 99;
1382
1383     } else {
1384       $self->paystart_month('');
1385       $self->paystart_year('');
1386       $self->payissue('');
1387     }
1388
1389   } elsif ( $check_payinfo && $self->payby =~ /^(CHEK|DCHK)$/ ) {
1390
1391     my $payinfo = $self->payinfo;
1392     $payinfo =~ s/[^\d\@]//g;
1393     if ( $conf->exists('echeck-nonus') ) {
1394       $payinfo =~ /^(\d+)\@(\d+)$/ or return 'invalid echeck account@aba';
1395       $payinfo = "$1\@$2";
1396     } else {
1397       $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba';
1398       $payinfo = "$1\@$2";
1399     }
1400     $self->payinfo($payinfo);
1401     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1402
1403     my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1404     if ( $ban ) {
1405       return 'Banned ACH account: banned on '.
1406              time2str('%a %h %o at %r', $ban->_date).
1407              ' by '. $ban->otaker.
1408              ' (ban# '. $ban->bannum. ')';
1409     }
1410
1411   } elsif ( $self->payby eq 'LECB' ) {
1412
1413     my $payinfo = $self->payinfo;
1414     $payinfo =~ s/\D//g;
1415     $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number';
1416     $payinfo = $1;
1417     $self->payinfo($payinfo);
1418     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1419
1420   } elsif ( $self->payby eq 'BILL' ) {
1421
1422     $error = $self->ut_textn('payinfo');
1423     return "Illegal P.O. number: ". $self->payinfo if $error;
1424     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1425
1426   } elsif ( $self->payby eq 'COMP' ) {
1427
1428     my $curuser = $FS::CurrentUser::CurrentUser;
1429     if (    ! $self->custnum
1430          && ! $curuser->access_right('Complimentary customer')
1431        )
1432     {
1433       return "You are not permitted to create complimentary accounts."
1434     }
1435
1436     $error = $self->ut_textn('payinfo');
1437     return "Illegal comp account issuer: ". $self->payinfo if $error;
1438     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1439
1440   } elsif ( $self->payby eq 'PREPAY' ) {
1441
1442     my $payinfo = $self->payinfo;
1443     $payinfo =~ s/\W//g; #anything else would just confuse things
1444     $self->payinfo($payinfo);
1445     $error = $self->ut_alpha('payinfo');
1446     return "Illegal prepayment identifier: ". $self->payinfo if $error;
1447     return "Unknown prepayment identifier"
1448       unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } );
1449     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1450
1451   }
1452
1453   if ( $self->paydate eq '' || $self->paydate eq '-' ) {
1454     return "Expiration date required"
1455       unless $self->payby =~ /^(BILL|PREPAY|CHEK|DCHK|LECB|CASH|WEST|MCRD)$/;
1456     $self->paydate('');
1457   } else {
1458     my( $m, $y );
1459     if ( $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) {
1460       ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" );
1461     } elsif ( $self->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) {
1462       ( $m, $y ) = ( $3, "20$2" );
1463     } else {
1464       return "Illegal expiration date: ". $self->paydate;
1465     }
1466     $self->paydate("$y-$m-01");
1467     my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
1468     return gettext('expired_card')
1469       if !$import
1470       && !$ignore_expired_card
1471       && ( $y<$nowy || ( $y==$nowy && $1<$nowm ) );
1472   }
1473
1474   if ( $self->payname eq '' && $self->payby !~ /^(CHEK|DCHK)$/ &&
1475        ( ! $conf->exists('require_cardname')
1476          || $self->payby !~ /^(CARD|DCRD)$/  )
1477   ) {
1478     $self->payname( $self->first. " ". $self->getfield('last') );
1479   } else {
1480     $self->payname =~ /^([\w \,\.\-\'\&]+)$/
1481       or return gettext('illegal_name'). " payname: ". $self->payname;
1482     $self->payname($1);
1483   }
1484
1485   foreach my $flag (qw( tax spool_cdr )) {
1486     $self->$flag() =~ /^(Y?)$/ or return "Illegal $flag: ". $self->$flag();
1487     $self->$flag($1);
1488   }
1489
1490   $self->otaker(getotaker) unless $self->otaker;
1491
1492   warn "$me check AFTER: \n". $self->_dump
1493     if $DEBUG > 2;
1494
1495   $self->SUPER::check;
1496 }
1497
1498 =item all_pkgs
1499
1500 Returns all packages (see L<FS::cust_pkg>) for this customer.
1501
1502 =cut
1503
1504 sub all_pkgs {
1505   my $self = shift;
1506   if ( $self->{'_pkgnum'} ) {
1507     values %{ $self->{'_pkgnum'}->cache };
1508   } else {
1509     qsearch( 'cust_pkg', { 'custnum' => $self->custnum });
1510   }
1511 }
1512
1513 =item ncancelled_pkgs
1514
1515 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
1516
1517 =cut
1518
1519 sub ncancelled_pkgs {
1520   my $self = shift;
1521   if ( $self->{'_pkgnum'} ) {
1522     grep { ! $_->getfield('cancel') } values %{ $self->{'_pkgnum'}->cache };
1523   } else {
1524     @{ [ # force list context
1525       qsearch( 'cust_pkg', {
1526         'custnum' => $self->custnum,
1527         'cancel'  => '',
1528       }),
1529       qsearch( 'cust_pkg', {
1530         'custnum' => $self->custnum,
1531         'cancel'  => 0,
1532       }),
1533     ] };
1534   }
1535 }
1536
1537 =item suspended_pkgs
1538
1539 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
1540
1541 =cut
1542
1543 sub suspended_pkgs {
1544   my $self = shift;
1545   grep { $_->susp } $self->ncancelled_pkgs;
1546 }
1547
1548 =item unflagged_suspended_pkgs
1549
1550 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
1551 customer (thouse packages without the `manual_flag' set).
1552
1553 =cut
1554
1555 sub unflagged_suspended_pkgs {
1556   my $self = shift;
1557   return $self->suspended_pkgs
1558     unless dbdef->table('cust_pkg')->column('manual_flag');
1559   grep { ! $_->manual_flag } $self->suspended_pkgs;
1560 }
1561
1562 =item unsuspended_pkgs
1563
1564 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
1565 this customer.
1566
1567 =cut
1568
1569 sub unsuspended_pkgs {
1570   my $self = shift;
1571   grep { ! $_->susp } $self->ncancelled_pkgs;
1572 }
1573
1574 =item num_cancelled_pkgs
1575
1576 Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
1577 customer.
1578
1579 =cut
1580
1581 sub num_cancelled_pkgs {
1582   my $self = shift;
1583   $self->num_pkgs("cancel IS NOT NULL AND cust_pkg.cancel != 0");
1584 }
1585
1586 sub num_pkgs {
1587   my( $self, $sql ) = @_;
1588   my $sth = dbh->prepare(
1589     "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? AND $sql"
1590   ) or die dbh->errstr;
1591   $sth->execute($self->custnum) or die $sth->errstr;
1592   $sth->fetchrow_arrayref->[0];
1593 }
1594
1595 =item unsuspend
1596
1597 Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
1598 and L<FS::cust_pkg>) for this customer.  Always returns a list: an empty list
1599 on success or a list of errors.
1600
1601 =cut
1602
1603 sub unsuspend {
1604   my $self = shift;
1605   grep { $_->unsuspend } $self->suspended_pkgs;
1606 }
1607
1608 =item suspend
1609
1610 Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
1611
1612 Returns a list: an empty list on success or a list of errors.
1613
1614 =cut
1615
1616 sub suspend {
1617   my $self = shift;
1618   grep { $_->suspend } $self->unsuspended_pkgs;
1619 }
1620
1621 =item suspend_if_pkgpart PKGPART [ , PKGPART ... ]
1622
1623 Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
1624 PKGPARTs (see L<FS::part_pkg>).
1625
1626 Returns a list: an empty list on success or a list of errors.
1627
1628 =cut
1629
1630 sub suspend_if_pkgpart {
1631   my $self = shift;
1632   my @pkgparts = @_;
1633   grep { $_->suspend }
1634     grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
1635       $self->unsuspended_pkgs;
1636 }
1637
1638 =item suspend_unless_pkgpart PKGPART [ , PKGPART ... ]
1639
1640 Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
1641 listed PKGPARTs (see L<FS::part_pkg>).
1642
1643 Returns a list: an empty list on success or a list of errors.
1644
1645 =cut
1646
1647 sub suspend_unless_pkgpart {
1648   my $self = shift;
1649   my @pkgparts = @_;
1650   grep { $_->suspend }
1651     grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
1652       $self->unsuspended_pkgs;
1653 }
1654
1655 =item cancel [ OPTION => VALUE ... ]
1656
1657 Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
1658
1659 Available options are: I<quiet>, I<reasonnum>, and I<ban>
1660
1661 I<quiet> can be set true to supress email cancellation notices.
1662
1663 # I<reasonnum> can be set to a cancellation reason (see L<FS::cancel_reason>)
1664
1665 I<ban> can be set true to ban this customer's credit card or ACH information,
1666 if present.
1667
1668 Always returns a list: an empty list on success or a list of errors.
1669
1670 =cut
1671
1672 sub cancel {
1673   my $self = shift;
1674   my %opt = @_;
1675
1676   if ( $opt{'ban'} && $self->payby =~ /^(CARD|DCRD|CHEK|DCHK)$/ ) {
1677
1678     #should try decryption (we might have the private key)
1679     # and if not maybe queue a job for the server that does?
1680     return ( "Can't (yet) ban encrypted credit cards" )
1681       if $self->is_encrypted($self->payinfo);
1682
1683     my $ban = new FS::banned_pay $self->_banned_pay_hashref;
1684     my $error = $ban->insert;
1685     return ( $error ) if $error;
1686
1687   }
1688
1689   grep { $_ } map { $_->cancel(@_) } $self->ncancelled_pkgs;
1690 }
1691
1692 sub _banned_pay_hashref {
1693   my $self = shift;
1694
1695   my %payby2ban = (
1696     'CARD' => 'CARD',
1697     'DCRD' => 'CARD',
1698     'CHEK' => 'CHEK',
1699     'DCHK' => 'CHEK'
1700   );
1701
1702   {
1703     'payby'   => $payby2ban{$self->payby},
1704     'payinfo' => md5_base64($self->payinfo),
1705     #'reason'  =>
1706   };
1707 }
1708
1709 =item agent
1710
1711 Returns the agent (see L<FS::agent>) for this customer.
1712
1713 =cut
1714
1715 sub agent {
1716   my $self = shift;
1717   qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1718 }
1719
1720 =item bill OPTIONS
1721
1722 Generates invoices (see L<FS::cust_bill>) for this customer.  Usually used in
1723 conjunction with the collect method.
1724
1725 Options are passed as name-value pairs.
1726
1727 Currently available options are:
1728
1729 resetup - if set true, re-charges setup fees.
1730
1731 time - bills the customer as if it were that time.  Specified as a UNIX
1732 timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and
1733 L<Date::Parse> for conversion functions.  For example:
1734
1735  use Date::Parse;
1736  ...
1737  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
1738
1739
1740 If there is an error, returns the error, otherwise returns false.
1741
1742 =cut
1743
1744 sub bill {
1745   my( $self, %options ) = @_;
1746   return '' if $self->payby eq 'COMP';
1747   warn "$me bill customer ". $self->custnum. "\n"
1748     if $DEBUG;
1749
1750   my $time = $options{'time'} || time;
1751
1752   my $error;
1753
1754   #put below somehow?
1755   local $SIG{HUP} = 'IGNORE';
1756   local $SIG{INT} = 'IGNORE';
1757   local $SIG{QUIT} = 'IGNORE';
1758   local $SIG{TERM} = 'IGNORE';
1759   local $SIG{TSTP} = 'IGNORE';
1760   local $SIG{PIPE} = 'IGNORE';
1761
1762   my $oldAutoCommit = $FS::UID::AutoCommit;
1763   local $FS::UID::AutoCommit = 0;
1764   my $dbh = dbh;
1765
1766   $self->select_for_update; #mutex
1767
1768   #create a new invoice
1769   #(we'll remove it later if it doesn't actually need to be generated [contains
1770   # no line items] and we're inside a transaciton so nothing else will see it)
1771   my $cust_bill = new FS::cust_bill ( {
1772     'custnum' => $self->custnum,
1773     '_date'   => $time,
1774     #'charged' => $charged,
1775     'charged' => 0,
1776   } );
1777   $error = $cust_bill->insert;
1778   if ( $error ) {
1779     $dbh->rollback if $oldAutoCommit;
1780     return "can't create invoice for customer #". $self->custnum. ": $error";
1781   }
1782   my $invnum = $cust_bill->invnum;
1783
1784   ###
1785   # find the packages which are due for billing, find out how much they are
1786   # & generate invoice database.
1787   ###
1788
1789   my( $total_setup, $total_recur ) = ( 0, 0 );
1790   my %tax;
1791   my @precommit_hooks = ();
1792
1793   foreach my $cust_pkg (
1794     qsearch('cust_pkg', { 'custnum' => $self->custnum } )
1795   ) {
1796
1797     #NO!! next if $cust_pkg->cancel;
1798     next if $cust_pkg->getfield('cancel');
1799
1800     warn "  bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG > 1;
1801
1802     #? to avoid use of uninitialized value errors... ?
1803     $cust_pkg->setfield('bill', '')
1804       unless defined($cust_pkg->bill);
1805
1806     my $part_pkg = $cust_pkg->part_pkg;
1807
1808     my %hash = $cust_pkg->hash;
1809     my $old_cust_pkg = new FS::cust_pkg \%hash;
1810
1811     my @details = ();
1812
1813     ###
1814     # bill setup
1815     ###
1816
1817     my $setup = 0;
1818     if ( !$cust_pkg->setup || $options{'resetup'} ) {
1819
1820       warn "    bill setup\n" if $DEBUG > 1;
1821
1822       $setup = eval { $cust_pkg->calc_setup( $time ) };
1823       if ( $@ ) {
1824         $dbh->rollback if $oldAutoCommit;
1825         return "$@ running calc_setup for $cust_pkg\n";
1826       }
1827
1828       $cust_pkg->setfield('setup', $time) unless $cust_pkg->setup;
1829     }
1830
1831     ###
1832     # bill recurring fee
1833     ###
1834
1835     my $recur = 0;
1836     my $sdate;
1837     if ( $part_pkg->getfield('freq') ne '0' &&
1838          ! $cust_pkg->getfield('susp') &&
1839          ( $cust_pkg->getfield('bill') || 0 ) <= $time
1840     ) {
1841
1842       warn "    bill recur\n" if $DEBUG > 1;
1843
1844       # XXX shared with $recur_prog
1845       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
1846
1847       #over two params!  lets at least switch to a hashref for the rest...
1848       my %param = ( 'precommit_hooks' => \@precommit_hooks, );
1849
1850       $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details, \%param ) };
1851       if ( $@ ) {
1852         $dbh->rollback if $oldAutoCommit;
1853         return "$@ running calc_recur for $cust_pkg\n";
1854       }
1855
1856       #change this bit to use Date::Manip? CAREFUL with timezones (see
1857       # mailing list archive)
1858       my ($sec,$min,$hour,$mday,$mon,$year) =
1859         (localtime($sdate) )[0,1,2,3,4,5];
1860
1861       #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
1862       # only for figuring next bill date, nothing else, so, reset $sdate again
1863       # here
1864       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
1865       $cust_pkg->last_bill($sdate)
1866         if $cust_pkg->dbdef_table->column('last_bill');
1867
1868       if ( $part_pkg->freq =~ /^\d+$/ ) {
1869         $mon += $part_pkg->freq;
1870         until ( $mon < 12 ) { $mon -= 12; $year++; }
1871       } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
1872         my $weeks = $1;
1873         $mday += $weeks * 7;
1874       } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
1875         my $days = $1;
1876         $mday += $days;
1877       } elsif ( $part_pkg->freq =~ /^(\d+)h$/ ) {
1878         my $hours = $1;
1879         $hour += $hours;
1880       } else {
1881         $dbh->rollback if $oldAutoCommit;
1882         return "unparsable frequency: ". $part_pkg->freq;
1883       }
1884       $cust_pkg->setfield('bill',
1885         timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
1886     }
1887
1888     warn "\$setup is undefined" unless defined($setup);
1889     warn "\$recur is undefined" unless defined($recur);
1890     warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
1891
1892     ###
1893     # If $cust_pkg has been modified, update it and create cust_bill_pkg records
1894     ###
1895
1896     if ( $cust_pkg->modified ) {
1897
1898       warn "  package ". $cust_pkg->pkgnum. " modified; updating\n"
1899         if $DEBUG >1;
1900
1901       $error=$cust_pkg->replace($old_cust_pkg);
1902       if ( $error ) { #just in case
1903         $dbh->rollback if $oldAutoCommit;
1904         return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error";
1905       }
1906
1907       $setup = sprintf( "%.2f", $setup );
1908       $recur = sprintf( "%.2f", $recur );
1909       if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
1910         $dbh->rollback if $oldAutoCommit;
1911         return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
1912       }
1913       if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
1914         $dbh->rollback if $oldAutoCommit;
1915         return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
1916       }
1917
1918       if ( $setup != 0 || $recur != 0 ) {
1919
1920         warn "    charges (setup=$setup, recur=$recur); adding line items\n"
1921           if $DEBUG > 1;
1922         my $cust_bill_pkg = new FS::cust_bill_pkg ({
1923           'invnum'  => $invnum,
1924           'pkgnum'  => $cust_pkg->pkgnum,
1925           'setup'   => $setup,
1926           'recur'   => $recur,
1927           'sdate'   => $sdate,
1928           'edate'   => $cust_pkg->bill,
1929           'details' => \@details,
1930         });
1931         $error = $cust_bill_pkg->insert;
1932         if ( $error ) {
1933           $dbh->rollback if $oldAutoCommit;
1934           return "can't create invoice line item for invoice #$invnum: $error";
1935         }
1936         $total_setup += $setup;
1937         $total_recur += $recur;
1938
1939         ###
1940         # handle taxes
1941         ###
1942
1943         unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
1944
1945           my $prefix =
1946             ( $conf->exists('tax-ship_address') && length($self->ship_last) )
1947             ? 'ship_'
1948             : '';
1949           my %taxhash = map { $_ => $self->get("$prefix$_") }
1950                             qw( state county country );
1951
1952           $taxhash{'taxclass'} = $part_pkg->taxclass;
1953
1954           my @taxes = qsearch( 'cust_main_county', \%taxhash );
1955
1956           unless ( @taxes ) {
1957             $taxhash{'taxclass'} = '';
1958             @taxes =  qsearch( 'cust_main_county', \%taxhash );
1959           }
1960
1961           #one more try at a whole-country tax rate
1962           unless ( @taxes ) {
1963             $taxhash{$_} = '' foreach qw( state county );
1964             @taxes =  qsearch( 'cust_main_county', \%taxhash );
1965           }
1966
1967           # maybe eliminate this entirely, along with all the 0% records
1968           unless ( @taxes ) {
1969             $dbh->rollback if $oldAutoCommit;
1970             return
1971               "fatal: can't find tax rate for state/county/country/taxclass ".
1972               join('/', ( map $self->get("$prefix$_"),
1973                               qw(state county country)
1974                         ),
1975                         $part_pkg->taxclass ). "\n";
1976           }
1977
1978           foreach my $tax ( @taxes ) {
1979
1980             my $taxable_charged = 0;
1981             $taxable_charged += $setup
1982               unless $part_pkg->setuptax =~ /^Y$/i
1983                   || $tax->setuptax =~ /^Y$/i;
1984             $taxable_charged += $recur
1985               unless $part_pkg->recurtax =~ /^Y$/i
1986                   || $tax->recurtax =~ /^Y$/i;
1987             next unless $taxable_charged;
1988
1989             if ( $tax->exempt_amount && $tax->exempt_amount > 0 ) {
1990               #my ($mon,$year) = (localtime($sdate) )[4,5];
1991               my ($mon,$year) = (localtime( $sdate || $cust_bill->_date ) )[4,5];
1992               $mon++;
1993               my $freq = $part_pkg->freq || 1;
1994               if ( $freq !~ /(\d+)$/ ) {
1995                 $dbh->rollback if $oldAutoCommit;
1996                 return "daily/weekly package definitions not (yet?)".
1997                        " compatible with monthly tax exemptions";
1998               }
1999               my $taxable_per_month =
2000                 sprintf("%.2f", $taxable_charged / $freq );
2001
2002               #call the whole thing off if this customer has any old
2003               #exemption records...
2004               my @cust_tax_exempt =
2005                 qsearch( 'cust_tax_exempt' => { custnum=> $self->custnum } );
2006               if ( @cust_tax_exempt ) {
2007                 $dbh->rollback if $oldAutoCommit;
2008                 return
2009                   'this customer still has old-style tax exemption records; '.
2010                   'run bin/fs-migrate-cust_tax_exempt?';
2011               }
2012
2013               foreach my $which_month ( 1 .. $freq ) {
2014
2015                 #maintain the new exemption table now
2016                 my $sql = "
2017                   SELECT SUM(amount)
2018                     FROM cust_tax_exempt_pkg
2019                       LEFT JOIN cust_bill_pkg USING ( billpkgnum )
2020                       LEFT JOIN cust_bill     USING ( invnum     )
2021                     WHERE custnum = ?
2022                       AND taxnum  = ?
2023                       AND year    = ?
2024                       AND month   = ?
2025                 ";
2026                 my $sth = dbh->prepare($sql) or do {
2027                   $dbh->rollback if $oldAutoCommit;
2028                   return "fatal: can't lookup exising exemption: ". dbh->errstr;
2029                 };
2030                 $sth->execute(
2031                   $self->custnum,
2032                   $tax->taxnum,
2033                   1900+$year,
2034                   $mon,
2035                 ) or do {
2036                   $dbh->rollback if $oldAutoCommit;
2037                   return "fatal: can't lookup exising exemption: ". dbh->errstr;
2038                 };
2039                 my $existing_exemption = $sth->fetchrow_arrayref->[0] || 0;
2040
2041                 my $remaining_exemption =
2042                   $tax->exempt_amount - $existing_exemption;
2043                 if ( $remaining_exemption > 0 ) {
2044                   my $addl = $remaining_exemption > $taxable_per_month
2045                     ? $taxable_per_month
2046                     : $remaining_exemption;
2047                   $taxable_charged -= $addl;
2048
2049                   my $cust_tax_exempt_pkg = new FS::cust_tax_exempt_pkg ( {
2050                     'billpkgnum' => $cust_bill_pkg->billpkgnum,
2051                     'taxnum'     => $tax->taxnum,
2052                     'year'       => 1900+$year,
2053                     'month'      => $mon,
2054                     'amount'     => sprintf("%.2f", $addl ),
2055                   } );
2056                   $error = $cust_tax_exempt_pkg->insert;
2057                   if ( $error ) {
2058                     $dbh->rollback if $oldAutoCommit;
2059                     return "fatal: can't insert cust_tax_exempt_pkg: $error";
2060                   }
2061                 } # if $remaining_exemption > 0
2062
2063                 #++
2064                 $mon++;
2065                 #until ( $mon < 12 ) { $mon -= 12; $year++; }
2066                 until ( $mon < 13 ) { $mon -= 12; $year++; }
2067
2068               } #foreach $which_month
2069
2070             } #if $tax->exempt_amount
2071
2072             $taxable_charged = sprintf( "%.2f", $taxable_charged);
2073
2074             #$tax += $taxable_charged * $cust_main_county->tax / 100
2075             $tax{ $tax->taxname || 'Tax' } +=
2076               $taxable_charged * $tax->tax / 100
2077
2078           } #foreach my $tax ( @taxes )
2079
2080         } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2081
2082       } #if $setup != 0 || $recur != 0
2083
2084     } #if $cust_pkg->modified
2085
2086   } #foreach my $cust_pkg
2087
2088   unless ( $cust_bill->cust_bill_pkg ) {
2089     $cust_bill->delete; #don't create an invoice w/o line items
2090     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2091     return '';
2092   }
2093
2094   my $charged = sprintf( "%.2f", $total_setup + $total_recur );
2095
2096   foreach my $taxname ( grep { $tax{$_} > 0 } keys %tax ) {
2097     my $tax = sprintf("%.2f", $tax{$taxname} );
2098     $charged = sprintf( "%.2f", $charged+$tax );
2099
2100     my $cust_bill_pkg = new FS::cust_bill_pkg ({
2101       'invnum'   => $invnum,
2102       'pkgnum'   => 0,
2103       'setup'    => $tax,
2104       'recur'    => 0,
2105       'sdate'    => '',
2106       'edate'    => '',
2107       'itemdesc' => $taxname,
2108     });
2109     $error = $cust_bill_pkg->insert;
2110     if ( $error ) {
2111       $dbh->rollback if $oldAutoCommit;
2112       return "can't create invoice line item for invoice #$invnum: $error";
2113     }
2114     $total_setup += $tax;
2115
2116   }
2117
2118   $cust_bill->charged( sprintf( "%.2f", $total_setup + $total_recur ) );
2119   $error = $cust_bill->replace;
2120   if ( $error ) {
2121     $dbh->rollback if $oldAutoCommit;
2122     return "can't update charged for invoice #$invnum: $error";
2123   }
2124
2125   foreach my $hook ( @precommit_hooks ) {
2126     eval {
2127       &{$hook}; #($self) ?
2128     };
2129     if ( $@ ) {
2130       $dbh->rollback if $oldAutoCommit;
2131       return "$@ running precommit hook $hook\n";
2132     }
2133   }
2134
2135   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2136   ''; #no error
2137 }
2138
2139 =item collect OPTIONS
2140
2141 (Attempt to) collect money for this customer's outstanding invoices (see
2142 L<FS::cust_bill>).  Usually used after the bill method.
2143
2144 Depending on the value of `payby', this may print or email an invoice (I<BILL>,
2145 I<DCRD>, or I<DCHK>), charge a credit card (I<CARD>), charge via electronic
2146 check/ACH (I<CHEK>), or just add any necessary (pseudo-)payment (I<COMP>).
2147
2148 Most actions are now triggered by invoice events; see L<FS::part_bill_event>
2149 and the invoice events web interface.
2150
2151 If there is an error, returns the error, otherwise returns false.
2152
2153 Options are passed as name-value pairs.
2154
2155 Currently available options are:
2156
2157 invoice_time - Use this time when deciding when to print invoices and
2158 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>
2159 for conversion functions.
2160
2161 retry - Retry card/echeck/LEC transactions even when not scheduled by invoice
2162 events.
2163
2164 quiet - set true to surpress email card/ACH decline notices.
2165
2166 freq - "1d" for the traditional, daily events (the default), or "1m" for the
2167 new monthly events
2168
2169 payby - allows for one time override of normal customer billing method
2170
2171 =cut
2172
2173 sub collect {
2174   my( $self, %options ) = @_;
2175   my $invoice_time = $options{'invoice_time'} || time;
2176
2177   #put below somehow?
2178   local $SIG{HUP} = 'IGNORE';
2179   local $SIG{INT} = 'IGNORE';
2180   local $SIG{QUIT} = 'IGNORE';
2181   local $SIG{TERM} = 'IGNORE';
2182   local $SIG{TSTP} = 'IGNORE';
2183   local $SIG{PIPE} = 'IGNORE';
2184
2185   my $oldAutoCommit = $FS::UID::AutoCommit;
2186   local $FS::UID::AutoCommit = 0;
2187   my $dbh = dbh;
2188
2189   $self->select_for_update; #mutex
2190
2191   my $balance = $self->balance;
2192   warn "$me collect customer ". $self->custnum. ": balance $balance\n"
2193     if $DEBUG;
2194   unless ( $balance > 0 ) { #redundant?????
2195     $dbh->rollback if $oldAutoCommit; #hmm
2196     return '';
2197   }
2198
2199   if ( exists($options{'retry_card'}) ) {
2200     carp 'retry_card option passed to collect is deprecated; use retry';
2201     $options{'retry'} ||= $options{'retry_card'};
2202   }
2203   if ( exists($options{'retry'}) && $options{'retry'} ) {
2204     my $error = $self->retry_realtime;
2205     if ( $error ) {
2206       $dbh->rollback if $oldAutoCommit;
2207       return $error;
2208     }
2209   }
2210
2211   my $extra_sql = '';
2212   if ( defined $options{'freq'} && $options{'freq'} eq '1m' ) {
2213     $extra_sql = " AND freq = '1m' ";
2214   } else {
2215     $extra_sql = " AND ( freq = '1d' OR freq IS NULL OR freq = '' ) ";
2216   }
2217
2218   foreach my $cust_bill ( $self->open_cust_bill ) {
2219
2220     # don't try to charge for the same invoice if it's already in a batch
2221     #next if qsearchs( 'cust_pay_batch', { 'invnum' => $cust_bill->invnum } );
2222
2223     last if $self->balance <= 0;
2224
2225     warn "  invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ")\n"
2226       if $DEBUG > 1;
2227
2228     foreach my $part_bill_event (
2229       sort {    $a->seconds   <=> $b->seconds
2230              || $a->weight    <=> $b->weight
2231              || $a->eventpart <=> $b->eventpart }
2232         grep { $_->seconds <= ( $invoice_time - $cust_bill->_date )
2233                && ! qsearch( 'cust_bill_event', {
2234                                 'invnum'    => $cust_bill->invnum,
2235                                 'eventpart' => $_->eventpart,
2236                                 'status'    => 'done',
2237                                                                    } )
2238              }
2239           qsearch( {
2240             'table'     => 'part_bill_event',
2241             'hashref'   => { 'payby'    => (exists($options{'payby'})
2242                                              ? $options{'payby'}
2243                                              : $self->payby
2244                                            ),
2245                              'disabled' => '',           },
2246             'extra_sql' => $extra_sql,
2247           } )
2248     ) {
2249
2250       last if $cust_bill->owed <= 0  # don't run subsequent events if owed<=0
2251            || $self->balance   <= 0; # or if balance<=0
2252
2253       warn "  calling invoice event (". $part_bill_event->eventcode. ")\n"
2254         if $DEBUG > 1;
2255       my $cust_main = $self; #for callback
2256
2257       my $error;
2258       {
2259         local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
2260         local $SIG{__DIE__}; # don't want Mason __DIE__ handler active
2261         $error = eval $part_bill_event->eventcode;
2262       }
2263
2264       my $status = '';
2265       my $statustext = '';
2266       if ( $@ ) {
2267         $status = 'failed';
2268         $statustext = $@;
2269       } elsif ( $error ) {
2270         $status = 'done';
2271         $statustext = $error;
2272       } else {
2273         $status = 'done'
2274       }
2275
2276       #add cust_bill_event
2277       my $cust_bill_event = new FS::cust_bill_event {
2278         'invnum'     => $cust_bill->invnum,
2279         'eventpart'  => $part_bill_event->eventpart,
2280         #'_date'      => $invoice_time,
2281         '_date'      => time,
2282         'status'     => $status,
2283         'statustext' => $statustext,
2284       };
2285       $error = $cust_bill_event->insert;
2286       if ( $error ) {
2287         #$dbh->rollback if $oldAutoCommit;
2288         #return "error: $error";
2289
2290         # gah, even with transactions.
2291         $dbh->commit if $oldAutoCommit; #well.
2292         my $e = 'WARNING: Event run but database not updated - '.
2293                 'error inserting cust_bill_event, invnum #'. $cust_bill->invnum.
2294                 ', eventpart '. $part_bill_event->eventpart.
2295                 ": $error";
2296         warn $e;
2297         return $e;
2298       }
2299
2300
2301     }
2302
2303   }
2304
2305   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2306   '';
2307
2308 }
2309
2310 =item retry_realtime
2311
2312 Schedules realtime credit card / electronic check / LEC billing events for
2313 for retry.  Useful if card information has changed or manual retry is desired.
2314 The 'collect' method must be called to actually retry the transaction.
2315
2316 Implementation details: For each of this customer's open invoices, changes
2317 the status of the first "done" (with statustext error) realtime processing
2318 event to "failed".
2319
2320 =cut
2321
2322 sub retry_realtime {
2323   my $self = shift;
2324
2325   local $SIG{HUP} = 'IGNORE';
2326   local $SIG{INT} = 'IGNORE';
2327   local $SIG{QUIT} = 'IGNORE';
2328   local $SIG{TERM} = 'IGNORE';
2329   local $SIG{TSTP} = 'IGNORE';
2330   local $SIG{PIPE} = 'IGNORE';
2331
2332   my $oldAutoCommit = $FS::UID::AutoCommit;
2333   local $FS::UID::AutoCommit = 0;
2334   my $dbh = dbh;
2335
2336   foreach my $cust_bill (
2337     grep { $_->cust_bill_event }
2338       $self->open_cust_bill
2339   ) {
2340     my @cust_bill_event =
2341       sort { $a->part_bill_event->seconds <=> $b->part_bill_event->seconds }
2342         grep {
2343                #$_->part_bill_event->plan eq 'realtime-card'
2344                $_->part_bill_event->eventcode =~
2345                    /\$cust_bill\->realtime_(card|ach|lec)/
2346                  && $_->status eq 'done'
2347                  && $_->statustext
2348              }
2349           $cust_bill->cust_bill_event;
2350     next unless @cust_bill_event;
2351     my $error = $cust_bill_event[0]->retry;
2352     if ( $error ) {
2353       $dbh->rollback if $oldAutoCommit;
2354       return "error scheduling invoice event for retry: $error";
2355     }
2356
2357   }
2358
2359   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2360   '';
2361
2362 }
2363
2364 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
2365
2366 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
2367 via a Business::OnlinePayment realtime gateway.  See
2368 L<http://420.am/business-onlinepayment> for supported gateways.
2369
2370 Available methods are: I<CC>, I<ECHECK> and I<LEC>
2371
2372 Available options are: I<description>, I<invnum>, I<quiet>
2373
2374 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
2375 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
2376 if set, will override the value from the customer record.
2377
2378 I<description> is a free-text field passed to the gateway.  It defaults to
2379 "Internet services".
2380
2381 If an I<invnum> is specified, this payment (if successful) is applied to the
2382 specified invoice.  If you don't specify an I<invnum> you might want to
2383 call the B<apply_payments> method.
2384
2385 I<quiet> can be set true to surpress email decline notices.
2386
2387 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
2388
2389 =cut
2390
2391 sub realtime_bop {
2392   my( $self, $method, $amount, %options ) = @_;
2393   if ( $DEBUG ) {
2394     warn "$me realtime_bop: $method $amount\n";
2395     warn "  $_ => $options{$_}\n" foreach keys %options;
2396   }
2397
2398   $options{'description'} ||= 'Internet services';
2399
2400   eval "use Business::OnlinePayment";
2401   die $@ if $@;
2402
2403   my $payinfo = exists($options{'payinfo'})
2404                   ? $options{'payinfo'}
2405                   : $self->payinfo;
2406
2407   ###
2408   # select a gateway
2409   ###
2410
2411   my $taxclass = '';
2412   if ( $options{'invnum'} ) {
2413     my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
2414     die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
2415     my @taxclasses =
2416       map  { $_->part_pkg->taxclass }
2417       grep { $_ }
2418       map  { $_->cust_pkg }
2419       $cust_bill->cust_bill_pkg;
2420     unless ( grep { $taxclasses[0] ne $_ } @taxclasses ) { #unless there are
2421                                                            #different taxclasses
2422       $taxclass = $taxclasses[0];
2423     }
2424   }
2425
2426   #look for an agent gateway override first
2427   my $cardtype;
2428   if ( $method eq 'CC' ) {
2429     $cardtype = cardtype($payinfo);
2430   } elsif ( $method eq 'ECHECK' ) {
2431     $cardtype = 'ACH';
2432   } else {
2433     $cardtype = $method;
2434   }
2435
2436   my $override =
2437        qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2438                                            cardtype => $cardtype,
2439                                            taxclass => $taxclass,       } )
2440     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2441                                            cardtype => '',
2442                                            taxclass => $taxclass,       } )
2443     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2444                                            cardtype => $cardtype,
2445                                            taxclass => '',              } )
2446     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2447                                            cardtype => '',
2448                                            taxclass => '',              } );
2449
2450   my $payment_gateway = '';
2451   my( $processor, $login, $password, $action, @bop_options );
2452   if ( $override ) { #use a payment gateway override
2453
2454     $payment_gateway = $override->payment_gateway;
2455
2456     $processor   = $payment_gateway->gateway_module;
2457     $login       = $payment_gateway->gateway_username;
2458     $password    = $payment_gateway->gateway_password;
2459     $action      = $payment_gateway->gateway_action;
2460     @bop_options = $payment_gateway->options;
2461
2462   } else { #use the standard settings from the config
2463
2464     ( $processor, $login, $password, $action, @bop_options ) =
2465       $self->default_payment_gateway($method);
2466
2467   }
2468
2469   ###
2470   # massage data
2471   ###
2472
2473   my $address = exists($options{'address1'})
2474                     ? $options{'address1'}
2475                     : $self->address1;
2476   my $address2 = exists($options{'address2'})
2477                     ? $options{'address2'}
2478                     : $self->address2;
2479   $address .= ", ". $address2 if length($address2);
2480
2481   my $o_payname = exists($options{'payname'})
2482                     ? $options{'payname'}
2483                     : $self->payname;
2484   my($payname, $payfirst, $paylast);
2485   if ( $o_payname && $method ne 'ECHECK' ) {
2486     ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
2487       or return "Illegal payname $payname";
2488     ($payfirst, $paylast) = ($1, $2);
2489   } else {
2490     $payfirst = $self->getfield('first');
2491     $paylast = $self->getfield('last');
2492     $payname =  "$payfirst $paylast";
2493   }
2494
2495   my @invoicing_list = grep { $_ ne 'POST' } $self->invoicing_list;
2496   if ( $conf->exists('emailinvoiceauto')
2497        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
2498     push @invoicing_list, $self->all_emails;
2499   }
2500
2501   my $email = ($conf->exists('business-onlinepayment-email-override'))
2502               ? $conf->config('business-onlinepayment-email-override')
2503               : $invoicing_list[0];
2504
2505   my %content = ();
2506
2507   my $payip = exists($options{'payip'})
2508                 ? $options{'payip'}
2509                 : $self->payip;
2510   $content{customer_ip} = $payip
2511     if length($payip);
2512
2513   if ( $method eq 'CC' ) {
2514
2515     $content{card_number} = $payinfo;
2516     my $paydate = exists($options{'paydate'})
2517                     ? $options{'paydate'}
2518                     : $self->paydate;
2519     $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
2520     $content{expiration} = "$2/$1";
2521
2522     my $paycvv = exists($options{'paycvv'})
2523                    ? $options{'paycvv'}
2524                    : $self->paycvv;
2525     $content{cvv2} = $self->paycvv
2526       if length($paycvv);
2527
2528     my $paystart_month = exists($options{'paystart_month'})
2529                            ? $options{'paystart_month'}
2530                            : $self->paystart_month;
2531
2532     my $paystart_year  = exists($options{'paystart_year'})
2533                            ? $options{'paystart_year'}
2534                            : $self->paystart_year;
2535
2536     $content{card_start} = "$paystart_month/$paystart_year"
2537       if $paystart_month && $paystart_year;
2538
2539     my $payissue       = exists($options{'payissue'})
2540                            ? $options{'payissue'}
2541                            : $self->payissue;
2542     $content{issue_number} = $payissue if $payissue;
2543
2544     $content{recurring_billing} = 'YES'
2545       if qsearch('cust_pay', { 'custnum' => $self->custnum,
2546                                'payby'   => 'CARD',
2547                                'payinfo' => $payinfo,
2548                              } );
2549
2550   } elsif ( $method eq 'ECHECK' ) {
2551     ( $content{account_number}, $content{routing_code} ) =
2552       split('@', $payinfo);
2553     $content{bank_name} = $o_payname;
2554     $content{account_type} = 'CHECKING';
2555     $content{account_name} = $payname;
2556     $content{customer_org} = $self->company ? 'B' : 'I';
2557     $content{customer_ssn} = exists($options{'ss'})
2558                                ? $options{'ss'}
2559                                : $self->ss;
2560   } elsif ( $method eq 'LEC' ) {
2561     $content{phone} = $payinfo;
2562   }
2563
2564   ###
2565   # run transaction(s)
2566   ###
2567
2568   my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
2569
2570   my $transaction = new Business::OnlinePayment( $processor, @bop_options );
2571   $transaction->content(
2572     'type'           => $method,
2573     'login'          => $login,
2574     'password'       => $password,
2575     'action'         => $action1,
2576     'description'    => $options{'description'},
2577     'amount'         => $amount,
2578     'invoice_number' => $options{'invnum'},
2579     'customer_id'    => $self->custnum,
2580     'last_name'      => $paylast,
2581     'first_name'     => $payfirst,
2582     'name'           => $payname,
2583     'address'        => $address,
2584     'city'           => ( exists($options{'city'})
2585                             ? $options{'city'}
2586                             : $self->city          ),
2587     'state'          => ( exists($options{'state'})
2588                             ? $options{'state'}
2589                             : $self->state          ),
2590     'zip'            => ( exists($options{'zip'})
2591                             ? $options{'zip'}
2592                             : $self->zip          ),
2593     'country'        => ( exists($options{'country'})
2594                             ? $options{'country'}
2595                             : $self->country          ),
2596     'referer'        => 'http://cleanwhisker.420.am/',
2597     'email'          => $email,
2598     'phone'          => $self->daytime || $self->night,
2599     %content, #after
2600   );
2601   $transaction->submit();
2602
2603   if ( $transaction->is_success() && $action2 ) {
2604     my $auth = $transaction->authorization;
2605     my $ordernum = $transaction->can('order_number')
2606                    ? $transaction->order_number
2607                    : '';
2608
2609     my $capture =
2610       new Business::OnlinePayment( $processor, @bop_options );
2611
2612     my %capture = (
2613       %content,
2614       type           => $method,
2615       action         => $action2,
2616       login          => $login,
2617       password       => $password,
2618       order_number   => $ordernum,
2619       amount         => $amount,
2620       authorization  => $auth,
2621       description    => $options{'description'},
2622     );
2623
2624     foreach my $field (qw( authorization_source_code returned_ACI                                          transaction_identifier validation_code
2625                            transaction_sequence_num local_transaction_date
2626                            local_transaction_time AVS_result_code          )) {
2627       $capture{$field} = $transaction->$field() if $transaction->can($field);
2628     }
2629
2630     $capture->content( %capture );
2631
2632     $capture->submit();
2633
2634     unless ( $capture->is_success ) {
2635       my $e = "Authorization successful but capture failed, custnum #".
2636               $self->custnum. ': '.  $capture->result_code.
2637               ": ". $capture->error_message;
2638       warn $e;
2639       return $e;
2640     }
2641
2642   }
2643
2644   ###
2645   # remove paycvv after initial transaction
2646   ###
2647
2648   #false laziness w/misc/process/payment.cgi - check both to make sure working
2649   # correctly
2650   if ( defined $self->dbdef_table->column('paycvv')
2651        && length($self->paycvv)
2652        && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
2653   ) {
2654     my $error = $self->remove_cvv;
2655     if ( $error ) {
2656       warn "WARNING: error removing cvv: $error\n";
2657     }
2658   }
2659
2660   ###
2661   # result handling
2662   ###
2663
2664   if ( $transaction->is_success() ) {
2665
2666     my %method2payby = (
2667       'CC'     => 'CARD',
2668       'ECHECK' => 'CHEK',
2669       'LEC'    => 'LECB',
2670     );
2671
2672     my $paybatch = '';
2673     if ( $payment_gateway ) { # agent override
2674       $paybatch = $payment_gateway->gatewaynum. '-';
2675     }
2676
2677     $paybatch .= "$processor:". $transaction->authorization;
2678
2679     $paybatch .= ':'. $transaction->order_number
2680       if $transaction->can('order_number')
2681       && length($transaction->order_number);
2682
2683     my $cust_pay = new FS::cust_pay ( {
2684        'custnum'  => $self->custnum,
2685        'invnum'   => $options{'invnum'},
2686        'paid'     => $amount,
2687        '_date'     => '',
2688        'payby'    => $method2payby{$method},
2689        'payinfo'  => $payinfo,
2690        'paybatch' => $paybatch,
2691     } );
2692     my $error = $cust_pay->insert;
2693     if ( $error ) {
2694       $cust_pay->invnum(''); #try again with no specific invnum
2695       my $error2 = $cust_pay->insert;
2696       if ( $error2 ) {
2697         # gah, even with transactions.
2698         my $e = 'WARNING: Card/ACH debited but database not updated - '.
2699                 "error inserting payment ($processor): $error2".
2700                 " (previously tried insert with invnum #$options{'invnum'}" .
2701                 ": $error )";
2702         warn $e;
2703         return $e;
2704       }
2705     }
2706     return ''; #no error
2707
2708   } else {
2709
2710     my $perror = "$processor error: ". $transaction->error_message;
2711
2712     if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
2713          && $conf->exists('emaildecline')
2714          && grep { $_ ne 'POST' } $self->invoicing_list
2715          && ! grep { $transaction->error_message =~ /$_/ }
2716                    $conf->config('emaildecline-exclude')
2717     ) {
2718       my @templ = $conf->config('declinetemplate');
2719       my $template = new Text::Template (
2720         TYPE   => 'ARRAY',
2721         SOURCE => [ map "$_\n", @templ ],
2722       ) or return "($perror) can't create template: $Text::Template::ERROR";
2723       $template->compile()
2724         or return "($perror) can't compile template: $Text::Template::ERROR";
2725
2726       my $templ_hash = { error => $transaction->error_message };
2727
2728       my $error = send_email(
2729         'from'    => $conf->config('invoice_from'),
2730         'to'      => [ grep { $_ ne 'POST' } $self->invoicing_list ],
2731         'subject' => 'Your payment could not be processed',
2732         'body'    => [ $template->fill_in(HASH => $templ_hash) ],
2733       );
2734
2735       $perror .= " (also received error sending decline notification: $error)"
2736         if $error;
2737
2738     }
2739
2740     return $perror;
2741   }
2742
2743 }
2744
2745 =item default_payment_gateway
2746
2747 =cut
2748
2749 sub default_payment_gateway {
2750   my( $self, $method ) = @_;
2751
2752   die "Real-time processing not enabled\n"
2753     unless $conf->exists('business-onlinepayment');
2754
2755   #load up config
2756   my $bop_config = 'business-onlinepayment';
2757   $bop_config .= '-ach'
2758     if $method eq 'ECHECK' && $conf->exists($bop_config. '-ach');
2759   my ( $processor, $login, $password, $action, @bop_options ) =
2760     $conf->config($bop_config);
2761   $action ||= 'normal authorization';
2762   pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
2763   die "No real-time processor is enabled - ".
2764       "did you set the business-onlinepayment configuration value?\n"
2765     unless $processor;
2766
2767   ( $processor, $login, $password, $action, @bop_options )
2768 }
2769
2770 =item remove_cvv
2771
2772 Removes the I<paycvv> field from the database directly.
2773
2774 If there is an error, returns the error, otherwise returns false.
2775
2776 =cut
2777
2778 sub remove_cvv {
2779   my $self = shift;
2780   my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
2781     or return dbh->errstr;
2782   $sth->execute($self->custnum)
2783     or return $sth->errstr;
2784   $self->paycvv('');
2785   '';
2786 }
2787
2788 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
2789
2790 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
2791 via a Business::OnlinePayment realtime gateway.  See
2792 L<http://420.am/business-onlinepayment> for supported gateways.
2793
2794 Available methods are: I<CC>, I<ECHECK> and I<LEC>
2795
2796 Available options are: I<amount>, I<reason>, I<paynum>
2797
2798 Most gateways require a reference to an original payment transaction to refund,
2799 so you probably need to specify a I<paynum>.
2800
2801 I<amount> defaults to the original amount of the payment if not specified.
2802
2803 I<reason> specifies a reason for the refund.
2804
2805 Implementation note: If I<amount> is unspecified or equal to the amount of the
2806 orignal payment, first an attempt is made to "void" the transaction via
2807 the gateway (to cancel a not-yet settled transaction) and then if that fails,
2808 the normal attempt is made to "refund" ("credit") the transaction via the
2809 gateway is attempted.
2810
2811 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
2812 #I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
2813 #if set, will override the value from the customer record.
2814
2815 #If an I<invnum> is specified, this payment (if successful) is applied to the
2816 #specified invoice.  If you don't specify an I<invnum> you might want to
2817 #call the B<apply_payments> method.
2818
2819 =cut
2820
2821 #some false laziness w/realtime_bop, not enough to make it worth merging
2822 #but some useful small subs should be pulled out
2823 sub realtime_refund_bop {
2824   my( $self, $method, %options ) = @_;
2825   if ( $DEBUG ) {
2826     warn "$me realtime_refund_bop: $method refund\n";
2827     warn "  $_ => $options{$_}\n" foreach keys %options;
2828   }
2829
2830   eval "use Business::OnlinePayment";
2831   die $@ if $@;
2832
2833   ###
2834   # look up the original payment and optionally a gateway for that payment
2835   ###
2836
2837   my $cust_pay = '';
2838   my $amount = $options{'amount'};
2839
2840   my( $processor, $login, $password, @bop_options ) ;
2841   my( $auth, $order_number ) = ( '', '', '' );
2842
2843   if ( $options{'paynum'} ) {
2844
2845     warn "  paynum: $options{paynum}\n" if $DEBUG > 1;
2846     $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
2847       or return "Unknown paynum $options{'paynum'}";
2848     $amount ||= $cust_pay->paid;
2849
2850     $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-]*)(:([\w\-]+))?$/
2851       or return "Can't parse paybatch for paynum $options{'paynum'}: ".
2852                 $cust_pay->paybatch;
2853     my $gatewaynum = '';
2854     ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
2855
2856     if ( $gatewaynum ) { #gateway for the payment to be refunded
2857
2858       my $payment_gateway =
2859         qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
2860       die "payment gateway $gatewaynum not found"
2861         unless $payment_gateway;
2862
2863       $processor   = $payment_gateway->gateway_module;
2864       $login       = $payment_gateway->gateway_username;
2865       $password    = $payment_gateway->gateway_password;
2866       @bop_options = $payment_gateway->options;
2867
2868     } else { #try the default gateway
2869
2870       my( $conf_processor, $unused_action );
2871       ( $conf_processor, $login, $password, $unused_action, @bop_options ) =
2872         $self->default_payment_gateway($method);
2873
2874       return "processor of payment $options{'paynum'} $processor does not".
2875              " match default processor $conf_processor"
2876         unless $processor eq $conf_processor;
2877
2878     }
2879
2880
2881   } else { # didn't specify a paynum, so look for agent gateway overrides
2882            # like a normal transaction
2883
2884     my $cardtype;
2885     if ( $method eq 'CC' ) {
2886       $cardtype = cardtype($self->payinfo);
2887     } elsif ( $method eq 'ECHECK' ) {
2888       $cardtype = 'ACH';
2889     } else {
2890       $cardtype = $method;
2891     }
2892     my $override =
2893            qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2894                                                cardtype => $cardtype,
2895                                                taxclass => '',              } )
2896         || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2897                                                cardtype => '',
2898                                                taxclass => '',              } );
2899
2900     if ( $override ) { #use a payment gateway override
2901
2902       my $payment_gateway = $override->payment_gateway;
2903
2904       $processor   = $payment_gateway->gateway_module;
2905       $login       = $payment_gateway->gateway_username;
2906       $password    = $payment_gateway->gateway_password;
2907       #$action      = $payment_gateway->gateway_action;
2908       @bop_options = $payment_gateway->options;
2909
2910     } else { #use the standard settings from the config
2911
2912       my $unused_action;
2913       ( $processor, $login, $password, $unused_action, @bop_options ) =
2914         $self->default_payment_gateway($method);
2915
2916     }
2917
2918   }
2919   return "neither amount nor paynum specified" unless $amount;
2920
2921   my %content = (
2922     'type'           => $method,
2923     'login'          => $login,
2924     'password'       => $password,
2925     'order_number'   => $order_number,
2926     'amount'         => $amount,
2927     'referer'        => 'http://cleanwhisker.420.am/',
2928   );
2929   $content{authorization} = $auth
2930     if length($auth); #echeck/ACH transactions have an order # but no auth
2931                       #(at least with authorize.net)
2932
2933   #first try void if applicable
2934   if ( $cust_pay && $cust_pay->paid == $amount ) { #and check dates?
2935     warn "  attempting void\n" if $DEBUG > 1;
2936     my $void = new Business::OnlinePayment( $processor, @bop_options );
2937     $void->content( 'action' => 'void', %content );
2938     $void->submit();
2939     if ( $void->is_success ) {
2940       my $error = $cust_pay->void($options{'reason'});
2941       if ( $error ) {
2942         # gah, even with transactions.
2943         my $e = 'WARNING: Card/ACH voided but database not updated - '.
2944                 "error voiding payment: $error";
2945         warn $e;
2946         return $e;
2947       }
2948       warn "  void successful\n" if $DEBUG > 1;
2949       return '';
2950     }
2951   }
2952
2953   warn "  void unsuccessful, trying refund\n"
2954     if $DEBUG > 1;
2955
2956   #massage data
2957   my $address = $self->address1;
2958   $address .= ", ". $self->address2 if $self->address2;
2959
2960   my($payname, $payfirst, $paylast);
2961   if ( $self->payname && $method ne 'ECHECK' ) {
2962     $payname = $self->payname;
2963     $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
2964       or return "Illegal payname $payname";
2965     ($payfirst, $paylast) = ($1, $2);
2966   } else {
2967     $payfirst = $self->getfield('first');
2968     $paylast = $self->getfield('last');
2969     $payname =  "$payfirst $paylast";
2970   }
2971
2972   my @invoicing_list = grep { $_ ne 'POST' } $self->invoicing_list;
2973   if ( $conf->exists('emailinvoiceauto')
2974        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
2975     push @invoicing_list, $self->all_emails;
2976   }
2977
2978   my $email = ($conf->exists('business-onlinepayment-email-override'))
2979               ? $conf->config('business-onlinepayment-email-override')
2980               : $invoicing_list[0];
2981
2982   my $payip = exists($options{'payip'})
2983                 ? $options{'payip'}
2984                 : $self->payip;
2985   $content{customer_ip} = $payip
2986     if length($payip);
2987
2988   my $payinfo = '';
2989   if ( $method eq 'CC' ) {
2990
2991     if ( $cust_pay ) {
2992       $content{card_number} = $payinfo = $cust_pay->payinfo;
2993       #$self->paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
2994       #$content{expiration} = "$2/$1";
2995     } else {
2996       $content{card_number} = $payinfo = $self->payinfo;
2997       $self->paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
2998       $content{expiration} = "$2/$1";
2999     }
3000
3001   } elsif ( $method eq 'ECHECK' ) {
3002     ( $content{account_number}, $content{routing_code} ) =
3003       split('@', $payinfo = $self->payinfo);
3004     $content{bank_name} = $self->payname;
3005     $content{account_type} = 'CHECKING';
3006     $content{account_name} = $payname;
3007     $content{customer_org} = $self->company ? 'B' : 'I';
3008     $content{customer_ssn} = $self->ss;
3009   } elsif ( $method eq 'LEC' ) {
3010     $content{phone} = $payinfo = $self->payinfo;
3011   }
3012
3013   #then try refund
3014   my $refund = new Business::OnlinePayment( $processor, @bop_options );
3015   my %sub_content = $refund->content(
3016     'action'         => 'credit',
3017     'customer_id'    => $self->custnum,
3018     'last_name'      => $paylast,
3019     'first_name'     => $payfirst,
3020     'name'           => $payname,
3021     'address'        => $address,
3022     'city'           => $self->city,
3023     'state'          => $self->state,
3024     'zip'            => $self->zip,
3025     'country'        => $self->country,
3026     'email'          => $email,
3027     'phone'          => $self->daytime || $self->night,
3028     %content, #after
3029   );
3030   warn join('', map { "  $_ => $sub_content{$_}\n" } keys %sub_content )
3031     if $DEBUG > 1;
3032   $refund->submit();
3033
3034   return "$processor error: ". $refund->error_message
3035     unless $refund->is_success();
3036
3037   my %method2payby = (
3038     'CC'     => 'CARD',
3039     'ECHECK' => 'CHEK',
3040     'LEC'    => 'LECB',
3041   );
3042
3043   my $paybatch = "$processor:". $refund->authorization;
3044   $paybatch .= ':'. $refund->order_number
3045     if $refund->can('order_number') && $refund->order_number;
3046
3047   while ( $cust_pay && $cust_pay->unappled < $amount ) {
3048     my @cust_bill_pay = $cust_pay->cust_bill_pay;
3049     last unless @cust_bill_pay;
3050     my $cust_bill_pay = pop @cust_bill_pay;
3051     my $error = $cust_bill_pay->delete;
3052     last if $error;
3053   }
3054
3055   my $cust_refund = new FS::cust_refund ( {
3056     'custnum'  => $self->custnum,
3057     'paynum'   => $options{'paynum'},
3058     'refund'   => $amount,
3059     '_date'    => '',
3060     'payby'    => $method2payby{$method},
3061     'payinfo'  => $payinfo,
3062     'paybatch' => $paybatch,
3063     'reason'   => $options{'reason'} || 'card or ACH refund',
3064   } );
3065   my $error = $cust_refund->insert;
3066   if ( $error ) {
3067     $cust_refund->paynum(''); #try again with no specific paynum
3068     my $error2 = $cust_refund->insert;
3069     if ( $error2 ) {
3070       # gah, even with transactions.
3071       my $e = 'WARNING: Card/ACH refunded but database not updated - '.
3072               "error inserting refund ($processor): $error2".
3073               " (previously tried insert with paynum #$options{'paynum'}" .
3074               ": $error )";
3075       warn $e;
3076       return $e;
3077     }
3078   }
3079
3080   ''; #no error
3081
3082 }
3083
3084 =item total_owed
3085
3086 Returns the total owed for this customer on all invoices
3087 (see L<FS::cust_bill/owed>).
3088
3089 =cut
3090
3091 sub total_owed {
3092   my $self = shift;
3093   $self->total_owed_date(2145859200); #12/31/2037
3094 }
3095
3096 =item total_owed_date TIME
3097
3098 Returns the total owed for this customer on all invoices with date earlier than
3099 TIME.  TIME is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also
3100 see L<Time::Local> and L<Date::Parse> for conversion functions.
3101
3102 =cut
3103
3104 sub total_owed_date {
3105   my $self = shift;
3106   my $time = shift;
3107   my $total_bill = 0;
3108   foreach my $cust_bill (
3109     grep { $_->_date <= $time }
3110       qsearch('cust_bill', { 'custnum' => $self->custnum, } )
3111   ) {
3112     $total_bill += $cust_bill->owed;
3113   }
3114   sprintf( "%.2f", $total_bill );
3115 }
3116
3117 =item apply_credits OPTION => VALUE ...
3118
3119 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
3120 to outstanding invoice balances in chronological order (or reverse
3121 chronological order if the I<order> option is set to B<newest>) and returns the
3122 value of any remaining unapplied credits available for refund (see
3123 L<FS::cust_refund>).
3124
3125 =cut
3126
3127 sub apply_credits {
3128   my $self = shift;
3129   my %opt = @_;
3130
3131   return 0 unless $self->total_credited;
3132
3133   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
3134       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
3135
3136   my @invoices = $self->open_cust_bill;
3137   @invoices = sort { $b->_date <=> $a->_date } @invoices
3138     if defined($opt{'order'}) && $opt{'order'} eq 'newest';
3139
3140   my $credit;
3141   foreach my $cust_bill ( @invoices ) {
3142     my $amount;
3143
3144     if ( !defined($credit) || $credit->credited == 0) {
3145       $credit = pop @credits or last;
3146     }
3147
3148     if ($cust_bill->owed >= $credit->credited) {
3149       $amount=$credit->credited;
3150     }else{
3151       $amount=$cust_bill->owed;
3152     }
3153
3154     my $cust_credit_bill = new FS::cust_credit_bill ( {
3155       'crednum' => $credit->crednum,
3156       'invnum'  => $cust_bill->invnum,
3157       'amount'  => $amount,
3158     } );
3159     my $error = $cust_credit_bill->insert;
3160     die $error if $error;
3161
3162     redo if ($cust_bill->owed > 0);
3163
3164   }
3165
3166   return $self->total_credited;
3167 }
3168
3169 =item apply_payments
3170
3171 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
3172 to outstanding invoice balances in chronological order.
3173
3174  #and returns the value of any remaining unapplied payments.
3175
3176 =cut
3177
3178 sub apply_payments {
3179   my $self = shift;
3180
3181   #return 0 unless
3182
3183   my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
3184       qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
3185
3186   my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
3187       qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
3188
3189   my $payment;
3190
3191   foreach my $cust_bill ( @invoices ) {
3192     my $amount;
3193
3194     if ( !defined($payment) || $payment->unapplied == 0 ) {
3195       $payment = pop @payments or last;
3196     }
3197
3198     if ( $cust_bill->owed >= $payment->unapplied ) {
3199       $amount = $payment->unapplied;
3200     } else {
3201       $amount = $cust_bill->owed;
3202     }
3203
3204     my $cust_bill_pay = new FS::cust_bill_pay ( {
3205       'paynum' => $payment->paynum,
3206       'invnum' => $cust_bill->invnum,
3207       'amount' => $amount,
3208     } );
3209     my $error = $cust_bill_pay->insert;
3210     die $error if $error;
3211
3212     redo if ( $cust_bill->owed > 0);
3213
3214   }
3215
3216   return $self->total_unapplied_payments;
3217 }
3218
3219 =item total_credited
3220
3221 Returns the total outstanding credit (see L<FS::cust_credit>) for this
3222 customer.  See L<FS::cust_credit/credited>.
3223
3224 =cut
3225
3226 sub total_credited {
3227   my $self = shift;
3228   my $total_credit = 0;
3229   foreach my $cust_credit ( qsearch('cust_credit', {
3230     'custnum' => $self->custnum,
3231   } ) ) {
3232     $total_credit += $cust_credit->credited;
3233   }
3234   sprintf( "%.2f", $total_credit );
3235 }
3236
3237 =item total_unapplied_payments
3238
3239 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
3240 See L<FS::cust_pay/unapplied>.
3241
3242 =cut
3243
3244 sub total_unapplied_payments {
3245   my $self = shift;
3246   my $total_unapplied = 0;
3247   foreach my $cust_pay ( qsearch('cust_pay', {
3248     'custnum' => $self->custnum,
3249   } ) ) {
3250     $total_unapplied += $cust_pay->unapplied;
3251   }
3252   sprintf( "%.2f", $total_unapplied );
3253 }
3254
3255 =item balance
3256
3257 Returns the balance for this customer (total_owed minus total_credited
3258 minus total_unapplied_payments).
3259
3260 =cut
3261
3262 sub balance {
3263   my $self = shift;
3264   sprintf( "%.2f",
3265     $self->total_owed - $self->total_credited - $self->total_unapplied_payments
3266   );
3267 }
3268
3269 =item balance_date TIME
3270
3271 Returns the balance for this customer, only considering invoices with date
3272 earlier than TIME (total_owed_date minus total_credited minus
3273 total_unapplied_payments).  TIME is specified as a UNIX timestamp; see
3274 L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion
3275 functions.
3276
3277 =cut
3278
3279 sub balance_date {
3280   my $self = shift;
3281   my $time = shift;
3282   sprintf( "%.2f",
3283     $self->total_owed_date($time)
3284       - $self->total_credited
3285       - $self->total_unapplied_payments
3286   );
3287 }
3288
3289 =item in_transit_payments
3290
3291 Returns the total of requests for payments for this customer pending in
3292 batches in transit to the bank.  See L<FS::pay_batch> and L<FS::cust_pay_batch>
3293
3294 =cut
3295
3296 sub in_transit_payments {
3297   my $self = shift;
3298   my $in_transit_payments = 0;
3299   foreach my $pay_batch ( qsearch('pay_batch', {
3300     'status' => 'I',
3301   } ) ) {
3302     foreach my $cust_pay_batch ( qsearch('cust_pay_batch', {
3303       'batchnum' => $pay_batch->batchnum,
3304       'custnum' => $self->custnum,
3305     } ) ) {
3306       $in_transit_payments += $cust_pay_batch->amount;
3307     }
3308   }
3309   sprintf( "%.2f", $in_transit_payments );
3310 }
3311
3312 =item paydate_monthyear
3313
3314 Returns a two-element list consisting of the month and year of this customer's
3315 paydate (credit card expiration date for CARD customers)
3316
3317 =cut
3318
3319 sub paydate_monthyear {
3320   my $self = shift;
3321   if ( $self->paydate  =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
3322     ( $2, $1 );
3323   } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
3324     ( $1, $3 );
3325   } else {
3326     ('', '');
3327   }
3328 }
3329
3330 =item payinfo_masked
3331
3332 Returns a "masked" payinfo field appropriate to the payment type.  Masked characters are replaced by 'x'es.  Use this to display publicly accessable account Information.
3333
3334 Credit Cards - Mask all but the last four characters.
3335 Checks - Mask all but last 2 of account number and bank routing number.
3336 Others - Do nothing, return the unmasked string.
3337
3338 =cut
3339
3340 sub payinfo_masked {
3341   my $self = shift;
3342   return $self->paymask;
3343 }
3344
3345 =item invoicing_list [ ARRAYREF ]
3346
3347 If an arguement is given, sets these email addresses as invoice recipients
3348 (see L<FS::cust_main_invoice>).  Errors are not fatal and are not reported
3349 (except as warnings), so use check_invoicing_list first.
3350
3351 Returns a list of email addresses (with svcnum entries expanded).
3352
3353 Note: You can clear the invoicing list by passing an empty ARRAYREF.  You can
3354 check it without disturbing anything by passing nothing.
3355
3356 This interface may change in the future.
3357
3358 =cut
3359
3360 sub invoicing_list {
3361   my( $self, $arrayref ) = @_;
3362
3363   if ( $arrayref ) {
3364     my @cust_main_invoice;
3365     if ( $self->custnum ) {
3366       @cust_main_invoice =
3367         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
3368     } else {
3369       @cust_main_invoice = ();
3370     }
3371     foreach my $cust_main_invoice ( @cust_main_invoice ) {
3372       #warn $cust_main_invoice->destnum;
3373       unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
3374         #warn $cust_main_invoice->destnum;
3375         my $error = $cust_main_invoice->delete;
3376         warn $error if $error;
3377       }
3378     }
3379     if ( $self->custnum ) {
3380       @cust_main_invoice =
3381         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
3382     } else {
3383       @cust_main_invoice = ();
3384     }
3385     my %seen = map { $_->address => 1 } @cust_main_invoice;
3386     foreach my $address ( @{$arrayref} ) {
3387       next if exists $seen{$address} && $seen{$address};
3388       $seen{$address} = 1;
3389       my $cust_main_invoice = new FS::cust_main_invoice ( {
3390         'custnum' => $self->custnum,
3391         'dest'    => $address,
3392       } );
3393       my $error = $cust_main_invoice->insert;
3394       warn $error if $error;
3395     }
3396   }
3397
3398   if ( $self->custnum ) {
3399     map { $_->address }
3400       qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
3401   } else {
3402     ();
3403   }
3404
3405 }
3406
3407 =item check_invoicing_list ARRAYREF
3408
3409 Checks these arguements as valid input for the invoicing_list method.  If there
3410 is an error, returns the error, otherwise returns false.
3411
3412 =cut
3413
3414 sub check_invoicing_list {
3415   my( $self, $arrayref ) = @_;
3416   foreach my $address ( @{$arrayref} ) {
3417
3418     if ($address eq 'FAX' and $self->getfield('fax') eq '') {
3419       return 'Can\'t add FAX invoice destination with a blank FAX number.';
3420     }
3421
3422     my $cust_main_invoice = new FS::cust_main_invoice ( {
3423       'custnum' => $self->custnum,
3424       'dest'    => $address,
3425     } );
3426     my $error = $self->custnum
3427                 ? $cust_main_invoice->check
3428                 : $cust_main_invoice->checkdest
3429     ;
3430     return $error if $error;
3431   }
3432   '';
3433 }
3434
3435 =item set_default_invoicing_list
3436
3437 Sets the invoicing list to all accounts associated with this customer,
3438 overwriting any previous invoicing list.
3439
3440 =cut
3441
3442 sub set_default_invoicing_list {
3443   my $self = shift;
3444   $self->invoicing_list($self->all_emails);
3445 }
3446
3447 =item all_emails
3448
3449 Returns the email addresses of all accounts provisioned for this customer.
3450
3451 =cut
3452
3453 sub all_emails {
3454   my $self = shift;
3455   my %list;
3456   foreach my $cust_pkg ( $self->all_pkgs ) {
3457     my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
3458     my @svc_acct =
3459       map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
3460         grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
3461           @cust_svc;
3462     $list{$_}=1 foreach map { $_->email } @svc_acct;
3463   }
3464   keys %list;
3465 }
3466
3467 =item invoicing_list_addpost
3468
3469 Adds postal invoicing to this customer.  If this customer is already configured
3470 to receive postal invoices, does nothing.
3471
3472 =cut
3473
3474 sub invoicing_list_addpost {
3475   my $self = shift;
3476   return if grep { $_ eq 'POST' } $self->invoicing_list;
3477   my @invoicing_list = $self->invoicing_list;
3478   push @invoicing_list, 'POST';
3479   $self->invoicing_list(\@invoicing_list);
3480 }
3481
3482 =item invoicing_list_emailonly
3483
3484 Returns the list of email invoice recipients (invoicing_list without non-email
3485 destinations such as POST and FAX).
3486
3487 =cut
3488
3489 sub invoicing_list_emailonly {
3490   my $self = shift;
3491   grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list;
3492 }
3493
3494 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
3495
3496 Returns an array of customers referred by this customer (referral_custnum set
3497 to this custnum).  If DEPTH is given, recurses up to the given depth, returning
3498 customers referred by customers referred by this customer and so on, inclusive.
3499 The default behavior is DEPTH 1 (no recursion).
3500
3501 =cut
3502
3503 sub referral_cust_main {
3504   my $self = shift;
3505   my $depth = @_ ? shift : 1;
3506   my $exclude = @_ ? shift : {};
3507
3508   my @cust_main =
3509     map { $exclude->{$_->custnum}++; $_; }
3510       grep { ! $exclude->{ $_->custnum } }
3511         qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
3512
3513   if ( $depth > 1 ) {
3514     push @cust_main,
3515       map { $_->referral_cust_main($depth-1, $exclude) }
3516         @cust_main;
3517   }
3518
3519   @cust_main;
3520 }
3521
3522 =item referral_cust_main_ncancelled
3523
3524 Same as referral_cust_main, except only returns customers with uncancelled
3525 packages.
3526
3527 =cut
3528
3529 sub referral_cust_main_ncancelled {
3530   my $self = shift;
3531   grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
3532 }
3533
3534 =item referral_cust_pkg [ DEPTH ]
3535
3536 Like referral_cust_main, except returns a flat list of all unsuspended (and
3537 uncancelled) packages for each customer.  The number of items in this list may
3538 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
3539
3540 =cut
3541
3542 sub referral_cust_pkg {
3543   my $self = shift;
3544   my $depth = @_ ? shift : 1;
3545
3546   map { $_->unsuspended_pkgs }
3547     grep { $_->unsuspended_pkgs }
3548       $self->referral_cust_main($depth);
3549 }
3550
3551 =item referring_cust_main
3552
3553 Returns the single cust_main record for the customer who referred this customer
3554 (referral_custnum), or false.
3555
3556 =cut
3557
3558 sub referring_cust_main {
3559   my $self = shift;
3560   return '' unless $self->referral_custnum;
3561   qsearchs('cust_main', { 'custnum' => $self->referral_custnum } );
3562 }
3563
3564 =item credit AMOUNT, REASON
3565
3566 Applies a credit to this customer.  If there is an error, returns the error,
3567 otherwise returns false.
3568
3569 =cut
3570
3571 sub credit {
3572   my( $self, $amount, $reason ) = @_;
3573   my $cust_credit = new FS::cust_credit {
3574     'custnum' => $self->custnum,
3575     'amount'  => $amount,
3576     'reason'  => $reason,
3577   };
3578   $cust_credit->insert;
3579 }
3580
3581 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
3582
3583 Creates a one-time charge for this customer.  If there is an error, returns
3584 the error, otherwise returns false.
3585
3586 =cut
3587
3588 sub charge {
3589   my ( $self, $amount ) = ( shift, shift );
3590   my $pkg      = @_ ? shift : 'One-time charge';
3591   my $comment  = @_ ? shift : '$'. sprintf("%.2f",$amount);
3592   my $taxclass = @_ ? shift : '';
3593
3594   local $SIG{HUP} = 'IGNORE';
3595   local $SIG{INT} = 'IGNORE';
3596   local $SIG{QUIT} = 'IGNORE';
3597   local $SIG{TERM} = 'IGNORE';
3598   local $SIG{TSTP} = 'IGNORE';
3599   local $SIG{PIPE} = 'IGNORE';
3600
3601   my $oldAutoCommit = $FS::UID::AutoCommit;
3602   local $FS::UID::AutoCommit = 0;
3603   my $dbh = dbh;
3604
3605   my $part_pkg = new FS::part_pkg ( {
3606     'pkg'      => $pkg,
3607     'comment'  => $comment,
3608     #'setup'    => $amount,
3609     #'recur'    => '0',
3610     'plan'     => 'flat',
3611     'plandata' => "setup_fee=$amount",
3612     'freq'     => 0,
3613     'disabled' => 'Y',
3614     'taxclass' => $taxclass,
3615   } );
3616
3617   my $error = $part_pkg->insert;
3618   if ( $error ) {
3619     $dbh->rollback if $oldAutoCommit;
3620     return $error;
3621   }
3622
3623   my $pkgpart = $part_pkg->pkgpart;
3624   my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
3625   unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
3626     my $type_pkgs = new FS::type_pkgs \%type_pkgs;
3627     $error = $type_pkgs->insert;
3628     if ( $error ) {
3629       $dbh->rollback if $oldAutoCommit;
3630       return $error;
3631     }
3632   }
3633
3634   my $cust_pkg = new FS::cust_pkg ( {
3635     'custnum' => $self->custnum,
3636     'pkgpart' => $pkgpart,
3637   } );
3638
3639   $error = $cust_pkg->insert;
3640   if ( $error ) {
3641     $dbh->rollback if $oldAutoCommit;
3642     return $error;
3643   }
3644
3645   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3646   '';
3647
3648 }
3649
3650 =item cust_bill
3651
3652 Returns all the invoices (see L<FS::cust_bill>) for this customer.
3653
3654 =cut
3655
3656 sub cust_bill {
3657   my $self = shift;
3658   sort { $a->_date <=> $b->_date }
3659     qsearch('cust_bill', { 'custnum' => $self->custnum, } )
3660 }
3661
3662 =item open_cust_bill
3663
3664 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
3665 customer.
3666
3667 =cut
3668
3669 sub open_cust_bill {
3670   my $self = shift;
3671   grep { $_->owed > 0 } $self->cust_bill;
3672 }
3673
3674 =item cust_credit
3675
3676 Returns all the credits (see L<FS::cust_credit>) for this customer.
3677
3678 =cut
3679
3680 sub cust_credit {
3681   my $self = shift;
3682   sort { $a->_date <=> $b->_date }
3683     qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
3684 }
3685
3686 =item cust_pay
3687
3688 Returns all the payments (see L<FS::cust_pay>) for this customer.
3689
3690 =cut
3691
3692 sub cust_pay {
3693   my $self = shift;
3694   sort { $a->_date <=> $b->_date }
3695     qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
3696 }
3697
3698 =item cust_pay_void
3699
3700 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
3701
3702 =cut
3703
3704 sub cust_pay_void {
3705   my $self = shift;
3706   sort { $a->_date <=> $b->_date }
3707     qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
3708 }
3709
3710
3711 =item cust_refund
3712
3713 Returns all the refunds (see L<FS::cust_refund>) for this customer.
3714
3715 =cut
3716
3717 sub cust_refund {
3718   my $self = shift;
3719   sort { $a->_date <=> $b->_date }
3720     qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
3721 }
3722
3723 =item select_for_update
3724
3725 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
3726 a mutex.
3727
3728 =cut
3729
3730 sub select_for_update {
3731   my $self = shift;
3732   qsearch('cust_main', { 'custnum' => $self->custnum }, '*', 'FOR UPDATE' );
3733 }
3734
3735 =item name
3736
3737 Returns a name string for this customer, either "Company (Last, First)" or
3738 "Last, First".
3739
3740 =cut
3741
3742 sub name {
3743   my $self = shift;
3744   my $name = $self->contact;
3745   $name = $self->company. " ($name)" if $self->company;
3746   $name;
3747 }
3748
3749 =item ship_name
3750
3751 Returns a name string for this (service/shipping) contact, either
3752 "Company (Last, First)" or "Last, First".
3753
3754 =cut
3755
3756 sub ship_name {
3757   my $self = shift;
3758   if ( $self->get('ship_last') ) {
3759     my $name = $self->ship_contact;
3760     $name = $self->ship_company. " ($name)" if $self->ship_company;
3761     $name;
3762   } else {
3763     $self->name;
3764   }
3765 }
3766
3767 =item contact
3768
3769 Returns this customer's full (billing) contact name only, "Last, First"
3770
3771 =cut
3772
3773 sub contact {
3774   my $self = shift;
3775   $self->get('last'). ', '. $self->first;
3776 }
3777
3778 =item ship_contact
3779
3780 Returns this customer's full (shipping) contact name only, "Last, First"
3781
3782 =cut
3783
3784 sub ship_contact {
3785   my $self = shift;
3786   $self->get('ship_last')
3787     ? $self->get('ship_last'). ', '. $self->ship_first
3788     : $self->contact;
3789 }
3790
3791 =item country_full
3792
3793 Returns this customer's full country name
3794
3795 =cut
3796
3797 sub country_full {
3798   my $self = shift;
3799   code2country($self->country);
3800 }
3801
3802 =item status
3803
3804 Returns a status string for this customer, currently:
3805
3806 =over 4
3807
3808 =item prospect - No packages have ever been ordered
3809
3810 =item active - One or more recurring packages is active
3811
3812 =item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled)
3813
3814 =item suspended - All non-cancelled recurring packages are suspended
3815
3816 =item cancelled - All recurring packages are cancelled
3817
3818 =back
3819
3820 =cut
3821
3822 sub status {
3823   my $self = shift;
3824   for my $status (qw( prospect active inactive suspended cancelled )) {
3825     my $method = $status.'_sql';
3826     my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
3827     my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
3828     $sth->execute( ($self->custnum) x $numnum ) or die $sth->errstr;
3829     return $status if $sth->fetchrow_arrayref->[0];
3830   }
3831 }
3832
3833 =item statuscolor
3834
3835 Returns a hex triplet color string for this customer's status.
3836
3837 =cut
3838
3839 use vars qw(%statuscolor);
3840 %statuscolor = (
3841   'prospect'  => '7e0079', #'000000', #black?  naw, purple
3842   'active'    => '00CC00', #green
3843   'inactive'  => '0000CC', #blue
3844   'suspended' => 'FF9900', #yellow
3845   'cancelled' => 'FF0000', #red
3846 );
3847
3848 sub statuscolor {
3849   my $self = shift;
3850   $statuscolor{$self->status};
3851 }
3852
3853 =back
3854
3855 =head1 CLASS METHODS
3856
3857 =over 4
3858
3859 =item prospect_sql
3860
3861 Returns an SQL expression identifying prospective cust_main records (customers
3862 with no packages ever ordered)
3863
3864 =cut
3865
3866 use vars qw($select_count_pkgs);
3867 $select_count_pkgs =
3868   "SELECT COUNT(*) FROM cust_pkg
3869     WHERE cust_pkg.custnum = cust_main.custnum";
3870
3871 sub select_count_pkgs_sql {
3872   $select_count_pkgs;
3873 }
3874
3875 sub prospect_sql { "
3876   0 = ( $select_count_pkgs )
3877 "; }
3878
3879 =item active_sql
3880
3881 Returns an SQL expression identifying active cust_main records (customers with
3882 no active recurring packages, but otherwise unsuspended/uncancelled).
3883
3884 =cut
3885
3886 sub active_sql { "
3887   0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. "
3888       )
3889 "; }
3890
3891 =item inactive_sql
3892
3893 Returns an SQL expression identifying inactive cust_main records (customers with
3894 active recurring packages).
3895
3896 =cut
3897
3898 sub inactive_sql { "
3899   0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
3900   AND
3901   0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
3902 "; }
3903
3904 =item susp_sql
3905 =item suspended_sql
3906
3907 Returns an SQL expression identifying suspended cust_main records.
3908
3909 =cut
3910
3911
3912 sub suspended_sql { susp_sql(@_); }
3913 sub susp_sql { "
3914     0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " )
3915     AND
3916     0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
3917 "; }
3918
3919 =item cancel_sql
3920 =item cancelled_sql
3921
3922 Returns an SQL expression identifying cancelled cust_main records.
3923
3924 =cut
3925
3926 sub cancelled_sql { cancel_sql(@_); }
3927 sub cancel_sql {
3928
3929   my $recurring_sql = FS::cust_pkg->recurring_sql;
3930   #my $recurring_sql = "
3931   #  '0' != ( select freq from part_pkg
3932   #             where cust_pkg.pkgpart = part_pkg.pkgpart )
3933   #";
3934
3935   "
3936     0 < ( $select_count_pkgs )
3937     AND 0 = ( $select_count_pkgs AND $recurring_sql
3938                   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3939             )
3940   ";
3941 }
3942
3943 =item uncancel_sql
3944 =item uncancelled_sql
3945
3946 Returns an SQL expression identifying un-cancelled cust_main records.
3947
3948 =cut
3949
3950 sub uncancelled_sql { uncancel_sql(@_); }
3951 sub uncancel_sql { "
3952   ( 0 < ( $select_count_pkgs
3953                    AND ( cust_pkg.cancel IS NULL
3954                          OR cust_pkg.cancel = 0
3955                        )
3956         )
3957     OR 0 = ( $select_count_pkgs )
3958   )
3959 "; }
3960
3961 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
3962
3963 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
3964 records.  Currently, I<first>, I<last> and/or I<company> may be specified (the
3965 appropriate ship_ field is also searched).
3966
3967 Additional options are the same as FS::Record::qsearch
3968
3969 =cut
3970
3971 sub fuzzy_search {
3972   my( $self, $fuzzy, $hash, @opt) = @_;
3973   #$self
3974   $hash ||= {};
3975   my @cust_main = ();
3976
3977   check_and_rebuild_fuzzyfiles();
3978   foreach my $field ( keys %$fuzzy ) {
3979     my %match = ();
3980     $match{$_}=1 foreach ( amatch( $fuzzy->{$field},
3981                                    ['i'],
3982                                    @{ $self->all_X($field) }
3983                                  )
3984                          );
3985
3986     my @fcust = ();
3987     foreach ( keys %match ) {
3988       push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
3989       push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
3990     }
3991     my %fsaw = ();
3992     push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
3993   }
3994
3995   # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
3996   my %saw = ();
3997   @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
3998
3999   @cust_main;
4000
4001 }
4002
4003 =back
4004
4005 =head1 SUBROUTINES
4006
4007 =over 4
4008
4009 =item smart_search OPTION => VALUE ...
4010
4011 Accepts the following options: I<search>, the string to search for.  The string
4012 will be searched for as a customer number, phone number, name or company name,
4013 first searching for an exact match then fuzzy and substring matches (in some
4014 cases - see the source code for the exact heuristics used).
4015
4016 Any additional options treated as an additional qualifier on the search
4017 (i.e. I<agentnum>).
4018
4019 Returns a (possibly empty) array of FS::cust_main objects.
4020
4021 =cut
4022
4023 sub smart_search {
4024   my %options = @_;
4025
4026   #here is the agent virtualization
4027   my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
4028
4029   my @cust_main = ();
4030
4031   my $search = delete $options{'search'};
4032   ( my $alphanum_search = $search ) =~ s/\W//g;
4033
4034   if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
4035
4036     #false laziness w/Record::ut_phone
4037     my $phonen = "$1-$2-$3";
4038     $phonen .= " x$4" if $4;
4039
4040     push @cust_main, qsearch( {
4041       'table'   => 'cust_main',
4042       'hashref' => { %options },
4043       'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
4044                      ' ( '.
4045                          join(' OR ', map "$_ = '$phonen'",
4046                                           qw( daytime night fax
4047                                               ship_daytime ship_night ship_fax )
4048                              ).
4049                      ' ) '.
4050                      " AND $agentnums_sql", #agent virtualization
4051     } );
4052
4053     unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
4054       #try looking for matches with extensions unless one was specified
4055
4056       push @cust_main, qsearch( {
4057         'table'   => 'cust_main',
4058         'hashref' => { %options },
4059         'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
4060                        ' ( '.
4061                            join(' OR ', map "$_ LIKE '$phonen\%'",
4062                                             qw( daytime night
4063                                                 ship_daytime ship_night )
4064                                ).
4065                        ' ) '.
4066                        " AND $agentnums_sql", #agent virtualization
4067       } );
4068
4069     }
4070
4071   } elsif ( $search =~ /^\s*(\d+)\s*$/ ) { # customer # search
4072
4073     push @cust_main, qsearch( {
4074       'table'     => 'cust_main',
4075       'hashref'   => { 'custnum' => $1, %options },
4076       'extra_sql' => " AND $agentnums_sql", #agent virtualization
4077     } );
4078
4079   } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
4080
4081     my($company, $last, $first) = ( $1, $2, $3 );
4082
4083     # "Company (Last, First)"
4084     #this is probably something a browser remembered,
4085     #so just do an exact search
4086
4087     foreach my $prefix ( '', 'ship_' ) {
4088       push @cust_main, qsearch( {
4089         'table'     => 'cust_main',
4090         'hashref'   => { $prefix.'first'   => $first,
4091                          $prefix.'last'    => $last,
4092                          $prefix.'company' => $company,
4093                          %options,
4094                        },
4095         'extra_sql' => " AND $agentnums_sql",
4096       } );
4097     }
4098
4099   } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
4100                                               # try (ship_){last,company}
4101
4102     my $value = lc($1);
4103
4104     # # remove "(Last, First)" in "Company (Last, First)", otherwise the
4105     # # full strings the browser remembers won't work
4106     # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
4107
4108     use Lingua::EN::NameParse;
4109     my $NameParse = new Lingua::EN::NameParse(
4110              auto_clean     => 1,
4111              allow_reversed => 1,
4112     );
4113
4114     my($last, $first) = ( '', '' );
4115     #maybe disable this too and just rely on NameParse?
4116     if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
4117
4118       ($last, $first) = ( $1, $2 );
4119
4120     #} elsif  ( $value =~ /^(.+)\s+(.+)$/ ) {
4121     } elsif ( ! $NameParse->parse($value) ) {
4122
4123       my %name = $NameParse->components;
4124       $first = $name{'given_name_1'};
4125       $last  = $name{'surname_1'};
4126
4127     }
4128
4129     if ( $first && $last ) {
4130
4131       my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
4132
4133       #exact
4134       my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
4135       $sql .= "
4136         (     ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
4137            OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
4138         )";
4139
4140       push @cust_main, qsearch( {
4141         'table'     => 'cust_main',
4142         'hashref'   => \%options,
4143         'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
4144       } );
4145
4146       # or it just be something that was typed in... (try that in a sec)
4147
4148     }
4149
4150     my $q_value = dbh->quote($value);
4151
4152     #exact
4153     my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
4154     $sql .= " (    LOWER(last)         = $q_value
4155                 OR LOWER(company)      = $q_value
4156                 OR LOWER(ship_last)    = $q_value
4157                 OR LOWER(ship_company) = $q_value
4158               )";
4159
4160     push @cust_main, qsearch( {
4161       'table'     => 'cust_main',
4162       'hashref'   => \%options,
4163       'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
4164     } );
4165
4166     unless ( @cust_main ) {  #no exact match, trying substring/fuzzy
4167
4168       #still some false laziness w/ search/cust_main.cgi
4169
4170       #substring
4171
4172       my @hashrefs = (
4173         { 'company'      => { op=>'ILIKE', value=>"%$value%" }, },
4174         { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
4175       );
4176
4177       if ( $first && $last ) {
4178
4179         push @hashrefs,
4180           { 'first'        => { op=>'ILIKE', value=>"%$first%" },
4181             'last'         => { op=>'ILIKE', value=>"%$last%" },
4182           },
4183           { 'ship_first'   => { op=>'ILIKE', value=>"%$first%" },
4184             'ship_last'    => { op=>'ILIKE', value=>"%$last%" },
4185           },
4186         ;
4187
4188       } else {
4189
4190         push @hashrefs,
4191           { 'last'         => { op=>'ILIKE', value=>"%$value%" }, },
4192           { 'ship_last'    => { op=>'ILIKE', value=>"%$value%" }, },
4193         ;
4194       }
4195
4196       foreach my $hashref ( @hashrefs ) {
4197
4198         push @cust_main, qsearch( {
4199           'table'     => 'cust_main',
4200           'hashref'   => { %$hashref,
4201                            %options,
4202                          },
4203           'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
4204         } );
4205
4206       }
4207
4208       #fuzzy
4209       my @fuzopts = (
4210         \%options,                #hashref
4211         '',                       #select
4212         " AND $agentnums_sql",    #extra_sql  #agent virtualization
4213       );
4214
4215       if ( $first && $last ) {
4216         push @cust_main, FS::cust_main->fuzzy_search(
4217           { 'last'   => $last,    #fuzzy hashref
4218             'first'  => $first }, #
4219           @fuzopts
4220         );
4221       }
4222       foreach my $field ( 'last', 'company' ) {
4223         push @cust_main,
4224           FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
4225       }
4226
4227     }
4228
4229     #eliminate duplicates
4230     my %saw = ();
4231     @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
4232
4233   }
4234
4235   @cust_main;
4236
4237 }
4238
4239 =item check_and_rebuild_fuzzyfiles
4240
4241 =cut
4242
4243 use vars qw(@fuzzyfields);
4244 @fuzzyfields = ( 'last', 'first', 'company' );
4245
4246 sub check_and_rebuild_fuzzyfiles {
4247   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
4248   rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
4249 }
4250
4251 =item rebuild_fuzzyfiles
4252
4253 =cut
4254
4255 sub rebuild_fuzzyfiles {
4256
4257   use Fcntl qw(:flock);
4258
4259   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
4260   mkdir $dir, 0700 unless -d $dir;
4261
4262   foreach my $fuzzy ( @fuzzyfields ) {
4263
4264     open(LOCK,">>$dir/cust_main.$fuzzy")
4265       or die "can't open $dir/cust_main.$fuzzy: $!";
4266     flock(LOCK,LOCK_EX)
4267       or die "can't lock $dir/cust_main.$fuzzy: $!";
4268
4269     open (CACHE,">$dir/cust_main.$fuzzy.tmp")
4270       or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
4271
4272     foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
4273       my $sth = dbh->prepare("SELECT $field FROM cust_main".
4274                              " WHERE $field != '' AND $field IS NOT NULL");
4275       $sth->execute or die $sth->errstr;
4276
4277       while ( my $row = $sth->fetchrow_arrayref ) {
4278         print CACHE $row->[0]. "\n";
4279       }
4280
4281     }
4282
4283     close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
4284
4285     rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
4286     close LOCK;
4287   }
4288
4289 }
4290
4291 =item all_X
4292
4293 =cut
4294
4295 sub all_X {
4296   my( $self, $field ) = @_;
4297   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
4298   open(CACHE,"<$dir/cust_main.$field")
4299     or die "can't open $dir/cust_main.$field: $!";
4300   my @array = map { chomp; $_; } <CACHE>;
4301   close CACHE;
4302   \@array;
4303 }
4304
4305 =item append_fuzzyfiles LASTNAME COMPANY
4306
4307 =cut
4308
4309 sub append_fuzzyfiles {
4310   #my( $first, $last, $company ) = @_;
4311
4312   &check_and_rebuild_fuzzyfiles;
4313
4314   use Fcntl qw(:flock);
4315
4316   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
4317
4318   foreach my $field (qw( first last company )) {
4319     my $value = shift;
4320
4321     if ( $value ) {
4322
4323       open(CACHE,">>$dir/cust_main.$field")
4324         or die "can't open $dir/cust_main.$field: $!";
4325       flock(CACHE,LOCK_EX)
4326         or die "can't lock $dir/cust_main.$field: $!";
4327
4328       print CACHE "$value\n";
4329
4330       flock(CACHE,LOCK_UN)
4331         or die "can't unlock $dir/cust_main.$field: $!";
4332       close CACHE;
4333     }
4334
4335   }
4336
4337   1;
4338 }
4339
4340 =item batch_import
4341
4342 =cut
4343
4344 sub batch_import {
4345   my $param = shift;
4346   #warn join('-',keys %$param);
4347   my $fh = $param->{filehandle};
4348   my $agentnum = $param->{agentnum};
4349
4350   my $refnum = $param->{refnum};
4351   my $pkgpart = $param->{pkgpart};
4352
4353   #my @fields = @{$param->{fields}};
4354   my $format = $param->{'format'};
4355   my @fields;
4356   my $payby;
4357   if ( $format eq 'simple' ) {
4358     @fields = qw( cust_pkg.setup dayphone first last
4359                   address1 address2 city state zip comments );
4360     $payby = 'BILL';
4361   } elsif ( $format eq 'extended' ) {
4362     @fields = qw( agent_custid refnum
4363                   last first address1 address2 city state zip country
4364                   daytime night
4365                   ship_last ship_first ship_address1 ship_address2
4366                   ship_city ship_state ship_zip ship_country
4367                   payinfo paycvv paydate
4368                   invoicing_list
4369                   cust_pkg.pkgpart
4370                   svc_acct.username svc_acct._password
4371                 );
4372     $payby = 'CARD';
4373   } else {
4374     die "unknown format $format";
4375   }
4376
4377   eval "use Text::CSV_XS;";
4378   die $@ if $@;
4379
4380   my $csv = new Text::CSV_XS;
4381   #warn $csv;
4382   #warn $fh;
4383
4384   my $imported = 0;
4385   #my $columns;
4386
4387   local $SIG{HUP} = 'IGNORE';
4388   local $SIG{INT} = 'IGNORE';
4389   local $SIG{QUIT} = 'IGNORE';
4390   local $SIG{TERM} = 'IGNORE';
4391   local $SIG{TSTP} = 'IGNORE';
4392   local $SIG{PIPE} = 'IGNORE';
4393
4394   my $oldAutoCommit = $FS::UID::AutoCommit;
4395   local $FS::UID::AutoCommit = 0;
4396   my $dbh = dbh;
4397
4398   #while ( $columns = $csv->getline($fh) ) {
4399   my $line;
4400   while ( defined($line=<$fh>) ) {
4401
4402     $csv->parse($line) or do {
4403       $dbh->rollback if $oldAutoCommit;
4404       return "can't parse: ". $csv->error_input();
4405     };
4406
4407     my @columns = $csv->fields();
4408     #warn join('-',@columns);
4409
4410     my %cust_main = (
4411       agentnum => $agentnum,
4412       refnum   => $refnum,
4413       country  => $conf->config('countrydefault') || 'US',
4414       payby    => $payby, #default
4415       paydate  => '12/2037', #default
4416     );
4417     my $billtime = time;
4418     my %cust_pkg = ( pkgpart => $pkgpart );
4419     my %svc_acct = ();
4420     foreach my $field ( @fields ) {
4421
4422       if ( $field =~ /^cust_pkg\.(pkgpart|setup|bill|susp|expire|cancel)$/ ) {
4423
4424         #$cust_pkg{$1} = str2time( shift @$columns );
4425         if ( $1 eq 'pkgpart' ) {
4426           $cust_pkg{$1} = shift @columns;
4427         } elsif ( $1 eq 'setup' ) {
4428           $billtime = str2time(shift @columns);
4429         } else {
4430           $cust_pkg{$1} = str2time( shift @columns );
4431         }
4432
4433       } elsif ( $field =~ /^svc_acct\.(username|_password)$/ ) {
4434
4435         $svc_acct{$1} = shift @columns;
4436
4437       } else {
4438
4439         #refnum interception
4440         if ( $field eq 'refnum' && $columns[0] !~ /^\s*(\d+)\s*$/ ) {
4441
4442           my $referral = $columns[0];
4443           my $part_referral = new FS::part_referral {
4444             'referral' => $referral,
4445             'agentnum' => $agentnum,
4446           };
4447
4448           my $error = $part_referral->insert;
4449           if ( $error ) {
4450             $dbh->rollback if $oldAutoCommit;
4451             return "can't auto-insert advertising source: $referral: $error";
4452           }
4453           $columns[0] = $part_referral->refnum;
4454         }
4455
4456         #$cust_main{$field} = shift @$columns;
4457         $cust_main{$field} = shift @columns;
4458       }
4459     }
4460
4461     my $invoicing_list = $cust_main{'invoicing_list'}
4462                            ? [ delete $cust_main{'invoicing_list'} ]
4463                            : [];
4464
4465     my $cust_main = new FS::cust_main ( \%cust_main );
4466
4467     use Tie::RefHash;
4468     tie my %hash, 'Tie::RefHash'; #this part is important
4469
4470     if ( $cust_pkg{'pkgpart'} ) {
4471       my $cust_pkg = new FS::cust_pkg ( \%cust_pkg );
4472
4473       my @svc_acct = ();
4474       if ( $svc_acct{'username'} ) {
4475         $svc_acct{svcpart} = $cust_pkg->part_pkg->svcpart( 'svc_acct' );
4476         push @svc_acct, new FS::svc_acct ( \%svc_acct )
4477       }
4478
4479       $hash{$cust_pkg} = \@svc_acct;
4480     }
4481
4482     my $error = $cust_main->insert( \%hash, $invoicing_list );
4483
4484     if ( $error ) {
4485       $dbh->rollback if $oldAutoCommit;
4486       return "can't insert customer for $line: $error";
4487     }
4488
4489     if ( $format eq 'simple' ) {
4490
4491       #false laziness w/bill.cgi
4492       $error = $cust_main->bill( 'time' => $billtime );
4493       if ( $error ) {
4494         $dbh->rollback if $oldAutoCommit;
4495         return "can't bill customer for $line: $error";
4496       }
4497
4498       $cust_main->apply_payments;
4499       $cust_main->apply_credits;
4500
4501       $error = $cust_main->collect();
4502       if ( $error ) {
4503         $dbh->rollback if $oldAutoCommit;
4504         return "can't collect customer for $line: $error";
4505       }
4506
4507     }
4508
4509     $imported++;
4510   }
4511
4512   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4513
4514   return "Empty file!" unless $imported;
4515
4516   ''; #no error
4517
4518 }
4519
4520 =item batch_charge
4521
4522 =cut
4523
4524 sub batch_charge {
4525   my $param = shift;
4526   #warn join('-',keys %$param);
4527   my $fh = $param->{filehandle};
4528   my @fields = @{$param->{fields}};
4529
4530   eval "use Text::CSV_XS;";
4531   die $@ if $@;
4532
4533   my $csv = new Text::CSV_XS;
4534   #warn $csv;
4535   #warn $fh;
4536
4537   my $imported = 0;
4538   #my $columns;
4539
4540   local $SIG{HUP} = 'IGNORE';
4541   local $SIG{INT} = 'IGNORE';
4542   local $SIG{QUIT} = 'IGNORE';
4543   local $SIG{TERM} = 'IGNORE';
4544   local $SIG{TSTP} = 'IGNORE';
4545   local $SIG{PIPE} = 'IGNORE';
4546
4547   my $oldAutoCommit = $FS::UID::AutoCommit;
4548   local $FS::UID::AutoCommit = 0;
4549   my $dbh = dbh;
4550
4551   #while ( $columns = $csv->getline($fh) ) {
4552   my $line;
4553   while ( defined($line=<$fh>) ) {
4554
4555     $csv->parse($line) or do {
4556       $dbh->rollback if $oldAutoCommit;
4557       return "can't parse: ". $csv->error_input();
4558     };
4559
4560     my @columns = $csv->fields();
4561     #warn join('-',@columns);
4562
4563     my %row = ();
4564     foreach my $field ( @fields ) {
4565       $row{$field} = shift @columns;
4566     }
4567
4568     my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
4569     unless ( $cust_main ) {
4570       $dbh->rollback if $oldAutoCommit;
4571       return "unknown custnum $row{'custnum'}";
4572     }
4573
4574     if ( $row{'amount'} > 0 ) {
4575       my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
4576       if ( $error ) {
4577         $dbh->rollback if $oldAutoCommit;
4578         return $error;
4579       }
4580       $imported++;
4581     } elsif ( $row{'amount'} < 0 ) {
4582       my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
4583                                       $row{'pkg'}                         );
4584       if ( $error ) {
4585         $dbh->rollback if $oldAutoCommit;
4586         return $error;
4587       }
4588       $imported++;
4589     } else {
4590       #hmm?
4591     }
4592
4593   }
4594
4595   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4596
4597   return "Empty file!" unless $imported;
4598
4599   ''; #no error
4600
4601 }
4602
4603 =back
4604
4605 =head1 BUGS
4606
4607 The delete method.
4608
4609 The delete method should possibly take an FS::cust_main object reference
4610 instead of a scalar customer number.
4611
4612 Bill and collect options should probably be passed as references instead of a
4613 list.
4614
4615 There should probably be a configuration file with a list of allowed credit
4616 card types.
4617
4618 No multiple currency support (probably a larger project than just this module).
4619
4620 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
4621
4622 =head1 SEE ALSO
4623
4624 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
4625 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
4626 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.
4627
4628 =cut
4629
4630 1;
4631