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