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