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