FS/FS/cust_main.pm

   1 package FS::cust_main;
   2
   3 require 5.006;
   4 use strict;
   5 use vars qw( @ISA @EXPORT_OK $DEBUG $me $conf @encrypted_fields
   6              $import $skip_fuzzyfiles $ignore_expired_card @paytypes);
   7 use vars qw( $realtime_bop_decline_quiet ); #ugh
   8 use Safe;
   9 use Carp;
  10 use Exporter;
  11 use Scalar::Util qw( blessed );
  12 use Time::Local qw(timelocal);
  13 use Data::Dumper;
  14 use Tie::IxHash;
  15 use Digest::MD5 qw(md5_base64);
  16 use Date::Format;
  17 #use Date::Manip;
  18 use File::Temp qw( tempfile );
  19 use String::Approx qw(amatch);
  20 use Business::CreditCard 0.28;
  21 use Locale::Country;
  22 use FS::UID qw( getotaker dbh driver_name );
  23 use FS::Record qw( qsearchs qsearch dbdef );
  24 use FS::Misc qw( generate_email send_email generate_ps do_print );
  25 use FS::Msgcat qw(gettext);
  26 use FS::payby;
  27 use FS::cust_pkg;
  28 use FS::cust_svc;
  29 use FS::cust_bill;
  30 use FS::cust_bill_pkg;
  31 use FS::cust_bill_pkg_display;
  32 use FS::cust_bill_pkg_tax_location;
  33 use FS::cust_bill_pkg_tax_rate_location;
  34 use FS::cust_pay;
  35 use FS::cust_pay_pending;
  36 use FS::cust_pay_void;
  37 use FS::cust_pay_batch;
  38 use FS::cust_credit;
  39 use FS::cust_refund;
  40 use FS::part_referral;
  41 use FS::cust_main_county;
  42 use FS::cust_location;
  43 use FS::cust_main_exemption;
  44 use FS::cust_tax_adjustment;
  45 use FS::tax_rate;
  46 use FS::tax_rate_location;
  47 use FS::cust_tax_location;
  48 use FS::part_pkg_taxrate;
  49 use FS::agent;
  50 use FS::cust_main_invoice;
  51 use FS::cust_credit_bill;
  52 use FS::cust_bill_pay;
  53 use FS::prepay_credit;
  54 use FS::queue;
  55 use FS::part_pkg;
  56 use FS::part_event;
  57 use FS::part_event_condition;
  58 #use FS::cust_event;
  59 use FS::type_pkgs;
  60 use FS::payment_gateway;
  61 use FS::agent_payment_gateway;
  62 use FS::banned_pay;
  63 use FS::payinfo_Mixin;
  64 use FS::TicketSystem;
  65
  66 @ISA = qw( FS::payinfo_Mixin FS::Record );
  67
  68 @EXPORT_OK = qw( smart_search );
  69
  70 $realtime_bop_decline_quiet = 0;
  71
  72 # 1 is mostly method/subroutine entry and options
  73 # 2 traces progress of some operations
  74 # 3 is even more information including possibly sensitive data
  75 $DEBUG = 0;
  76 $me = '[FS::cust_main]';
  77
  78 $import = 0;
  79 $skip_fuzzyfiles = 0;
  80 $ignore_expired_card = 0;
  81
  82 @encrypted_fields = ('payinfo', 'paycvv');
  83 sub nohistory_fields { ('paycvv'); }
  84
  85 @paytypes = ('', 'Personal checking', 'Personal savings', 'Business checking', 'Business savings');
  86
  87 #ask FS::UID to run this stuff for us later
  88 #$FS::UID::callback{'FS::cust_main'} = sub {
  89 install_callback FS::UID sub {
  90   $conf = new FS::Conf;
  91   #yes, need it for stuff below (prolly should be cached)
  92 };
  93
  94 sub _cache {
  95   my $self = shift;
  96   my ( $hashref, $cache ) = @_;
  97   if ( exists $hashref->{'pkgnum'} ) {
  98     #@{ $self->{'_pkgnum'} } = ();
  99     my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum});
 100     $self->{'_pkgnum'} = $subcache;
 101     #push @{ $self->{'_pkgnum'} },
 102     FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum};
 103   }
 104 }
 105
 106 =head1 NAME
 107
 108 FS::cust_main - Object methods for cust_main records
 109
 110 =head1 SYNOPSIS
 111
 112   use FS::cust_main;
 113
 114   $record = new FS::cust_main \%hash;
 115   $record = new FS::cust_main { 'column' => 'value' };
 116
 117   $error = $record->insert;
 118
 119   $error = $new_record->replace($old_record);
 120
 121   $error = $record->delete;
 122
 123   $error = $record->check;
 124
 125   @cust_pkg = $record->all_pkgs;
 126
 127   @cust_pkg = $record->ncancelled_pkgs;
 128
 129   @cust_pkg = $record->suspended_pkgs;
 130
 131   $error = $record->bill;
 132   $error = $record->bill %options;
 133   $error = $record->bill 'time' => $time;
 134
 135   $error = $record->collect;
 136   $error = $record->collect %options;
 137   $error = $record->collect 'invoice_time'   => $time,
 138                           ;
 139
 140 =head1 DESCRIPTION
 141
 142 An FS::cust_main object represents a customer.  FS::cust_main inherits from
 143 FS::Record.  The following fields are currently supported:
 144
 145 =over 4
 146
 147 =item custnum
 148
 149 Primary key (assigned automatically for new customers)
 150
 151 =item agentnum
 152
 153 Agent (see L<FS::agent>)
 154
 155 =item refnum
 156
 157 Advertising source (see L<FS::part_referral>)
 158
 159 =item first
 160
 161 First name
 162
 163 =item last
 164
 165 Last name
 166
 167 =item ss
 168
 169 Cocial security number (optional)
 170
 171 =item company
 172
 173 (optional)
 174
 175 =item address1
 176
 177 =item address2
 178
 179 (optional)
 180
 181 =item city
 182
 183 =item county
 184
 185 (optional, see L<FS::cust_main_county>)
 186
 187 =item state
 188
 189 (see L<FS::cust_main_county>)
 190
 191 =item zip
 192
 193 =item country
 194
 195 (see L<FS::cust_main_county>)
 196
 197 =item daytime
 198
 199 phone (optional)
 200
 201 =item night
 202
 203 phone (optional)
 204
 205 =item fax
 206
 207 phone (optional)
 208
 209 =item ship_first
 210
 211 Shipping first name
 212
 213 =item ship_last
 214
 215 Shipping last name
 216
 217 =item ship_company
 218
 219 (optional)
 220
 221 =item ship_address1
 222
 223 =item ship_address2
 224
 225 (optional)
 226
 227 =item ship_city
 228
 229 =item ship_county
 230
 231 (optional, see L<FS::cust_main_county>)
 232
 233 =item ship_state
 234
 235 (see L<FS::cust_main_county>)
 236
 237 =item ship_zip
 238
 239 =item ship_country
 240
 241 (see L<FS::cust_main_county>)
 242
 243 =item ship_daytime
 244
 245 phone (optional)
 246
 247 =item ship_night
 248
 249 phone (optional)
 250
 251 =item ship_fax
 252
 253 phone (optional)
 254
 255 =item payby
 256
 257 Payment Type (See L<FS::payinfo_Mixin> for valid payby values)
 258
 259 =item payinfo
 260
 261 Payment Information (See L<FS::payinfo_Mixin> for data format)
 262
 263 =item paymask
 264
 265 Masked payinfo (See L<FS::payinfo_Mixin> for how this works)
 266
 267 =item paycvv
 268
 269 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
 270
 271 =item paydate
 272
 273 Expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy
 274
 275 =item paystart_month
 276
 277 Start date month (maestro/solo cards only)
 278
 279 =item paystart_year
 280
 281 Start date year (maestro/solo cards only)
 282
 283 =item payissue
 284
 285 Issue number (maestro/solo cards only)
 286
 287 =item payname
 288
 289 Name on card or billing name
 290
 291 =item payip
 292
 293 IP address from which payment information was received
 294
 295 =item tax
 296
 297 Tax exempt, empty or `Y'
 298
 299 =item otaker
 300
 301 Order taker (assigned automatically, see L<FS::UID>)
 302
 303 =item comments
 304
 305 Comments (optional)
 306
 307 =item referral_custnum
 308
 309 Referring customer number
 310
 311 =item spool_cdr
 312
 313 Enable individual CDR spooling, empty or `Y'
 314
 315 =item dundate
 316
 317 A suggestion to events (see L<FS::part_bill_event">) to delay until this unix timestamp
 318
 319 =item squelch_cdr
 320
 321 Discourage individual CDR printing, empty or `Y'
 322
 323 =back
 324
 325 =head1 METHODS
 326
 327 =over 4
 328
 329 =item new HASHREF
 330
 331 Creates a new customer.  To add the customer to the database, see L<"insert">.
 332
 333 Note that this stores the hash reference, not a distinct copy of the hash it
 334 points to.  You can ask the object for a copy with the I<hash> method.
 335
 336 =cut
 337
 338 sub table { 'cust_main'; }
 339
 340 =item insert [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
 341
 342 Adds this customer to the database.  If there is an error, returns the error,
 343 otherwise returns false.
 344
 345 CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert
 346 method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records
 347 are inserted atomicly, or the transaction is rolled back.  Passing an empty
 348 hash reference is equivalent to not supplying this parameter.  There should be
 349 a better explanation of this, but until then, here's an example:
 350
 351   use Tie::RefHash;
 352   tie %hash, 'Tie::RefHash'; #this part is important
 353   %hash = (
 354     $cust_pkg => [ $svc_acct ],
 355     ...
 356   );
 357   $cust_main->insert( \%hash );
 358
 359 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
 360 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
 361 expected and rollback the entire transaction; it is not necessary to call
 362 check_invoicing_list first.  The invoicing_list is set after the records in the
 363 CUST_PKG_HASHREF above are inserted, so it is now possible to set an
 364 invoicing_list destination to the newly-created svc_acct.  Here's an example:
 365
 366   $cust_main->insert( {}, [ $email, 'POST' ] );
 367
 368 Currently available options are: I<depend_jobnum>, I<noexport> and I<tax_exemption>.
 369
 370 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 371 on the supplied jobnum (they will not run until the specific job completes).
 372 This can be used to defer provisioning until some action completes (such
 373 as running the customer's credit card successfully).
 374
 375 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 376 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 377 the B<reexport> method.)
 378
 379 The I<tax_exemption> option can be set to an arrayref of tax names.
 380 FS::cust_main_exemption records will be created and inserted.
 381
 382 =cut
 383
 384 sub insert {
 385   my $self = shift;
 386   my $cust_pkgs = @_ ? shift : {};
 387   my $invoicing_list = @_ ? shift : '';
 388   my %options = @_;
 389   warn "$me insert called with options ".
 390        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 391     if $DEBUG;
 392
 393   local $SIG{HUP} = 'IGNORE';
 394   local $SIG{INT} = 'IGNORE';
 395   local $SIG{QUIT} = 'IGNORE';
 396   local $SIG{TERM} = 'IGNORE';
 397   local $SIG{TSTP} = 'IGNORE';
 398   local $SIG{PIPE} = 'IGNORE';
 399
 400   my $oldAutoCommit = $FS::UID::AutoCommit;
 401   local $FS::UID::AutoCommit = 0;
 402   my $dbh = dbh;
 403
 404   my $prepay_identifier = '';
 405   my( $amount, $seconds, $upbytes, $downbytes, $totalbytes ) = (0, 0, 0, 0, 0);
 406   my $payby = '';
 407   if ( $self->payby eq 'PREPAY' ) {
 408
 409     $self->payby('BILL');
 410     $prepay_identifier = $self->payinfo;
 411     $self->payinfo('');
 412
 413     warn "  looking up prepaid card $prepay_identifier\n"
 414       if $DEBUG > 1;
 415
 416     my $error = $self->get_prepay( $prepay_identifier,
 417                                    'amount_ref'     => \$amount,
 418                                    'seconds_ref'    => \$seconds,
 419                                    'upbytes_ref'    => \$upbytes,
 420                                    'downbytes_ref'  => \$downbytes,
 421                                    'totalbytes_ref' => \$totalbytes,
 422                                  );
 423     if ( $error ) {
 424       $dbh->rollback if $oldAutoCommit;
 425       #return "error applying prepaid card (transaction rolled back): $error";
 426       return $error;
 427     }
 428
 429     $payby = 'PREP' if $amount;
 430
 431   } elsif ( $self->payby =~ /^(CASH|WEST|MCRD)$/ ) {
 432
 433     $payby = $1;
 434     $self->payby('BILL');
 435     $amount = $self->paid;
 436
 437   }
 438
 439   warn "  inserting $self\n"
 440     if $DEBUG > 1;
 441
 442   $self->signupdate(time) unless $self->signupdate;
 443
 444   $self->auto_agent_custid()
 445     if $conf->config('cust_main-auto_agent_custid') && ! $self->agent_custid;
 446
 447   my $error = $self->SUPER::insert;
 448   if ( $error ) {
 449     $dbh->rollback if $oldAutoCommit;
 450     #return "inserting cust_main record (transaction rolled back): $error";
 451     return $error;
 452   }
 453
 454   warn "  setting invoicing list\n"
 455     if $DEBUG > 1;
 456
 457   if ( $invoicing_list ) {
 458     $error = $self->check_invoicing_list( $invoicing_list );
 459     if ( $error ) {
 460       $dbh->rollback if $oldAutoCommit;
 461       #return "checking invoicing_list (transaction rolled back): $error";
 462       return $error;
 463     }
 464     $self->invoicing_list( $invoicing_list );
 465   }
 466
 467   warn "  setting cust_main_exemption\n"
 468     if $DEBUG > 1;
 469
 470   my $tax_exemption = delete $options{'tax_exemption'};
 471   if ( $tax_exemption ) {
 472     foreach my $taxname ( @$tax_exemption ) {
 473       my $cust_main_exemption = new FS::cust_main_exemption {
 474         'custnum' => $self->custnum,
 475         'taxname' => $taxname,
 476       };
 477       my $error = $cust_main_exemption->insert;
 478       if ( $error ) {
 479         $dbh->rollback if $oldAutoCommit;
 480         return "inserting cust_main_exemption (transaction rolled back): $error";
 481       }
 482     }
 483   }
 484
 485   if (    $conf->config('cust_main-skeleton_tables')
 486        && $conf->config('cust_main-skeleton_custnum') ) {
 487
 488     warn "  inserting skeleton records\n"
 489       if $DEBUG > 1;
 490
 491     my $error = $self->start_copy_skel;
 492     if ( $error ) {
 493       $dbh->rollback if $oldAutoCommit;
 494       return $error;
 495     }
 496
 497   }
 498
 499   warn "  ordering packages\n"
 500     if $DEBUG > 1;
 501
 502   $error = $self->order_pkgs( $cust_pkgs,
 503                               %options,
 504                               'seconds_ref'    => \$seconds,
 505                               'upbytes_ref'    => \$upbytes,
 506                               'downbytes_ref'  => \$downbytes,
 507                               'totalbytes_ref' => \$totalbytes,
 508                             );
 509   if ( $error ) {
 510     $dbh->rollback if $oldAutoCommit;
 511     return $error;
 512   }
 513
 514   if ( $seconds ) {
 515     $dbh->rollback if $oldAutoCommit;
 516     return "No svc_acct record to apply pre-paid time";
 517   }
 518   if ( $upbytes || $downbytes || $totalbytes ) {
 519     $dbh->rollback if $oldAutoCommit;
 520     return "No svc_acct record to apply pre-paid data";
 521   }
 522
 523   if ( $amount ) {
 524     warn "  inserting initial $payby payment of $amount\n"
 525       if $DEBUG > 1;
 526     $error = $self->insert_cust_pay($payby, $amount, $prepay_identifier);
 527     if ( $error ) {
 528       $dbh->rollback if $oldAutoCommit;
 529       return "inserting payment (transaction rolled back): $error";
 530     }
 531   }
 532
 533   unless ( $import || $skip_fuzzyfiles ) {
 534     warn "  queueing fuzzyfiles update\n"
 535       if $DEBUG > 1;
 536     $error = $self->queue_fuzzyfiles_update;
 537     if ( $error ) {
 538       $dbh->rollback if $oldAutoCommit;
 539       return "updating fuzzy search cache: $error";
 540     }
 541   }
 542
 543   warn "  insert complete; committing transaction\n"
 544     if $DEBUG > 1;
 545
 546   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 547   '';
 548
 549 }
 550
 551 use File::CounterFile;
 552 sub auto_agent_custid {
 553   my $self = shift;
 554
 555   my $format = $conf->config('cust_main-auto_agent_custid');
 556   my $agent_custid;
 557   if ( $format eq '1YMMXXXXXXXX' ) {
 558
 559     my $counter = new File::CounterFile 'cust_main.agent_custid';
 560     $counter->lock;
 561
 562     my $ym = 100000000000 + time2str('%y%m00000000', time);
 563     if ( $ym > $counter->value ) {
 564       $counter->{'value'} = $agent_custid = $ym;
 565       $counter->{'updated'} = 1;
 566     } else {
 567       $agent_custid = $counter->inc;
 568     }
 569
 570     $counter->unlock;
 571
 572   } else {
 573     die "Unknown cust_main-auto_agent_custid format: $format";
 574   }
 575
 576   $self->agent_custid($agent_custid);
 577
 578 }
 579
 580 sub start_copy_skel {
 581   my $self = shift;
 582
 583   #'mg_user_preference' => {},
 584   #'mg_user_indicator_profile.user_indicator_profile_id' => { 'mg_profile_indicator.profile_indicator_id' => { 'mg_profile_details.profile_detail_id' }, },
 585   #'mg_watchlist_header.watchlist_header_id' => { 'mg_watchlist_details.watchlist_details_id' },
 586   #'mg_user_grid_header.grid_header_id' => { 'mg_user_grid_details.user_grid_details_id' },
 587   #'mg_portfolio_header.portfolio_header_id' => { 'mg_portfolio_trades.portfolio_trades_id' => { 'mg_portfolio_trades_positions.portfolio_trades_positions_id' } },
 588   my @tables = eval(join('\n',$conf->config('cust_main-skeleton_tables')));
 589   die $@ if $@;
 590
 591   _copy_skel( 'cust_main',                                 #tablename
 592               $conf->config('cust_main-skeleton_custnum'), #sourceid
 593               $self->custnum,                              #destid
 594               @tables,                                     #child tables
 595             );
 596 }
 597
 598 #recursive subroutine, not a method
 599 sub _copy_skel {
 600   my( $table, $sourceid, $destid, %child_tables ) = @_;
 601
 602   my $primary_key;
 603   if ( $table =~ /^(\w+)\.(\w+)$/ ) {
 604     ( $table, $primary_key ) = ( $1, $2 );
 605   } else {
 606     my $dbdef_table = dbdef->table($table);
 607     $primary_key = $dbdef_table->primary_key
 608       or return "$table has no primary key".
 609                 " (or do you need to run dbdef-create?)";
 610   }
 611
 612   warn "  _copy_skel: $table.$primary_key $sourceid to $destid for ".
 613        join (', ', keys %child_tables). "\n"
 614     if $DEBUG > 2;
 615
 616   foreach my $child_table_def ( keys %child_tables ) {
 617
 618     my $child_table;
 619     my $child_pkey = '';
 620     if ( $child_table_def =~ /^(\w+)\.(\w+)$/ ) {
 621       ( $child_table, $child_pkey ) = ( $1, $2 );
 622     } else {
 623       $child_table = $child_table_def;
 624
 625       $child_pkey = dbdef->table($child_table)->primary_key;
 626       #  or return "$table has no primary key".
 627       #            " (or do you need to run dbdef-create?)\n";
 628     }
 629
 630     my $sequence = '';
 631     if ( keys %{ $child_tables{$child_table_def} } ) {
 632
 633       return "$child_table has no primary key".
 634              " (run dbdef-create or try specifying it?)\n"
 635         unless $child_pkey;
 636
 637       #false laziness w/Record::insert and only works on Pg
 638       #refactor the proper last-inserted-id stuff out of Record::insert if this
 639       # ever gets use for anything besides a quick kludge for one customer
 640       my $default = dbdef->table($child_table)->column($child_pkey)->default;
 641       $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i
 642         or return "can't parse $child_table.$child_pkey default value ".
 643                   " for sequence name: $default";
 644       $sequence = $1;
 645
 646     }
 647
 648     my @sel_columns = grep { $_ ne $primary_key }
 649                            dbdef->table($child_table)->columns;
 650     my $sel_columns = join(', ', @sel_columns );
 651
 652     my @ins_columns = grep { $_ ne $child_pkey } @sel_columns;
 653     my $ins_columns = ' ( '. join(', ', $primary_key, @ins_columns ). ' ) ';
 654     my $placeholders = ' ( ?, '. join(', ', map '?', @ins_columns ). ' ) ';
 655
 656     my $sel_st = "SELECT $sel_columns FROM $child_table".
 657                  " WHERE $primary_key = $sourceid";
 658     warn "    $sel_st\n"
 659       if $DEBUG > 2;
 660     my $sel_sth = dbh->prepare( $sel_st )
 661       or return dbh->errstr;
 662
 663     $sel_sth->execute or return $sel_sth->errstr;
 664
 665     while ( my $row = $sel_sth->fetchrow_hashref ) {
 666
 667       warn "    selected row: ".
 668            join(', ', map { "$_=".$row->{$_} } keys %$row ). "\n"
 669         if $DEBUG > 2;
 670
 671       my $statement =
 672         "INSERT INTO $child_table $ins_columns VALUES $placeholders";
 673       my $ins_sth =dbh->prepare($statement)
 674           or return dbh->errstr;
 675       my @param = ( $destid, map $row->{$_}, @ins_columns );
 676       warn "    $statement: [ ". join(', ', @param). " ]\n"
 677         if $DEBUG > 2;
 678       $ins_sth->execute( @param )
 679         or return $ins_sth->errstr;
 680
 681       #next unless keys %{ $child_tables{$child_table} };
 682       next unless $sequence;
 683
 684       #another section of that laziness
 685       my $seq_sql = "SELECT currval('$sequence')";
 686       my $seq_sth = dbh->prepare($seq_sql) or return dbh->errstr;
 687       $seq_sth->execute or return $seq_sth->errstr;
 688       my $insertid = $seq_sth->fetchrow_arrayref->[0];
 689
 690       # don't drink soap!  recurse!  recurse!  okay!
 691       my $error =
 692         _copy_skel( $child_table_def,
 693                     $row->{$child_pkey}, #sourceid
 694                     $insertid, #destid
 695                     %{ $child_tables{$child_table_def} },
 696                   );
 697       return $error if $error;
 698
 699     }
 700
 701   }
 702
 703   return '';
 704
 705 }
 706
 707 =item order_pkg HASHREF | OPTION => VALUE ...
 708
 709 Orders a single package.
 710
 711 Options may be passed as a list of key/value pairs or as a hash reference.
 712 Options are:
 713
 714 =over 4
 715
 716 =item cust_pkg
 717
 718 FS::cust_pkg object
 719
 720 =item cust_location
 721
 722 Optional FS::cust_location object
 723
 724 =item svcs
 725
 726 Optional arryaref of FS::svc_* service objects.
 727
 728 =item depend_jobnum
 729
 730 If this option is set to a job queue jobnum (see L<FS::queue>), all provisioning
 731 jobs will have a dependancy on the supplied job (they will not run until the
 732 specific job completes).  This can be used to defer provisioning until some
 733 action completes (such as running the customer's credit card successfully).
 734
 735 =item ticket_subject
 736
 737 Optional subject for a ticket created and attached to this customer
 738
 739 =item ticket_subject
 740
 741 Optional queue name for ticket additions
 742
 743 =back
 744
 745 =cut
 746
 747 sub order_pkg {
 748   my $self = shift;
 749   my $opt = ref($_[0]) ? shift : { @_ };
 750
 751   warn "$me order_pkg called with options ".
 752        join(', ', map { "$_: $opt->{$_}" } keys %$opt ). "\n"
 753     if $DEBUG;
 754
 755   my $cust_pkg = $opt->{'cust_pkg'};
 756   my $svcs     = $opt->{'svcs'} || [];
 757
 758   my %svc_options = ();
 759   $svc_options{'depend_jobnum'} = $opt->{'depend_jobnum'}
 760     if exists($opt->{'depend_jobnum'}) && $opt->{'depend_jobnum'};
 761
 762   my %insert_params = map { $opt->{$_} ? ( $_ => $opt->{$_} ) : () }
 763                           qw( ticket_subject ticket_queue );
 764
 765   local $SIG{HUP} = 'IGNORE';
 766   local $SIG{INT} = 'IGNORE';
 767   local $SIG{QUIT} = 'IGNORE';
 768   local $SIG{TERM} = 'IGNORE';
 769   local $SIG{TSTP} = 'IGNORE';
 770   local $SIG{PIPE} = 'IGNORE';
 771
 772   my $oldAutoCommit = $FS::UID::AutoCommit;
 773   local $FS::UID::AutoCommit = 0;
 774   my $dbh = dbh;
 775
 776   if ( $opt->{'cust_location'} &&
 777        ( ! $cust_pkg->locationnum || $cust_pkg->locationnum == -1 ) ) {
 778     my $error = $opt->{'cust_location'}->insert;
 779     if ( $error ) {
 780       $dbh->rollback if $oldAutoCommit;
 781       return "inserting cust_location (transaction rolled back): $error";
 782     }
 783     $cust_pkg->locationnum($opt->{'cust_location'}->locationnum);
 784   }
 785
 786   $cust_pkg->custnum( $self->custnum );
 787
 788   my $error = $cust_pkg->insert( %insert_params );
 789   if ( $error ) {
 790     $dbh->rollback if $oldAutoCommit;
 791     return "inserting cust_pkg (transaction rolled back): $error";
 792   }
 793
 794   foreach my $svc_something ( @{ $opt->{'svcs'} } ) {
 795     if ( $svc_something->svcnum ) {
 796       my $old_cust_svc = $svc_something->cust_svc;
 797       my $new_cust_svc = new FS::cust_svc { $old_cust_svc->hash };
 798       $new_cust_svc->pkgnum( $cust_pkg->pkgnum);
 799       $error = $new_cust_svc->replace($old_cust_svc);
 800     } else {
 801       $svc_something->pkgnum( $cust_pkg->pkgnum );
 802       if ( $svc_something->isa('FS::svc_acct') ) {
 803         foreach ( grep { $opt->{$_.'_ref'} && ${ $opt->{$_.'_ref'} } }
 804                        qw( seconds upbytes downbytes totalbytes )      ) {
 805           $svc_something->$_( $svc_something->$_() + ${ $opt->{$_.'_ref'} } );
 806           ${ $opt->{$_.'_ref'} } = 0;
 807         }
 808       }
 809       $error = $svc_something->insert(%svc_options);
 810     }
 811     if ( $error ) {
 812       $dbh->rollback if $oldAutoCommit;
 813       return "inserting svc_ (transaction rolled back): $error";
 814     }
 815   }
 816
 817   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 818   ''; #no error
 819
 820 }
 821
 822 #deprecated #=item order_pkgs HASHREF [ , SECONDSREF ] [ , OPTION => VALUE ... ]
 823 =item order_pkgs HASHREF [ , OPTION => VALUE ... ]
 824
 825 Like the insert method on an existing record, this method orders multiple
 826 packages and included services atomicaly.  Pass a Tie::RefHash data structure
 827 to this method containing FS::cust_pkg and FS::svc_I<tablename> objects.
 828 There should be a better explanation of this, but until then, here's an
 829 example:
 830
 831   use Tie::RefHash;
 832   tie %hash, 'Tie::RefHash'; #this part is important
 833   %hash = (
 834     $cust_pkg => [ $svc_acct ],
 835     ...
 836   );
 837   $cust_main->order_pkgs( \%hash, 'noexport'=>1 );
 838
 839 Services can be new, in which case they are inserted, or existing unaudited
 840 services, in which case they are linked to the newly-created package.
 841
 842 Currently available options are: I<depend_jobnum>, I<noexport>, I<seconds_ref>,
 843 I<upbytes_ref>, I<downbytes_ref>, and I<totalbytes_ref>.
 844
 845 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 846 on the supplied jobnum (they will not run until the specific job completes).
 847 This can be used to defer provisioning until some action completes (such
 848 as running the customer's credit card successfully).
 849
 850 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 851 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 852 the B<reexport> method for each cust_pkg object.  Using the B<reexport> method
 853 on the cust_main object is not recommended, as existing services will also be
 854 reexported.)
 855
 856 If I<seconds_ref>, I<upbytes_ref>, I<downbytes_ref>, or I<totalbytes_ref> is
 857 provided, the scalars (provided by references) will be incremented by the
 858 values of the prepaid card.`
 859
 860 =cut
 861
 862 sub order_pkgs {
 863   my $self = shift;
 864   my $cust_pkgs = shift;
 865   my $seconds_ref = ref($_[0]) ? shift : ''; #deprecated
 866   my %options = @_;
 867   $seconds_ref ||= $options{'seconds_ref'};
 868
 869   warn "$me order_pkgs called with options ".
 870        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 871     if $DEBUG;
 872
 873   local $SIG{HUP} = 'IGNORE';
 874   local $SIG{INT} = 'IGNORE';
 875   local $SIG{QUIT} = 'IGNORE';
 876   local $SIG{TERM} = 'IGNORE';
 877   local $SIG{TSTP} = 'IGNORE';
 878   local $SIG{PIPE} = 'IGNORE';
 879
 880   my $oldAutoCommit = $FS::UID::AutoCommit;
 881   local $FS::UID::AutoCommit = 0;
 882   my $dbh = dbh;
 883
 884   local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
 885
 886   foreach my $cust_pkg ( keys %$cust_pkgs ) {
 887
 888     my $error = $self->order_pkg(
 889       'cust_pkg'     => $cust_pkg,
 890       'svcs'         => $cust_pkgs->{$cust_pkg},
 891       'seconds_ref'  => $seconds_ref,
 892       map { $_ => $options{$_} } qw( upbytes_ref downbytes_ref totalbytes_ref
 893                                      depend_jobnum
 894                                    )
 895     );
 896     if ( $error ) {
 897       $dbh->rollback if $oldAutoCommit;
 898       return $error;
 899     }
 900
 901   }
 902
 903   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 904   ''; #no error
 905 }
 906
 907 =item recharge_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , AMOUNTREF, SECONDSREF, UPBYTEREF, DOWNBYTEREF ]
 908
 909 Recharges this (existing) customer with the specified prepaid card (see
 910 L<FS::prepay_credit>), specified either by I<identifier> or as an
 911 FS::prepay_credit object.  If there is an error, returns the error, otherwise
 912 returns false.
 913
 914 Optionally, five scalar references can be passed as well.  They will have their
 915 values filled in with the amount, number of seconds, and number of upload,
 916 download, and total bytes applied by this prepaid card.
 917
 918 =cut
 919
 920 #the ref bullshit here should be refactored like get_prepay.  MyAccount.pm is
 921 #the only place that uses these args
 922 sub recharge_prepay {
 923   my( $self, $prepay_credit, $amountref, $secondsref,
 924       $upbytesref, $downbytesref, $totalbytesref ) = @_;
 925
 926   local $SIG{HUP} = 'IGNORE';
 927   local $SIG{INT} = 'IGNORE';
 928   local $SIG{QUIT} = 'IGNORE';
 929   local $SIG{TERM} = 'IGNORE';
 930   local $SIG{TSTP} = 'IGNORE';
 931   local $SIG{PIPE} = 'IGNORE';
 932
 933   my $oldAutoCommit = $FS::UID::AutoCommit;
 934   local $FS::UID::AutoCommit = 0;
 935   my $dbh = dbh;
 936
 937   my( $amount, $seconds, $upbytes, $downbytes, $totalbytes) = ( 0, 0, 0, 0, 0 );
 938
 939   my $error = $self->get_prepay( $prepay_credit,
 940                                  'amount_ref'     => \$amount,
 941                                  'seconds_ref'    => \$seconds,
 942                                  'upbytes_ref'    => \$upbytes,
 943                                  'downbytes_ref'  => \$downbytes,
 944                                  'totalbytes_ref' => \$totalbytes,
 945                                )
 946            || $self->increment_seconds($seconds)
 947            || $self->increment_upbytes($upbytes)
 948            || $self->increment_downbytes($downbytes)
 949            || $self->increment_totalbytes($totalbytes)
 950            || $self->insert_cust_pay_prepay( $amount,
 951                                              ref($prepay_credit)
 952                                                ? $prepay_credit->identifier
 953                                                : $prepay_credit
 954                                            );
 955
 956   if ( $error ) {
 957     $dbh->rollback if $oldAutoCommit;
 958     return $error;
 959   }
 960
 961   if ( defined($amountref)  ) { $$amountref  = $amount;  }
 962   if ( defined($secondsref) ) { $$secondsref = $seconds; }
 963   if ( defined($upbytesref) ) { $$upbytesref = $upbytes; }
 964   if ( defined($downbytesref) ) { $$downbytesref = $downbytes; }
 965   if ( defined($totalbytesref) ) { $$totalbytesref = $totalbytes; }
 966
 967   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 968   '';
 969
 970 }
 971
 972 =item get_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , OPTION => VALUE ... ]
 973
 974 Looks up and deletes a prepaid card (see L<FS::prepay_credit>),
 975 specified either by I<identifier> or as an FS::prepay_credit object.
 976
 977 Available options are: I<amount_ref>, I<seconds_ref>, I<upbytes_ref>, I<downbytes_ref>, and I<totalbytes_ref>.  The scalars (provided by references) will be
 978 incremented by the values of the prepaid card.
 979
 980 If the prepaid card specifies an I<agentnum> (see L<FS::agent>), it is used to
 981 check or set this customer's I<agentnum>.
 982
 983 If there is an error, returns the error, otherwise returns false.
 984
 985 =cut
 986
 987
 988 sub get_prepay {
 989   my( $self, $prepay_credit, %opt ) = @_;
 990
 991   local $SIG{HUP} = 'IGNORE';
 992   local $SIG{INT} = 'IGNORE';
 993   local $SIG{QUIT} = 'IGNORE';
 994   local $SIG{TERM} = 'IGNORE';
 995   local $SIG{TSTP} = 'IGNORE';
 996   local $SIG{PIPE} = 'IGNORE';
 997
 998   my $oldAutoCommit = $FS::UID::AutoCommit;
 999   local $FS::UID::AutoCommit = 0;
1000   my $dbh = dbh;
1001
1002   unless ( ref($prepay_credit) ) {
1003
1004     my $identifier = $prepay_credit;
1005
1006     $prepay_credit = qsearchs(
1007       'prepay_credit',
1008       { 'identifier' => $prepay_credit },
1009       '',
1010       'FOR UPDATE'
1011     );
1012
1013     unless ( $prepay_credit ) {
1014       $dbh->rollback if $oldAutoCommit;
1015       return "Invalid prepaid card: ". $identifier;
1016     }
1017
1018   }
1019
1020   if ( $prepay_credit->agentnum ) {
1021     if ( $self->agentnum && $self->agentnum != $prepay_credit->agentnum ) {
1022       $dbh->rollback if $oldAutoCommit;
1023       return "prepaid card not valid for agent ". $self->agentnum;
1024     }
1025     $self->agentnum($prepay_credit->agentnum);
1026   }
1027
1028   my $error = $prepay_credit->delete;
1029   if ( $error ) {
1030     $dbh->rollback if $oldAutoCommit;
1031     return "removing prepay_credit (transaction rolled back): $error";
1032   }
1033
1034   ${ $opt{$_.'_ref'} } += $prepay_credit->$_()
1035     for grep $opt{$_.'_ref'}, qw( amount seconds upbytes downbytes totalbytes );
1036
1037   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1038   '';
1039
1040 }
1041
1042 =item increment_upbytes SECONDS
1043
1044 Updates this customer's single or primary account (see L<FS::svc_acct>) by
1045 the specified number of upbytes.  If there is an error, returns the error,
1046 otherwise returns false.
1047
1048 =cut
1049
1050 sub increment_upbytes {
1051   _increment_column( shift, 'upbytes', @_);
1052 }
1053
1054 =item increment_downbytes SECONDS
1055
1056 Updates this customer's single or primary account (see L<FS::svc_acct>) by
1057 the specified number of downbytes.  If there is an error, returns the error,
1058 otherwise returns false.
1059
1060 =cut
1061
1062 sub increment_downbytes {
1063   _increment_column( shift, 'downbytes', @_);
1064 }
1065
1066 =item increment_totalbytes SECONDS
1067
1068 Updates this customer's single or primary account (see L<FS::svc_acct>) by
1069 the specified number of totalbytes.  If there is an error, returns the error,
1070 otherwise returns false.
1071
1072 =cut
1073
1074 sub increment_totalbytes {
1075   _increment_column( shift, 'totalbytes', @_);
1076 }
1077
1078 =item increment_seconds SECONDS
1079
1080 Updates this customer's single or primary account (see L<FS::svc_acct>) by
1081 the specified number of seconds.  If there is an error, returns the error,
1082 otherwise returns false.
1083
1084 =cut
1085
1086 sub increment_seconds {
1087   _increment_column( shift, 'seconds', @_);
1088 }
1089
1090 =item _increment_column AMOUNT
1091
1092 Updates this customer's single or primary account (see L<FS::svc_acct>) by
1093 the specified number of seconds or bytes.  If there is an error, returns
1094 the error, otherwise returns false.
1095
1096 =cut
1097
1098 sub _increment_column {
1099   my( $self, $column, $amount ) = @_;
1100   warn "$me increment_column called: $column, $amount\n"
1101     if $DEBUG;
1102
1103   return '' unless $amount;
1104
1105   my @cust_pkg = grep { $_->part_pkg->svcpart('svc_acct') }
1106                       $self->ncancelled_pkgs;
1107
1108   if ( ! @cust_pkg ) {
1109     return 'No packages with primary or single services found'.
1110            ' to apply pre-paid time';
1111   } elsif ( scalar(@cust_pkg) > 1 ) {
1112     #maybe have a way to specify the package/account?
1113     return 'Multiple packages found to apply pre-paid time';
1114   }
1115
1116   my $cust_pkg = $cust_pkg[0];
1117   warn "  found package pkgnum ". $cust_pkg->pkgnum. "\n"
1118     if $DEBUG > 1;
1119
1120   my @cust_svc =
1121     $cust_pkg->cust_svc( $cust_pkg->part_pkg->svcpart('svc_acct') );
1122
1123   if ( ! @cust_svc ) {
1124     return 'No account found to apply pre-paid time';
1125   } elsif ( scalar(@cust_svc) > 1 ) {
1126     return 'Multiple accounts found to apply pre-paid time';
1127   }
1128
1129   my $svc_acct = $cust_svc[0]->svc_x;
1130   warn "  found service svcnum ". $svc_acct->pkgnum.
1131        ' ('. $svc_acct->email. ")\n"
1132     if $DEBUG > 1;
1133
1134   $column = "increment_$column";
1135   $svc_acct->$column($amount);
1136
1137 }
1138
1139 =item insert_cust_pay_prepay AMOUNT [ PAYINFO ]
1140
1141 Inserts a prepayment in the specified amount for this customer.  An optional
1142 second argument can specify the prepayment identifier for tracking purposes.
1143 If there is an error, returns the error, otherwise returns false.
1144
1145 =cut
1146
1147 sub insert_cust_pay_prepay {
1148   shift->insert_cust_pay('PREP', @_);
1149 }
1150
1151 =item insert_cust_pay_cash AMOUNT [ PAYINFO ]
1152
1153 Inserts a cash payment in the specified amount for this customer.  An optional
1154 second argument can specify the payment identifier for tracking purposes.
1155 If there is an error, returns the error, otherwise returns false.
1156
1157 =cut
1158
1159 sub insert_cust_pay_cash {
1160   shift->insert_cust_pay('CASH', @_);
1161 }
1162
1163 =item insert_cust_pay_west AMOUNT [ PAYINFO ]
1164
1165 Inserts a Western Union payment in the specified amount for this customer.  An
1166 optional second argument can specify the prepayment identifier for tracking
1167 purposes.  If there is an error, returns the error, otherwise returns false.
1168
1169 =cut
1170
1171 sub insert_cust_pay_west {
1172   shift->insert_cust_pay('WEST', @_);
1173 }
1174
1175 sub insert_cust_pay {
1176   my( $self, $payby, $amount ) = splice(@_, 0, 3);
1177   my $payinfo = scalar(@_) ? shift : '';
1178
1179   my $cust_pay = new FS::cust_pay {
1180     'custnum' => $self->custnum,
1181     'paid'    => sprintf('%.2f', $amount),
1182     #'_date'   => #date the prepaid card was purchased???
1183     'payby'   => $payby,
1184     'payinfo' => $payinfo,
1185   };
1186   $cust_pay->insert;
1187
1188 }
1189
1190 =item reexport
1191
1192 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1193 order_pkgs methods for a better way to defer provisioning.
1194
1195 Re-schedules all exports by calling the B<reexport> method of all associated
1196 packages (see L<FS::cust_pkg>).  If there is an error, returns the error;
1197 otherwise returns false.
1198
1199 =cut
1200
1201 sub reexport {
1202   my $self = shift;
1203
1204   carp "WARNING: FS::cust_main::reexport is deprectated; ".
1205        "use the depend_jobnum option to insert or order_pkgs to delay export";
1206
1207   local $SIG{HUP} = 'IGNORE';
1208   local $SIG{INT} = 'IGNORE';
1209   local $SIG{QUIT} = 'IGNORE';
1210   local $SIG{TERM} = 'IGNORE';
1211   local $SIG{TSTP} = 'IGNORE';
1212   local $SIG{PIPE} = 'IGNORE';
1213
1214   my $oldAutoCommit = $FS::UID::AutoCommit;
1215   local $FS::UID::AutoCommit = 0;
1216   my $dbh = dbh;
1217
1218   foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
1219     my $error = $cust_pkg->reexport;
1220     if ( $error ) {
1221       $dbh->rollback if $oldAutoCommit;
1222       return $error;
1223     }
1224   }
1225
1226   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1227   '';
1228
1229 }
1230
1231 =item delete NEW_CUSTNUM
1232
1233 This deletes the customer.  If there is an error, returns the error, otherwise
1234 returns false.
1235
1236 This will completely remove all traces of the customer record.  This is not
1237 what you want when a customer cancels service; for that, cancel all of the
1238 customer's packages (see L</cancel>).
1239
1240 If the customer has any uncancelled packages, you need to pass a new (valid)
1241 customer number for those packages to be transferred to.  Cancelled packages
1242 will be deleted.  Did I mention that this is NOT what you want when a customer
1243 cancels service and that you really should be looking see L<FS::cust_pkg/cancel>?
1244
1245 You can't delete a customer with invoices (see L<FS::cust_bill>),
1246 or credits (see L<FS::cust_credit>), payments (see L<FS::cust_pay>) or
1247 refunds (see L<FS::cust_refund>).
1248
1249 =cut
1250
1251 sub delete {
1252   my $self = shift;
1253
1254   local $SIG{HUP} = 'IGNORE';
1255   local $SIG{INT} = 'IGNORE';
1256   local $SIG{QUIT} = 'IGNORE';
1257   local $SIG{TERM} = 'IGNORE';
1258   local $SIG{TSTP} = 'IGNORE';
1259   local $SIG{PIPE} = 'IGNORE';
1260
1261   my $oldAutoCommit = $FS::UID::AutoCommit;
1262   local $FS::UID::AutoCommit = 0;
1263   my $dbh = dbh;
1264
1265   if ( $self->cust_bill ) {
1266     $dbh->rollback if $oldAutoCommit;
1267     return "Can't delete a customer with invoices";
1268   }
1269   if ( $self->cust_credit ) {
1270     $dbh->rollback if $oldAutoCommit;
1271     return "Can't delete a customer with credits";
1272   }
1273   if ( $self->cust_pay ) {
1274     $dbh->rollback if $oldAutoCommit;
1275     return "Can't delete a customer with payments";
1276   }
1277   if ( $self->cust_refund ) {
1278     $dbh->rollback if $oldAutoCommit;
1279     return "Can't delete a customer with refunds";
1280   }
1281
1282   my @cust_pkg = $self->ncancelled_pkgs;
1283   if ( @cust_pkg ) {
1284     my $new_custnum = shift;
1285     unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) {
1286       $dbh->rollback if $oldAutoCommit;
1287       return "Invalid new customer number: $new_custnum";
1288     }
1289     foreach my $cust_pkg ( @cust_pkg ) {
1290       my %hash = $cust_pkg->hash;
1291       $hash{'custnum'} = $new_custnum;
1292       my $new_cust_pkg = new FS::cust_pkg ( \%hash );
1293       my $error = $new_cust_pkg->replace($cust_pkg,
1294                                          options => { $cust_pkg->options },
1295                                         );
1296       if ( $error ) {
1297         $dbh->rollback if $oldAutoCommit;
1298         return $error;
1299       }
1300     }
1301   }
1302   my @cancelled_cust_pkg = $self->all_pkgs;
1303   foreach my $cust_pkg ( @cancelled_cust_pkg ) {
1304     my $error = $cust_pkg->delete;
1305     if ( $error ) {
1306       $dbh->rollback if $oldAutoCommit;
1307       return $error;
1308     }
1309   }
1310
1311   foreach my $cust_main_invoice ( #(email invoice destinations, not invoices)
1312     qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } )
1313   ) {
1314     my $error = $cust_main_invoice->delete;
1315     if ( $error ) {
1316       $dbh->rollback if $oldAutoCommit;
1317       return $error;
1318     }
1319   }
1320
1321   foreach my $cust_main_exemption (
1322     qsearch( 'cust_main_exemption', { 'custnum' => $self->custnum } )
1323   ) {
1324     my $error = $cust_main_exemption->delete;
1325     if ( $error ) {
1326       $dbh->rollback if $oldAutoCommit;
1327       return $error;
1328     }
1329   }
1330
1331   my $error = $self->SUPER::delete;
1332   if ( $error ) {
1333     $dbh->rollback if $oldAutoCommit;
1334     return $error;
1335   }
1336
1337   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1338   '';
1339
1340 }
1341
1342 =item replace [ OLD_RECORD ] [ INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
1343
1344
1345 Replaces the OLD_RECORD with this one in the database.  If there is an error,
1346 returns the error, otherwise returns false.
1347
1348 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
1349 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
1350 expected and rollback the entire transaction; it is not necessary to call
1351 check_invoicing_list first.  Here's an example:
1352
1353   $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
1354
1355 Currently available options are: I<tax_exemption>.
1356
1357 The I<tax_exemption> option can be set to an arrayref of tax names.
1358 FS::cust_main_exemption records will be deleted and inserted as appropriate.
1359
1360 =cut
1361
1362 sub replace {
1363   my $self = shift;
1364
1365   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
1366               ? shift
1367               : $self->replace_old;
1368
1369   my @param = @_;
1370
1371   warn "$me replace called\n"
1372     if $DEBUG;
1373
1374   my $curuser = $FS::CurrentUser::CurrentUser;
1375   if (    $self->payby eq 'COMP'
1376        && $self->payby ne $old->payby
1377        && ! $curuser->access_right('Complimentary customer')
1378      )
1379   {
1380     return "You are not permitted to create complimentary accounts.";
1381   }
1382
1383   local($ignore_expired_card) = 1
1384     if $old->payby  =~ /^(CARD|DCRD)$/
1385     && $self->payby =~ /^(CARD|DCRD)$/
1386     && ( $old->payinfo eq $self->payinfo || $old->paymask eq $self->paymask );
1387
1388   local $SIG{HUP} = 'IGNORE';
1389   local $SIG{INT} = 'IGNORE';
1390   local $SIG{QUIT} = 'IGNORE';
1391   local $SIG{TERM} = 'IGNORE';
1392   local $SIG{TSTP} = 'IGNORE';
1393   local $SIG{PIPE} = 'IGNORE';
1394
1395   my $oldAutoCommit = $FS::UID::AutoCommit;
1396   local $FS::UID::AutoCommit = 0;
1397   my $dbh = dbh;
1398
1399   my $error = $self->SUPER::replace($old);
1400
1401   if ( $error ) {
1402     $dbh->rollback if $oldAutoCommit;
1403     return $error;
1404   }
1405
1406   if ( @param && ref($param[0]) eq 'ARRAY' ) { # INVOICING_LIST_ARYREF
1407     my $invoicing_list = shift @param;
1408     $error = $self->check_invoicing_list( $invoicing_list );
1409     if ( $error ) {
1410       $dbh->rollback if $oldAutoCommit;
1411       return $error;
1412     }
1413     $self->invoicing_list( $invoicing_list );
1414   }
1415
1416   my %options = @param;
1417
1418   my $tax_exemption = delete $options{'tax_exemption'};
1419   if ( $tax_exemption ) {
1420
1421     my %cust_main_exemption =
1422       map { $_->taxname => $_ }
1423           qsearch('cust_main_exemption', { 'custnum' => $old->custnum } );
1424
1425     foreach my $taxname ( @$tax_exemption ) {
1426
1427       next if delete $cust_main_exemption{$taxname};
1428
1429       my $cust_main_exemption = new FS::cust_main_exemption {
1430         'custnum' => $self->custnum,
1431         'taxname' => $taxname,
1432       };
1433       my $error = $cust_main_exemption->insert;
1434       if ( $error ) {
1435         $dbh->rollback if $oldAutoCommit;
1436         return "inserting cust_main_exemption (transaction rolled back): $error";
1437       }
1438     }
1439
1440     foreach my $cust_main_exemption ( values %cust_main_exemption ) {
1441       my $error = $cust_main_exemption->delete;
1442       if ( $error ) {
1443         $dbh->rollback if $oldAutoCommit;
1444         return "deleting cust_main_exemption (transaction rolled back): $error";
1445       }
1446     }
1447
1448   }
1449
1450   if ( $self->payby =~ /^(CARD|CHEK|LECB)$/ &&
1451        grep { $self->get($_) ne $old->get($_) } qw(payinfo paydate payname) ) {
1452     # card/check/lec info has changed, want to retry realtime_ invoice events
1453     my $error = $self->retry_realtime;
1454     if ( $error ) {
1455       $dbh->rollback if $oldAutoCommit;
1456       return $error;
1457     }
1458   }
1459
1460   unless ( $import || $skip_fuzzyfiles ) {
1461     $error = $self->queue_fuzzyfiles_update;
1462     if ( $error ) {
1463       $dbh->rollback if $oldAutoCommit;
1464       return "updating fuzzy search cache: $error";
1465     }
1466   }
1467
1468   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1469   '';
1470
1471 }
1472
1473 =item queue_fuzzyfiles_update
1474
1475 Used by insert & replace to update the fuzzy search cache
1476
1477 =cut
1478
1479 sub queue_fuzzyfiles_update {
1480   my $self = shift;
1481
1482   local $SIG{HUP} = 'IGNORE';
1483   local $SIG{INT} = 'IGNORE';
1484   local $SIG{QUIT} = 'IGNORE';
1485   local $SIG{TERM} = 'IGNORE';
1486   local $SIG{TSTP} = 'IGNORE';
1487   local $SIG{PIPE} = 'IGNORE';
1488
1489   my $oldAutoCommit = $FS::UID::AutoCommit;
1490   local $FS::UID::AutoCommit = 0;
1491   my $dbh = dbh;
1492
1493   my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1494   my $error = $queue->insert( map $self->getfield($_),
1495                                   qw(first last company)
1496                             );
1497   if ( $error ) {
1498     $dbh->rollback if $oldAutoCommit;
1499     return "queueing job (transaction rolled back): $error";
1500   }
1501
1502   if ( $self->ship_last ) {
1503     $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1504     $error = $queue->insert( map $self->getfield("ship_$_"),
1505                                  qw(first last company)
1506                            );
1507     if ( $error ) {
1508       $dbh->rollback if $oldAutoCommit;
1509       return "queueing job (transaction rolled back): $error";
1510     }
1511   }
1512
1513   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1514   '';
1515
1516 }
1517
1518 =item check
1519
1520 Checks all fields to make sure this is a valid customer record.  If there is
1521 an error, returns the error, otherwise returns false.  Called by the insert
1522 and replace methods.
1523
1524 =cut
1525
1526 sub check {
1527   my $self = shift;
1528
1529   warn "$me check BEFORE: \n". $self->_dump
1530     if $DEBUG > 2;
1531
1532   my $error =
1533     $self->ut_numbern('custnum')
1534     || $self->ut_number('agentnum')
1535     || $self->ut_textn('agent_custid')
1536     || $self->ut_number('refnum')
1537     || $self->ut_textn('custbatch')
1538     || $self->ut_name('last')
1539     || $self->ut_name('first')
1540     || $self->ut_snumbern('birthdate')
1541     || $self->ut_snumbern('signupdate')
1542     || $self->ut_textn('company')
1543     || $self->ut_text('address1')
1544     || $self->ut_textn('address2')
1545     || $self->ut_text('city')
1546     || $self->ut_textn('county')
1547     || $self->ut_textn('state')
1548     || $self->ut_country('country')
1549     || $self->ut_anything('comments')
1550     || $self->ut_numbern('referral_custnum')
1551     || $self->ut_textn('stateid')
1552     || $self->ut_textn('stateid_state')
1553     || $self->ut_textn('invoice_terms')
1554     || $self->ut_alphan('geocode')
1555   ;
1556
1557   #barf.  need message catalogs.  i18n.  etc.
1558   $error .= "Please select an advertising source."
1559     if $error =~ /^Illegal or empty \(numeric\) refnum: /;
1560   return $error if $error;
1561
1562   return "Unknown agent"
1563     unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1564
1565   return "Unknown refnum"
1566     unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } );
1567
1568   return "Unknown referring custnum: ". $self->referral_custnum
1569     unless ! $self->referral_custnum
1570            || qsearchs( 'cust_main', { 'custnum' => $self->referral_custnum } );
1571
1572   if ( $self->ss eq '' ) {
1573     $self->ss('');
1574   } else {
1575     my $ss = $self->ss;
1576     $ss =~ s/\D//g;
1577     $ss =~ /^(\d{3})(\d{2})(\d{4})$/
1578       or return "Illegal social security number: ". $self->ss;
1579     $self->ss("$1-$2-$3");
1580   }
1581
1582
1583 # bad idea to disable, causes billing to fail because of no tax rates later
1584 #  unless ( $import ) {
1585     unless ( qsearch('cust_main_county', {
1586       'country' => $self->country,
1587       'state'   => '',
1588      } ) ) {
1589       return "Unknown state/county/country: ".
1590         $self->state. "/". $self->county. "/". $self->country
1591         unless qsearch('cust_main_county',{
1592           'state'   => $self->state,
1593           'county'  => $self->county,
1594           'country' => $self->country,
1595         } );
1596     }
1597 #  }
1598
1599   $error =
1600     $self->ut_phonen('daytime', $self->country)
1601     || $self->ut_phonen('night', $self->country)
1602     || $self->ut_phonen('fax', $self->country)
1603     || $self->ut_zip('zip', $self->country)
1604   ;
1605   return $error if $error;
1606
1607   if ( $conf->exists('cust_main-require_phone')
1608        && ! length($self->daytime) && ! length($self->night)
1609      ) {
1610
1611     my $daytime_label = FS::Msgcat::_gettext('daytime') =~ /^(daytime)?$/
1612                           ? 'Day Phone'
1613                           : FS::Msgcat::_gettext('daytime');
1614     my $night_label = FS::Msgcat::_gettext('night') =~ /^(night)?$/
1615                         ? 'Night Phone'
1616                         : FS::Msgcat::_gettext('night');
1617
1618     return "$daytime_label or $night_label is required"
1619
1620   }
1621
1622   if ( $self->has_ship_address
1623        && scalar ( grep { $self->getfield($_) ne $self->getfield("ship_$_") }
1624                         $self->addr_fields )
1625      )
1626   {
1627     my $error =
1628       $self->ut_name('ship_last')
1629       || $self->ut_name('ship_first')
1630       || $self->ut_textn('ship_company')
1631       || $self->ut_text('ship_address1')
1632       || $self->ut_textn('ship_address2')
1633       || $self->ut_text('ship_city')
1634       || $self->ut_textn('ship_county')
1635       || $self->ut_textn('ship_state')
1636       || $self->ut_country('ship_country')
1637     ;
1638     return $error if $error;
1639
1640     #false laziness with above
1641     unless ( qsearchs('cust_main_county', {
1642       'country' => $self->ship_country,
1643       'state'   => '',
1644      } ) ) {
1645       return "Unknown ship_state/ship_county/ship_country: ".
1646         $self->ship_state. "/". $self->ship_county. "/". $self->ship_country
1647         unless qsearch('cust_main_county',{
1648           'state'   => $self->ship_state,
1649           'county'  => $self->ship_county,
1650           'country' => $self->ship_country,
1651         } );
1652     }
1653     #eofalse
1654
1655     $error =
1656       $self->ut_phonen('ship_daytime', $self->ship_country)
1657       || $self->ut_phonen('ship_night', $self->ship_country)
1658       || $self->ut_phonen('ship_fax', $self->ship_country)
1659       || $self->ut_zip('ship_zip', $self->ship_country)
1660     ;
1661     return $error if $error;
1662
1663     return "Unit # is required."
1664       if $self->ship_address2 =~ /^\s*$/
1665       && $conf->exists('cust_main-require_address2');
1666
1667   } else { # ship_ info eq billing info, so don't store dup info in database
1668
1669     $self->setfield("ship_$_", '')
1670       foreach $self->addr_fields;
1671
1672     return "Unit # is required."
1673       if $self->address2 =~ /^\s*$/
1674       && $conf->exists('cust_main-require_address2');
1675
1676   }
1677
1678   #$self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY|CASH|WEST|MCRD)$/
1679   #  or return "Illegal payby: ". $self->payby;
1680   #$self->payby($1);
1681   FS::payby->can_payby($self->table, $self->payby)
1682     or return "Illegal payby: ". $self->payby;
1683
1684   $error =    $self->ut_numbern('paystart_month')
1685            || $self->ut_numbern('paystart_year')
1686            || $self->ut_numbern('payissue')
1687            || $self->ut_textn('paytype')
1688   ;
1689   return $error if $error;
1690
1691   if ( $self->payip eq '' ) {
1692     $self->payip('');
1693   } else {
1694     $error = $self->ut_ip('payip');
1695     return $error if $error;
1696   }
1697
1698   # If it is encrypted and the private key is not availaible then we can't
1699   # check the credit card.
1700
1701   my $check_payinfo = 1;
1702
1703   if ($self->is_encrypted($self->payinfo)) {
1704     $check_payinfo = 0;
1705   }
1706
1707   if ( $check_payinfo && $self->payby =~ /^(CARD|DCRD)$/ ) {
1708
1709     my $payinfo = $self->payinfo;
1710     $payinfo =~ s/\D//g;
1711     $payinfo =~ /^(\d{13,16})$/
1712       or return gettext('invalid_card'); # . ": ". $self->payinfo;
1713     $payinfo = $1;
1714     $self->payinfo($payinfo);
1715     validate($payinfo)
1716       or return gettext('invalid_card'); # . ": ". $self->payinfo;
1717
1718     return gettext('unknown_card_type')
1719       if cardtype($self->payinfo) eq "Unknown";
1720
1721     my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1722     if ( $ban ) {
1723       return 'Banned credit card: banned on '.
1724              time2str('%a %h %o at %r', $ban->_date).
1725              ' by '. $ban->otaker.
1726              ' (ban# '. $ban->bannum. ')';
1727     }
1728
1729     if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) {
1730       if ( cardtype($self->payinfo) eq 'American Express card' ) {
1731         $self->paycvv =~ /^(\d{4})$/
1732           or return "CVV2 (CID) for American Express cards is four digits.";
1733         $self->paycvv($1);
1734       } else {
1735         $self->paycvv =~ /^(\d{3})$/
1736           or return "CVV2 (CVC2/CID) is three digits.";
1737         $self->paycvv($1);
1738       }
1739     } else {
1740       $self->paycvv('');
1741     }
1742
1743     my $cardtype = cardtype($payinfo);
1744     if ( $cardtype =~ /^(Switch|Solo)$/i ) {
1745
1746       return "Start date or issue number is required for $cardtype cards"
1747         unless $self->paystart_month && $self->paystart_year or $self->payissue;
1748
1749       return "Start month must be between 1 and 12"
1750         if $self->paystart_month
1751            and $self->paystart_month < 1 || $self->paystart_month > 12;
1752
1753       return "Start year must be 1990 or later"
1754         if $self->paystart_year
1755            and $self->paystart_year < 1990;
1756
1757       return "Issue number must be beween 1 and 99"
1758         if $self->payissue
1759           and $self->payissue < 1 || $self->payissue > 99;
1760
1761     } else {
1762       $self->paystart_month('');
1763       $self->paystart_year('');
1764       $self->payissue('');
1765     }
1766
1767   } elsif ( $check_payinfo && $self->payby =~ /^(CHEK|DCHK)$/ ) {
1768
1769     my $payinfo = $self->payinfo;
1770     $payinfo =~ s/[^\d\@]//g;
1771     if ( $conf->exists('echeck-nonus') ) {
1772       $payinfo =~ /^(\d+)\@(\d+)$/ or return 'invalid echeck account@aba';
1773       $payinfo = "$1\@$2";
1774     } else {
1775       $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba';
1776       $payinfo = "$1\@$2";
1777     }
1778     $self->payinfo($payinfo);
1779     $self->paycvv('');
1780
1781     my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1782     if ( $ban ) {
1783       return 'Banned ACH account: banned on '.
1784              time2str('%a %h %o at %r', $ban->_date).
1785              ' by '. $ban->otaker.
1786              ' (ban# '. $ban->bannum. ')';
1787     }
1788
1789   } elsif ( $self->payby eq 'LECB' ) {
1790
1791     my $payinfo = $self->payinfo;
1792     $payinfo =~ s/\D//g;
1793     $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number';
1794     $payinfo = $1;
1795     $self->payinfo($payinfo);
1796     $self->paycvv('');
1797
1798   } elsif ( $self->payby eq 'BILL' ) {
1799
1800     $error = $self->ut_textn('payinfo');
1801     return "Illegal P.O. number: ". $self->payinfo if $error;
1802     $self->paycvv('');
1803
1804   } elsif ( $self->payby eq 'COMP' ) {
1805
1806     my $curuser = $FS::CurrentUser::CurrentUser;
1807     if (    ! $self->custnum
1808          && ! $curuser->access_right('Complimentary customer')
1809        )
1810     {
1811       return "You are not permitted to create complimentary accounts."
1812     }
1813
1814     $error = $self->ut_textn('payinfo');
1815     return "Illegal comp account issuer: ". $self->payinfo if $error;
1816     $self->paycvv('');
1817
1818   } elsif ( $self->payby eq 'PREPAY' ) {
1819
1820     my $payinfo = $self->payinfo;
1821     $payinfo =~ s/\W//g; #anything else would just confuse things
1822     $self->payinfo($payinfo);
1823     $error = $self->ut_alpha('payinfo');
1824     return "Illegal prepayment identifier: ". $self->payinfo if $error;
1825     return "Unknown prepayment identifier"
1826       unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } );
1827     $self->paycvv('');
1828
1829   }
1830
1831   if ( $self->paydate eq '' || $self->paydate eq '-' ) {
1832     return "Expiration date required"
1833       unless $self->payby =~ /^(BILL|PREPAY|CHEK|DCHK|LECB|CASH|WEST|MCRD)$/;
1834     $self->paydate('');
1835   } else {
1836     my( $m, $y );
1837     if ( $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) {
1838       ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" );
1839     } elsif ( $self->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) {
1840       ( $m, $y ) = ( $3, "20$2" );
1841     } else {
1842       return "Illegal expiration date: ". $self->paydate;
1843     }
1844     $self->paydate("$y-$m-01");
1845     my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
1846     return gettext('expired_card')
1847       if !$import
1848       && !$ignore_expired_card
1849       && ( $y<$nowy || ( $y==$nowy && $1<$nowm ) );
1850   }
1851
1852   if ( $self->payname eq '' && $self->payby !~ /^(CHEK|DCHK)$/ &&
1853        ( ! $conf->exists('require_cardname')
1854          || $self->payby !~ /^(CARD|DCRD)$/  )
1855   ) {
1856     $self->payname( $self->first. " ". $self->getfield('last') );
1857   } else {
1858     $self->payname =~ /^([\w \,\.\-\'\&]+)$/
1859       or return gettext('illegal_name'). " payname: ". $self->payname;
1860     $self->payname($1);
1861   }
1862
1863   foreach my $flag (qw( tax spool_cdr squelch_cdr archived )) {
1864     $self->$flag() =~ /^(Y?)$/ or return "Illegal $flag: ". $self->$flag();
1865     $self->$flag($1);
1866   }
1867
1868   $self->otaker(getotaker) unless $self->otaker;
1869
1870   warn "$me check AFTER: \n". $self->_dump
1871     if $DEBUG > 2;
1872
1873   $self->SUPER::check;
1874 }
1875
1876 =item addr_fields
1877
1878 Returns a list of fields which have ship_ duplicates.
1879
1880 =cut
1881
1882 sub addr_fields {
1883   qw( last first company
1884       address1 address2 city county state zip country
1885       daytime night fax
1886     );
1887 }
1888
1889 =item has_ship_address
1890
1891 Returns true if this customer record has a separate shipping address.
1892
1893 =cut
1894
1895 sub has_ship_address {
1896   my $self = shift;
1897   scalar( grep { $self->getfield("ship_$_") ne '' } $self->addr_fields );
1898 }
1899
1900 =item all_pkgs [ EXTRA_QSEARCH_PARAMS_HASHREF ]
1901
1902 Returns all packages (see L<FS::cust_pkg>) for this customer.
1903
1904 =cut
1905
1906 sub all_pkgs {
1907   my $self = shift;
1908   my $extra_qsearch = ref($_[0]) ? shift : {};
1909
1910   return $self->num_pkgs unless wantarray || keys(%$extra_qsearch);
1911
1912   my @cust_pkg = ();
1913   if ( $self->{'_pkgnum'} ) {
1914     @cust_pkg = values %{ $self->{'_pkgnum'}->cache };
1915   } else {
1916     @cust_pkg = $self->_cust_pkg($extra_qsearch);
1917   }
1918
1919   sort sort_packages @cust_pkg;
1920 }
1921
1922 =item cust_pkg
1923
1924 Synonym for B<all_pkgs>.
1925
1926 =cut
1927
1928 sub cust_pkg {
1929   shift->all_pkgs(@_);
1930 }
1931
1932 =item cust_location
1933
1934 Returns all locations (see L<FS::cust_location>) for this customer.
1935
1936 =cut
1937
1938 sub cust_location {
1939   my $self = shift;
1940   qsearch('cust_location', { 'custnum' => $self->custnum } );
1941 }
1942
1943 =item ncancelled_pkgs [ EXTRA_QSEARCH_PARAMS_HASHREF ]
1944
1945 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
1946
1947 =cut
1948
1949 sub ncancelled_pkgs {
1950   my $self = shift;
1951   my $extra_qsearch = ref($_[0]) ? shift : {};
1952
1953   return $self->num_ncancelled_pkgs unless wantarray;
1954
1955   my @cust_pkg = ();
1956   if ( $self->{'_pkgnum'} ) {
1957
1958     warn "$me ncancelled_pkgs: returning cached objects"
1959       if $DEBUG > 1;
1960
1961     @cust_pkg = grep { ! $_->getfield('cancel') }
1962                 values %{ $self->{'_pkgnum'}->cache };
1963
1964   } else {
1965
1966     warn "$me ncancelled_pkgs: searching for packages with custnum ".
1967          $self->custnum. "\n"
1968       if $DEBUG > 1;
1969
1970     $extra_qsearch->{'extra_sql'} .= ' AND ( cancel IS NULL OR cancel = 0 ) ';
1971
1972     @cust_pkg = $self->_cust_pkg($extra_qsearch);
1973
1974   }
1975
1976   sort sort_packages @cust_pkg;
1977
1978 }
1979
1980 sub _cust_pkg {
1981   my $self = shift;
1982   my $extra_qsearch = ref($_[0]) ? shift : {};
1983
1984   $extra_qsearch->{'select'} ||= '*';
1985   $extra_qsearch->{'select'} .=
1986    ',( SELECT COUNT(*) FROM cust_svc WHERE cust_pkg.pkgnum = cust_svc.pkgnum )
1987      AS _num_cust_svc';
1988
1989   map {
1990         $_->{'_num_cust_svc'} = $_->get('_num_cust_svc');
1991         $_;
1992       }
1993   qsearch({
1994     %$extra_qsearch,
1995     'table'   => 'cust_pkg',
1996     'hashref' => { 'custnum' => $self->custnum },
1997   });
1998
1999 }
2000
2001 # This should be generalized to use config options to determine order.
2002 sub sort_packages {
2003
2004   if ( $a->get('cancel') xor $b->get('cancel') ) {
2005     return -1 if $b->get('cancel');
2006     return  1 if $a->get('cancel');
2007     #shouldn't get here...
2008     return 0;
2009   } else {
2010     my $a_num_cust_svc = $a->num_cust_svc;
2011     my $b_num_cust_svc = $b->num_cust_svc;
2012     return 0  if !$a_num_cust_svc && !$b_num_cust_svc;
2013     return -1 if  $a_num_cust_svc && !$b_num_cust_svc;
2014     return 1  if !$a_num_cust_svc &&  $b_num_cust_svc;
2015     my @a_cust_svc = $a->cust_svc;
2016     my @b_cust_svc = $b->cust_svc;
2017     $a_cust_svc[0]->svc_x->label cmp $b_cust_svc[0]->svc_x->label;
2018   }
2019
2020 }
2021
2022 =item suspended_pkgs
2023
2024 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
2025
2026 =cut
2027
2028 sub suspended_pkgs {
2029   my $self = shift;
2030   grep { $_->susp } $self->ncancelled_pkgs;
2031 }
2032
2033 =item unflagged_suspended_pkgs
2034
2035 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
2036 customer (thouse packages without the `manual_flag' set).
2037
2038 =cut
2039
2040 sub unflagged_suspended_pkgs {
2041   my $self = shift;
2042   return $self->suspended_pkgs
2043     unless dbdef->table('cust_pkg')->column('manual_flag');
2044   grep { ! $_->manual_flag } $self->suspended_pkgs;
2045 }
2046
2047 =item unsuspended_pkgs
2048
2049 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
2050 this customer.
2051
2052 =cut
2053
2054 sub unsuspended_pkgs {
2055   my $self = shift;
2056   grep { ! $_->susp } $self->ncancelled_pkgs;
2057 }
2058
2059 =item num_cancelled_pkgs
2060
2061 Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
2062 customer.
2063
2064 =cut
2065
2066 sub num_cancelled_pkgs {
2067   shift->num_pkgs("cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0");
2068 }
2069
2070 sub num_ncancelled_pkgs {
2071   shift->num_pkgs("( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )");
2072 }
2073
2074 sub num_pkgs {
2075   my( $self ) = shift;
2076   my $sql = scalar(@_) ? shift : '';
2077   $sql = "AND $sql" if $sql && $sql !~ /^\s*$/ && $sql !~ /^\s*AND/i;
2078   my $sth = dbh->prepare(
2079     "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? $sql"
2080   ) or die dbh->errstr;
2081   $sth->execute($self->custnum) or die $sth->errstr;
2082   $sth->fetchrow_arrayref->[0];
2083 }
2084
2085 =item unsuspend
2086
2087 Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
2088 and L<FS::cust_pkg>) for this customer.  Always returns a list: an empty list
2089 on success or a list of errors.
2090
2091 =cut
2092
2093 sub unsuspend {
2094   my $self = shift;
2095   grep { $_->unsuspend } $self->suspended_pkgs;
2096 }
2097
2098 =item suspend
2099
2100 Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
2101
2102 Returns a list: an empty list on success or a list of errors.
2103
2104 =cut
2105
2106 sub suspend {
2107   my $self = shift;
2108   grep { $_->suspend(@_) } $self->unsuspended_pkgs;
2109 }
2110
2111 =item suspend_if_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
2112
2113 Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
2114 PKGPARTs (see L<FS::part_pkg>).  Preferred usage is to pass a hashref instead
2115 of a list of pkgparts; the hashref has the following keys:
2116
2117 =over 4
2118
2119 =item pkgparts - listref of pkgparts
2120
2121 =item (other options are passed to the suspend method)
2122
2123 =back
2124
2125
2126 Returns a list: an empty list on success or a list of errors.
2127
2128 =cut
2129
2130 sub suspend_if_pkgpart {
2131   my $self = shift;
2132   my (@pkgparts, %opt);
2133   if (ref($_[0]) eq 'HASH'){
2134     @pkgparts = @{$_[0]{pkgparts}};
2135     %opt      = %{$_[0]};
2136   }else{
2137     @pkgparts = @_;
2138   }
2139   grep { $_->suspend(%opt) }
2140     grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
2141       $self->unsuspended_pkgs;
2142 }
2143
2144 =item suspend_unless_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
2145
2146 Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
2147 given PKGPARTs (see L<FS::part_pkg>).  Preferred usage is to pass a hashref
2148 instead of a list of pkgparts; the hashref has the following keys:
2149
2150 =over 4
2151
2152 =item pkgparts - listref of pkgparts
2153
2154 =item (other options are passed to the suspend method)
2155
2156 =back
2157
2158 Returns a list: an empty list on success or a list of errors.
2159
2160 =cut
2161
2162 sub suspend_unless_pkgpart {
2163   my $self = shift;
2164   my (@pkgparts, %opt);
2165   if (ref($_[0]) eq 'HASH'){
2166     @pkgparts = @{$_[0]{pkgparts}};
2167     %opt      = %{$_[0]};
2168   }else{
2169     @pkgparts = @_;
2170   }
2171   grep { $_->suspend(%opt) }
2172     grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
2173       $self->unsuspended_pkgs;
2174 }
2175
2176 =item cancel [ OPTION => VALUE ... ]
2177
2178 Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
2179
2180 Available options are:
2181
2182 =over 4
2183
2184 =item quiet - can be set true to supress email cancellation notices.
2185
2186 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
2187
2188 =item ban - can be set true to ban this customer's credit card or ACH information, if present.
2189
2190 =back
2191
2192 Always returns a list: an empty list on success or a list of errors.
2193
2194 =cut
2195
2196 sub cancel {
2197   my( $self, %opt ) = @_;
2198
2199   warn "$me cancel called on customer ". $self->custnum. " with options ".
2200        join(', ', map { "$_: $opt{$_}" } keys %opt ). "\n"
2201     if $DEBUG;
2202
2203   return ( 'access denied' )
2204     unless $FS::CurrentUser::CurrentUser->access_right('Cancel customer');
2205
2206   if ( $opt{'ban'} && $self->payby =~ /^(CARD|DCRD|CHEK|DCHK)$/ ) {
2207
2208     #should try decryption (we might have the private key)
2209     # and if not maybe queue a job for the server that does?
2210     return ( "Can't (yet) ban encrypted credit cards" )
2211       if $self->is_encrypted($self->payinfo);
2212
2213     my $ban = new FS::banned_pay $self->_banned_pay_hashref;
2214     my $error = $ban->insert;
2215     return ( $error ) if $error;
2216
2217   }
2218
2219   my @pkgs = $self->ncancelled_pkgs;
2220
2221   warn "$me cancelling ". scalar($self->ncancelled_pkgs). "/".
2222        scalar(@pkgs). " packages for customer ". $self->custnum. "\n"
2223     if $DEBUG;
2224
2225   grep { $_ } map { $_->cancel(%opt) } $self->ncancelled_pkgs;
2226 }
2227
2228 sub _banned_pay_hashref {
2229   my $self = shift;
2230
2231   my %payby2ban = (
2232     'CARD' => 'CARD',
2233     'DCRD' => 'CARD',
2234     'CHEK' => 'CHEK',
2235     'DCHK' => 'CHEK'
2236   );
2237
2238   {
2239     'payby'   => $payby2ban{$self->payby},
2240     'payinfo' => md5_base64($self->payinfo),
2241     #don't ever *search* on reason! #'reason'  =>
2242   };
2243 }
2244
2245 =item notes
2246
2247 Returns all notes (see L<FS::cust_main_note>) for this customer.
2248
2249 =cut
2250
2251 sub notes {
2252   my $self = shift;
2253   #order by?
2254   qsearch( 'cust_main_note',
2255            { 'custnum' => $self->custnum },
2256            '',
2257            'ORDER BY _DATE DESC'
2258          );
2259 }
2260
2261 =item agent
2262
2263 Returns the agent (see L<FS::agent>) for this customer.
2264
2265 =cut
2266
2267 sub agent {
2268   my $self = shift;
2269   qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
2270 }
2271
2272 =item bill_and_collect
2273
2274 Cancels and suspends any packages due, generates bills, applies payments and
2275 cred
2276
2277 Warns on errors (Does not currently: If there is an error, returns the error, otherwise returns false.)
2278
2279 Options are passed as name-value pairs.  Currently available options are:
2280
2281 =over 4
2282
2283 =item time
2284
2285 Bills the customer as if it were that time.  Specified as a UNIX timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion functions.  For example:
2286
2287  use Date::Parse;
2288  ...
2289  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
2290
2291 =item invoice_time
2292
2293 Used in conjunction with the I<time> option, this option specifies the date of for the generated invoices.  Other calculations, such as whether or not to generate the invoice in the first place, are not affected.
2294
2295 =item check_freq
2296
2297 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
2298
2299 =item resetup
2300
2301 If set true, re-charges setup fees.
2302
2303 =item debug
2304
2305 Debugging level.  Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), 3 (more information), or 4 (include full search queries)
2306
2307 =back
2308
2309 =cut
2310
2311 sub bill_and_collect {
2312   my( $self, %options ) = @_;
2313
2314   #$options{actual_time} not $options{time} because freeside-daily -d is for
2315   #pre-printing invoices
2316   $self->cancel_expired_pkgs(    $options{actual_time} );
2317   $self->suspend_adjourned_pkgs( $options{actual_time} );
2318
2319   my $error = $self->bill( %options );
2320   warn "Error billing, custnum ". $self->custnum. ": $error" if $error;
2321
2322   $self->apply_payments_and_credits;
2323
2324   unless ( $conf->exists('cancelled_cust-noevents')
2325            && ! $self->num_ncancelled_pkgs
2326   ) {
2327
2328     $error = $self->collect( %options );
2329     warn "Error collecting, custnum". $self->custnum. ": $error" if $error;
2330
2331   }
2332
2333 }
2334
2335 sub cancel_expired_pkgs {
2336   my ( $self, $time ) = @_;
2337
2338   my @cancel_pkgs = $self->ncancelled_pkgs( {
2339     'extra_sql' => " AND expire IS NOT NULL AND expire > 0 AND expire <= $time "
2340   } );
2341
2342   foreach my $cust_pkg ( @cancel_pkgs ) {
2343     my $cpr = $cust_pkg->last_cust_pkg_reason('expire');
2344     my $error = $cust_pkg->cancel($cpr ? ( 'reason'        => $cpr->reasonnum,
2345                                            'reason_otaker' => $cpr->otaker
2346                                          )
2347                                        : ()
2348                                  );
2349     warn "Error cancelling expired pkg ". $cust_pkg->pkgnum.
2350          " for custnum ". $self->custnum. ": $error"
2351       if $error;
2352   }
2353
2354 }
2355
2356 sub suspend_adjourned_pkgs {
2357   my ( $self, $time ) = @_;
2358
2359   my @susp_pkgs = $self->ncancelled_pkgs( {
2360     'extra_sql' =>
2361       " AND ( susp IS NULL OR susp = 0 )
2362         AND (    ( bill    IS NOT NULL AND bill    != 0 AND bill    <  $time )
2363               OR ( adjourn IS NOT NULL AND adjourn != 0 AND adjourn <= $time )
2364             )
2365       ",
2366   } );
2367
2368   #only because there's no SQL test for is_prepaid :/
2369   @susp_pkgs =
2370     grep {     (    $_->part_pkg->is_prepaid
2371                  && $_->bill
2372                  && $_->bill < $time
2373                )
2374             || (    $_->adjourn
2375                  && $_->adjourn <= $time
2376                )
2377
2378          }
2379          @susp_pkgs;
2380
2381   foreach my $cust_pkg ( @susp_pkgs ) {
2382     my $cpr = $cust_pkg->last_cust_pkg_reason('adjourn')
2383       if ($cust_pkg->adjourn && $cust_pkg->adjourn < $^T);
2384     my $error = $cust_pkg->suspend($cpr ? ( 'reason' => $cpr->reasonnum,
2385                                             'reason_otaker' => $cpr->otaker
2386                                           )
2387                                         : ()
2388                                   );
2389
2390     warn "Error suspending package ". $cust_pkg->pkgnum.
2391          " for custnum ". $self->custnum. ": $error"
2392       if $error;
2393   }
2394
2395 }
2396
2397 =item bill OPTIONS
2398
2399 Generates invoices (see L<FS::cust_bill>) for this customer.  Usually used in
2400 conjunction with the collect method by calling B<bill_and_collect>.
2401
2402 If there is an error, returns the error, otherwise returns false.
2403
2404 Options are passed as name-value pairs.  Currently available options are:
2405
2406 =over 4
2407
2408 =item resetup
2409
2410 If set true, re-charges setup fees.
2411
2412 =item time
2413
2414 Bills the customer as if it were that time.  Specified as a UNIX timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion functions.  For example:
2415
2416  use Date::Parse;
2417  ...
2418  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
2419
2420 =item pkg_list
2421
2422 An array ref of specific packages (objects) to attempt billing, instead trying all of them.
2423
2424  $cust_main->bill( pkg_list => [$pkg1, $pkg2] );
2425
2426 =item invoice_time
2427
2428 Used in conjunction with the I<time> option, this option specifies the date of for the generated invoices.  Other calculations, such as whether or not to generate the invoice in the first place, are not affected.
2429
2430 =back
2431
2432 =cut
2433
2434 sub bill {
2435   my( $self, %options ) = @_;
2436   return '' if $self->payby eq 'COMP';
2437   warn "$me bill customer ". $self->custnum. "\n"
2438     if $DEBUG;
2439
2440   my $time = $options{'time'} || time;
2441   my $invoice_time = $options{'invoice_time'} || $time;
2442
2443   #put below somehow?
2444   local $SIG{HUP} = 'IGNORE';
2445   local $SIG{INT} = 'IGNORE';
2446   local $SIG{QUIT} = 'IGNORE';
2447   local $SIG{TERM} = 'IGNORE';
2448   local $SIG{TSTP} = 'IGNORE';
2449   local $SIG{PIPE} = 'IGNORE';
2450
2451   my $oldAutoCommit = $FS::UID::AutoCommit;
2452   local $FS::UID::AutoCommit = 0;
2453   my $dbh = dbh;
2454
2455   $self->select_for_update; #mutex
2456
2457   my @cust_bill_pkg = ();
2458
2459   ###
2460   # find the packages which are due for billing, find out how much they are
2461   # & generate invoice database.
2462   ###
2463
2464   my( $total_setup, $total_recur, $postal_charge ) = ( 0, 0, 0 );
2465   my %taxlisthash;
2466   my @precommit_hooks = ();
2467
2468   foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
2469
2470     warn "  bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG > 1;
2471
2472     #? to avoid use of uninitialized value errors... ?
2473     $cust_pkg->setfield('bill', '')
2474       unless defined($cust_pkg->bill);
2475
2476     #my $part_pkg = $cust_pkg->part_pkg;
2477
2478     my $real_pkgpart = $cust_pkg->pkgpart;
2479     my %hash = $cust_pkg->hash;
2480
2481     foreach my $part_pkg ( $cust_pkg->part_pkg->self_and_bill_linked ) {
2482
2483       $cust_pkg->set($_, $hash{$_}) foreach qw ( setup last_bill bill );
2484
2485       my $error =
2486         $self->_make_lines( 'part_pkg'            => $part_pkg,
2487                             'cust_pkg'            => $cust_pkg,
2488                             'precommit_hooks'     => \@precommit_hooks,
2489                             'line_items'          => \@cust_bill_pkg,
2490                             'setup'               => \$total_setup,
2491                             'recur'               => \$total_recur,
2492                             'tax_matrix'          => \%taxlisthash,
2493                             'time'                => $time,
2494                             'options'             => \%options,
2495                           );
2496       if ($error) {
2497         $dbh->rollback if $oldAutoCommit;
2498         return $error;
2499       }
2500
2501     } #foreach my $part_pkg
2502
2503   } #foreach my $cust_pkg
2504
2505   unless ( @cust_bill_pkg ) { #don't create an invoice w/o line items
2506     #but do commit any package date cycling that happened
2507     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2508     return '';
2509   }
2510
2511   if ( scalar( grep { $_->recur && $_->recur > 0 } @cust_bill_pkg) ||
2512          !$conf->exists('postal_invoice-recurring_only')
2513      )
2514   {
2515
2516     my $postal_pkg = $self->charge_postal_fee();
2517     if ( $postal_pkg && !ref( $postal_pkg ) ) {
2518
2519       $dbh->rollback if $oldAutoCommit;
2520       return "can't charge postal invoice fee for customer ".
2521         $self->custnum. ": $postal_pkg";
2522
2523     } elsif ( $postal_pkg ) {
2524
2525       foreach my $part_pkg ( $postal_pkg->part_pkg->self_and_bill_linked ) {
2526         my $error =
2527           $self->_make_lines( 'part_pkg'            => $part_pkg,
2528                               'cust_pkg'            => $postal_pkg,
2529                               'precommit_hooks'     => \@precommit_hooks,
2530                               'line_items'          => \@cust_bill_pkg,
2531                               'setup'               => \$total_setup,
2532                               'recur'               => \$total_recur,
2533                               'tax_matrix'          => \%taxlisthash,
2534                               'time'                => $time,
2535                               'options'             => \%options,
2536                             );
2537         if ($error) {
2538           $dbh->rollback if $oldAutoCommit;
2539           return $error;
2540         }
2541       }
2542
2543     }
2544
2545   }
2546
2547   warn "having a look at the taxes we found...\n" if $DEBUG > 2;
2548
2549   # keys are tax names (as printed on invoices / itemdesc )
2550   # values are listrefs of taxlisthash keys (internal identifiers)
2551   my %taxname = ();
2552
2553   # keys are taxlisthash keys (internal identifiers)
2554   # values are (cumulative) amounts
2555   my %tax = ();
2556
2557   # keys are taxlisthash keys (internal identifiers)
2558   # values are listrefs of cust_bill_pkg_tax_location hashrefs
2559   my %tax_location = ();
2560
2561   # keys are taxlisthash keys (internal identifiers)
2562   # values are listrefs of cust_bill_pkg_tax_rate_location hashrefs
2563   my %tax_rate_location = ();
2564
2565   foreach my $tax ( keys %taxlisthash ) {
2566     my $tax_object = shift @{ $taxlisthash{$tax} };
2567     warn "found ". $tax_object->taxname. " as $tax\n" if $DEBUG > 2;
2568     warn " ". join('/', @{ $taxlisthash{$tax} } ). "\n" if $DEBUG > 2;
2569     my $hashref_or_error =
2570       $tax_object->taxline( $taxlisthash{$tax},
2571                             'custnum'      => $self->custnum,
2572                             'invoice_time' => $invoice_time
2573                           );
2574     unless ( ref($hashref_or_error) ) {
2575       $dbh->rollback if $oldAutoCommit;
2576       return $hashref_or_error;
2577     }
2578     unshift @{ $taxlisthash{$tax} }, $tax_object;
2579
2580     my $name   = $hashref_or_error->{'name'};
2581     my $amount = $hashref_or_error->{'amount'};
2582
2583     #warn "adding $amount as $name\n";
2584     $taxname{ $name } ||= [];
2585     push @{ $taxname{ $name } }, $tax;
2586
2587     $tax{ $tax } += $amount;
2588
2589     $tax_location{ $tax } ||= [];
2590     if ( $tax_object->get('pkgnum') || $tax_object->get('locationnum') ) {
2591       push @{ $tax_location{ $tax }  },
2592         {
2593           'taxnum'      => $tax_object->taxnum,
2594           'taxtype'     => ref($tax_object),
2595           'pkgnum'      => $tax_object->get('pkgnum'),
2596           'locationnum' => $tax_object->get('locationnum'),
2597           'amount'      => sprintf('%.2f', $amount ),
2598         };
2599     }
2600
2601     $tax_rate_location{ $tax } ||= [];
2602     if ( ref($tax_object) eq 'FS::tax_rate' ) {
2603       my $taxratelocationnum =
2604         $tax_object->tax_rate_location->taxratelocationnum;
2605       push @{ $tax_rate_location{ $tax }  },
2606         {
2607           'taxnum'             => $tax_object->taxnum,
2608           'taxtype'            => ref($tax_object),
2609           'amount'             => sprintf('%.2f', $amount ),
2610           'locationtaxid'      => $tax_object->location,
2611           'taxratelocationnum' => $taxratelocationnum,
2612         };
2613     }
2614
2615   }
2616
2617   #move the cust_tax_exempt_pkg records to the cust_bill_pkgs we will commit
2618   my %packagemap = map { $_->pkgnum => $_ } @cust_bill_pkg;
2619   foreach my $tax ( keys %taxlisthash ) {
2620     foreach ( @{ $taxlisthash{$tax} }[1 ... scalar(@{ $taxlisthash{$tax} })] ) {
2621       next unless ref($_) eq 'FS::cust_bill_pkg';
2622
2623       push @{ $packagemap{$_->pkgnum}->_cust_tax_exempt_pkg },
2624         splice( @{ $_->_cust_tax_exempt_pkg } );
2625     }
2626   }
2627
2628   #consolidate and create tax line items
2629   warn "consolidating and generating...\n" if $DEBUG > 2;
2630   foreach my $taxname ( keys %taxname ) {
2631     my $tax = 0;
2632     my %seen = ();
2633     my @cust_bill_pkg_tax_location = ();
2634     my @cust_bill_pkg_tax_rate_location = ();
2635     warn "adding $taxname\n" if $DEBUG > 1;
2636     foreach my $taxitem ( @{ $taxname{$taxname} } ) {
2637       next if $seen{$taxitem}++;
2638       warn "adding $tax{$taxitem}\n" if $DEBUG > 1;
2639       $tax += $tax{$taxitem};
2640       push @cust_bill_pkg_tax_location,
2641         map { new FS::cust_bill_pkg_tax_location $_ }
2642             @{ $tax_location{ $taxitem } };
2643       push @cust_bill_pkg_tax_rate_location,
2644         map { new FS::cust_bill_pkg_tax_rate_location $_ }
2645             @{ $tax_rate_location{ $taxitem } };
2646     }
2647     next unless $tax;
2648
2649     $tax = sprintf('%.2f', $tax );
2650     $total_setup = sprintf('%.2f', $total_setup+$tax );
2651
2652     push @cust_bill_pkg, new FS::cust_bill_pkg {
2653       'pkgnum'   => 0,
2654       'setup'    => $tax,
2655       'recur'    => 0,
2656       'sdate'    => '',
2657       'edate'    => '',
2658       'itemdesc' => $taxname,
2659       'cust_bill_pkg_tax_location' => \@cust_bill_pkg_tax_location,
2660       'cust_bill_pkg_tax_rate_location' => \@cust_bill_pkg_tax_rate_location,
2661     };
2662
2663   }
2664
2665   #add tax adjustments
2666   warn "adding tax adjustments...\n" if $DEBUG > 2;
2667   foreach my $cust_tax_adjustment (
2668     qsearch('cust_tax_adjustment', { 'custnum'    => $self->custnum,
2669                                      'billpkgnum' => '',
2670                                    }
2671            )
2672   ) {
2673
2674     my $tax = sprintf('%.2f', $cust_tax_adjustment->amount );
2675     $total_setup = sprintf('%.2f', $total_setup+$tax );
2676
2677     my $itemdesc = $cust_tax_adjustment->taxname;
2678     $itemdesc = '' if $itemdesc eq 'Tax';
2679
2680     push @cust_bill_pkg, new FS::cust_bill_pkg {
2681       'pkgnum'      => 0,
2682       'setup'       => $tax,
2683       'recur'       => 0,
2684       'sdate'       => '',
2685       'edate'       => '',
2686       'itemdesc'    => $itemdesc,
2687       'itemcomment' => $cust_tax_adjustment->comment,
2688       'cust_tax_adjustment' => $cust_tax_adjustment,
2689       #'cust_bill_pkg_tax_location' => \@cust_bill_pkg_tax_location,
2690     };
2691
2692   }
2693
2694   my $charged = sprintf('%.2f', $total_setup + $total_recur );
2695
2696   #create the new invoice
2697   my $cust_bill = new FS::cust_bill ( {
2698     'custnum' => $self->custnum,
2699     '_date'   => ( $invoice_time ),
2700     'charged' => $charged,
2701   } );
2702   my $error = $cust_bill->insert;
2703   if ( $error ) {
2704     $dbh->rollback if $oldAutoCommit;
2705     return "can't create invoice for customer #". $self->custnum. ": $error";
2706   }
2707
2708   foreach my $cust_bill_pkg ( @cust_bill_pkg ) {
2709     $cust_bill_pkg->invnum($cust_bill->invnum);
2710     my $error = $cust_bill_pkg->insert;
2711     if ( $error ) {
2712       $dbh->rollback if $oldAutoCommit;
2713       return "can't create invoice line item: $error";
2714     }
2715   }
2716
2717
2718   foreach my $hook ( @precommit_hooks ) {
2719     eval {
2720       &{$hook}; #($self) ?
2721     };
2722     if ( $@ ) {
2723       $dbh->rollback if $oldAutoCommit;
2724       return "$@ running precommit hook $hook\n";
2725     }
2726   }
2727
2728   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2729   ''; #no error
2730 }
2731
2732
2733 sub _make_lines {
2734   my ($self, %params) = @_;
2735
2736   my $part_pkg = $params{part_pkg} or die "no part_pkg specified";
2737   my $cust_pkg = $params{cust_pkg} or die "no cust_pkg specified";
2738   my $precommit_hooks = $params{precommit_hooks} or die "no package specified";
2739   my $cust_bill_pkgs = $params{line_items} or die "no line buffer specified";
2740   my $total_setup = $params{setup} or die "no setup accumulator specified";
2741   my $total_recur = $params{recur} or die "no recur accumulator specified";
2742   my $taxlisthash = $params{tax_matrix} or die "no tax accumulator specified";
2743   my $time = $params{'time'} or die "no time specified";
2744   my (%options) = %{$params{options}};
2745
2746   my $dbh = dbh;
2747   my $real_pkgpart = $cust_pkg->pkgpart;
2748   my %hash = $cust_pkg->hash;
2749   my $old_cust_pkg = new FS::cust_pkg \%hash;
2750
2751   my @details = ();
2752
2753   my $lineitems = 0;
2754
2755   $cust_pkg->pkgpart($part_pkg->pkgpart);
2756
2757   ###
2758   # bill setup
2759   ###
2760
2761   my $setup = 0;
2762   my $unitsetup = 0;
2763   if ( ! $cust_pkg->setup &&
2764        (
2765          ( $conf->exists('disable_setup_suspended_pkgs') &&
2766           ! $cust_pkg->getfield('susp')
2767         ) || ! $conf->exists('disable_setup_suspended_pkgs')
2768        )
2769     || $options{'resetup'}
2770   ) {
2771
2772     warn "    bill setup\n" if $DEBUG > 1;
2773     $lineitems++;
2774
2775     $setup = eval { $cust_pkg->calc_setup( $time, \@details ) };
2776     return "$@ running calc_setup for $cust_pkg\n"
2777       if $@;
2778
2779     $unitsetup = $cust_pkg->part_pkg->unit_setup || $setup; #XXX uuh
2780
2781     $cust_pkg->setfield('setup', $time)
2782       unless $cust_pkg->setup;
2783           #do need it, but it won't get written to the db
2784           #|| $cust_pkg->pkgpart != $real_pkgpart;
2785
2786   }
2787
2788   ###
2789   # bill recurring fee
2790   ###
2791
2792   #XXX unit stuff here too
2793   my $recur = 0;
2794   my $unitrecur = 0;
2795   my $sdate;
2796   if ( ! $cust_pkg->getfield('susp') and
2797            ( $part_pkg->getfield('freq') ne '0' &&
2798              ( $cust_pkg->getfield('bill') || 0 ) <= $time
2799            )
2800         || ( $part_pkg->plan eq 'voip_cdr'
2801               && $part_pkg->option('bill_every_call')
2802            )
2803   ) {
2804
2805     # XXX should this be a package event?  probably.  events are called
2806     # at collection time at the moment, though...
2807     $part_pkg->reset_usage($cust_pkg, 'debug'=>$DEBUG)
2808       if $part_pkg->can('reset_usage');
2809       #don't want to reset usage just cause we want a line item??
2810       #&& $part_pkg->pkgpart == $real_pkgpart;
2811
2812     warn "    bill recur\n" if $DEBUG > 1;
2813     $lineitems++;
2814
2815     # XXX shared with $recur_prog
2816     $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2817
2818     #over two params!  lets at least switch to a hashref for the rest...
2819     my $increment_next_bill = ( $part_pkg->freq ne '0'
2820                                 && ( $cust_pkg->getfield('bill') || 0 ) <= $time
2821                               );
2822     my %param = ( 'precommit_hooks'     => $precommit_hooks,
2823                   'increment_next_bill' => $increment_next_bill,
2824                 );
2825
2826     $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details, \%param ) };
2827     return "$@ running calc_recur for $cust_pkg\n"
2828       if ( $@ );
2829
2830     if ( $increment_next_bill ) {
2831
2832       my $next_bill = $part_pkg->add_freq($sdate);
2833       return "unparsable frequency: ". $part_pkg->freq
2834         if $next_bill == -1;
2835
2836       #pro-rating magic - if $recur_prog fiddled $sdate, want to use that
2837       # only for figuring next bill date, nothing else, so, reset $sdate again
2838       # here
2839       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2840       #no need, its in $hash{last_bill}# my $last_bill = $cust_pkg->last_bill;
2841       $cust_pkg->last_bill($sdate);
2842
2843       $cust_pkg->setfield('bill', $next_bill );
2844
2845     }
2846
2847   }
2848
2849   warn "\$setup is undefined" unless defined($setup);
2850   warn "\$recur is undefined" unless defined($recur);
2851   warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
2852
2853   ###
2854   # If there's line items, create em cust_bill_pkg records
2855   # If $cust_pkg has been modified, update it (if we're a real pkgpart)
2856   ###
2857
2858   if ( $lineitems ) {
2859
2860     if ( $cust_pkg->modified && $cust_pkg->pkgpart == $real_pkgpart ) {
2861       # hmm.. and if just the options are modified in some weird price plan?
2862
2863       warn "  package ". $cust_pkg->pkgnum. " modified; updating\n"
2864         if $DEBUG >1;
2865
2866       my $error = $cust_pkg->replace( $old_cust_pkg,
2867                                       'options' => { $cust_pkg->options },
2868                                     );
2869       return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error"
2870         if $error; #just in case
2871     }
2872
2873     $setup = sprintf( "%.2f", $setup );
2874     $recur = sprintf( "%.2f", $recur );
2875     if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
2876       return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
2877     }
2878     if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
2879       return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
2880     }
2881
2882     if ( $setup != 0 || $recur != 0 ) {
2883
2884       warn "    charges (setup=$setup, recur=$recur); adding line items\n"
2885         if $DEBUG > 1;
2886
2887       my @cust_pkg_detail = map { $_->detail } $cust_pkg->cust_pkg_detail('I');
2888       if ( $DEBUG > 1 ) {
2889         warn "      adding customer package invoice detail: $_\n"
2890           foreach @cust_pkg_detail;
2891       }
2892       push @details, @cust_pkg_detail;
2893
2894       my $cust_bill_pkg = new FS::cust_bill_pkg {
2895         'pkgnum'    => $cust_pkg->pkgnum,
2896         'setup'     => $setup,
2897         'unitsetup' => $unitsetup,
2898         'recur'     => $recur,
2899         'unitrecur' => $unitrecur,
2900         'quantity'  => $cust_pkg->quantity,
2901         'details'   => \@details,
2902       };
2903
2904       if ( $part_pkg->option('recur_temporality', 1) eq 'preceding' ) {
2905         $cust_bill_pkg->sdate( $hash{last_bill} );
2906         $cust_bill_pkg->edate( $sdate - 86399   ); #60s*60m*24h-1
2907       } else { #if ( $part_pkg->option('recur_temporality', 1) eq 'upcoming' ) {
2908         $cust_bill_pkg->sdate( $sdate );
2909         $cust_bill_pkg->edate( $cust_pkg->bill );
2910       }
2911
2912       $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
2913         unless $part_pkg->pkgpart == $real_pkgpart;
2914
2915       $$total_setup += $setup;
2916       $$total_recur += $recur;
2917
2918       ###
2919       # handle taxes
2920       ###
2921
2922       my $error =
2923         $self->_handle_taxes($part_pkg, $taxlisthash, $cust_bill_pkg, $cust_pkg, $options{invoice_time});
2924       return $error if $error;
2925
2926       push @$cust_bill_pkgs, $cust_bill_pkg;
2927
2928     } #if $setup != 0 || $recur != 0
2929
2930   } #if $line_items
2931
2932   '';
2933
2934 }
2935
2936 sub _handle_taxes {
2937   my $self = shift;
2938   my $part_pkg = shift;
2939   my $taxlisthash = shift;
2940   my $cust_bill_pkg = shift;
2941   my $cust_pkg = shift;
2942   my $invoice_time = shift;
2943
2944   my %cust_bill_pkg = ();
2945   my %taxes = ();
2946
2947   my @classes;
2948   #push @classes, $cust_bill_pkg->usage_classes if $cust_bill_pkg->type eq 'U';
2949   push @classes, $cust_bill_pkg->usage_classes if $cust_bill_pkg->usage;
2950   push @classes, 'setup' if $cust_bill_pkg->setup;
2951   push @classes, 'recur' if $cust_bill_pkg->recur;
2952
2953   if ( $self->tax !~ /Y/i && $self->payby ne 'COMP' ) {
2954
2955     if ( $conf->exists('enable_taxproducts')
2956          && ( scalar($part_pkg->part_pkg_taxoverride)
2957               || $part_pkg->has_taxproduct
2958             )
2959        )
2960     {
2961
2962       if ( $conf->exists('tax-pkg_address') && $cust_pkg->locationnum ) {
2963         return "fatal: Can't (yet) use tax-pkg_address with taxproducts";
2964       }
2965
2966       foreach my $class (@classes) {
2967         my $err_or_ref = $self->_gather_taxes( $part_pkg, $class );
2968         return $err_or_ref unless ref($err_or_ref);
2969         $taxes{$class} = $err_or_ref;
2970       }
2971
2972       unless (exists $taxes{''}) {
2973         my $err_or_ref = $self->_gather_taxes( $part_pkg, '' );
2974         return $err_or_ref unless ref($err_or_ref);
2975         $taxes{''} = $err_or_ref;
2976       }
2977
2978     } else {
2979
2980       my @loc_keys = qw( state county country );
2981       my %taxhash;
2982       if ( $conf->exists('tax-pkg_address') && $cust_pkg->locationnum ) {
2983         my $cust_location = $cust_pkg->cust_location;
2984         %taxhash = map { $_ => $cust_location->$_()    } @loc_keys;
2985       } else {
2986         my $prefix =
2987           ( $conf->exists('tax-ship_address') && length($self->ship_last) )
2988           ? 'ship_'
2989           : '';
2990         %taxhash = map { $_ => $self->get("$prefix$_") } @loc_keys;
2991       }
2992
2993       $taxhash{'taxclass'} = $part_pkg->taxclass;
2994
2995       my @taxes = qsearch( 'cust_main_county', \%taxhash );
2996
2997       my %taxhash_elim = %taxhash;
2998
2999       my @elim = qw( taxclass county state );
3000       while ( !scalar(@taxes) && scalar(@elim) ) {
3001         $taxhash_elim{ shift(@elim) } = '';
3002         @taxes = qsearch( 'cust_main_county', \%taxhash_elim );
3003       }
3004
3005       @taxes = grep { ! $_->taxname or ! $self->tax_exemption($_->taxname) }
3006                     @taxes
3007         if $self->cust_main_exemption; #just to be safe
3008
3009       if ( $conf->exists('tax-pkg_address') && $cust_pkg->locationnum ) {
3010         foreach (@taxes) {
3011           $_->set('pkgnum',      $cust_pkg->pkgnum );
3012           $_->set('locationnum', $cust_pkg->locationnum );
3013         }
3014       }
3015
3016       $taxes{''} = [ @taxes ];
3017       $taxes{'setup'} = [ @taxes ];
3018       $taxes{'recur'} = [ @taxes ];
3019       $taxes{$_} = [ @taxes ] foreach (@classes);
3020
3021       # # maybe eliminate this entirely, along with all the 0% records
3022       # unless ( @taxes ) {
3023       #   return
3024       #     "fatal: can't find tax rate for state/county/country/taxclass ".
3025       #     join('/', map $taxhash{$_}, qw(state county country taxclass) );
3026       # }
3027
3028     } #if $conf->exists('enable_taxproducts') ...
3029
3030   }
3031
3032   my @display = ();
3033   if ( $conf->exists('separate_usage') ) {
3034     my $section = $cust_pkg->part_pkg->option('usage_section', 'Hush!');
3035     my $summary = $cust_pkg->part_pkg->option('summarize_usage', 'Hush!');
3036     push @display, new FS::cust_bill_pkg_display { type    => 'S' };
3037     push @display, new FS::cust_bill_pkg_display { type    => 'R' };
3038     push @display, new FS::cust_bill_pkg_display { type    => 'U',
3039                                                    section => $section
3040                                                  };
3041     if ($section && $summary) {
3042       $display[2]->post_total('Y');
3043       push @display, new FS::cust_bill_pkg_display { type    => 'U',
3044                                                      summary => 'Y',
3045                                                    }
3046     }
3047   }
3048   $cust_bill_pkg->set('display', \@display);
3049
3050   my %tax_cust_bill_pkg = $cust_bill_pkg->disintegrate;
3051   foreach my $key (keys %tax_cust_bill_pkg) {
3052     my @taxes = @{ $taxes{$key} || [] };
3053     my $tax_cust_bill_pkg = $tax_cust_bill_pkg{$key};
3054
3055     my %localtaxlisthash = ();
3056     foreach my $tax ( @taxes ) {
3057
3058       my $taxname = ref( $tax ). ' '. $tax->taxnum;
3059 #      $taxname .= ' pkgnum'. $cust_pkg->pkgnum.
3060 #                  ' locationnum'. $cust_pkg->locationnum
3061 #        if $conf->exists('tax-pkg_address') && $cust_pkg->locationnum;
3062
3063       $taxlisthash->{ $taxname } ||= [ $tax ];
3064       push @{ $taxlisthash->{ $taxname  } }, $tax_cust_bill_pkg;
3065
3066       $localtaxlisthash{ $taxname } ||= [ $tax ];
3067       push @{ $localtaxlisthash{ $taxname  } }, $tax_cust_bill_pkg;
3068
3069     }
3070
3071     warn "finding taxed taxes...\n" if $DEBUG > 2;
3072     foreach my $tax ( keys %localtaxlisthash ) {
3073       my $tax_object = shift @{ $localtaxlisthash{$tax} };
3074       warn "found possible taxed tax ". $tax_object->taxname. " we call $tax\n"
3075         if $DEBUG > 2;
3076       next unless $tax_object->can('tax_on_tax');
3077
3078       foreach my $tot ( $tax_object->tax_on_tax( $self ) ) {
3079         my $totname = ref( $tot ). ' '. $tot->taxnum;
3080
3081         warn "checking $totname which we call ". $tot->taxname. " as applicable\n"
3082           if $DEBUG > 2;
3083         next unless exists( $localtaxlisthash{ $totname } ); # only increase
3084                                                              # existing taxes
3085         warn "adding $totname to taxed taxes\n" if $DEBUG > 2;
3086         my $hashref_or_error =
3087           $tax_object->taxline( $localtaxlisthash{$tax},
3088                                 'custnum'      => $self->custnum,
3089                                 'invoice_time' => $invoice_time,
3090                               );
3091         return $hashref_or_error
3092           unless ref($hashref_or_error);
3093
3094         $taxlisthash->{ $totname } ||= [ $tot ];
3095         push @{ $taxlisthash->{ $totname  } }, $hashref_or_error->{amount};
3096
3097       }
3098     }
3099
3100   }
3101
3102   '';
3103 }
3104
3105 sub _gather_taxes {
3106   my $self = shift;
3107   my $part_pkg = shift;
3108   my $class = shift;
3109
3110   my @taxes = ();
3111   my $geocode = $self->geocode('cch');
3112
3113   my @taxclassnums = map { $_->taxclassnum }
3114                      $part_pkg->part_pkg_taxoverride($class);
3115
3116   unless (@taxclassnums) {
3117     @taxclassnums = map { $_->taxclassnum }
3118                     grep { $_->taxable eq 'Y' }
3119                     $part_pkg->part_pkg_taxrate('cch', $geocode, $class);
3120   }
3121   warn "Found taxclassnum values of ". join(',', @taxclassnums)
3122     if $DEBUG;
3123
3124   my $extra_sql =
3125     "AND (".
3126     join(' OR ', map { "taxclassnum = $_" } @taxclassnums ). ")";
3127
3128   @taxes = qsearch({ 'table' => 'tax_rate',
3129                      'hashref' => { 'geocode' => $geocode, },
3130                      'extra_sql' => $extra_sql,
3131                   })
3132     if scalar(@taxclassnums);
3133
3134   warn "Found taxes ".
3135        join(',', map{ ref($_). " ". $_->get($_->primary_key) } @taxes). "\n"
3136    if $DEBUG;
3137
3138   [ @taxes ];
3139
3140 }
3141
3142 =item collect OPTIONS
3143
3144 (Attempt to) collect money for this customer's outstanding invoices (see
3145 L<FS::cust_bill>).  Usually used after the bill method.
3146
3147 Actions are now triggered by billing events; see L<FS::part_event> and the
3148 billing events web interface.  Old-style invoice events (see
3149 L<FS::part_bill_event>) have been deprecated.
3150
3151 If there is an error, returns the error, otherwise returns false.
3152
3153 Options are passed as name-value pairs.
3154
3155 Currently available options are:
3156
3157 =over 4
3158
3159 =item invoice_time
3160
3161 Use this time when deciding when to print invoices and 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> for conversion functions.
3162
3163 =item retry
3164
3165 Retry card/echeck/LEC transactions even when not scheduled by invoice events.
3166
3167 =item quiet
3168
3169 set true to surpress email card/ACH decline notices.
3170
3171 =item check_freq
3172
3173 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
3174
3175 =item payby
3176
3177 allows for one time override of normal customer billing method
3178
3179 =item debug
3180
3181 Debugging level.  Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), 3 (more information), or 4 (include full search queries)
3182
3183
3184 =back
3185
3186 =cut
3187
3188 sub collect {
3189   my( $self, %options ) = @_;
3190   my $invoice_time = $options{'invoice_time'} || time;
3191
3192   #put below somehow?
3193   local $SIG{HUP} = 'IGNORE';
3194   local $SIG{INT} = 'IGNORE';
3195   local $SIG{QUIT} = 'IGNORE';
3196   local $SIG{TERM} = 'IGNORE';
3197   local $SIG{TSTP} = 'IGNORE';
3198   local $SIG{PIPE} = 'IGNORE';
3199
3200   my $oldAutoCommit = $FS::UID::AutoCommit;
3201   local $FS::UID::AutoCommit = 0;
3202   my $dbh = dbh;
3203
3204   $self->select_for_update; #mutex
3205
3206   if ( $DEBUG ) {
3207     my $balance = $self->balance;
3208     warn "$me collect customer ". $self->custnum. ": balance $balance\n"
3209   }
3210
3211   if ( exists($options{'retry_card'}) ) {
3212     carp 'retry_card option passed to collect is deprecated; use retry';
3213     $options{'retry'} ||= $options{'retry_card'};
3214   }
3215   if ( exists($options{'retry'}) && $options{'retry'} ) {
3216     my $error = $self->retry_realtime;
3217     if ( $error ) {
3218       $dbh->rollback if $oldAutoCommit;
3219       return $error;
3220     }
3221   }
3222
3223   # false laziness w/pay_batch::import_results
3224
3225   my $due_cust_event = $self->due_cust_event(
3226     'debug'      => ( $options{'debug'} || 0 ),
3227     'time'       => $invoice_time,
3228     'check_freq' => $options{'check_freq'},
3229   );
3230   unless( ref($due_cust_event) ) {
3231     $dbh->rollback if $oldAutoCommit;
3232     return $due_cust_event;
3233   }
3234
3235   foreach my $cust_event ( @$due_cust_event ) {
3236
3237     #XXX lock event
3238
3239     #re-eval event conditions (a previous event could have changed things)
3240     unless ( $cust_event->test_conditions( 'time' => $invoice_time ) ) {
3241       #don't leave stray "new/locked" records around
3242       my $error = $cust_event->delete;
3243       if ( $error ) {
3244         #gah, even with transactions
3245         $dbh->commit if $oldAutoCommit; #well.
3246         return $error;
3247       }
3248       next;
3249     }
3250
3251     {
3252       local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
3253       warn "  running cust_event ". $cust_event->eventnum. "\n"
3254         if $DEBUG > 1;
3255
3256
3257       #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
3258       if ( my $error = $cust_event->do_event() ) {
3259         #XXX wtf is this?  figure out a proper dealio with return value
3260         #from do_event
3261           # gah, even with transactions.
3262           $dbh->commit if $oldAutoCommit; #well.
3263           return $error;
3264         }
3265     }
3266
3267   }
3268
3269   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3270   '';
3271
3272 }
3273
3274 =item due_cust_event [ HASHREF | OPTION => VALUE ... ]
3275
3276 Inserts database records for and returns an ordered listref of new events due
3277 for this customer, as FS::cust_event objects (see L<FS::cust_event>).  If no
3278 events are due, an empty listref is returned.  If there is an error, returns a
3279 scalar error message.
3280
3281 To actually run the events, call each event's test_condition method, and if
3282 still true, call the event's do_event method.
3283
3284 Options are passed as a hashref or as a list of name-value pairs.  Available
3285 options are:
3286
3287 =over 4
3288
3289 =item check_freq
3290
3291 Search only for events of this check frequency (how often events of this type are checked); currently "1d" (daily, the default) and "1m" (monthly) are recognized.
3292
3293 =item time
3294
3295 "Current time" for the events.
3296
3297 =item debug
3298
3299 Debugging level.  Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), 3 (more information), or 4 (include full search queries)
3300
3301 =item eventtable
3302
3303 Only return events for the specified eventtable (by default, events of all eventtables are returned)
3304
3305 =item objects
3306
3307 Explicitly pass the objects to be tested (typically used with eventtable).
3308
3309 =item testonly
3310
3311 Set to true to return the objects, but not actually insert them into the
3312 database.
3313
3314 =back
3315
3316 =cut
3317
3318 sub due_cust_event {
3319   my $self = shift;
3320   my %opt = ref($_[0]) ? %{ $_[0] } : @_;
3321
3322   #???
3323   #my $DEBUG = $opt{'debug'}
3324   local($DEBUG) = $opt{'debug'}
3325     if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG;
3326
3327   warn "$me due_cust_event called with options ".
3328        join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
3329     if $DEBUG;
3330
3331   $opt{'time'} ||= time;
3332
3333   local $SIG{HUP} = 'IGNORE';
3334   local $SIG{INT} = 'IGNORE';
3335   local $SIG{QUIT} = 'IGNORE';
3336   local $SIG{TERM} = 'IGNORE';
3337   local $SIG{TSTP} = 'IGNORE';
3338   local $SIG{PIPE} = 'IGNORE';
3339
3340   my $oldAutoCommit = $FS::UID::AutoCommit;
3341   local $FS::UID::AutoCommit = 0;
3342   my $dbh = dbh;
3343
3344   $self->select_for_update #mutex
3345     unless $opt{testonly};
3346
3347   ###
3348   # 1: find possible events (initial search)
3349   ###
3350
3351   my @cust_event = ();
3352
3353   my @eventtable = $opt{'eventtable'}
3354                      ? ( $opt{'eventtable'} )
3355                      : FS::part_event->eventtables_runorder;
3356
3357   foreach my $eventtable ( @eventtable ) {
3358
3359     my @objects;
3360     if ( $opt{'objects'} ) {
3361
3362       @objects = @{ $opt{'objects'} };
3363
3364     } else {
3365
3366       #my @objects = $self->eventtable(); # sub cust_main { @{ [ $self ] }; }
3367       @objects = ( $eventtable eq 'cust_main' )
3368                    ? ( $self )
3369                    : ( $self->$eventtable() );
3370
3371     }
3372
3373     my @e_cust_event = ();
3374
3375     my $cross = "CROSS JOIN $eventtable";
3376     $cross .= ' LEFT JOIN cust_main USING ( custnum )'
3377       unless $eventtable eq 'cust_main';
3378
3379     foreach my $object ( @objects ) {
3380
3381       #this first search uses the condition_sql magic for optimization.
3382       #the more possible events we can eliminate in this step the better
3383
3384       my $cross_where = '';
3385       my $pkey = $object->primary_key;
3386       $cross_where = "$eventtable.$pkey = ". $object->$pkey();
3387
3388       my $join = FS::part_event_condition->join_conditions_sql( $eventtable );
3389       my $extra_sql =
3390         FS::part_event_condition->where_conditions_sql( $eventtable,
3391                                                         'time'=>$opt{'time'}
3392                                                       );
3393       my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
3394
3395       $extra_sql = "AND $extra_sql" if $extra_sql;
3396
3397       #here is the agent virtualization
3398       $extra_sql .= " AND (    part_event.agentnum IS NULL
3399                             OR part_event.agentnum = ". $self->agentnum. ' )';
3400
3401       $extra_sql .= " $order";
3402
3403       warn "searching for events for $eventtable ". $object->$pkey. "\n"
3404         if $opt{'debug'} > 2;
3405       my @part_event = qsearch( {
3406         'debug'     => ( $opt{'debug'} > 3 ? 1 : 0 ),
3407         'select'    => 'part_event.*',
3408         'table'     => 'part_event',
3409         'addl_from' => "$cross $join",
3410         'hashref'   => { 'check_freq' => ( $opt{'check_freq'} || '1d' ),
3411                          'eventtable' => $eventtable,
3412                          'disabled'   => '',
3413                        },
3414         'extra_sql' => "AND $cross_where $extra_sql",
3415       } );
3416
3417       if ( $DEBUG > 2 ) {
3418         my $pkey = $object->primary_key;
3419         warn "      ". scalar(@part_event).
3420              " possible events found for $eventtable ". $object->$pkey(). "\n";
3421       }
3422
3423       push @e_cust_event, map { $_->new_cust_event($object) } @part_event;
3424
3425     }
3426
3427     warn "    ". scalar(@e_cust_event).
3428          " subtotal possible cust events found for $eventtable\n"
3429       if $DEBUG > 1;
3430
3431     push @cust_event, @e_cust_event;
3432
3433   }
3434
3435   warn "  ". scalar(@cust_event).
3436        " total possible cust events found in initial search\n"
3437     if $DEBUG; # > 1;
3438
3439   ##
3440   # 2: test conditions
3441   ##
3442
3443   my %unsat = ();
3444
3445   @cust_event = grep $_->test_conditions( 'time'          => $opt{'time'},
3446                                           'stats_hashref' => \%unsat ),
3447                      @cust_event;
3448
3449   warn "  ". scalar(@cust_event). " cust events left satisfying conditions\n"
3450     if $DEBUG; # > 1;
3451
3452   warn "    invalid conditions not eliminated with condition_sql:\n".
3453        join('', map "      $_: ".$unsat{$_}."\n", keys %unsat )
3454     if $DEBUG; # > 1;
3455
3456   ##
3457   # 3: insert
3458   ##
3459
3460   unless( $opt{testonly} ) {
3461     foreach my $cust_event ( @cust_event ) {
3462
3463       my $error = $cust_event->insert();
3464       if ( $error ) {
3465         $dbh->rollback if $oldAutoCommit;
3466         return $error;
3467       }
3468
3469     }
3470   }
3471
3472   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3473
3474   ##
3475   # 4: return
3476   ##
3477
3478   warn "  returning events: ". Dumper(@cust_event). "\n"
3479     if $DEBUG > 2;
3480
3481   \@cust_event;
3482
3483 }
3484
3485 =item retry_realtime
3486
3487 Schedules realtime / batch  credit card / electronic check / LEC billing
3488 events for for retry.  Useful if card information has changed or manual
3489 retry is desired.  The 'collect' method must be called to actually retry
3490 the transaction.
3491
3492 Implementation details: For either this customer, or for each of this
3493 customer's open invoices, changes the status of the first "done" (with
3494 statustext error) realtime processing event to "failed".
3495
3496 =cut
3497
3498 sub retry_realtime {
3499   my $self = shift;
3500
3501   local $SIG{HUP} = 'IGNORE';
3502   local $SIG{INT} = 'IGNORE';
3503   local $SIG{QUIT} = 'IGNORE';
3504   local $SIG{TERM} = 'IGNORE';
3505   local $SIG{TSTP} = 'IGNORE';
3506   local $SIG{PIPE} = 'IGNORE';
3507
3508   my $oldAutoCommit = $FS::UID::AutoCommit;
3509   local $FS::UID::AutoCommit = 0;
3510   my $dbh = dbh;
3511
3512   #a little false laziness w/due_cust_event (not too bad, really)
3513
3514   my $join = FS::part_event_condition->join_conditions_sql;
3515   my $order = FS::part_event_condition->order_conditions_sql;
3516   my $mine =
3517   '( '
3518    . join ( ' OR ' , map {
3519     "( part_event.eventtable = " . dbh->quote($_)
3520     . " AND tablenum IN( SELECT " . dbdef->table($_)->primary_key . " from $_ where custnum = " . dbh->quote( $self->custnum ) . "))" ;
3521    } FS::part_event->eventtables)
3522    . ') ';
3523
3524   #here is the agent virtualization
3525   my $agent_virt = " (    part_event.agentnum IS NULL
3526                        OR part_event.agentnum = ". $self->agentnum. ' )';
3527
3528   #XXX this shouldn't be hardcoded, actions should declare it...
3529   my @realtime_events = qw(
3530     cust_bill_realtime_card
3531     cust_bill_realtime_check
3532     cust_bill_realtime_lec
3533     cust_bill_batch
3534   );
3535
3536   my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'",
3537                                                   @realtime_events
3538                                      ).
3539                           ' ) ';
3540
3541   my @cust_event = qsearchs({
3542     'table'     => 'cust_event',
3543     'select'    => 'cust_event.*',
3544     'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
3545     'hashref'   => { 'status' => 'done' },
3546     'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ".
3547                    " AND $mine AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
3548   });
3549
3550   my %seen_invnum = ();
3551   foreach my $cust_event (@cust_event) {
3552
3553     #max one for the customer, one for each open invoice
3554     my $cust_X = $cust_event->cust_X;
3555     next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
3556                           ? $cust_X->invnum
3557                           : 0
3558                         }++
3559          or $cust_event->part_event->eventtable eq 'cust_bill'
3560             && ! $cust_X->owed;
3561
3562     my $error = $cust_event->retry;
3563     if ( $error ) {
3564       $dbh->rollback if $oldAutoCommit;
3565       return "error scheduling event for retry: $error";
3566     }
3567
3568   }
3569
3570   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3571   '';
3572
3573 }
3574
3575 # some horrid false laziness here to avoid refactor fallout
3576 # eventually realtime realtime_bop and realtime_refund_bop should go
3577 # away and be replaced by _new_realtime_bop and _new_realtime_refund_bop
3578
3579 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
3580
3581 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
3582 via a Business::OnlinePayment realtime gateway.  See
3583 L<http://420.am/business-onlinepayment> for supported gateways.
3584
3585 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3586
3587 Available options are: I<description>, I<invnum>, I<quiet>, I<paynum_ref>, I<payunique>
3588
3589 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3590 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
3591 if set, will override the value from the customer record.
3592
3593 I<description> is a free-text field passed to the gateway.  It defaults to
3594 "Internet services".
3595
3596 If an I<invnum> is specified, this payment (if successful) is applied to the
3597 specified invoice.  If you don't specify an I<invnum> you might want to
3598 call the B<apply_payments> method.
3599
3600 I<quiet> can be set true to surpress email decline notices.
3601
3602 I<paynum_ref> can be set to a scalar reference.  It will be filled in with the
3603 resulting paynum, if any.
3604
3605 I<payunique> is a unique identifier for this payment.
3606
3607 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
3608
3609 =cut
3610
3611 sub realtime_bop {
3612   my $self = shift;
3613
3614   return $self->_new_realtime_bop(@_)
3615     if $self->_new_bop_required();
3616
3617   my( $method, $amount, %options ) = @_;
3618   if ( $DEBUG ) {
3619     warn "$me realtime_bop: $method $amount\n";
3620     warn "  $_ => $options{$_}\n" foreach keys %options;
3621   }
3622
3623   $options{'description'} ||= 'Internet services';
3624
3625   return $self->fake_bop($method, $amount, %options) if $options{'fake'};
3626
3627   eval "use Business::OnlinePayment";
3628   die $@ if $@;
3629
3630   my $payinfo = exists($options{'payinfo'})
3631                   ? $options{'payinfo'}
3632                   : $self->payinfo;
3633
3634   my %method2payby = (
3635     'CC'     => 'CARD',
3636     'ECHECK' => 'CHEK',
3637     'LEC'    => 'LECB',
3638   );
3639
3640   ###
3641   # check for banned credit card/ACH
3642   ###
3643
3644   my $ban = qsearchs('banned_pay', {
3645     'payby'   => $method2payby{$method},
3646     'payinfo' => md5_base64($payinfo),
3647   } );
3648   return "Banned credit card" if $ban;
3649
3650   ###
3651   # set taxclass and trans_is_recur based on invnum if there is one
3652   ###
3653
3654   my $taxclass = '';
3655   my $trans_is_recur = 0;
3656   if ( $options{'invnum'} ) {
3657
3658     my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
3659     die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
3660
3661     my @part_pkg =
3662       map  { $_->part_pkg }
3663       grep { $_ }
3664       map  { $_->cust_pkg }
3665       $cust_bill->cust_bill_pkg;
3666
3667     my @taxclasses = map $_->taxclass, @part_pkg;
3668     $taxclass = $taxclasses[0]
3669       unless grep { $taxclasses[0] ne $_ } @taxclasses; #unless there are
3670                                                         #different taxclasses
3671     $trans_is_recur = 1
3672       if grep { $_->freq ne '0' } @part_pkg;
3673
3674   }
3675
3676   ###
3677   # select a gateway
3678   ###
3679
3680   #look for an agent gateway override first
3681   my $cardtype;
3682   if ( $method eq 'CC' ) {
3683     $cardtype = cardtype($payinfo);
3684   } elsif ( $method eq 'ECHECK' ) {
3685     $cardtype = 'ACH';
3686   } else {
3687     $cardtype = $method;
3688   }
3689
3690   my $override =
3691        qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3692                                            cardtype => $cardtype,
3693                                            taxclass => $taxclass,       } )
3694     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3695                                            cardtype => '',
3696                                            taxclass => $taxclass,       } )
3697     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3698                                            cardtype => $cardtype,
3699                                            taxclass => '',              } )
3700     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3701                                            cardtype => '',
3702                                            taxclass => '',              } );
3703
3704   my $payment_gateway = '';
3705   my( $processor, $login, $password, $action, @bop_options );
3706   if ( $override ) { #use a payment gateway override
3707
3708     $payment_gateway = $override->payment_gateway;
3709
3710     $processor   = $payment_gateway->gateway_module;
3711     $login       = $payment_gateway->gateway_username;
3712     $password    = $payment_gateway->gateway_password;
3713     $action      = $payment_gateway->gateway_action;
3714     @bop_options = $payment_gateway->options;
3715
3716   } else { #use the standard settings from the config
3717
3718     ( $processor, $login, $password, $action, @bop_options ) =
3719       $self->default_payment_gateway($method);
3720
3721   }
3722
3723   ###
3724   # massage data
3725   ###
3726
3727   my $address = exists($options{'address1'})
3728                     ? $options{'address1'}
3729                     : $self->address1;
3730   my $address2 = exists($options{'address2'})
3731                     ? $options{'address2'}
3732                     : $self->address2;
3733   $address .= ", ". $address2 if length($address2);
3734
3735   my $o_payname = exists($options{'payname'})
3736                     ? $options{'payname'}
3737                     : $self->payname;
3738   my($payname, $payfirst, $paylast);
3739   if ( $o_payname && $method ne 'ECHECK' ) {
3740     ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3741       or return "Illegal payname $payname";
3742     ($payfirst, $paylast) = ($1, $2);
3743   } else {
3744     $payfirst = $self->getfield('first');
3745     $paylast = $self->getfield('last');
3746     $payname =  "$payfirst $paylast";
3747   }
3748
3749   my @invoicing_list = $self->invoicing_list_emailonly;
3750   if ( $conf->exists('emailinvoiceautoalways')
3751        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3752        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3753     push @invoicing_list, $self->all_emails;
3754   }
3755
3756   my $email = ($conf->exists('business-onlinepayment-email-override'))
3757               ? $conf->config('business-onlinepayment-email-override')
3758               : $invoicing_list[0];
3759
3760   my %content = ();
3761
3762   my $payip = exists($options{'payip'})
3763                 ? $options{'payip'}
3764                 : $self->payip;
3765   $content{customer_ip} = $payip
3766     if length($payip);
3767
3768   $content{invoice_number} = $options{'invnum'}
3769     if exists($options{'invnum'}) && length($options{'invnum'});
3770
3771   $content{email_customer} =
3772     (    $conf->exists('business-onlinepayment-email_customer')
3773       || $conf->exists('business-onlinepayment-email-override') );
3774
3775   my $paydate = '';
3776   if ( $method eq 'CC' ) {
3777
3778     $content{card_number} = $payinfo;
3779     $paydate = exists($options{'paydate'})
3780                     ? $options{'paydate'}
3781                     : $self->paydate;
3782     $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3783     $content{expiration} = "$2/$1";
3784
3785     my $paycvv = exists($options{'paycvv'})
3786                    ? $options{'paycvv'}
3787                    : $self->paycvv;
3788     $content{cvv2} = $paycvv
3789       if length($paycvv);
3790
3791     my $paystart_month = exists($options{'paystart_month'})
3792                            ? $options{'paystart_month'}
3793                            : $self->paystart_month;
3794
3795     my $paystart_year  = exists($options{'paystart_year'})
3796                            ? $options{'paystart_year'}
3797                            : $self->paystart_year;
3798
3799     $content{card_start} = "$paystart_month/$paystart_year"
3800       if $paystart_month && $paystart_year;
3801
3802     my $payissue       = exists($options{'payissue'})
3803                            ? $options{'payissue'}
3804                            : $self->payissue;
3805     $content{issue_number} = $payissue if $payissue;
3806
3807     if ( $self->_bop_recurring_billing( 'payinfo'        => $payinfo,
3808                                         'trans_is_recur' => $trans_is_recur,
3809                                       )
3810        )
3811     {
3812       $content{recurring_billing} = 'YES';
3813       $content{acct_code} = 'rebill'
3814         if $conf->exists('credit_card-recurring_billing_acct_code');
3815     }
3816
3817   } elsif ( $method eq 'ECHECK' ) {
3818     ( $content{account_number}, $content{routing_code} ) =
3819       split('@', $payinfo);
3820     $content{bank_name} = $o_payname;
3821     $content{bank_state} = exists($options{'paystate'})
3822                              ? $options{'paystate'}
3823                              : $self->getfield('paystate');
3824     $content{account_type} = exists($options{'paytype'})
3825                                ? uc($options{'paytype'}) || 'CHECKING'
3826                                : uc($self->getfield('paytype')) || 'CHECKING';
3827     $content{account_name} = $payname;
3828     $content{customer_org} = $self->company ? 'B' : 'I';
3829     $content{state_id}       = exists($options{'stateid'})
3830                                  ? $options{'stateid'}
3831                                  : $self->getfield('stateid');
3832     $content{state_id_state} = exists($options{'stateid_state'})
3833                                  ? $options{'stateid_state'}
3834                                  : $self->getfield('stateid_state');
3835     $content{customer_ssn} = exists($options{'ss'})
3836                                ? $options{'ss'}
3837                                : $self->ss;
3838   } elsif ( $method eq 'LEC' ) {
3839     $content{phone} = $payinfo;
3840   }
3841
3842   ###
3843   # run transaction(s)
3844   ###
3845
3846   my $balance = exists( $options{'balance'} )
3847                   ? $options{'balance'}
3848                   : $self->balance;
3849
3850   $self->select_for_update; #mutex ... just until we get our pending record in
3851
3852   #the checks here are intended to catch concurrent payments
3853   #double-form-submission prevention is taken care of in cust_pay_pending::check
3854
3855   #check the balance
3856   return "The customer's balance has changed; $method transaction aborted."
3857     if $self->balance < $balance;
3858     #&& $self->balance < $amount; #might as well anyway?
3859
3860   #also check and make sure there aren't *other* pending payments for this cust
3861
3862   my @pending = qsearch('cust_pay_pending', {
3863     'custnum' => $self->custnum,
3864     'status'  => { op=>'!=', value=>'done' }
3865   });
3866   return "A payment is already being processed for this customer (".
3867          join(', ', map 'paypendingnum '. $_->paypendingnum, @pending ).
3868          "); $method transaction aborted."
3869     if scalar(@pending);
3870
3871   #okay, good to go, if we're a duplicate, cust_pay_pending will kick us out
3872
3873   my $cust_pay_pending = new FS::cust_pay_pending {
3874     'custnum'           => $self->custnum,
3875     #'invnum'            => $options{'invnum'},
3876     'paid'              => $amount,
3877     '_date'             => '',
3878     'payby'             => $method2payby{$method},
3879     'payinfo'           => $payinfo,
3880     'paydate'           => $paydate,
3881     'recurring_billing' => $content{recurring_billing},
3882     'status'            => 'new',
3883     'gatewaynum'        => ( $payment_gateway ? $payment_gateway->gatewaynum : '' ),
3884   };
3885   $cust_pay_pending->payunique( $options{payunique} )
3886     if defined($options{payunique}) && length($options{payunique});
3887   my $cpp_new_err = $cust_pay_pending->insert; #mutex lost when this is inserted
3888   return $cpp_new_err if $cpp_new_err;
3889
3890   my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
3891
3892   my $transaction = new Business::OnlinePayment( $processor, @bop_options );
3893   $transaction->content(
3894     'type'           => $method,
3895     'login'          => $login,
3896     'password'       => $password,
3897     'action'         => $action1,
3898     'description'    => $options{'description'},
3899     'amount'         => $amount,
3900     #'invoice_number' => $options{'invnum'},
3901     'customer_id'    => $self->custnum,
3902     'last_name'      => $paylast,
3903     'first_name'     => $payfirst,
3904     'name'           => $payname,
3905     'address'        => $address,
3906     'city'           => ( exists($options{'city'})
3907                             ? $options{'city'}
3908                             : $self->city          ),
3909     'state'          => ( exists($options{'state'})
3910                             ? $options{'state'}
3911                             : $self->state          ),
3912     'zip'            => ( exists($options{'zip'})
3913                             ? $options{'zip'}
3914                             : $self->zip          ),
3915     'country'        => ( exists($options{'country'})
3916                             ? $options{'country'}
3917                             : $self->country          ),
3918     'referer'        => 'http://cleanwhisker.420.am/', #XXX fix referer :/
3919     'email'          => $email,
3920     'phone'          => $self->daytime || $self->night,
3921     %content, #after
3922   );
3923
3924   $cust_pay_pending->status('pending');
3925   my $cpp_pending_err = $cust_pay_pending->replace;
3926   return $cpp_pending_err if $cpp_pending_err;
3927
3928   #config?
3929   my $BOP_TESTING = 0;
3930   my $BOP_TESTING_SUCCESS = 1;
3931
3932   unless ( $BOP_TESTING ) {
3933     $transaction->submit();
3934   } else {
3935     if ( $BOP_TESTING_SUCCESS ) {
3936       $transaction->is_success(1);
3937       $transaction->authorization('fake auth');
3938     } else {
3939       $transaction->is_success(0);
3940       $transaction->error_message('fake failure');
3941     }
3942   }
3943
3944   if ( $transaction->is_success() && $action2 ) {
3945
3946     $cust_pay_pending->status('authorized');
3947     my $cpp_authorized_err = $cust_pay_pending->replace;
3948     return $cpp_authorized_err if $cpp_authorized_err;
3949
3950     my $auth = $transaction->authorization;
3951     my $ordernum = $transaction->can('order_number')
3952                    ? $transaction->order_number
3953                    : '';
3954
3955     my $capture =
3956       new Business::OnlinePayment( $processor, @bop_options );
3957
3958     my %capture = (
3959       %content,
3960       type           => $method,
3961       action         => $action2,
3962       login          => $login,
3963       password       => $password,
3964       order_number   => $ordernum,
3965       amount         => $amount,
3966       authorization  => $auth,
3967       description    => $options{'description'},
3968     );
3969
3970     foreach my $field (qw( authorization_source_code returned_ACI
3971                            transaction_identifier validation_code
3972                            transaction_sequence_num local_transaction_date
3973                            local_transaction_time AVS_result_code          )) {
3974       $capture{$field} = $transaction->$field() if $transaction->can($field);
3975     }
3976
3977     $capture->content( %capture );
3978
3979     $capture->submit();
3980
3981     unless ( $capture->is_success ) {
3982       my $e = "Authorization successful but capture failed, custnum #".
3983               $self->custnum. ': '.  $capture->result_code.
3984               ": ". $capture->error_message;
3985       warn $e;
3986       return $e;
3987     }
3988
3989   }
3990
3991   $cust_pay_pending->status($transaction->is_success() ? 'captured' : 'declined');
3992   my $cpp_captured_err = $cust_pay_pending->replace;
3993   return $cpp_captured_err if $cpp_captured_err;
3994
3995   ###
3996   # remove paycvv after initial transaction
3997   ###
3998
3999   #false laziness w/misc/process/payment.cgi - check both to make sure working
4000   # correctly
4001   if ( defined $self->dbdef_table->column('paycvv')
4002        && length($self->paycvv)
4003        && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
4004   ) {
4005     my $error = $self->remove_cvv;
4006     if ( $error ) {
4007       warn "WARNING: error removing cvv: $error\n";
4008     }
4009   }
4010
4011   ###
4012   # result handling
4013   ###
4014
4015   if ( $transaction->is_success() ) {
4016
4017     my $paybatch = '';
4018     if ( $payment_gateway ) { # agent override
4019       $paybatch = $payment_gateway->gatewaynum. '-';
4020     }
4021
4022     $paybatch .= "$processor:". $transaction->authorization;
4023
4024     $paybatch .= ':'. $transaction->order_number
4025       if $transaction->can('order_number')
4026       && length($transaction->order_number);
4027
4028     my $cust_pay = new FS::cust_pay ( {
4029        'custnum'  => $self->custnum,
4030        'invnum'   => $options{'invnum'},
4031        'paid'     => $amount,
4032        '_date'    => '',
4033        'payby'    => $method2payby{$method},
4034        'payinfo'  => $payinfo,
4035        'paybatch' => $paybatch,
4036        'paydate'  => $paydate,
4037     } );
4038     #doesn't hurt to know, even though the dup check is in cust_pay_pending now
4039     $cust_pay->payunique( $options{payunique} )
4040       if defined($options{payunique}) && length($options{payunique});
4041
4042     my $oldAutoCommit = $FS::UID::AutoCommit;
4043     local $FS::UID::AutoCommit = 0;
4044     my $dbh = dbh;
4045
4046     #start a transaction, insert the cust_pay and set cust_pay_pending.status to done in a single transction
4047
4048     my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
4049
4050     if ( $error ) {
4051       $cust_pay->invnum(''); #try again with no specific invnum
4052       my $error2 = $cust_pay->insert( $options{'manual'} ?
4053                                       ( 'manual' => 1 ) : ()
4054                                     );
4055       if ( $error2 ) {
4056         # gah.  but at least we have a record of the state we had to abort in
4057         # from cust_pay_pending now.
4058         my $e = "WARNING: $method captured but payment not recorded - ".
4059                 "error inserting payment ($processor): $error2".
4060                 " (previously tried insert with invnum #$options{'invnum'}" .
4061                 ": $error ) - pending payment saved as paypendingnum ".
4062                 $cust_pay_pending->paypendingnum. "\n";
4063         warn $e;
4064         return $e;
4065       }
4066     }
4067
4068     if ( $options{'paynum_ref'} ) {
4069       ${ $options{'paynum_ref'} } = $cust_pay->paynum;
4070     }
4071
4072     $cust_pay_pending->status('done');
4073     $cust_pay_pending->statustext('captured');
4074     $cust_pay_pending->paynum($cust_pay->paynum);
4075     my $cpp_done_err = $cust_pay_pending->replace;
4076
4077     if ( $cpp_done_err ) {
4078
4079       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4080       my $e = "WARNING: $method captured but payment not recorded - ".
4081               "error updating status for paypendingnum ".
4082               $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
4083       warn $e;
4084       return $e;
4085
4086     } else {
4087
4088       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4089       return ''; #no error
4090
4091     }
4092
4093   } else {
4094
4095     my $perror = "$processor error: ". $transaction->error_message;
4096
4097     unless ( $transaction->error_message ) {
4098
4099       my $t_response;
4100       if ( $transaction->can('response_page') ) {
4101         $t_response = {
4102                         'page'    => ( $transaction->can('response_page')
4103                                          ? $transaction->response_page
4104                                          : ''
4105                                      ),
4106                         'code'    => ( $transaction->can('response_code')
4107                                          ? $transaction->response_code
4108                                          : ''
4109                                      ),
4110                         'headers' => ( $transaction->can('response_headers')
4111                                          ? $transaction->response_headers
4112                                          : ''
4113                                      ),
4114                       };
4115       } else {
4116         $t_response .=
4117           "No additional debugging information available for $processor";
4118       }
4119
4120       $perror .= "No error_message returned from $processor -- ".
4121                  ( ref($t_response) ? Dumper($t_response) : $t_response );
4122
4123     }
4124
4125     if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
4126          && $conf->exists('emaildecline')
4127          && grep { $_ ne 'POST' } $self->invoicing_list
4128          && ! grep { $transaction->error_message =~ /$_/ }
4129                    $conf->config('emaildecline-exclude')
4130     ) {
4131       my @templ = $conf->config('declinetemplate');
4132       my $template = new Text::Template (
4133         TYPE   => 'ARRAY',
4134         SOURCE => [ map "$_\n", @templ ],
4135       ) or return "($perror) can't create template: $Text::Template::ERROR";
4136       $template->compile()
4137         or return "($perror) can't compile template: $Text::Template::ERROR";
4138
4139       my $templ_hash = { error => $transaction->error_message };
4140
4141       my $error = send_email(
4142         'from'    => $conf->config('invoice_from', $self->agentnum ),
4143         'to'      => [ grep { $_ ne 'POST' } $self->invoicing_list ],
4144         'subject' => 'Your payment could not be processed',
4145         'body'    => [ $template->fill_in(HASH => $templ_hash) ],
4146       );
4147
4148       $perror .= " (also received error sending decline notification: $error)"
4149         if $error;
4150
4151     }
4152
4153     $cust_pay_pending->status('done');
4154     $cust_pay_pending->statustext("declined: $perror");
4155     my $cpp_done_err = $cust_pay_pending->replace;
4156     if ( $cpp_done_err ) {
4157       my $e = "WARNING: $method declined but pending payment not resolved - ".
4158               "error updating status for paypendingnum ".
4159               $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
4160       warn $e;
4161       $perror = "$e ($perror)";
4162     }
4163
4164     return $perror;
4165   }
4166
4167 }
4168
4169 sub _bop_recurring_billing {
4170   my( $self, %opt ) = @_;
4171
4172   my $method = $conf->config('credit_card-recurring_billing_flag');
4173
4174   if ( $method eq 'transaction_is_recur' ) {
4175
4176     return 1 if $opt{'trans_is_recur'};
4177
4178   } else {
4179
4180     my %hash = ( 'custnum' => $self->custnum,
4181                  'payby'   => 'CARD',
4182                );
4183
4184     return 1
4185       if qsearch('cust_pay', { %hash, 'payinfo' => $opt{'payinfo'} } )
4186       || qsearch('cust_pay', { %hash, 'paymask' => $self->mask_payinfo('CARD',
4187                                                                $opt{'payinfo'} )
4188                              } );
4189
4190   }
4191
4192   return 0;
4193
4194 }
4195
4196
4197 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
4198
4199 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
4200 via a Business::OnlinePayment realtime gateway.  See
4201 L<http://420.am/business-onlinepayment> for supported gateways.
4202
4203 Available methods are: I<CC>, I<ECHECK> and I<LEC>
4204
4205 Available options are: I<amount>, I<reason>, I<paynum>, I<paydate>
4206
4207 Most gateways require a reference to an original payment transaction to refund,
4208 so you probably need to specify a I<paynum>.
4209
4210 I<amount> defaults to the original amount of the payment if not specified.
4211
4212 I<reason> specifies a reason for the refund.
4213
4214 I<paydate> specifies the expiration date for a credit card overriding the
4215 value from the customer record or the payment record. Specified as yyyy-mm-dd
4216
4217 Implementation note: If I<amount> is unspecified or equal to the amount of the
4218 orignal payment, first an attempt is made to "void" the transaction via
4219 the gateway (to cancel a not-yet settled transaction) and then if that fails,
4220 the normal attempt is made to "refund" ("credit") the transaction via the
4221 gateway is attempted.
4222
4223 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
4224 #I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
4225 #if set, will override the value from the customer record.
4226
4227 #If an I<invnum> is specified, this payment (if successful) is applied to the
4228 #specified invoice.  If you don't specify an I<invnum> you might want to
4229 #call the B<apply_payments> method.
4230
4231 =cut
4232
4233 #some false laziness w/realtime_bop, not enough to make it worth merging
4234 #but some useful small subs should be pulled out
4235 sub realtime_refund_bop {
4236   my $self = shift;
4237
4238   return $self->_new_realtime_refund_bop(@_)
4239     if $self->_new_bop_required();
4240
4241   my( $method, %options ) = @_;
4242   if ( $DEBUG ) {
4243     warn "$me realtime_refund_bop: $method refund\n";
4244     warn "  $_ => $options{$_}\n" foreach keys %options;
4245   }
4246
4247   eval "use Business::OnlinePayment";
4248   die $@ if $@;
4249
4250   ###
4251   # look up the original payment and optionally a gateway for that payment
4252   ###
4253
4254   my $cust_pay = '';
4255   my $amount = $options{'amount'};
4256
4257   my( $processor, $login, $password, @bop_options ) ;
4258   my( $auth, $order_number ) = ( '', '', '' );
4259
4260   if ( $options{'paynum'} ) {
4261
4262     warn "  paynum: $options{paynum}\n" if $DEBUG > 1;
4263     $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
4264       or return "Unknown paynum $options{'paynum'}";
4265     $amount ||= $cust_pay->paid;
4266
4267     $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-\/ ]*)(:([\w\-]+))?$/
4268       or return "Can't parse paybatch for paynum $options{'paynum'}: ".
4269                 $cust_pay->paybatch;
4270     my $gatewaynum = '';
4271     ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
4272
4273     if ( $gatewaynum ) { #gateway for the payment to be refunded
4274
4275       my $payment_gateway =
4276         qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
4277       die "payment gateway $gatewaynum not found"
4278         unless $payment_gateway;
4279
4280       $processor   = $payment_gateway->gateway_module;
4281       $login       = $payment_gateway->gateway_username;
4282       $password    = $payment_gateway->gateway_password;
4283       @bop_options = $payment_gateway->options;
4284
4285     } else { #try the default gateway
4286
4287       my( $conf_processor, $unused_action );
4288       ( $conf_processor, $login, $password, $unused_action, @bop_options ) =
4289         $self->default_payment_gateway($method);
4290
4291       return "processor of payment $options{'paynum'} $processor does not".
4292              " match default processor $conf_processor"
4293         unless $processor eq $conf_processor;
4294
4295     }
4296
4297
4298   } else { # didn't specify a paynum, so look for agent gateway overrides
4299            # like a normal transaction
4300
4301     my $cardtype;
4302     if ( $method eq 'CC' ) {
4303       $cardtype = cardtype($self->payinfo);
4304     } elsif ( $method eq 'ECHECK' ) {
4305       $cardtype = 'ACH';
4306     } else {
4307       $cardtype = $method;
4308     }
4309     my $override =
4310            qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
4311                                                cardtype => $cardtype,
4312                                                taxclass => '',              } )
4313         || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
4314                                                cardtype => '',
4315                                                taxclass => '',              } );
4316
4317     if ( $override ) { #use a payment gateway override
4318
4319       my $payment_gateway = $override->payment_gateway;
4320
4321       $processor   = $payment_gateway->gateway_module;
4322       $login       = $payment_gateway->gateway_username;
4323       $password    = $payment_gateway->gateway_password;
4324       #$action      = $payment_gateway->gateway_action;
4325       @bop_options = $payment_gateway->options;
4326
4327     } else { #use the standard settings from the config
4328
4329       my $unused_action;
4330       ( $processor, $login, $password, $unused_action, @bop_options ) =
4331         $self->default_payment_gateway($method);
4332
4333     }
4334
4335   }
4336   return "neither amount nor paynum specified" unless $amount;
4337
4338   my %content = (
4339     'type'           => $method,
4340     'login'          => $login,
4341     'password'       => $password,
4342     'order_number'   => $order_number,
4343     'amount'         => $amount,
4344     'referer'        => 'http://cleanwhisker.420.am/', #XXX fix referer :/
4345   );
4346   $content{authorization} = $auth
4347     if length($auth); #echeck/ACH transactions have an order # but no auth
4348                       #(at least with authorize.net)
4349
4350   my $disable_void_after;
4351   if ($conf->exists('disable_void_after')
4352       && $conf->config('disable_void_after') =~ /^(\d+)$/) {
4353     $disable_void_after = $1;
4354   }
4355
4356   #first try void if applicable
4357   if ( $cust_pay && $cust_pay->paid == $amount
4358     && (
4359       ( not defined($disable_void_after) )
4360       || ( time < ($cust_pay->_date + $disable_void_after ) )
4361     )
4362   ) {
4363     warn "  attempting void\n" if $DEBUG > 1;
4364     my $void = new Business::OnlinePayment( $processor, @bop_options );
4365     $void->content( 'action' => 'void', %content );
4366     $void->submit();
4367     if ( $void->is_success ) {
4368       my $error = $cust_pay->void($options{'reason'});
4369       if ( $error ) {
4370         # gah, even with transactions.
4371         my $e = 'WARNING: Card/ACH voided but database not updated - '.
4372                 "error voiding payment: $error";
4373         warn $e;
4374         return $e;
4375       }
4376       warn "  void successful\n" if $DEBUG > 1;
4377       return '';
4378     }
4379   }
4380
4381   warn "  void unsuccessful, trying refund\n"
4382     if $DEBUG > 1;
4383
4384   #massage data
4385   my $address = $self->address1;
4386   $address .= ", ". $self->address2 if $self->address2;
4387
4388   my($payname, $payfirst, $paylast);
4389   if ( $self->payname && $method ne 'ECHECK' ) {
4390     $payname = $self->payname;
4391     $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
4392       or return "Illegal payname $payname";
4393     ($payfirst, $paylast) = ($1, $2);
4394   } else {
4395     $payfirst = $self->getfield('first');
4396     $paylast = $self->getfield('last');
4397     $payname =  "$payfirst $paylast";
4398   }
4399
4400   my @invoicing_list = $self->invoicing_list_emailonly;
4401   if ( $conf->exists('emailinvoiceautoalways')
4402        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
4403        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
4404     push @invoicing_list, $self->all_emails;
4405   }
4406
4407   my $email = ($conf->exists('business-onlinepayment-email-override'))
4408               ? $conf->config('business-onlinepayment-email-override')
4409               : $invoicing_list[0];
4410
4411   my $payip = exists($options{'payip'})
4412                 ? $options{'payip'}
4413                 : $self->payip;
4414   $content{customer_ip} = $payip
4415     if length($payip);
4416
4417   my $payinfo = '';
4418   if ( $method eq 'CC' ) {
4419
4420     if ( $cust_pay ) {
4421       $content{card_number} = $payinfo = $cust_pay->payinfo;
4422       (exists($options{'paydate'}) ? $options{'paydate'} : $cust_pay->paydate)
4423         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/ &&
4424         ($content{expiration} = "$2/$1");  # where available
4425     } else {
4426       $content{card_number} = $payinfo = $self->payinfo;
4427       (exists($options{'paydate'}) ? $options{'paydate'} : $self->paydate)
4428         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
4429       $content{expiration} = "$2/$1";
4430     }
4431
4432   } elsif ( $method eq 'ECHECK' ) {
4433
4434     if ( $cust_pay ) {
4435       $payinfo = $cust_pay->payinfo;
4436     } else {
4437       $payinfo = $self->payinfo;
4438     }
4439     ( $content{account_number}, $content{routing_code} )= split('@', $payinfo );
4440     $content{bank_name} = $self->payname;
4441     $content{account_type} = 'CHECKING';
4442     $content{account_name} = $payname;
4443     $content{customer_org} = $self->company ? 'B' : 'I';
4444     $content{customer_ssn} = $self->ss;
4445   } elsif ( $method eq 'LEC' ) {
4446     $content{phone} = $payinfo = $self->payinfo;
4447   }
4448
4449   #then try refund
4450   my $refund = new Business::OnlinePayment( $processor, @bop_options );
4451   my %sub_content = $refund->content(
4452     'action'         => 'credit',
4453     'customer_id'    => $self->custnum,
4454     'last_name'      => $paylast,
4455     'first_name'     => $payfirst,
4456     'name'           => $payname,
4457     'address'        => $address,
4458     'city'           => $self->city,
4459     'state'          => $self->state,
4460     'zip'            => $self->zip,
4461     'country'        => $self->country,
4462     'email'          => $email,
4463     'phone'          => $self->daytime || $self->night,
4464     %content, #after
4465   );
4466   warn join('', map { "  $_ => $sub_content{$_}\n" } keys %sub_content )
4467     if $DEBUG > 1;
4468   $refund->submit();
4469
4470   return "$processor error: ". $refund->error_message
4471     unless $refund->is_success();
4472
4473   my %method2payby = (
4474     'CC'     => 'CARD',
4475     'ECHECK' => 'CHEK',
4476     'LEC'    => 'LECB',
4477   );
4478
4479   my $paybatch = "$processor:". $refund->authorization;
4480   $paybatch .= ':'. $refund->order_number
4481     if $refund->can('order_number') && $refund->order_number;
4482
4483   while ( $cust_pay && $cust_pay->unapplied < $amount ) {
4484     my @cust_bill_pay = $cust_pay->cust_bill_pay;
4485     last unless @cust_bill_pay;
4486     my $cust_bill_pay = pop @cust_bill_pay;
4487     my $error = $cust_bill_pay->delete;
4488     last if $error;
4489   }
4490
4491   my $cust_refund = new FS::cust_refund ( {
4492     'custnum'  => $self->custnum,
4493     'paynum'   => $options{'paynum'},
4494     'refund'   => $amount,
4495     '_date'    => '',
4496     'payby'    => $method2payby{$method},
4497     'payinfo'  => $payinfo,
4498     'paybatch' => $paybatch,
4499     'reason'   => $options{'reason'} || 'card or ACH refund',
4500   } );
4501   my $error = $cust_refund->insert;
4502   if ( $error ) {
4503     $cust_refund->paynum(''); #try again with no specific paynum
4504     my $error2 = $cust_refund->insert;
4505     if ( $error2 ) {
4506       # gah, even with transactions.
4507       my $e = 'WARNING: Card/ACH refunded but database not updated - '.
4508               "error inserting refund ($processor): $error2".
4509               " (previously tried insert with paynum #$options{'paynum'}" .
4510               ": $error )";
4511       warn $e;
4512       return $e;
4513     }
4514   }
4515
4516   ''; #no error
4517
4518 }
4519
4520 # does the configuration indicate the new bop routines are required?
4521
4522 sub _new_bop_required {
4523   my $self = shift;
4524
4525   my $botpp = 'Business::OnlineThirdPartyPayment';
4526
4527   return 1
4528     if ( $conf->config('business-onlinepayment-namespace') eq $botpp ||
4529          scalar( grep { $_->gateway_namespace eq $botpp }
4530                  qsearch( 'payment_gateway', { 'disabled' => '' } )
4531                )
4532        )
4533   ;
4534
4535   '';
4536 }
4537
4538
4539 =item realtime_collect [ OPTION => VALUE ... ]
4540
4541 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
4542 via a Business::OnlinePayment or Business::OnlineThirdPartyPayment realtime
4543 gateway.  See L<http://420.am/business-onlinepayment> and
4544 L<http://420.am/business-onlinethirdpartypayment> for supported gateways.
4545
4546 On failure returns an error message.
4547
4548 Returns false or a hashref upon success.  The hashref contains keys popup_url reference, and collectitems.  The first is a URL to which a browser should be redirected for completion of collection.  The second is a reference id for the transaction suitable for the end user.  The collectitems is a reference to a list of name value pairs suitable for assigning to a html form and posted to popup_url.
4549
4550 Available options are: I<method>, I<amount>, I<description>, I<invnum>, I<quiet>, I<paynum_ref>, I<payunique>, I<session_id>
4551
4552 I<method> is one of: I<CC>, I<ECHECK> and I<LEC>.  If none is specified
4553 then it is deduced from the customer record.
4554
4555 If no I<amount> is specified, then the customer balance is used.
4556
4557 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
4558 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
4559 if set, will override the value from the customer record.
4560
4561 I<description> is a free-text field passed to the gateway.  It defaults to
4562 "Internet services".
4563
4564 If an I<invnum> is specified, this payment (if successful) is applied to the
4565 specified invoice.  If you don't specify an I<invnum> you might want to
4566 call the B<apply_payments> method.
4567
4568 I<quiet> can be set true to surpress email decline notices.
4569
4570 I<paynum_ref> can be set to a scalar reference.  It will be filled in with the
4571 resulting paynum, if any.
4572
4573 I<payunique> is a unique identifier for this payment.
4574
4575 I<session_id> is a session identifier associated with this payment.
4576
4577 I<depend_jobnum> allows payment capture to unlock export jobs
4578
4579 =cut
4580
4581 sub realtime_collect {
4582   my( $self, %options ) = @_;
4583
4584   if ( $DEBUG ) {
4585     warn "$me realtime_collect:\n";
4586     warn "  $_ => $options{$_}\n" foreach keys %options;
4587   }
4588
4589   $options{amount} = $self->balance unless exists( $options{amount} );
4590   $options{method} = FS::payby->payby2bop($self->payby)
4591     unless exists( $options{method} );
4592
4593   return $self->realtime_bop({%options});
4594
4595 }
4596
4597 =item _realtime_bop { [ ARG => VALUE ... ] }
4598
4599 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
4600 via a Business::OnlinePayment realtime gateway.  See
4601 L<http://420.am/business-onlinepayment> for supported gateways.
4602
4603 Required arguments in the hashref are I<method>, and I<amount>
4604
4605 Available methods are: I<CC>, I<ECHECK> and I<LEC>
4606
4607 Available optional arguments are: I<description>, I<invnum>, I<quiet>, I<paynum_ref>, I<payunique>, I<session_id>
4608
4609 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
4610 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
4611 if set, will override the value from the customer record.
4612
4613 I<description> is a free-text field passed to the gateway.  It defaults to
4614 "Internet services".
4615
4616 If an I<invnum> is specified, this payment (if successful) is applied to the
4617 specified invoice.  If you don't specify an I<invnum> you might want to
4618 call the B<apply_payments> method.
4619
4620 I<quiet> can be set true to surpress email decline notices.
4621
4622 I<paynum_ref> can be set to a scalar reference.  It will be filled in with the
4623 resulting paynum, if any.
4624
4625 I<payunique> is a unique identifier for this payment.
4626
4627 I<session_id> is a session identifier associated with this payment.
4628
4629 I<depend_jobnum> allows payment capture to unlock export jobs
4630
4631 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
4632
4633 =cut
4634
4635 # some helper routines
4636 sub _payment_gateway {
4637   my ($self, $options) = @_;
4638
4639   $options->{payment_gateway} = $self->agent->payment_gateway( %$options )
4640     unless exists($options->{payment_gateway});
4641
4642   $options->{payment_gateway};
4643 }
4644
4645 sub _bop_auth {
4646   my ($self, $options) = @_;
4647
4648   (
4649     'login'    => $options->{payment_gateway}->gateway_username,
4650     'password' => $options->{payment_gateway}->gateway_password,
4651   );
4652 }
4653
4654 sub _bop_options {
4655   my ($self, $options) = @_;
4656
4657   $options->{payment_gateway}->gatewaynum
4658     ? $options->{payment_gateway}->options
4659     : @{ $options->{payment_gateway}->get('options') };
4660 }
4661
4662 sub _bop_defaults {
4663   my ($self, $options) = @_;
4664
4665   $options->{description} ||= 'Internet services';
4666   $options->{payinfo} = $self->payinfo unless exists( $options->{payinfo} );
4667   $options->{invnum} ||= '';
4668   $options->{payname} = $self->payname unless exists( $options->{payname} );
4669 }
4670
4671 sub _bop_content {
4672   my ($self, $options) = @_;
4673   my %content = ();
4674
4675   $content{address} = exists($options->{'address1'})
4676                         ? $options->{'address1'}
4677                         : $self->address1;
4678   my $address2 = exists($options->{'address2'})
4679                    ? $options->{'address2'}
4680                    : $self->address2;
4681   $content{address} .= ", ". $address2 if length($address2);
4682
4683   my $payip = exists($options->{'payip'}) ? $options->{'payip'} : $self->payip;
4684   $content{customer_ip} = $payip if length($payip);
4685
4686   $content{invoice_number} = $options->{'invnum'}
4687     if exists($options->{'invnum'}) && length($options->{'invnum'});
4688
4689   $content{email_customer} =
4690     (    $conf->exists('business-onlinepayment-email_customer')
4691       || $conf->exists('business-onlinepayment-email-override') );
4692
4693   $content{payfirst} = $self->getfield('first');
4694   $content{paylast} = $self->getfield('last');
4695
4696   $content{account_name} = "$content{payfirst} $content{paylast}"
4697     if $options->{method} eq 'ECHECK';
4698
4699   $content{name} = $options->{payname};
4700   $content{name} = $content{account_name} if exists($content{account_name});
4701
4702   $content{city} = exists($options->{city})
4703                      ? $options->{city}
4704                      : $self->city;
4705   $content{state} = exists($options->{state})
4706                       ? $options->{state}
4707                       : $self->state;
4708   $content{zip} = exists($options->{zip})
4709                     ? $options->{'zip'}
4710                     : $self->zip;
4711   $content{country} = exists($options->{country})
4712                         ? $options->{country}
4713                         : $self->country;
4714   $content{referer} = 'http://cleanwhisker.420.am/'; #XXX fix referer :/
4715   $content{phone} = $self->daytime || $self->night;
4716
4717   (%content);
4718 }
4719
4720 my %bop_method2payby = (
4721   'CC'     => 'CARD',
4722   'ECHECK' => 'CHEK',
4723   'LEC'    => 'LECB',
4724 );
4725
4726 sub _new_realtime_bop {
4727   my $self = shift;
4728
4729   my %options = ();
4730   if (ref($_[0]) eq 'HASH') {
4731     %options = %{$_[0]};
4732   } else {
4733     my ( $method, $amount ) = ( shift, shift );
4734     %options = @_;
4735     $options{method} = $method;
4736     $options{amount} = $amount;
4737   }
4738
4739   if ( $DEBUG ) {
4740     warn "$me realtime_bop (new): $options{method} $options{amount}\n";
4741     warn "  $_ => $options{$_}\n" foreach keys %options;
4742   }
4743
4744   return $self->fake_bop(%options) if $options{'fake'};
4745
4746   $self->_bop_defaults(\%options);
4747
4748   ###
4749   # set trans_is_recur based on invnum if there is one
4750   ###
4751
4752   my $trans_is_recur = 0;
4753   if ( $options{'invnum'} ) {
4754
4755     my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
4756     die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
4757
4758     my @part_pkg =
4759       map  { $_->part_pkg }
4760       grep { $_ }
4761       map  { $_->cust_pkg }
4762       $cust_bill->cust_bill_pkg;
4763
4764     $trans_is_recur = 1
4765       if grep { $_->freq ne '0' } @part_pkg;
4766
4767   }
4768
4769   ###
4770   # select a gateway
4771   ###
4772
4773   my $payment_gateway =  $self->_payment_gateway( \%options );
4774   my $namespace = $payment_gateway->gateway_namespace;
4775
4776   eval "use $namespace";
4777   die $@ if $@;
4778
4779   ###
4780   # check for banned credit card/ACH
4781   ###
4782
4783   my $ban = qsearchs('banned_pay', {
4784     'payby'   => $bop_method2payby{$options{method}},
4785     'payinfo' => md5_base64($options{payinfo}),
4786   } );
4787   return "Banned credit card" if $ban;
4788
4789   ###
4790   # massage data
4791   ###
4792
4793   my (%bop_content) = $self->_bop_content(\%options);
4794
4795   if ( $options{method} ne 'ECHECK' ) {
4796     $options{payname} =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
4797       or return "Illegal payname $options{payname}";
4798     ($bop_content{payfirst}, $bop_content{paylast}) = ($1, $2);
4799   }
4800
4801   my @invoicing_list = $self->invoicing_list_emailonly;
4802   if ( $conf->exists('emailinvoiceautoalways')
4803        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
4804        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
4805     push @invoicing_list, $self->all_emails;
4806   }
4807
4808   my $email = ($conf->exists('business-onlinepayment-email-override'))
4809               ? $conf->config('business-onlinepayment-email-override')
4810               : $invoicing_list[0];
4811
4812   my $paydate = '';
4813   my %content = ();
4814   if ( $namespace eq 'Business::OnlinePayment' && $options{method} eq 'CC' ) {
4815
4816     $content{card_number} = $options{payinfo};
4817     $paydate = exists($options{'paydate'})
4818                     ? $options{'paydate'}
4819                     : $self->paydate;
4820     $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
4821     $content{expiration} = "$2/$1";
4822
4823     my $paycvv = exists($options{'paycvv'})
4824                    ? $options{'paycvv'}
4825                    : $self->paycvv;
4826     $content{cvv2} = $paycvv
4827       if length($paycvv);
4828
4829     my $paystart_month = exists($options{'paystart_month'})
4830                            ? $options{'paystart_month'}
4831                            : $self->paystart_month;
4832
4833     my $paystart_year  = exists($options{'paystart_year'})
4834                            ? $options{'paystart_year'}
4835                            : $self->paystart_year;
4836
4837     $content{card_start} = "$paystart_month/$paystart_year"
4838       if $paystart_month && $paystart_year;
4839
4840     my $payissue       = exists($options{'payissue'})
4841                            ? $options{'payissue'}
4842                            : $self->payissue;
4843     $content{issue_number} = $payissue if $payissue;
4844
4845     if ( $self->_bop_recurring_billing( 'payinfo'        => $options{'payinfo'},
4846                                         'trans_is_recur' => $trans_is_recur,
4847                                       )
4848        )
4849     {
4850       $content{recurring_billing} = 'YES';
4851       $content{acct_code} = 'rebill'
4852         if $conf->exists('credit_card-recurring_billing_acct_code');
4853     }
4854
4855   } elsif ( $namespace eq 'Business::OnlinePayment' && $options{method} eq 'ECHECK' ){
4856     ( $content{account_number}, $content{routing_code} ) =
4857       split('@', $options{payinfo});
4858     $content{bank_name} = $options{payname};
4859     $content{bank_state} = exists($options{'paystate'})
4860                              ? $options{'paystate'}
4861                              : $self->getfield('paystate');
4862     $content{account_type} = exists($options{'paytype'})
4863                                ? uc($options{'paytype'}) || 'CHECKING'
4864                                : uc($self->getfield('paytype')) || 'CHECKING';
4865     $content{customer_org} = $self->company ? 'B' : 'I';
4866     $content{state_id}       = exists($options{'stateid'})
4867                                  ? $options{'stateid'}
4868                                  : $self->getfield('stateid');
4869     $content{state_id_state} = exists($options{'stateid_state'})
4870                                  ? $options{'stateid_state'}
4871                                  : $self->getfield('stateid_state');
4872     $content{customer_ssn} = exists($options{'ss'})
4873                                ? $options{'ss'}
4874                                : $self->ss;
4875   } elsif ( $namespace eq 'Business::OnlinePayment' && $options{method} eq 'LEC' ) {
4876     $content{phone} = $options{payinfo};
4877   } elsif ( $namespace eq 'Business::OnlineThirdPartyPayment' ) {
4878     #move along
4879   } else {
4880     #die an evil death
4881   }
4882
4883   ###
4884   # run transaction(s)
4885   ###
4886
4887   my $balance = exists( $options{'balance'} )
4888                   ? $options{'balance'}
4889                   : $self->balance;
4890
4891   $self->select_for_update; #mutex ... just until we get our pending record in
4892
4893   #the checks here are intended to catch concurrent payments
4894   #double-form-submission prevention is taken care of in cust_pay_pending::check
4895
4896   #check the balance
4897   return "The customer's balance has changed; $options{method} transaction aborted."
4898     if $self->balance < $balance;
4899     #&& $self->balance < $options{amount}; #might as well anyway?
4900
4901   #also check and make sure there aren't *other* pending payments for this cust
4902
4903   my @pending = qsearch('cust_pay_pending', {
4904     'custnum' => $self->custnum,
4905     'status'  => { op=>'!=', value=>'done' }
4906   });
4907   return "A payment is already being processed for this customer (".
4908          join(', ', map 'paypendingnum '. $_->paypendingnum, @pending ).
4909          "); $options{method} transaction aborted."
4910     if scalar(@pending);
4911
4912   #okay, good to go, if we're a duplicate, cust_pay_pending will kick us out
4913
4914   my $cust_pay_pending = new FS::cust_pay_pending {
4915     'custnum'           => $self->custnum,
4916     #'invnum'            => $options{'invnum'},
4917     'paid'              => $options{amount},
4918     '_date'             => '',
4919     'payby'             => $bop_method2payby{$options{method}},
4920     'payinfo'           => $options{payinfo},
4921     'paydate'           => $paydate,
4922     'recurring_billing' => $content{recurring_billing},
4923     'status'            => 'new',
4924     'gatewaynum'        => $payment_gateway->gatewaynum || '',
4925     'session_id'        => $options{session_id} || '',
4926     'jobnum'            => $options{depend_jobnum} || '',
4927   };
4928   $cust_pay_pending->payunique( $options{payunique} )
4929     if defined($options{payunique}) && length($options{payunique});
4930   my $cpp_new_err = $cust_pay_pending->insert; #mutex lost when this is inserted
4931   return $cpp_new_err if $cpp_new_err;
4932
4933   my( $action1, $action2 ) =
4934     split( /\s*\,\s*/, $payment_gateway->gateway_action );
4935
4936   my $transaction = new $namespace( $payment_gateway->gateway_module,
4937                                     $self->_bop_options(\%options),
4938                                   );
4939
4940   $transaction->content(
4941     'type'           => $options{method},
4942     $self->_bop_auth(\%options),
4943     'action'         => $action1,
4944     'description'    => $options{'description'},
4945     'amount'         => $options{amount},
4946     #'invoice_number' => $options{'invnum'},
4947     'customer_id'    => $self->custnum,
4948     %bop_content,
4949     'reference'      => $cust_pay_pending->paypendingnum, #for now
4950     'email'          => $email,
4951     %content, #after
4952   );
4953
4954   $cust_pay_pending->status('pending');
4955   my $cpp_pending_err = $cust_pay_pending->replace;
4956   return $cpp_pending_err if $cpp_pending_err;
4957
4958   #config?
4959   my $BOP_TESTING = 0;
4960   my $BOP_TESTING_SUCCESS = 1;
4961
4962   unless ( $BOP_TESTING ) {
4963     $transaction->submit();
4964   } else {
4965     if ( $BOP_TESTING_SUCCESS ) {
4966       $transaction->is_success(1);
4967       $transaction->authorization('fake auth');
4968     } else {
4969       $transaction->is_success(0);
4970       $transaction->error_message('fake failure');
4971     }
4972   }
4973
4974   if ( $transaction->is_success() && $namespace eq 'Business::OnlineThirdPartyPayment' ) {
4975
4976     return { reference => $cust_pay_pending->paypendingnum,
4977              map { $_ => $transaction->$_ } qw ( popup_url collectitems ) };
4978
4979   } elsif ( $transaction->is_success() && $action2 ) {
4980
4981     $cust_pay_pending->status('authorized');
4982     my $cpp_authorized_err = $cust_pay_pending->replace;
4983     return $cpp_authorized_err if $cpp_authorized_err;
4984
4985     my $auth = $transaction->authorization;
4986     my $ordernum = $transaction->can('order_number')
4987                    ? $transaction->order_number
4988                    : '';
4989
4990     my $capture =
4991       new Business::OnlinePayment( $payment_gateway->gateway_module,
4992                                    $self->_bop_options(\%options),
4993                                  );
4994
4995     my %capture = (
4996       %content,
4997       type           => $options{method},
4998       action         => $action2,
4999       $self->_bop_auth(\%options),
5000       order_number   => $ordernum,
5001       amount         => $options{amount},
5002       authorization  => $auth,
5003       description    => $options{'description'},
5004     );
5005
5006     foreach my $field (qw( authorization_source_code returned_ACI
5007                            transaction_identifier validation_code
5008                            transaction_sequence_num local_transaction_date
5009                            local_transaction_time AVS_result_code          )) {
5010       $capture{$field} = $transaction->$field() if $transaction->can($field);
5011     }
5012
5013     $capture->content( %capture );
5014
5015     $capture->submit();
5016
5017     unless ( $capture->is_success ) {
5018       my $e = "Authorization successful but capture failed, custnum #".
5019               $self->custnum. ': '.  $capture->result_code.
5020               ": ". $capture->error_message;
5021       warn $e;
5022       return $e;
5023     }
5024
5025   }
5026
5027   ###
5028   # remove paycvv after initial transaction
5029   ###
5030
5031   #false laziness w/misc/process/payment.cgi - check both to make sure working
5032   # correctly
5033   if ( defined $self->dbdef_table->column('paycvv')
5034        && length($self->paycvv)
5035        && ! grep { $_ eq cardtype($options{payinfo}) } $conf->config('cvv-save')
5036   ) {
5037     my $error = $self->remove_cvv;
5038     if ( $error ) {
5039       warn "WARNING: error removing cvv: $error\n";
5040     }
5041   }
5042
5043   ###
5044   # result handling
5045   ###
5046
5047   $self->_realtime_bop_result( $cust_pay_pending, $transaction, %options );
5048
5049 }
5050
5051 =item fake_bop
5052
5053 =cut
5054
5055 sub fake_bop {
5056   my $self = shift;
5057
5058   my %options = ();
5059   if (ref($_[0]) eq 'HASH') {
5060     %options = %{$_[0]};
5061   } else {
5062     my ( $method, $amount ) = ( shift, shift );
5063     %options = @_;
5064     $options{method} = $method;
5065     $options{amount} = $amount;
5066   }
5067
5068   if ( $options{'fake_failure'} ) {
5069      return "Error: No error; test failure requested with fake_failure";
5070   }
5071
5072   #my $paybatch = '';
5073   #if ( $payment_gateway->gatewaynum ) { # agent override
5074   #  $paybatch = $payment_gateway->gatewaynum. '-';
5075   #}
5076   #
5077   #$paybatch .= "$processor:". $transaction->authorization;
5078   #
5079   #$paybatch .= ':'. $transaction->order_number
5080   #  if $transaction->can('order_number')
5081   #  && length($transaction->order_number);
5082
5083   my $paybatch = 'FakeProcessor:54:32';
5084
5085   my $cust_pay = new FS::cust_pay ( {
5086      'custnum'  => $self->custnum,
5087      'invnum'   => $options{'invnum'},
5088      'paid'     => $options{amount},
5089      '_date'    => '',
5090      'payby'    => $bop_method2payby{$options{method}},
5091      #'payinfo'  => $payinfo,
5092      'payinfo'  => '4111111111111111',
5093      'paybatch' => $paybatch,
5094      #'paydate'  => $paydate,
5095      'paydate'  => '2012-05-01',
5096   } );
5097   $cust_pay->payunique( $options{payunique} ) if length($options{payunique});
5098
5099   my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
5100
5101   if ( $error ) {
5102     $cust_pay->invnum(''); #try again with no specific invnum
5103     my $error2 = $cust_pay->insert( $options{'manual'} ?
5104                                     ( 'manual' => 1 ) : ()
5105                                   );
5106     if ( $error2 ) {
5107       # gah, even with transactions.
5108       my $e = 'WARNING: Card/ACH debited but database not updated - '.
5109               "error inserting (fake!) payment: $error2".
5110               " (previously tried insert with invnum #$options{'invnum'}" .
5111               ": $error )";
5112       warn $e;
5113       return $e;
5114     }
5115   }
5116
5117   if ( $options{'paynum_ref'} ) {
5118     ${ $options{'paynum_ref'} } = $cust_pay->paynum;
5119   }
5120
5121   return ''; #no error
5122
5123 }
5124
5125
5126 # item _realtime_bop_result CUST_PAY_PENDING, BOP_OBJECT [ OPTION => VALUE ... ]
5127 #
5128 # Wraps up processing of a realtime credit card, ACH (electronic check) or
5129 # phone bill transaction.
5130
5131 sub _realtime_bop_result {
5132   my( $self, $cust_pay_pending, $transaction, %options ) = @_;
5133   if ( $DEBUG ) {
5134     warn "$me _realtime_bop_result: pending transaction ".
5135       $cust_pay_pending->paypendingnum. "\n";
5136     warn "  $_ => $options{$_}\n" foreach keys %options;
5137   }
5138
5139   my $payment_gateway = $options{payment_gateway}
5140     or return "no payment gateway in arguments to _realtime_bop_result";
5141
5142   $cust_pay_pending->status($transaction->is_success() ? 'captured' : 'declined');
5143   my $cpp_captured_err = $cust_pay_pending->replace;
5144   return $cpp_captured_err if $cpp_captured_err;
5145
5146   if ( $transaction->is_success() ) {
5147
5148     my $paybatch = '';
5149     if ( $payment_gateway->gatewaynum ) { # agent override
5150       $paybatch = $payment_gateway->gatewaynum. '-';
5151     }
5152
5153     $paybatch .= $payment_gateway->gateway_module. ":".
5154       $transaction->authorization;
5155
5156     $paybatch .= ':'. $transaction->order_number
5157       if $transaction->can('order_number')
5158       && length($transaction->order_number);
5159
5160     my $cust_pay = new FS::cust_pay ( {
5161        'custnum'  => $self->custnum,
5162        'invnum'   => $options{'invnum'},
5163        'paid'     => $cust_pay_pending->paid,
5164        '_date'    => '',
5165        'payby'    => $cust_pay_pending->payby,
5166        #'payinfo'  => $payinfo,
5167        'paybatch' => $paybatch,
5168        'paydate'  => $cust_pay_pending->paydate,
5169     } );
5170     #doesn't hurt to know, even though the dup check is in cust_pay_pending now
5171     $cust_pay->payunique( $options{payunique} )
5172       if defined($options{payunique}) && length($options{payunique});
5173
5174     my $oldAutoCommit = $FS::UID::AutoCommit;
5175     local $FS::UID::AutoCommit = 0;
5176     my $dbh = dbh;
5177
5178     #start a transaction, insert the cust_pay and set cust_pay_pending.status to done in a single transction
5179
5180     my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
5181
5182     if ( $error ) {
5183       $cust_pay->invnum(''); #try again with no specific invnum
5184       my $error2 = $cust_pay->insert( $options{'manual'} ?
5185                                       ( 'manual' => 1 ) : ()
5186                                     );
5187       if ( $error2 ) {
5188         # gah.  but at least we have a record of the state we had to abort in
5189         # from cust_pay_pending now.
5190         my $e = "WARNING: $options{method} captured but payment not recorded -".
5191                 " error inserting payment (". $payment_gateway->gateway_module.
5192                 "): $error2".
5193                 " (previously tried insert with invnum #$options{'invnum'}" .
5194                 ": $error ) - pending payment saved as paypendingnum ".
5195                 $cust_pay_pending->paypendingnum. "\n";
5196         warn $e;
5197         return $e;
5198       }
5199     }
5200
5201     my $jobnum = $cust_pay_pending->jobnum;
5202     if ( $jobnum ) {
5203        my $placeholder = qsearchs( 'queue', { 'jobnum' => $jobnum } );
5204
5205        unless ( $placeholder ) {
5206          $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
5207          my $e = "WARNING: $options{method} captured but job $jobnum not ".
5208              "found for paypendingnum ". $cust_pay_pending->paypendingnum. "\n";
5209          warn $e;
5210          return $e;
5211        }
5212
5213        $error = $placeholder->delete;
5214
5215        if ( $error ) {
5216          $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
5217          my $e = "WARNING: $options{method} captured but could not delete ".
5218               "job $jobnum for paypendingnum ".
5219               $cust_pay_pending->paypendingnum. ": $error\n";
5220          warn $e;
5221          return $e;
5222        }
5223
5224     }
5225
5226     if ( $options{'paynum_ref'} ) {
5227       ${ $options{'paynum_ref'} } = $cust_pay->paynum;
5228     }
5229
5230     $cust_pay_pending->status('done');
5231     $cust_pay_pending->statustext('captured');
5232     $cust_pay_pending->paynum($cust_pay->paynum);
5233     my $cpp_done_err = $cust_pay_pending->replace;
5234
5235     if ( $cpp_done_err ) {
5236
5237       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
5238       my $e = "WARNING: $options{method} captured but payment not recorded - ".
5239               "error updating status for paypendingnum ".
5240               $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
5241       warn $e;
5242       return $e;
5243
5244     } else {
5245
5246       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5247       return ''; #no error
5248
5249     }
5250
5251   } else {
5252
5253     my $perror = $payment_gateway->gateway_module. " error: ".
5254       $transaction->error_message;
5255
5256     my $jobnum = $cust_pay_pending->jobnum;
5257     if ( $jobnum ) {
5258        my $placeholder = qsearchs( 'queue', { 'jobnum' => $jobnum } );
5259
5260        if ( $placeholder ) {
5261          my $error = $placeholder->depended_delete;
5262          $error ||= $placeholder->delete;
5263          warn "error removing provisioning jobs after declined paypendingnum ".
5264            $cust_pay_pending->paypendingnum. "\n";
5265        } else {
5266          my $e = "error finding job $jobnum for declined paypendingnum ".
5267               $cust_pay_pending->paypendingnum. "\n";
5268          warn $e;
5269        }
5270
5271     }
5272
5273     unless ( $transaction->error_message ) {
5274
5275       my $t_response;
5276       if ( $transaction->can('response_page') ) {
5277         $t_response = {
5278                         'page'    => ( $transaction->can('response_page')
5279                                          ? $transaction->response_page
5280                                          : ''
5281                                      ),
5282                         'code'    => ( $transaction->can('response_code')
5283                                          ? $transaction->response_code
5284                                          : ''
5285                                      ),
5286                         'headers' => ( $transaction->can('response_headers')
5287                                          ? $transaction->response_headers
5288                                          : ''
5289                                      ),
5290                       };
5291       } else {
5292         $t_response .=
5293           "No additional debugging information available for ".
5294             $payment_gateway->gateway_module;
5295       }
5296
5297       $perror .= "No error_message returned from ".
5298                    $payment_gateway->gateway_module. " -- ".
5299                  ( ref($t_response) ? Dumper($t_response) : $t_response );
5300
5301     }
5302
5303     if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
5304          && $conf->exists('emaildecline')
5305          && grep { $_ ne 'POST' } $self->invoicing_list
5306          && ! grep { $transaction->error_message =~ /$_/ }
5307                    $conf->config('emaildecline-exclude')
5308     ) {
5309       my @templ = $conf->config('declinetemplate');
5310       my $template = new Text::Template (
5311         TYPE   => 'ARRAY',
5312         SOURCE => [ map "$_\n", @templ ],
5313       ) or return "($perror) can't create template: $Text::Template::ERROR";
5314       $template->compile()
5315         or return "($perror) can't compile template: $Text::Template::ERROR";
5316
5317       my $templ_hash = { error => $transaction->error_message };
5318
5319       my $error = send_email(
5320         'from'    => $conf->config('invoice_from', $self->agentnum ),
5321         'to'      => [ grep { $_ ne 'POST' } $self->invoicing_list ],
5322         'subject' => 'Your payment could not be processed',
5323         'body'    => [ $template->fill_in(HASH => $templ_hash) ],
5324       );
5325
5326       $perror .= " (also received error sending decline notification: $error)"
5327         if $error;
5328
5329     }
5330
5331     $cust_pay_pending->status('done');
5332     $cust_pay_pending->statustext("declined: $perror");
5333     my $cpp_done_err = $cust_pay_pending->replace;
5334     if ( $cpp_done_err ) {
5335       my $e = "WARNING: $options{method} declined but pending payment not ".
5336               "resolved - error updating status for paypendingnum ".
5337               $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
5338       warn $e;
5339       $perror = "$e ($perror)";
5340     }
5341
5342     return $perror;
5343   }
5344
5345 }
5346
5347 =item realtime_botpp_capture CUST_PAY_PENDING [ OPTION => VALUE ... ]
5348
5349 Verifies successful third party processing of a realtime credit card,
5350 ACH (electronic check) or phone bill transaction via a
5351 Business::OnlineThirdPartyPayment realtime gateway.  See
5352 L<http://420.am/business-onlinethirdpartypayment> for supported gateways.
5353
5354 Available options are: I<description>, I<invnum>, I<quiet>, I<paynum_ref>, I<payunique>
5355
5356 The additional options I<payname>, I<city>, I<state>,
5357 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
5358 if set, will override the value from the customer record.
5359
5360 I<description> is a free-text field passed to the gateway.  It defaults to
5361 "Internet services".
5362
5363 If an I<invnum> is specified, this payment (if successful) is applied to the
5364 specified invoice.  If you don't specify an I<invnum> you might want to
5365 call the B<apply_payments> method.
5366
5367 I<quiet> can be set true to surpress email decline notices.
5368
5369 I<paynum_ref> can be set to a scalar reference.  It will be filled in with the
5370 resulting paynum, if any.
5371
5372 I<payunique> is a unique identifier for this payment.
5373
5374 Returns a hashref containing elements bill_error (which will be undefined
5375 upon success) and session_id of any associated session.
5376
5377 =cut
5378
5379 sub realtime_botpp_capture {
5380   my( $self, $cust_pay_pending, %options ) = @_;
5381   if ( $DEBUG ) {
5382     warn "$me realtime_botpp_capture: pending transaction $cust_pay_pending\n";
5383     warn "  $_ => $options{$_}\n" foreach keys %options;
5384   }
5385
5386   eval "use Business::OnlineThirdPartyPayment";
5387   die $@ if $@;
5388
5389   ###
5390   # select the gateway
5391   ###
5392
5393   my $method = FS::payby->payby2bop($cust_pay_pending->payby);
5394
5395   my $payment_gateway = $cust_pay_pending->gatewaynum
5396     ? qsearchs( 'payment_gateway',
5397                 { gatewaynum => $cust_pay_pending->gatewaynum }
5398               )
5399     : $self->agent->payment_gateway( 'method' => $method,
5400                                      # 'invnum'  => $cust_pay_pending->invnum,
5401                                      # 'payinfo' => $cust_pay_pending->payinfo,
5402                                    );
5403
5404   $options{payment_gateway} = $payment_gateway; # for the helper subs
5405
5406   ###
5407   # massage data
5408   ###
5409
5410   my @invoicing_list = $self->invoicing_list_emailonly;
5411   if ( $conf->exists('emailinvoiceautoalways')
5412        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
5413        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
5414     push @invoicing_list, $self->all_emails;
5415   }
5416
5417   my $email = ($conf->exists('business-onlinepayment-email-override'))
5418               ? $conf->config('business-onlinepayment-email-override')
5419               : $invoicing_list[0];
5420
5421   my %content = ();
5422
5423   $content{email_customer} =
5424     (    $conf->exists('business-onlinepayment-email_customer')
5425       || $conf->exists('business-onlinepayment-email-override') );
5426
5427   ###
5428   # run transaction(s)
5429   ###
5430
5431   my $transaction =
5432     new Business::OnlineThirdPartyPayment( $payment_gateway->gateway_module,
5433                                            $self->_bop_options(\%options),
5434                                          );
5435
5436   $transaction->reference({ %options });
5437
5438   $transaction->content(
5439     'type'           => $method,
5440     $self->_bop_auth(\%options),
5441     'action'         => 'Post Authorization',
5442     'description'    => $options{'description'},
5443     'amount'         => $cust_pay_pending->paid,
5444     #'invoice_number' => $options{'invnum'},
5445     'customer_id'    => $self->custnum,
5446     'referer'        => 'http://cleanwhisker.420.am/',
5447     'reference'      => $cust_pay_pending->paypendingnum,
5448     'email'          => $email,
5449     'phone'          => $self->daytime || $self->night,
5450     %content, #after
5451     # plus whatever is required for bogus capture avoidance
5452   );
5453
5454   $transaction->submit();
5455
5456   my $error =
5457     $self->_realtime_bop_result( $cust_pay_pending, $transaction, %options );
5458
5459   {
5460     bill_error => $error,
5461     session_id => $cust_pay_pending->session_id,
5462   }
5463
5464 }
5465
5466 =item default_payment_gateway DEPRECATED -- use agent->payment_gateway
5467
5468 =cut
5469
5470 sub default_payment_gateway {
5471   my( $self, $method ) = @_;
5472
5473   die "Real-time processing not enabled\n"
5474     unless $conf->exists('business-onlinepayment');
5475
5476   #warn "default_payment_gateway deprecated -- use agent->payment_gateway\n";
5477
5478   #load up config
5479   my $bop_config = 'business-onlinepayment';
5480   $bop_config .= '-ach'
5481     if $method =~ /^(ECHECK|CHEK)$/ && $conf->exists($bop_config. '-ach');
5482   my ( $processor, $login, $password, $action, @bop_options ) =
5483     $conf->config($bop_config);
5484   $action ||= 'normal authorization';
5485   pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
5486   die "No real-time processor is enabled - ".
5487       "did you set the business-onlinepayment configuration value?\n"
5488     unless $processor;
5489
5490   ( $processor, $login, $password, $action, @bop_options )
5491 }
5492
5493 =item remove_cvv
5494
5495 Removes the I<paycvv> field from the database directly.
5496
5497 If there is an error, returns the error, otherwise returns false.
5498
5499 =cut
5500
5501 sub remove_cvv {
5502   my $self = shift;
5503   my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
5504     or return dbh->errstr;
5505   $sth->execute($self->custnum)
5506     or return $sth->errstr;
5507   $self->paycvv('');
5508   '';
5509 }
5510
5511 =item _new_realtime_refund_bop METHOD [ OPTION => VALUE ... ]
5512
5513 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
5514 via a Business::OnlinePayment realtime gateway.  See
5515 L<http://420.am/business-onlinepayment> for supported gateways.
5516
5517 Available methods are: I<CC>, I<ECHECK> and I<LEC>
5518
5519 Available options are: I<amount>, I<reason>, I<paynum>, I<paydate>
5520
5521 Most gateways require a reference to an original payment transaction to refund,
5522 so you probably need to specify a I<paynum>.
5523
5524 I<amount> defaults to the original amount of the payment if not specified.
5525
5526 I<reason> specifies a reason for the refund.
5527
5528 I<paydate> specifies the expiration date for a credit card overriding the
5529 value from the customer record or the payment record. Specified as yyyy-mm-dd
5530
5531 Implementation note: If I<amount> is unspecified or equal to the amount of the
5532 orignal payment, first an attempt is made to "void" the transaction via
5533 the gateway (to cancel a not-yet settled transaction) and then if that fails,
5534 the normal attempt is made to "refund" ("credit") the transaction via the
5535 gateway is attempted.
5536
5537 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
5538 #I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
5539 #if set, will override the value from the customer record.
5540
5541 #If an I<invnum> is specified, this payment (if successful) is applied to the
5542 #specified invoice.  If you don't specify an I<invnum> you might want to
5543 #call the B<apply_payments> method.
5544
5545 =cut
5546
5547 #some false laziness w/realtime_bop, not enough to make it worth merging
5548 #but some useful small subs should be pulled out
5549 sub _new_realtime_refund_bop {
5550   my $self = shift;
5551
5552   my %options = ();
5553   if (ref($_[0]) ne 'HASH') {
5554     %options = %{$_[0]};
5555   } else {
5556     my $method = shift;
5557     %options = @_;
5558     $options{method} = $method;
5559   }
5560
5561   if ( $DEBUG ) {
5562     warn "$me realtime_refund_bop (new): $options{method} refund\n";
5563     warn "  $_ => $options{$_}\n" foreach keys %options;
5564   }
5565
5566   ###
5567   # look up the original payment and optionally a gateway for that payment
5568   ###
5569
5570   my $cust_pay = '';
5571   my $amount = $options{'amount'};
5572
5573   my( $processor, $login, $password, @bop_options, $namespace ) ;
5574   my( $auth, $order_number ) = ( '', '', '' );
5575
5576   if ( $options{'paynum'} ) {
5577
5578     warn "  paynum: $options{paynum}\n" if $DEBUG > 1;
5579     $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
5580       or return "Unknown paynum $options{'paynum'}";
5581     $amount ||= $cust_pay->paid;
5582
5583     $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-\/ ]*)(:([\w\-]+))?$/
5584       or return "Can't parse paybatch for paynum $options{'paynum'}: ".
5585                 $cust_pay->paybatch;
5586     my $gatewaynum = '';
5587     ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
5588
5589     if ( $gatewaynum ) { #gateway for the payment to be refunded
5590
5591       my $payment_gateway =
5592         qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
5593       die "payment gateway $gatewaynum not found"
5594         unless $payment_gateway;
5595
5596       $processor   = $payment_gateway->gateway_module;
5597       $login       = $payment_gateway->gateway_username;
5598       $password    = $payment_gateway->gateway_password;
5599       $namespace   = $payment_gateway->gateway_namespace;
5600       @bop_options = $payment_gateway->options;
5601
5602     } else { #try the default gateway
5603
5604       my $conf_processor;
5605       my $payment_gateway =
5606         $self->agent->payment_gateway('method' => $options{method});
5607
5608       ( $conf_processor, $login, $password, $namespace ) =
5609         map { my $method = "gateway_$_"; $payment_gateway->$method }
5610           qw( module username password namespace );
5611
5612       @bop_options = $payment_gateway->gatewaynum
5613                        ? $payment_gateway->options
5614                        : @{ $payment_gateway->get('options') };
5615
5616       return "processor of payment $options{'paynum'} $processor does not".
5617              " match default processor $conf_processor"
5618         unless $processor eq $conf_processor;
5619
5620     }
5621
5622
5623   } else { # didn't specify a paynum, so look for agent gateway overrides
5624            # like a normal transaction
5625
5626     my $payment_gateway =
5627       $self->agent->payment_gateway( 'method'  => $options{method},
5628                                      #'payinfo' => $payinfo,
5629                                    );
5630     my( $processor, $login, $password, $namespace ) =
5631       map { my $method = "gateway_$_"; $payment_gateway->$method }
5632         qw( module username password namespace );
5633
5634     my @bop_options = $payment_gateway->gatewaynum
5635                         ? $payment_gateway->options
5636                         : @{ $payment_gateway->get('options') };
5637
5638   }
5639   return "neither amount nor paynum specified" unless $amount;
5640
5641   eval "use $namespace";
5642   die $@ if $@;
5643
5644   my %content = (
5645     'type'           => $options{method},
5646     'login'          => $login,
5647     'password'       => $password,
5648     'order_number'   => $order_number,
5649     'amount'         => $amount,
5650     'referer'        => 'http://cleanwhisker.420.am/', #XXX fix referer :/
5651   );
5652   $content{authorization} = $auth
5653     if length($auth); #echeck/ACH transactions have an order # but no auth
5654                       #(at least with authorize.net)
5655
5656   my $disable_void_after;
5657   if ($conf->exists('disable_void_after')
5658       && $conf->config('disable_void_after') =~ /^(\d+)$/) {
5659     $disable_void_after = $1;
5660   }
5661
5662   #first try void if applicable
5663   if ( $cust_pay && $cust_pay->paid == $amount
5664     && (
5665       ( not defined($disable_void_after) )
5666       || ( time < ($cust_pay->_date + $disable_void_after ) )
5667     )
5668   ) {
5669     warn "  attempting void\n" if $DEBUG > 1;
5670     my $void = new Business::OnlinePayment( $processor, @bop_options );
5671     $void->content( 'action' => 'void', %content );
5672     $void->submit();
5673     if ( $void->is_success ) {
5674       my $error = $cust_pay->void($options{'reason'});
5675       if ( $error ) {
5676         # gah, even with transactions.
5677         my $e = 'WARNING: Card/ACH voided but database not updated - '.
5678                 "error voiding payment: $error";
5679         warn $e;
5680         return $e;
5681       }
5682       warn "  void successful\n" if $DEBUG > 1;
5683       return '';
5684     }
5685   }
5686
5687   warn "  void unsuccessful, trying refund\n"
5688     if $DEBUG > 1;
5689
5690   #massage data
5691   my $address = $self->address1;
5692   $address .= ", ". $self->address2 if $self->address2;
5693
5694   my($payname, $payfirst, $paylast);
5695   if ( $self->payname && $options{method} ne 'ECHECK' ) {
5696     $payname = $self->payname;
5697     $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
5698       or return "Illegal payname $payname";
5699     ($payfirst, $paylast) = ($1, $2);
5700   } else {
5701     $payfirst = $self->getfield('first');
5702     $paylast = $self->getfield('last');
5703     $payname =  "$payfirst $paylast";
5704   }
5705
5706   my @invoicing_list = $self->invoicing_list_emailonly;
5707   if ( $conf->exists('emailinvoiceautoalways')
5708        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
5709        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
5710     push @invoicing_list, $self->all_emails;
5711   }
5712
5713   my $email = ($conf->exists('business-onlinepayment-email-override'))
5714               ? $conf->config('business-onlinepayment-email-override')
5715               : $invoicing_list[0];
5716
5717   my $payip = exists($options{'payip'})
5718                 ? $options{'payip'}
5719                 : $self->payip;
5720   $content{customer_ip} = $payip
5721     if length($payip);
5722
5723   my $payinfo = '';
5724   if ( $options{method} eq 'CC' ) {
5725
5726     if ( $cust_pay ) {
5727       $content{card_number} = $payinfo = $cust_pay->payinfo;
5728       (exists($options{'paydate'}) ? $options{'paydate'} : $cust_pay->paydate)
5729         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/ &&
5730         ($content{expiration} = "$2/$1");  # where available
5731     } else {
5732       $content{card_number} = $payinfo = $self->payinfo;
5733       (exists($options{'paydate'}) ? $options{'paydate'} : $self->paydate)
5734         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
5735       $content{expiration} = "$2/$1";
5736     }
5737
5738   } elsif ( $options{method} eq 'ECHECK' ) {
5739
5740     if ( $cust_pay ) {
5741       $payinfo = $cust_pay->payinfo;
5742     } else {
5743       $payinfo = $self->payinfo;
5744     }
5745     ( $content{account_number}, $content{routing_code} )= split('@', $payinfo );
5746     $content{bank_name} = $self->payname;
5747     $content{account_type} = 'CHECKING';
5748     $content{account_name} = $payname;
5749     $content{customer_org} = $self->company ? 'B' : 'I';
5750     $content{customer_ssn} = $self->ss;
5751   } elsif ( $options{method} eq 'LEC' ) {
5752     $content{phone} = $payinfo = $self->payinfo;
5753   }
5754
5755   #then try refund
5756   my $refund = new Business::OnlinePayment( $processor, @bop_options );
5757   my %sub_content = $refund->content(
5758     'action'         => 'credit',
5759     'customer_id'    => $self->custnum,
5760     'last_name'      => $paylast,
5761     'first_name'     => $payfirst,
5762     'name'           => $payname,
5763     'address'        => $address,
5764     'city'           => $self->city,
5765     'state'          => $self->state,
5766     'zip'            => $self->zip,
5767     'country'        => $self->country,
5768     'email'          => $email,
5769     'phone'          => $self->daytime || $self->night,
5770     %content, #after
5771   );
5772   warn join('', map { "  $_ => $sub_content{$_}\n" } keys %sub_content )
5773     if $DEBUG > 1;
5774   $refund->submit();
5775
5776   return "$processor error: ". $refund->error_message
5777     unless $refund->is_success();
5778
5779   my $paybatch = "$processor:". $refund->authorization;
5780   $paybatch .= ':'. $refund->order_number
5781     if $refund->can('order_number') && $refund->order_number;
5782
5783   while ( $cust_pay && $cust_pay->unapplied < $amount ) {
5784     my @cust_bill_pay = $cust_pay->cust_bill_pay;
5785     last unless @cust_bill_pay;
5786     my $cust_bill_pay = pop @cust_bill_pay;
5787     my $error = $cust_bill_pay->delete;
5788     last if $error;
5789   }
5790
5791   my $cust_refund = new FS::cust_refund ( {
5792     'custnum'  => $self->custnum,
5793     'paynum'   => $options{'paynum'},
5794     'refund'   => $amount,
5795     '_date'    => '',
5796     'payby'    => $bop_method2payby{$options{method}},
5797     'payinfo'  => $payinfo,
5798     'paybatch' => $paybatch,
5799     'reason'   => $options{'reason'} || 'card or ACH refund',
5800   } );
5801   my $error = $cust_refund->insert;
5802   if ( $error ) {
5803     $cust_refund->paynum(''); #try again with no specific paynum
5804     my $error2 = $cust_refund->insert;
5805     if ( $error2 ) {
5806       # gah, even with transactions.
5807       my $e = 'WARNING: Card/ACH refunded but database not updated - '.
5808               "error inserting refund ($processor): $error2".
5809               " (previously tried insert with paynum #$options{'paynum'}" .
5810               ": $error )";
5811       warn $e;
5812       return $e;
5813     }
5814   }
5815
5816   ''; #no error
5817
5818 }
5819
5820 =item batch_card OPTION => VALUE...
5821
5822 Adds a payment for this invoice to the pending credit card batch (see
5823 L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value,
5824 runs the payment using a realtime gateway.
5825
5826 =cut
5827
5828 sub batch_card {
5829   my ($self, %options) = @_;
5830
5831   my $amount;
5832   if (exists($options{amount})) {
5833     $amount = $options{amount};
5834   }else{
5835     $amount = sprintf("%.2f", $self->balance - $self->in_transit_payments);
5836   }
5837   return '' unless $amount > 0;
5838
5839   my $invnum = delete $options{invnum};
5840   my $payby = $options{invnum} || $self->payby;  #dubious
5841
5842   if ($options{'realtime'}) {
5843     return $self->realtime_bop( FS::payby->payby2bop($self->payby),
5844                                 $amount,
5845                                 %options,
5846                               );
5847   }
5848
5849   my $oldAutoCommit = $FS::UID::AutoCommit;
5850   local $FS::UID::AutoCommit = 0;
5851   my $dbh = dbh;
5852
5853   #this needs to handle mysql as well as Pg, like svc_acct.pm
5854   #(make it into a common function if folks need to do batching with mysql)
5855   $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE")
5856     or return "Cannot lock pay_batch: " . $dbh->errstr;
5857
5858   my %pay_batch = (
5859     'status' => 'O',
5860     'payby'  => FS::payby->payby2payment($payby),
5861   );
5862
5863   my $pay_batch = qsearchs( 'pay_batch', \%pay_batch );
5864
5865   unless ( $pay_batch ) {
5866     $pay_batch = new FS::pay_batch \%pay_batch;
5867     my $error = $pay_batch->insert;
5868     if ( $error ) {
5869       $dbh->rollback if $oldAutoCommit;
5870       die "error creating new batch: $error\n";
5871     }
5872   }
5873
5874   my $old_cust_pay_batch = qsearchs('cust_pay_batch', {
5875       'batchnum' => $pay_batch->batchnum,
5876       'custnum'  => $self->custnum,
5877   } );
5878
5879   foreach (qw( address1 address2 city state zip country payby payinfo paydate
5880                payname )) {
5881     $options{$_} = '' unless exists($options{$_});
5882   }
5883
5884   my $cust_pay_batch = new FS::cust_pay_batch ( {
5885     'batchnum' => $pay_batch->batchnum,
5886     'invnum'   => $invnum || 0,                    # is there a better value?
5887                                                    # this field should be
5888                                                    # removed...
5889                                                    # cust_bill_pay_batch now
5890     'custnum'  => $self->custnum,
5891     'last'     => $self->getfield('last'),
5892     'first'    => $self->getfield('first'),
5893     'address1' => $options{address1} || $self->address1,
5894     'address2' => $options{address2} || $self->address2,
5895     'city'     => $options{city}     || $self->city,
5896     'state'    => $options{state}    || $self->state,
5897     'zip'      => $options{zip}      || $self->zip,
5898     'country'  => $options{country}  || $self->country,
5899     'payby'    => $options{payby}    || $self->payby,
5900     'payinfo'  => $options{payinfo}  || $self->payinfo,
5901     'exp'      => $options{paydate}  || $self->paydate,
5902     'payname'  => $options{payname}  || $self->payname,
5903     'amount'   => $amount,                         # consolidating
5904   } );
5905
5906   $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum)
5907     if $old_cust_pay_batch;
5908
5909   my $error;
5910   if ($old_cust_pay_batch) {
5911     $error = $cust_pay_batch->replace($old_cust_pay_batch)
5912   } else {
5913     $error = $cust_pay_batch->insert;
5914   }
5915
5916   if ( $error ) {
5917     $dbh->rollback if $oldAutoCommit;
5918     die $error;
5919   }
5920
5921   my $unapplied =   $self->total_unapplied_credits
5922                   + $self->total_unapplied_payments
5923                   + $self->in_transit_payments;
5924   foreach my $cust_bill ($self->open_cust_bill) {
5925     #$dbh->commit or die $dbh->errstr if $oldAutoCommit;
5926     my $cust_bill_pay_batch = new FS::cust_bill_pay_batch {
5927       'invnum' => $cust_bill->invnum,
5928       'paybatchnum' => $cust_pay_batch->paybatchnum,
5929       'amount' => $cust_bill->owed,
5930       '_date' => time,
5931     };
5932     if ($unapplied >= $cust_bill_pay_batch->amount){
5933       $unapplied -= $cust_bill_pay_batch->amount;
5934       next;
5935     }else{
5936       $cust_bill_pay_batch->amount(sprintf ( "%.2f",
5937                                    $cust_bill_pay_batch->amount - $unapplied ));      $unapplied = 0;
5938     }
5939     $error = $cust_bill_pay_batch->insert;
5940     if ( $error ) {
5941       $dbh->rollback if $oldAutoCommit;
5942       die $error;
5943     }
5944   }
5945
5946   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5947   '';
5948 }
5949
5950 =item apply_payments_and_credits
5951
5952 Applies unapplied payments and credits.
5953
5954 In most cases, this new method should be used in place of sequential
5955 apply_payments and apply_credits methods.
5956
5957 If there is an error, returns the error, otherwise returns false.
5958
5959 =cut
5960
5961 sub apply_payments_and_credits {
5962   my $self = shift;
5963
5964   local $SIG{HUP} = 'IGNORE';
5965   local $SIG{INT} = 'IGNORE';
5966   local $SIG{QUIT} = 'IGNORE';
5967   local $SIG{TERM} = 'IGNORE';
5968   local $SIG{TSTP} = 'IGNORE';
5969   local $SIG{PIPE} = 'IGNORE';
5970
5971   my $oldAutoCommit = $FS::UID::AutoCommit;
5972   local $FS::UID::AutoCommit = 0;
5973   my $dbh = dbh;
5974
5975   $self->select_for_update; #mutex
5976
5977   foreach my $cust_bill ( $self->open_cust_bill ) {
5978     my $error = $cust_bill->apply_payments_and_credits;
5979     if ( $error ) {
5980       $dbh->rollback if $oldAutoCommit;
5981       return "Error applying: $error";
5982     }
5983   }
5984
5985   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5986   ''; #no error
5987
5988 }
5989
5990 =item apply_credits OPTION => VALUE ...
5991
5992 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
5993 to outstanding invoice balances in chronological order (or reverse
5994 chronological order if the I<order> option is set to B<newest>) and returns the
5995 value of any remaining unapplied credits available for refund (see
5996 L<FS::cust_refund>).
5997
5998 Dies if there is an error.
5999
6000 =cut
6001
6002 sub apply_credits {
6003   my $self = shift;
6004   my %opt = @_;
6005
6006   local $SIG{HUP} = 'IGNORE';
6007   local $SIG{INT} = 'IGNORE';
6008   local $SIG{QUIT} = 'IGNORE';
6009   local $SIG{TERM} = 'IGNORE';
6010   local $SIG{TSTP} = 'IGNORE';
6011   local $SIG{PIPE} = 'IGNORE';
6012
6013   my $oldAutoCommit = $FS::UID::AutoCommit;
6014   local $FS::UID::AutoCommit = 0;
6015   my $dbh = dbh;
6016
6017   $self->select_for_update; #mutex
6018
6019   unless ( $self->total_unapplied_credits ) {
6020     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6021     return 0;
6022   }
6023
6024   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
6025       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
6026
6027   my @invoices = $self->open_cust_bill;
6028   @invoices = sort { $b->_date <=> $a->_date } @invoices
6029     if defined($opt{'order'}) && $opt{'order'} eq 'newest';
6030
6031   my $credit;
6032   foreach my $cust_bill ( @invoices ) {
6033     my $amount;
6034
6035     if ( !defined($credit) || $credit->credited == 0) {
6036       $credit = pop @credits or last;
6037     }
6038
6039     if ($cust_bill->owed >= $credit->credited) {
6040       $amount=$credit->credited;
6041     }else{
6042       $amount=$cust_bill->owed;
6043     }
6044
6045     my $cust_credit_bill = new FS::cust_credit_bill ( {
6046       'crednum' => $credit->crednum,
6047       'invnum'  => $cust_bill->invnum,
6048       'amount'  => $amount,
6049     } );
6050     my $error = $cust_credit_bill->insert;
6051     if ( $error ) {
6052       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
6053       die $error;
6054     }
6055
6056     redo if ($cust_bill->owed > 0);
6057
6058   }
6059
6060   my $total_unapplied_credits = $self->total_unapplied_credits;
6061
6062   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6063
6064   return $total_unapplied_credits;
6065 }
6066
6067 =item apply_payments
6068
6069 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
6070 to outstanding invoice balances in chronological order.
6071
6072  #and returns the value of any remaining unapplied payments.
6073
6074 Dies if there is an error.
6075
6076 =cut
6077
6078 sub apply_payments {
6079   my $self = shift;
6080
6081   local $SIG{HUP} = 'IGNORE';
6082   local $SIG{INT} = 'IGNORE';
6083   local $SIG{QUIT} = 'IGNORE';
6084   local $SIG{TERM} = 'IGNORE';
6085   local $SIG{TSTP} = 'IGNORE';
6086   local $SIG{PIPE} = 'IGNORE';
6087
6088   my $oldAutoCommit = $FS::UID::AutoCommit;
6089   local $FS::UID::AutoCommit = 0;
6090   my $dbh = dbh;
6091
6092   $self->select_for_update; #mutex
6093
6094   #return 0 unless
6095
6096   my @payments = sort { $b->_date <=> $a->_date }
6097                  grep { $_->unapplied > 0 }
6098                  $self->cust_pay;
6099
6100   my @invoices = sort { $a->_date <=> $b->_date}
6101                  grep { $_->owed > 0 }
6102                  $self->cust_bill;
6103
6104   my $payment;
6105
6106   foreach my $cust_bill ( @invoices ) {
6107     my $amount;
6108
6109     if ( !defined($payment) || $payment->unapplied == 0 ) {
6110       $payment = pop @payments or last;
6111     }
6112
6113     if ( $cust_bill->owed >= $payment->unapplied ) {
6114       $amount = $payment->unapplied;
6115     } else {
6116       $amount = $cust_bill->owed;
6117     }
6118
6119     my $cust_bill_pay = new FS::cust_bill_pay ( {
6120       'paynum' => $payment->paynum,
6121       'invnum' => $cust_bill->invnum,
6122       'amount' => $amount,
6123     } );
6124     my $error = $cust_bill_pay->insert;
6125     if ( $error ) {
6126       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
6127       die $error;
6128     }
6129
6130     redo if ( $cust_bill->owed > 0);
6131
6132   }
6133
6134   my $total_unapplied_payments = $self->total_unapplied_payments;
6135
6136   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6137
6138   return $total_unapplied_payments;
6139 }
6140
6141 =item total_owed
6142
6143 Returns the total owed for this customer on all invoices
6144 (see L<FS::cust_bill/owed>).
6145
6146 =cut
6147
6148 sub total_owed {
6149   my $self = shift;
6150   $self->total_owed_date(2145859200); #12/31/2037
6151 }
6152
6153 =item total_owed_date TIME
6154
6155 Returns the total owed for this customer on all invoices with date earlier than
6156 TIME.  TIME is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also
6157 see L<Time::Local> and L<Date::Parse> for conversion functions.
6158
6159 =cut
6160
6161 sub total_owed_date {
6162   my $self = shift;
6163   my $time = shift;
6164
6165 #  my $custnum = $self->custnum;
6166 #
6167 #  my $owed_sql = FS::cust_bill->owed_sql;
6168 #
6169 #  my $sql = "
6170 #    SELECT SUM($owed_sql) FROM cust_bill
6171 #      WHERE custnum = $custnum
6172 #        AND _date <= $time
6173 #  ";
6174 #
6175 #  my $sth = dbh->prepare($sql) or die dbh->errstr;
6176 #  $sth->execute() or die $sth->errstr;
6177 #
6178 #  return sprintf( '%.2f', $sth->fetchrow_arrayref->[0] );
6179
6180   my $total_bill = 0;
6181   foreach my $cust_bill (
6182     grep { $_->_date <= $time }
6183       qsearch('cust_bill', { 'custnum' => $self->custnum, } )
6184   ) {
6185     $total_bill += $cust_bill->owed;
6186   }
6187   sprintf( "%.2f", $total_bill );
6188
6189 }
6190
6191 =item total_paid
6192
6193 Returns the total amount of all payments.
6194
6195 =cut
6196
6197 sub total_paid {
6198   my $self = shift;
6199   my $total = 0;
6200   $total += $_->paid foreach $self->cust_pay;
6201   sprintf( "%.2f", $total );
6202 }
6203
6204 =item total_unapplied_credits
6205
6206 Returns the total outstanding credit (see L<FS::cust_credit>) for this
6207 customer.  See L<FS::cust_credit/credited>.
6208
6209 =item total_credited
6210
6211 Old name for total_unapplied_credits.  Don't use.
6212
6213 =cut
6214
6215 sub total_credited {
6216   #carp "total_credited deprecated, use total_unapplied_credits";
6217   shift->total_unapplied_credits(@_);
6218 }
6219
6220 sub total_unapplied_credits {
6221   my $self = shift;
6222   my $total_credit = 0;
6223   $total_credit += $_->credited foreach $self->cust_credit;
6224   sprintf( "%.2f", $total_credit );
6225 }
6226
6227 =item total_unapplied_payments
6228
6229 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
6230 See L<FS::cust_pay/unapplied>.
6231
6232 =cut
6233
6234 sub total_unapplied_payments {
6235   my $self = shift;
6236   my $total_unapplied = 0;
6237   $total_unapplied += $_->unapplied foreach $self->cust_pay;
6238   sprintf( "%.2f", $total_unapplied );
6239 }
6240
6241 =item total_unapplied_refunds
6242
6243 Returns the total unrefunded refunds (see L<FS::cust_refund>) for this
6244 customer.  See L<FS::cust_refund/unapplied>.
6245
6246 =cut
6247
6248 sub total_unapplied_refunds {
6249   my $self = shift;
6250   my $total_unapplied = 0;
6251   $total_unapplied += $_->unapplied foreach $self->cust_refund;
6252   sprintf( "%.2f", $total_unapplied );
6253 }
6254
6255 =item balance
6256
6257 Returns the balance for this customer (total_owed plus total_unrefunded, minus
6258 total_unapplied_credits minus total_unapplied_payments).
6259
6260 =cut
6261
6262 sub balance {
6263   my $self = shift;
6264   sprintf( "%.2f",
6265       $self->total_owed
6266     + $self->total_unapplied_refunds
6267     - $self->total_unapplied_credits
6268     - $self->total_unapplied_payments
6269   );
6270 }
6271
6272 =item balance_date TIME
6273
6274 Returns the balance for this customer, only considering invoices with date
6275 earlier than TIME (total_owed_date minus total_credited minus
6276 total_unapplied_payments).  TIME is specified as a UNIX timestamp; see
6277 L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion
6278 functions.
6279
6280 =cut
6281
6282 sub balance_date {
6283   my $self = shift;
6284   my $time = shift;
6285   sprintf( "%.2f",
6286         $self->total_owed_date($time)
6287       + $self->total_unapplied_refunds
6288       - $self->total_unapplied_credits
6289       - $self->total_unapplied_payments
6290   );
6291 }
6292
6293 =item in_transit_payments
6294
6295 Returns the total of requests for payments for this customer pending in
6296 batches in transit to the bank.  See L<FS::pay_batch> and L<FS::cust_pay_batch>
6297
6298 =cut
6299
6300 sub in_transit_payments {
6301   my $self = shift;
6302   my $in_transit_payments = 0;
6303   foreach my $pay_batch ( qsearch('pay_batch', {
6304     'status' => 'I',
6305   } ) ) {
6306     foreach my $cust_pay_batch ( qsearch('cust_pay_batch', {
6307       'batchnum' => $pay_batch->batchnum,
6308       'custnum' => $self->custnum,
6309     } ) ) {
6310       $in_transit_payments += $cust_pay_batch->amount;
6311     }
6312   }
6313   sprintf( "%.2f", $in_transit_payments );
6314 }
6315
6316 =item payment_info
6317
6318 Returns a hash of useful information for making a payment.
6319
6320 =over 4
6321
6322 =item balance
6323
6324 Current balance.
6325
6326 =item payby
6327
6328 'CARD' (credit card - automatic), 'DCRD' (credit card - on-demand),
6329 'CHEK' (electronic check - automatic), 'DCHK' (electronic check - on-demand),
6330 'LECB' (Phone bill billing), 'BILL' (billing), or 'COMP' (free).
6331
6332 =back
6333
6334 For credit card transactions:
6335
6336 =over 4
6337
6338 =item card_type 1
6339
6340 =item payname
6341
6342 Exact name on card
6343
6344 =back
6345
6346 For electronic check transactions:
6347
6348 =over 4
6349
6350 =item stateid_state
6351
6352 =back
6353
6354 =cut
6355
6356 sub payment_info {
6357   my $self = shift;
6358
6359   my %return = ();
6360
6361   $return{balance} = $self->balance;
6362
6363   $return{payname} = $self->payname
6364                      || ( $self->first. ' '. $self->get('last') );
6365
6366   $return{$_} = $self->get($_) for qw(address1 address2 city state zip);
6367
6368   $return{payby} = $self->payby;
6369   $return{stateid_state} = $self->stateid_state;
6370
6371   if ( $self->payby =~ /^(CARD|DCRD)$/ ) {
6372     $return{card_type} = cardtype($self->payinfo);
6373     $return{payinfo} = $self->paymask;
6374
6375     @return{'month', 'year'} = $self->paydate_monthyear;
6376
6377   }
6378
6379   if ( $self->payby =~ /^(CHEK|DCHK)$/ ) {
6380     my ($payinfo1, $payinfo2) = split '@', $self->paymask;
6381     $return{payinfo1} = $payinfo1;
6382     $return{payinfo2} = $payinfo2;
6383     $return{paytype}  = $self->paytype;
6384     $return{paystate} = $self->paystate;
6385
6386   }
6387
6388   #doubleclick protection
6389   my $_date = time;
6390   $return{paybatch} = "webui-MyAccount-$_date-$$-". rand() * 2**32;
6391
6392   %return;
6393
6394 }
6395
6396 =item paydate_monthyear
6397
6398 Returns a two-element list consisting of the month and year of this customer's
6399 paydate (credit card expiration date for CARD customers)
6400
6401 =cut
6402
6403 sub paydate_monthyear {
6404   my $self = shift;
6405   if ( $self->paydate  =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
6406     ( $2, $1 );
6407   } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
6408     ( $1, $3 );
6409   } else {
6410     ('', '');
6411   }
6412 }
6413
6414 =item tax_exemption TAXNAME
6415
6416 =cut
6417
6418 sub tax_exemption {
6419   my( $self, $taxname ) = @_;
6420
6421   qsearchs( 'cust_main_exemption', { 'custnum' => $self->custnum,
6422                                      'taxname' => $taxname,
6423                                    },
6424           );
6425 }
6426
6427 =item cust_main_exemption
6428
6429 =cut
6430
6431 sub cust_main_exemption {
6432   my $self = shift;
6433   qsearch( 'cust_main_exemption', { 'custnum' => $self->custnum } );
6434 }
6435
6436 =item invoicing_list [ ARRAYREF ]
6437
6438 If an arguement is given, sets these email addresses as invoice recipients
6439 (see L<FS::cust_main_invoice>).  Errors are not fatal and are not reported
6440 (except as warnings), so use check_invoicing_list first.
6441
6442 Returns a list of email addresses (with svcnum entries expanded).
6443
6444 Note: You can clear the invoicing list by passing an empty ARRAYREF.  You can
6445 check it without disturbing anything by passing nothing.
6446
6447 This interface may change in the future.
6448
6449 =cut
6450
6451 sub invoicing_list {
6452   my( $self, $arrayref ) = @_;
6453
6454   if ( $arrayref ) {
6455     my @cust_main_invoice;
6456     if ( $self->custnum ) {
6457       @cust_main_invoice =
6458         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
6459     } else {
6460       @cust_main_invoice = ();
6461     }
6462     foreach my $cust_main_invoice ( @cust_main_invoice ) {
6463       #warn $cust_main_invoice->destnum;
6464       unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
6465         #warn $cust_main_invoice->destnum;
6466         my $error = $cust_main_invoice->delete;
6467         warn $error if $error;
6468       }
6469     }
6470     if ( $self->custnum ) {
6471       @cust_main_invoice =
6472         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
6473     } else {
6474       @cust_main_invoice = ();
6475     }
6476     my %seen = map { $_->address => 1 } @cust_main_invoice;
6477     foreach my $address ( @{$arrayref} ) {
6478       next if exists $seen{$address} && $seen{$address};
6479       $seen{$address} = 1;
6480       my $cust_main_invoice = new FS::cust_main_invoice ( {
6481         'custnum' => $self->custnum,
6482         'dest'    => $address,
6483       } );
6484       my $error = $cust_main_invoice->insert;
6485       warn $error if $error;
6486     }
6487   }
6488
6489   if ( $self->custnum ) {
6490     map { $_->address }
6491       qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
6492   } else {
6493     ();
6494   }
6495
6496 }
6497
6498 =item check_invoicing_list ARRAYREF
6499
6500 Checks these arguements as valid input for the invoicing_list method.  If there
6501 is an error, returns the error, otherwise returns false.
6502
6503 =cut
6504
6505 sub check_invoicing_list {
6506   my( $self, $arrayref ) = @_;
6507
6508   foreach my $address ( @$arrayref ) {
6509
6510     if ($address eq 'FAX' and $self->getfield('fax') eq '') {
6511       return 'Can\'t add FAX invoice destination with a blank FAX number.';
6512     }
6513
6514     my $cust_main_invoice = new FS::cust_main_invoice ( {
6515       'custnum' => $self->custnum,
6516       'dest'    => $address,
6517     } );
6518     my $error = $self->custnum
6519                 ? $cust_main_invoice->check
6520                 : $cust_main_invoice->checkdest
6521     ;
6522     return $error if $error;
6523
6524   }
6525
6526   return "Email address required"
6527     if $conf->exists('cust_main-require_invoicing_list_email')
6528     && ! grep { $_ !~ /^([A-Z]+)$/ } @$arrayref;
6529
6530   '';
6531 }
6532
6533 =item set_default_invoicing_list
6534
6535 Sets the invoicing list to all accounts associated with this customer,
6536 overwriting any previous invoicing list.
6537
6538 =cut
6539
6540 sub set_default_invoicing_list {
6541   my $self = shift;
6542   $self->invoicing_list($self->all_emails);
6543 }
6544
6545 =item all_emails
6546
6547 Returns the email addresses of all accounts provisioned for this customer.
6548
6549 =cut
6550
6551 sub all_emails {
6552   my $self = shift;
6553   my %list;
6554   foreach my $cust_pkg ( $self->all_pkgs ) {
6555     my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
6556     my @svc_acct =
6557       map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
6558         grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
6559           @cust_svc;
6560     $list{$_}=1 foreach map { $_->email } @svc_acct;
6561   }
6562   keys %list;
6563 }
6564
6565 =item invoicing_list_addpost
6566
6567 Adds postal invoicing to this customer.  If this customer is already configured
6568 to receive postal invoices, does nothing.
6569
6570 =cut
6571
6572 sub invoicing_list_addpost {
6573   my $self = shift;
6574   return if grep { $_ eq 'POST' } $self->invoicing_list;
6575   my @invoicing_list = $self->invoicing_list;
6576   push @invoicing_list, 'POST';
6577   $self->invoicing_list(\@invoicing_list);
6578 }
6579
6580 =item invoicing_list_emailonly
6581
6582 Returns the list of email invoice recipients (invoicing_list without non-email
6583 destinations such as POST and FAX).
6584
6585 =cut
6586
6587 sub invoicing_list_emailonly {
6588   my $self = shift;
6589   warn "$me invoicing_list_emailonly called"
6590     if $DEBUG;
6591   grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list;
6592 }
6593
6594 =item invoicing_list_emailonly_scalar
6595
6596 Returns the list of email invoice recipients (invoicing_list without non-email
6597 destinations such as POST and FAX) as a comma-separated scalar.
6598
6599 =cut
6600
6601 sub invoicing_list_emailonly_scalar {
6602   my $self = shift;
6603   warn "$me invoicing_list_emailonly_scalar called"
6604     if $DEBUG;
6605   join(', ', $self->invoicing_list_emailonly);
6606 }
6607
6608 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
6609
6610 Returns an array of customers referred by this customer (referral_custnum set
6611 to this custnum).  If DEPTH is given, recurses up to the given depth, returning
6612 customers referred by customers referred by this customer and so on, inclusive.
6613 The default behavior is DEPTH 1 (no recursion).
6614
6615 =cut
6616
6617 sub referral_cust_main {
6618   my $self = shift;
6619   my $depth = @_ ? shift : 1;
6620   my $exclude = @_ ? shift : {};
6621
6622   my @cust_main =
6623     map { $exclude->{$_->custnum}++; $_; }
6624       grep { ! $exclude->{ $_->custnum } }
6625         qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
6626
6627   if ( $depth > 1 ) {
6628     push @cust_main,
6629       map { $_->referral_cust_main($depth-1, $exclude) }
6630         @cust_main;
6631   }
6632
6633   @cust_main;
6634 }
6635
6636 =item referral_cust_main_ncancelled
6637
6638 Same as referral_cust_main, except only returns customers with uncancelled
6639 packages.
6640
6641 =cut
6642
6643 sub referral_cust_main_ncancelled {
6644   my $self = shift;
6645   grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
6646 }
6647
6648 =item referral_cust_pkg [ DEPTH ]
6649
6650 Like referral_cust_main, except returns a flat list of all unsuspended (and
6651 uncancelled) packages for each customer.  The number of items in this list may
6652 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
6653
6654 =cut
6655
6656 sub referral_cust_pkg {
6657   my $self = shift;
6658   my $depth = @_ ? shift : 1;
6659
6660   map { $_->unsuspended_pkgs }
6661     grep { $_->unsuspended_pkgs }
6662       $self->referral_cust_main($depth);
6663 }
6664
6665 =item referring_cust_main
6666
6667 Returns the single cust_main record for the customer who referred this customer
6668 (referral_custnum), or false.
6669
6670 =cut
6671
6672 sub referring_cust_main {
6673   my $self = shift;
6674   return '' unless $self->referral_custnum;
6675   qsearchs('cust_main', { 'custnum' => $self->referral_custnum } );
6676 }
6677
6678 =item credit AMOUNT, REASON [ , OPTION => VALUE ... ]
6679
6680 Applies a credit to this customer.  If there is an error, returns the error,
6681 otherwise returns false.
6682
6683 REASON can be a text string, an FS::reason object, or a scalar reference to
6684 a reasonnum.  If a text string, it will be automatically inserted as a new
6685 reason, and a 'reason_type' option must be passed to indicate the
6686 FS::reason_type for the new reason.
6687
6688 An I<addlinfo> option may be passed to set the credit's I<addlinfo> field.
6689
6690 Any other options are passed to FS::cust_credit::insert.
6691
6692 =cut
6693
6694 sub credit {
6695   my( $self, $amount, $reason, %options ) = @_;
6696
6697   my $cust_credit = new FS::cust_credit {
6698     'custnum' => $self->custnum,
6699     'amount'  => $amount,
6700   };
6701
6702   if ( ref($reason) ) {
6703
6704     if ( ref($reason) eq 'SCALAR' ) {
6705       $cust_credit->reasonnum( $$reason );
6706     } else {
6707       $cust_credit->reasonnum( $reason->reasonnum );
6708     }
6709
6710   } else {
6711     $cust_credit->set('reason', $reason)
6712   }
6713
6714   $cust_credit->addlinfo( delete $options{'addlinfo'} )
6715     if exists($options{'addlinfo'});
6716
6717   $cust_credit->insert(%options);
6718
6719 }
6720
6721 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
6722
6723 Creates a one-time charge for this customer.  If there is an error, returns
6724 the error, otherwise returns false.
6725
6726 =cut
6727
6728 sub charge {
6729   my $self = shift;
6730   my ( $amount, $quantity, $pkg, $comment, $classnum, $additional );
6731   my ( $setuptax, $taxclass );   #internal taxes
6732   my ( $taxproduct, $override ); #vendor (CCH) taxes
6733   if ( ref( $_[0] ) ) {
6734     $amount     = $_[0]->{amount};
6735     $quantity   = exists($_[0]->{quantity}) ? $_[0]->{quantity} : 1;
6736     $pkg        = exists($_[0]->{pkg}) ? $_[0]->{pkg} : 'One-time charge';
6737     $comment    = exists($_[0]->{comment}) ? $_[0]->{comment}
6738                                            : '$'. sprintf("%.2f",$amount);
6739     $setuptax   = exists($_[0]->{setuptax}) ? $_[0]->{setuptax} : '';
6740     $taxclass   = exists($_[0]->{taxclass}) ? $_[0]->{taxclass} : '';
6741     $classnum   = exists($_[0]->{classnum}) ? $_[0]->{classnum} : '';
6742     $additional = $_[0]->{additional};
6743     $taxproduct = $_[0]->{taxproductnum};
6744     $override   = { '' => $_[0]->{tax_override} };
6745   }else{
6746     $amount     = shift;
6747     $quantity   = 1;
6748     $pkg        = @_ ? shift : 'One-time charge';
6749     $comment    = @_ ? shift : '$'. sprintf("%.2f",$amount);
6750     $setuptax   = '';
6751     $taxclass   = @_ ? shift : '';
6752     $additional = [];
6753   }
6754
6755   local $SIG{HUP} = 'IGNORE';
6756   local $SIG{INT} = 'IGNORE';
6757   local $SIG{QUIT} = 'IGNORE';
6758   local $SIG{TERM} = 'IGNORE';
6759   local $SIG{TSTP} = 'IGNORE';
6760   local $SIG{PIPE} = 'IGNORE';
6761
6762   my $oldAutoCommit = $FS::UID::AutoCommit;
6763   local $FS::UID::AutoCommit = 0;
6764   my $dbh = dbh;
6765
6766   my $part_pkg = new FS::part_pkg ( {
6767     'pkg'           => $pkg,
6768     'comment'       => $comment,
6769     'plan'          => 'flat',
6770     'freq'          => 0,
6771     'disabled'      => 'Y',
6772     'classnum'      => $classnum ? $classnum : '',
6773     'setuptax'      => $setuptax,
6774     'taxclass'      => $taxclass,
6775     'taxproductnum' => $taxproduct,
6776   } );
6777
6778   my %options = ( ( map { ("additional_info$_" => $additional->[$_] ) }
6779                         ( 0 .. @$additional - 1 )
6780                   ),
6781                   'additional_count' => scalar(@$additional),
6782                   'setup_fee' => $amount,
6783                 );
6784
6785   my $error = $part_pkg->insert( options       => \%options,
6786                                  tax_overrides => $override,
6787                                );
6788   if ( $error ) {
6789     $dbh->rollback if $oldAutoCommit;
6790     return $error;
6791   }
6792
6793   my $pkgpart = $part_pkg->pkgpart;
6794   my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
6795   unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
6796     my $type_pkgs = new FS::type_pkgs \%type_pkgs;
6797     $error = $type_pkgs->insert;
6798     if ( $error ) {
6799       $dbh->rollback if $oldAutoCommit;
6800       return $error;
6801     }
6802   }
6803
6804   my $cust_pkg = new FS::cust_pkg ( {
6805     'custnum'  => $self->custnum,
6806     'pkgpart'  => $pkgpart,
6807     'quantity' => $quantity,
6808   } );
6809
6810   $error = $cust_pkg->insert;
6811   if ( $error ) {
6812     $dbh->rollback if $oldAutoCommit;
6813     return $error;
6814   }
6815
6816   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6817   '';
6818
6819 }
6820
6821 #=item charge_postal_fee
6822 #
6823 #Applies a one time charge this customer.  If there is an error,
6824 #returns the error, returns the cust_pkg charge object or false
6825 #if there was no charge.
6826 #
6827 #=cut
6828 #
6829 # This should be a customer event.  For that to work requires that bill
6830 # also be a customer event.
6831
6832 sub charge_postal_fee {
6833   my $self = shift;
6834
6835   my $pkgpart = $conf->config('postal_invoice-fee_pkgpart');
6836   return '' unless ($pkgpart && grep { $_ eq 'POST' } $self->invoicing_list);
6837
6838   my $cust_pkg = new FS::cust_pkg ( {
6839     'custnum'  => $self->custnum,
6840     'pkgpart'  => $pkgpart,
6841     'quantity' => 1,
6842   } );
6843
6844   my $error = $cust_pkg->insert;
6845   $error ? $error : $cust_pkg;
6846 }
6847
6848 =item cust_bill
6849
6850 Returns all the invoices (see L<FS::cust_bill>) for this customer.
6851
6852 =cut
6853
6854 sub cust_bill {
6855   my $self = shift;
6856   sort { $a->_date <=> $b->_date }
6857     qsearch('cust_bill', { 'custnum' => $self->custnum, } )
6858 }
6859
6860 =item open_cust_bill
6861
6862 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
6863 customer.
6864
6865 =cut
6866
6867 sub open_cust_bill {
6868   my $self = shift;
6869
6870   qsearch({
6871     'table'     => 'cust_bill',
6872     'hashref'   => { 'custnum' => $self->custnum, },
6873     'extra_sql' => ' AND '. FS::cust_bill->owed_sql. ' > 0',
6874     'order_by'  => 'ORDER BY _date ASC',
6875   });
6876
6877 }
6878
6879 =item cust_credit
6880
6881 Returns all the credits (see L<FS::cust_credit>) for this customer.
6882
6883 =cut
6884
6885 sub cust_credit {
6886   my $self = shift;
6887   sort { $a->_date <=> $b->_date }
6888     qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
6889 }
6890
6891 =item cust_pay
6892
6893 Returns all the payments (see L<FS::cust_pay>) for this customer.
6894
6895 =cut
6896
6897 sub cust_pay {
6898   my $self = shift;
6899   sort { $a->_date <=> $b->_date }
6900     qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
6901 }
6902
6903 =item cust_pay_void
6904
6905 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
6906
6907 =cut
6908
6909 sub cust_pay_void {
6910   my $self = shift;
6911   sort { $a->_date <=> $b->_date }
6912     qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
6913 }
6914
6915 =item cust_pay_batch
6916
6917 Returns all batched payments (see L<FS::cust_pay_void>) for this customer.
6918
6919 =cut
6920
6921 sub cust_pay_batch {
6922   my $self = shift;
6923   sort { $a->paybatchnum <=> $b->paybatchnum }
6924     qsearch( 'cust_pay_batch', { 'custnum' => $self->custnum } )
6925 }
6926
6927 =item cust_pay_pending
6928
6929 Returns all pending payments (see L<FS::cust_pay_pending>) for this customer
6930 (without status "done").
6931
6932 =cut
6933
6934 sub cust_pay_pending {
6935   my $self = shift;
6936   return $self->num_cust_pay_pending unless wantarray;
6937   sort { $a->_date <=> $b->_date }
6938     qsearch( 'cust_pay_pending', {
6939                                    'custnum' => $self->custnum,
6940                                    'status'  => { op=>'!=', value=>'done' },
6941                                  },
6942            );
6943 }
6944
6945 =item num_cust_pay_pending
6946
6947 Returns the number of pending payments (see L<FS::cust_pay_pending>) for this
6948 customer (without status "done").  Also called automatically when the
6949 cust_pay_pending method is used in a scalar context.
6950
6951 =cut
6952
6953 sub num_cust_pay_pending {
6954   my $self = shift;
6955   my $sql = " SELECT COUNT(*) FROM cust_pay_pending ".
6956             "   WHERE custnum = ? AND status != 'done' ";
6957   my $sth = dbh->prepare($sql) or die dbh->errstr;
6958   $sth->execute($self->custnum) or die $sth->errstr;
6959   $sth->fetchrow_arrayref->[0];
6960 }
6961
6962 =item cust_refund
6963
6964 Returns all the refunds (see L<FS::cust_refund>) for this customer.
6965
6966 =cut
6967
6968 sub cust_refund {
6969   my $self = shift;
6970   sort { $a->_date <=> $b->_date }
6971     qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
6972 }
6973
6974 =item display_custnum
6975
6976 Returns the displayed customer number for this customer: agent_custid if
6977 cust_main-default_agent_custid is set and it has a value, custnum otherwise.
6978
6979 =cut
6980
6981 sub display_custnum {
6982   my $self = shift;
6983   if ( $conf->exists('cust_main-default_agent_custid') && $self->agent_custid ){
6984     return $self->agent_custid;
6985   } else {
6986     return $self->custnum;
6987   }
6988 }
6989
6990 =item name
6991
6992 Returns a name string for this customer, either "Company (Last, First)" or
6993 "Last, First".
6994
6995 =cut
6996
6997 sub name {
6998   my $self = shift;
6999   my $name = $self->contact;
7000   $name = $self->company. " ($name)" if $self->company;
7001   $name;
7002 }
7003
7004 =item ship_name
7005
7006 Returns a name string for this (service/shipping) contact, either
7007 "Company (Last, First)" or "Last, First".
7008
7009 =cut
7010
7011 sub ship_name {
7012   my $self = shift;
7013   if ( $self->get('ship_last') ) {
7014     my $name = $self->ship_contact;
7015     $name = $self->ship_company. " ($name)" if $self->ship_company;
7016     $name;
7017   } else {
7018     $self->name;
7019   }
7020 }
7021
7022 =item name_short
7023
7024 Returns a name string for this customer, either "Company" or "First Last".
7025
7026 =cut
7027
7028 sub name_short {
7029   my $self = shift;
7030   $self->company !~ /^\s*$/ ? $self->company : $self->contact_firstlast;
7031 }
7032
7033 =item ship_name_short
7034
7035 Returns a name string for this (service/shipping) contact, either "Company"
7036 or "First Last".
7037
7038 =cut
7039
7040 sub ship_name_short {
7041   my $self = shift;
7042   if ( $self->get('ship_last') ) {
7043     $self->ship_company !~ /^\s*$/
7044       ? $self->ship_company
7045       : $self->ship_contact_firstlast;
7046   } else {
7047     $self->name_company_or_firstlast;
7048   }
7049 }
7050
7051 =item contact
7052
7053 Returns this customer's full (billing) contact name only, "Last, First"
7054
7055 =cut
7056
7057 sub contact {
7058   my $self = shift;
7059   $self->get('last'). ', '. $self->first;
7060 }
7061
7062 =item ship_contact
7063
7064 Returns this customer's full (shipping) contact name only, "Last, First"
7065
7066 =cut
7067
7068 sub ship_contact {
7069   my $self = shift;
7070   $self->get('ship_last')
7071     ? $self->get('ship_last'). ', '. $self->ship_first
7072     : $self->contact;
7073 }
7074
7075 =item contact_firstlast
7076
7077 Returns this customers full (billing) contact name only, "First Last".
7078
7079 =cut
7080
7081 sub contact_firstlast {
7082   my $self = shift;
7083   $self->first. ' '. $self->get('last');
7084 }
7085
7086 =item ship_contact_firstlast
7087
7088 Returns this customer's full (shipping) contact name only, "First Last".
7089
7090 =cut
7091
7092 sub ship_contact_firstlast {
7093   my $self = shift;
7094   $self->get('ship_last')
7095     ? $self->first. ' '. $self->get('ship_last')
7096     : $self->contact_firstlast;
7097 }
7098
7099 =item country_full
7100
7101 Returns this customer's full country name
7102
7103 =cut
7104
7105 sub country_full {
7106   my $self = shift;
7107   code2country($self->country);
7108 }
7109
7110 =item geocode DATA_VENDOR
7111
7112 Returns a value for the customer location as encoded by DATA_VENDOR.
7113 Currently this only makes sense for "CCH" as DATA_VENDOR.
7114
7115 =cut
7116
7117 sub geocode {
7118   my ($self, $data_vendor) = (shift, shift);  #always cch for now
7119
7120   my $geocode = $self->get('geocode');  #XXX only one data_vendor for geocode
7121   return $geocode if $geocode;
7122
7123   my $prefix = ( $conf->exists('tax-ship_address') && length($self->ship_last) )
7124                ? 'ship_'
7125                : '';
7126
7127   my ($zip,$plus4) = split /-/, $self->get("${prefix}zip")
7128     if $self->country eq 'US';
7129
7130   #CCH specific location stuff
7131   my $extra_sql = "AND plus4lo <= '$plus4' AND plus4hi >= '$plus4'";
7132
7133   my @cust_tax_location =
7134     qsearch( {
7135                'table'     => 'cust_tax_location',
7136                'hashref'   => { 'zip' => $zip, 'data_vendor' => $data_vendor },
7137                'extra_sql' => $extra_sql,
7138                'order_by'  => 'ORDER BY plus4hi',#overlapping with distinct ends
7139              }
7140            );
7141   $geocode = $cust_tax_location[0]->geocode
7142     if scalar(@cust_tax_location);
7143
7144   $geocode;
7145 }
7146
7147 =item cust_status
7148
7149 =item status
7150
7151 Returns a status string for this customer, currently:
7152
7153 =over 4
7154
7155 =item prospect - No packages have ever been ordered
7156
7157 =item active - One or more recurring packages is active
7158
7159 =item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled)
7160
7161 =item suspended - All non-cancelled recurring packages are suspended
7162
7163 =item cancelled - All recurring packages are cancelled
7164
7165 =back
7166
7167 =cut
7168
7169 sub status { shift->cust_status(@_); }
7170
7171 sub cust_status {
7172   my $self = shift;
7173   for my $status (qw( prospect active inactive suspended cancelled )) {
7174     my $method = $status.'_sql';
7175     my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
7176     my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
7177     $sth->execute( ($self->custnum) x $numnum )
7178       or die "Error executing 'SELECT $sql': ". $sth->errstr;
7179     return $status if $sth->fetchrow_arrayref->[0];
7180   }
7181 }
7182
7183 =item ucfirst_cust_status
7184
7185 =item ucfirst_status
7186
7187 Returns the status with the first character capitalized.
7188
7189 =cut
7190
7191 sub ucfirst_status { shift->ucfirst_cust_status(@_); }
7192
7193 sub ucfirst_cust_status {
7194   my $self = shift;
7195   ucfirst($self->cust_status);
7196 }
7197
7198 =item statuscolor
7199
7200 Returns a hex triplet color string for this customer's status.
7201
7202 =cut
7203
7204 use vars qw(%statuscolor);
7205 tie %statuscolor, 'Tie::IxHash',
7206   'prospect'  => '7e0079', #'000000', #black?  naw, purple
7207   'active'    => '00CC00', #green
7208   'inactive'  => '0000CC', #blue
7209   'suspended' => 'FF9900', #yellow
7210   'cancelled' => 'FF0000', #red
7211 ;
7212
7213 sub statuscolor { shift->cust_statuscolor(@_); }
7214
7215 sub cust_statuscolor {
7216   my $self = shift;
7217   $statuscolor{$self->cust_status};
7218 }
7219
7220 =item tickets
7221
7222 Returns an array of hashes representing the customer's RT tickets.
7223
7224 =cut
7225
7226 sub tickets {
7227   my $self = shift;
7228
7229   my $num = $conf->config('cust_main-max_tickets') || 10;
7230   my @tickets = ();
7231
7232   if ( $conf->config('ticket_system') ) {
7233     unless ( $conf->config('ticket_system-custom_priority_field') ) {
7234
7235       @tickets = @{ FS::TicketSystem->customer_tickets($self->custnum, $num) };
7236
7237     } else {
7238
7239       foreach my $priority (
7240         $conf->config('ticket_system-custom_priority_field-values'), ''
7241       ) {
7242         last if scalar(@tickets) >= $num;
7243         push @tickets,
7244           @{ FS::TicketSystem->customer_tickets( $self->custnum,
7245                                                  $num - scalar(@tickets),
7246                                                  $priority,
7247                                                )
7248            };
7249       }
7250     }
7251   }
7252   (@tickets);
7253 }
7254
7255 # Return services representing svc_accts in customer support packages
7256 sub support_services {
7257   my $self = shift;
7258   my %packages = map { $_ => 1 } $conf->config('support_packages');
7259
7260   grep { $_->pkg_svc && $_->pkg_svc->primary_svc eq 'Y' }
7261     grep { $_->part_svc->svcdb eq 'svc_acct' }
7262     map { $_->cust_svc }
7263     grep { exists $packages{ $_->pkgpart } }
7264     $self->ncancelled_pkgs;
7265
7266 }
7267
7268 =back
7269
7270 =head1 CLASS METHODS
7271
7272 =over 4
7273
7274 =item statuses
7275
7276 Class method that returns the list of possible status strings for customers
7277 (see L<the status method|/status>).  For example:
7278
7279   @statuses = FS::cust_main->statuses();
7280
7281 =cut
7282
7283 sub statuses {
7284   #my $self = shift; #could be class...
7285   keys %statuscolor;
7286 }
7287
7288 =item prospect_sql
7289
7290 Returns an SQL expression identifying prospective cust_main records (customers
7291 with no packages ever ordered)
7292
7293 =cut
7294
7295 use vars qw($select_count_pkgs);
7296 $select_count_pkgs =
7297   "SELECT COUNT(*) FROM cust_pkg
7298     WHERE cust_pkg.custnum = cust_main.custnum";
7299
7300 sub select_count_pkgs_sql {
7301   $select_count_pkgs;
7302 }
7303
7304 sub prospect_sql { "
7305   0 = ( $select_count_pkgs )
7306 "; }
7307
7308 =item active_sql
7309
7310 Returns an SQL expression identifying active cust_main records (customers with
7311 active recurring packages).
7312
7313 =cut
7314
7315 sub active_sql { "
7316   0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. "
7317       )
7318 "; }
7319
7320 =item inactive_sql
7321
7322 Returns an SQL expression identifying inactive cust_main records (customers with
7323 no active recurring packages, but otherwise unsuspended/uncancelled).
7324
7325 =cut
7326
7327 sub inactive_sql { "
7328   0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
7329   AND
7330   0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
7331 "; }
7332
7333 =item susp_sql
7334 =item suspended_sql
7335
7336 Returns an SQL expression identifying suspended cust_main records.
7337
7338 =cut
7339
7340
7341 sub suspended_sql { susp_sql(@_); }
7342 sub susp_sql { "
7343     0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " )
7344     AND
7345     0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
7346 "; }
7347
7348 =item cancel_sql
7349 =item cancelled_sql
7350
7351 Returns an SQL expression identifying cancelled cust_main records.
7352
7353 =cut
7354
7355 sub cancelled_sql { cancel_sql(@_); }
7356 sub cancel_sql {
7357
7358   my $recurring_sql = FS::cust_pkg->recurring_sql;
7359   my $cancelled_sql = FS::cust_pkg->cancelled_sql;
7360
7361   "
7362         0 < ( $select_count_pkgs )
7363     AND 0 < ( $select_count_pkgs AND $recurring_sql AND $cancelled_sql   )
7364     AND 0 = ( $select_count_pkgs AND $recurring_sql
7365                   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
7366             )
7367     AND 0 = (  $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
7368   ";
7369
7370 }
7371
7372 =item uncancel_sql
7373 =item uncancelled_sql
7374
7375 Returns an SQL expression identifying un-cancelled cust_main records.
7376
7377 =cut
7378
7379 sub uncancelled_sql { uncancel_sql(@_); }
7380 sub uncancel_sql { "
7381   ( 0 < ( $select_count_pkgs
7382                    AND ( cust_pkg.cancel IS NULL
7383                          OR cust_pkg.cancel = 0
7384                        )
7385         )
7386     OR 0 = ( $select_count_pkgs )
7387   )
7388 "; }
7389
7390 =item balance_sql
7391
7392 Returns an SQL fragment to retreive the balance.
7393
7394 =cut
7395
7396 sub balance_sql { "
7397     ( SELECT COALESCE( SUM(charged), 0 ) FROM cust_bill
7398         WHERE cust_bill.custnum   = cust_main.custnum     )
7399   - ( SELECT COALESCE( SUM(paid),    0 ) FROM cust_pay
7400         WHERE cust_pay.custnum    = cust_main.custnum     )
7401   - ( SELECT COALESCE( SUM(amount),  0 ) FROM cust_credit
7402         WHERE cust_credit.custnum = cust_main.custnum     )
7403   + ( SELECT COALESCE( SUM(refund),  0 ) FROM cust_refund
7404         WHERE cust_refund.custnum = cust_main.custnum     )
7405 "; }
7406
7407 =item balance_date_sql START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
7408
7409 Returns an SQL fragment to retreive the balance for this customer, only
7410 considering invoices with date earlier than START_TIME, and optionally not
7411 later than END_TIME (total_owed_date minus total_unapplied_credits minus
7412 total_unapplied_payments).
7413
7414 Times are specified as SQL fragments or numeric
7415 UNIX timestamps; see L<perlfunc/"time">).  Also see L<Time::Local> and
7416 L<Date::Parse> for conversion functions.  The empty string can be passed
7417 to disable that time constraint completely.
7418
7419 Available options are:
7420
7421 =over 4
7422
7423 =item unapplied_date
7424
7425 set to true to disregard unapplied credits, payments and refunds outside the specified time period - by default the time period restriction only applies to invoices (useful for reporting, probably a bad idea for event triggering)
7426
7427 =item total
7428
7429 (unused.  obsolete?)
7430 set to true to remove all customer comparison clauses, for totals
7431
7432 =item where
7433
7434 (unused.  obsolete?)
7435 WHERE clause hashref (elements "AND"ed together) (typically used with the total option)
7436
7437 =item join
7438
7439 (unused.  obsolete?)
7440 JOIN clause (typically used with the total option)
7441
7442 =back
7443
7444 =cut
7445
7446 sub balance_date_sql {
7447   my( $class, $start, $end, %opt ) = @_;
7448
7449   my $owed         = FS::cust_bill->owed_sql;
7450   my $unapp_refund = FS::cust_refund->unapplied_sql;
7451   my $unapp_credit = FS::cust_credit->unapplied_sql;
7452   my $unapp_pay    = FS::cust_pay->unapplied_sql;
7453
7454   my $j = $opt{'join'} || '';
7455
7456   my $owed_wh   = $class->_money_table_where( 'cust_bill',   $start,$end,%opt );
7457   my $refund_wh = $class->_money_table_where( 'cust_refund', $start,$end,%opt );
7458   my $credit_wh = $class->_money_table_where( 'cust_credit', $start,$end,%opt );
7459   my $pay_wh    = $class->_money_table_where( 'cust_pay',    $start,$end,%opt );
7460
7461   "   ( SELECT COALESCE(SUM($owed),         0) FROM cust_bill   $j $owed_wh   )
7462     + ( SELECT COALESCE(SUM($unapp_refund), 0) FROM cust_refund $j $refund_wh )
7463     - ( SELECT COALESCE(SUM($unapp_credit), 0) FROM cust_credit $j $credit_wh )
7464     - ( SELECT COALESCE(SUM($unapp_pay),    0) FROM cust_pay    $j $pay_wh    )
7465   ";
7466
7467 }
7468
7469 =item _money_table_where TABLE START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
7470
7471 Helper method for balance_date_sql; name (and usage) subject to change
7472 (suggestions welcome).
7473
7474 Returns a WHERE clause for the specified monetary TABLE (cust_bill,
7475 cust_refund, cust_credit or cust_pay).
7476
7477 If TABLE is "cust_bill" or the unapplied_date option is true, only
7478 considers records with date earlier than START_TIME, and optionally not
7479 later than END_TIME .
7480
7481 =cut
7482
7483 sub _money_table_where {
7484   my( $class, $table, $start, $end, %opt ) = @_;
7485
7486   my @where = ();
7487   push @where, "cust_main.custnum = $table.custnum" unless $opt{'total'};
7488   if ( $table eq 'cust_bill' || $opt{'unapplied_date'} ) {
7489     push @where, "$table._date <= $start" if defined($start) && length($start);
7490     push @where, "$table._date >  $end"   if defined($end)   && length($end);
7491   }
7492   push @where, @{$opt{'where'}} if $opt{'where'};
7493   my $where = scalar(@where) ? 'WHERE '. join(' AND ', @where ) : '';
7494
7495   $where;
7496
7497 }
7498
7499 =item search_sql HASHREF
7500
7501 (Class method)
7502
7503 Returns a qsearch hash expression to search for parameters specified in HREF.
7504 Valid parameters are
7505
7506 =over 4
7507
7508 =item agentnum
7509
7510 =item status
7511
7512 =item cancelled_pkgs
7513
7514 bool
7515
7516 =item signupdate
7517
7518 listref of start date, end date
7519
7520 =item payby
7521
7522 listref
7523
7524 =item current_balance
7525
7526 listref (list returned by FS::UI::Web::parse_lt_gt($cgi, 'current_balance'))
7527
7528 =item cust_fields
7529
7530 =item flattened_pkgs
7531
7532 bool
7533
7534 =back
7535
7536 =cut
7537
7538 sub search_sql {
7539   my ($class, $params) = @_;
7540
7541   my $dbh = dbh;
7542
7543   my @where = ();
7544   my $orderby;
7545
7546   ##
7547   # parse agent
7548   ##
7549
7550   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
7551     push @where,
7552       "cust_main.agentnum = $1";
7553   }
7554
7555   ##
7556   # parse status
7557   ##
7558
7559   #prospect active inactive suspended cancelled
7560   if ( grep { $params->{'status'} eq $_ } FS::cust_main->statuses() ) {
7561     my $method = $params->{'status'}. '_sql';
7562     #push @where, $class->$method();
7563     push @where, FS::cust_main->$method();
7564   }
7565
7566   ##
7567   # parse cancelled package checkbox
7568   ##
7569
7570   my $pkgwhere = "";
7571
7572   $pkgwhere .= "AND (cancel = 0 or cancel is null)"
7573     unless $params->{'cancelled_pkgs'};
7574
7575   ##
7576   # parse without census tract checkbox
7577   ##
7578
7579   push @where, "(censustract = '' or censustract is null)"
7580     if $params->{'no_censustract'};
7581
7582   ##
7583   # dates
7584   ##
7585
7586   foreach my $field (qw( signupdate )) {
7587
7588     next unless exists($params->{$field});
7589
7590     my($beginning, $ending) = @{$params->{$field}};
7591
7592     push @where,
7593       "cust_main.$field IS NOT NULL",
7594       "cust_main.$field >= $beginning",
7595       "cust_main.$field <= $ending";
7596
7597     $orderby ||= "ORDER BY cust_main.$field";
7598
7599   }
7600
7601   ###
7602   # payby
7603   ###
7604
7605   my @payby = grep /^([A-Z]{4})$/, @{ $params->{'payby'} };
7606   if ( @payby ) {
7607     push @where, '( '. join(' OR ', map "cust_main.payby = '$_'", @payby). ' )';
7608   }
7609
7610   ##
7611   # amounts
7612   ##
7613
7614   #my $balance_sql = $class->balance_sql();
7615   my $balance_sql = FS::cust_main->balance_sql();
7616
7617   push @where, map { s/current_balance/$balance_sql/; $_ }
7618                    @{ $params->{'current_balance'} };
7619
7620   ##
7621   # custbatch
7622   ##
7623
7624   if ( $params->{'custbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
7625     push @where,
7626       "cust_main.custbatch = '$1'";
7627   }
7628
7629   ##
7630   # setup queries, subs, etc. for the search
7631   ##
7632
7633   $orderby ||= 'ORDER BY custnum';
7634
7635   # here is the agent virtualization
7636   push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
7637
7638   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
7639
7640   my $addl_from = 'LEFT JOIN cust_pkg USING ( custnum  ) ';
7641
7642   my $count_query = "SELECT COUNT(*) FROM cust_main $extra_sql";
7643
7644   my $select = join(', ',
7645                  'cust_main.custnum',
7646                  FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
7647                );
7648
7649   my(@extra_headers) = ();
7650   my(@extra_fields)  = ();
7651
7652   if ($params->{'flattened_pkgs'}) {
7653
7654     if ($dbh->{Driver}->{Name} eq 'Pg') {
7655
7656       $select .= ", array_to_string(array(select pkg from cust_pkg left join part_pkg using ( pkgpart ) where cust_main.custnum = cust_pkg.custnum $pkgwhere),'|') as magic";
7657
7658     }elsif ($dbh->{Driver}->{Name} =~ /^mysql/i) {
7659       $select .= ", GROUP_CONCAT(pkg SEPARATOR '|') as magic";
7660       $addl_from .= " LEFT JOIN part_pkg using ( pkgpart )";
7661     }else{
7662       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
7663            "omitting packing information from report.";
7664     }
7665
7666     my $header_query = "SELECT COUNT(cust_pkg.custnum = cust_main.custnum) AS count FROM cust_main $addl_from $extra_sql $pkgwhere group by cust_main.custnum order by count desc limit 1";
7667
7668     my $sth = dbh->prepare($header_query) or die dbh->errstr;
7669     $sth->execute() or die $sth->errstr;
7670     my $headerrow = $sth->fetchrow_arrayref;
7671     my $headercount = $headerrow ? $headerrow->[0] : 0;
7672     while($headercount) {
7673       unshift @extra_headers, "Package ". $headercount;
7674       unshift @extra_fields, eval q!sub {my $c = shift;
7675                                          my @a = split '\|', $c->magic;
7676                                          my $p = $a[!.--$headercount. q!];
7677                                          $p;
7678                                         };!;
7679     }
7680
7681   }
7682
7683   my $sql_query = {
7684     'table'         => 'cust_main',
7685     'select'        => $select,
7686     'hashref'       => {},
7687     'extra_sql'     => $extra_sql,
7688     'order_by'      => $orderby,
7689     'count_query'   => $count_query,
7690     'extra_headers' => \@extra_headers,
7691     'extra_fields'  => \@extra_fields,
7692   };
7693
7694 }
7695
7696 =item email_search_sql HASHREF
7697
7698 (Class method)
7699
7700 Emails a notice to the specified customers.
7701
7702 Valid parameters are those of the L<search_sql> method, plus the following:
7703
7704 =over 4
7705
7706 =item from
7707
7708 From: address
7709
7710 =item subject
7711
7712 Email Subject:
7713
7714 =item html_body
7715
7716 HTML body
7717
7718 =item text_body
7719
7720 Text body
7721
7722 =item job
7723
7724 Optional job queue job for status updates.
7725
7726 =back
7727
7728 Returns an error message, or false for success.
7729
7730 If an error occurs during any email, stops the enture send and returns that
7731 error.  Presumably if you're getting SMTP errors aborting is better than
7732 retrying everything.
7733
7734 =cut
7735
7736 sub email_search_sql {
7737   my($class, $params) = @_;
7738
7739   my $from = delete $params->{from};
7740   my $subject = delete $params->{subject};
7741   my $html_body = delete $params->{html_body};
7742   my $text_body = delete $params->{text_body};
7743
7744   my $job = delete $params->{'job'};
7745
7746   my $sql_query = $class->search_sql($params);
7747
7748   my $count_query   = delete($sql_query->{'count_query'});
7749   my $count_sth = dbh->prepare($count_query)
7750     or die "Error preparing $count_query: ". dbh->errstr;
7751   $count_sth->execute
7752     or die "Error executing $count_query: ". $count_sth->errstr;
7753   my $count_arrayref = $count_sth->fetchrow_arrayref;
7754   my $num_cust = $count_arrayref->[0];
7755
7756   #my @extra_headers = @{ delete($sql_query->{'extra_headers'}) };
7757   #my @extra_fields  = @{ delete($sql_query->{'extra_fields'})  };
7758
7759
7760   my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
7761
7762   #eventually order+limit magic to reduce memory use?
7763   foreach my $cust_main ( qsearch($sql_query) ) {
7764
7765     my $to = $cust_main->invoicing_list_emailonly_scalar;
7766     next unless $to;
7767
7768     my $error = send_email(
7769       generate_email(
7770         'from'      => $from,
7771         'to'        => $to,
7772         'subject'   => $subject,
7773         'html_body' => $html_body,
7774         'text_body' => $text_body,
7775       )
7776     );
7777     return $error if $error;
7778
7779     if ( $job ) { #progressbar foo
7780       $num++;
7781       if ( time - $min_sec > $last ) {
7782         my $error = $job->update_statustext(
7783           int( 100 * $num / $num_cust )
7784         );
7785         die $error if $error;
7786         $last = time;
7787       }
7788     }
7789
7790   }
7791
7792   return '';
7793 }
7794
7795 use Storable qw(thaw);
7796 use Data::Dumper;
7797 use MIME::Base64;
7798 sub process_email_search_sql {
7799   my $job = shift;
7800   #warn "$me process_re_X $method for job $job\n" if $DEBUG;
7801
7802   my $param = thaw(decode_base64(shift));
7803   warn Dumper($param) if $DEBUG;
7804
7805   $param->{'job'} = $job;
7806
7807   my $error = FS::cust_main->email_search_sql( $param );
7808   die $error if $error;
7809
7810 }
7811
7812 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
7813
7814 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
7815 records.  Currently, I<first>, I<last> and/or I<company> may be specified (the
7816 appropriate ship_ field is also searched).
7817
7818 Additional options are the same as FS::Record::qsearch
7819
7820 =cut
7821
7822 sub fuzzy_search {
7823   my( $self, $fuzzy, $hash, @opt) = @_;
7824   #$self
7825   $hash ||= {};
7826   my @cust_main = ();
7827
7828   check_and_rebuild_fuzzyfiles();
7829   foreach my $field ( keys %$fuzzy ) {
7830
7831     my $all = $self->all_X($field);
7832     next unless scalar(@$all);
7833
7834     my %match = ();
7835     $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) );
7836
7837     my @fcust = ();
7838     foreach ( keys %match ) {
7839       push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
7840       push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
7841     }
7842     my %fsaw = ();
7843     push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
7844   }
7845
7846   # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
7847   my %saw = ();
7848   @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
7849
7850   @cust_main;
7851
7852 }
7853
7854 =item masked FIELD
7855
7856 Returns a masked version of the named field
7857
7858 =cut
7859
7860 sub masked {
7861 my ($self,$field) = @_;
7862
7863 # Show last four
7864
7865 'x'x(length($self->getfield($field))-4).
7866   substr($self->getfield($field), (length($self->getfield($field))-4));
7867
7868 }
7869
7870 =back
7871
7872 =head1 SUBROUTINES
7873
7874 =over 4
7875
7876 =item smart_search OPTION => VALUE ...
7877
7878 Accepts the following options: I<search>, the string to search for.  The string
7879 will be searched for as a customer number, phone number, name or company name,
7880 as an exact, or, in some cases, a substring or fuzzy match (see the source code
7881 for the exact heuristics used); I<no_fuzzy_on_exact>, causes smart_search to
7882 skip fuzzy matching when an exact match is found.
7883
7884 Any additional options are treated as an additional qualifier on the search
7885 (i.e. I<agentnum>).
7886
7887 Returns a (possibly empty) array of FS::cust_main objects.
7888
7889 =cut
7890
7891 sub smart_search {
7892   my %options = @_;
7893
7894   #here is the agent virtualization
7895   my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
7896
7897   my @cust_main = ();
7898
7899   my $skip_fuzzy = delete $options{'no_fuzzy_on_exact'};
7900   my $search = delete $options{'search'};
7901   ( my $alphanum_search = $search ) =~ s/\W//g;
7902
7903   if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
7904
7905     #false laziness w/Record::ut_phone
7906     my $phonen = "$1-$2-$3";
7907     $phonen .= " x$4" if $4;
7908
7909     push @cust_main, qsearch( {
7910       'table'   => 'cust_main',
7911       'hashref' => { %options },
7912       'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
7913                      ' ( '.
7914                          join(' OR ', map "$_ = '$phonen'",
7915                                           qw( daytime night fax
7916                                               ship_daytime ship_night ship_fax )
7917                              ).
7918                      ' ) '.
7919                      " AND $agentnums_sql", #agent virtualization
7920     } );
7921
7922     unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
7923       #try looking for matches with extensions unless one was specified
7924
7925       push @cust_main, qsearch( {
7926         'table'   => 'cust_main',
7927         'hashref' => { %options },
7928         'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
7929                        ' ( '.
7930                            join(' OR ', map "$_ LIKE '$phonen\%'",
7931                                             qw( daytime night
7932                                                 ship_daytime ship_night )
7933                                ).
7934                        ' ) '.
7935                        " AND $agentnums_sql", #agent virtualization
7936       } );
7937
7938     }
7939
7940   # custnum search (also try agent_custid), with some tweaking options if your
7941   # legacy cust "numbers" have letters
7942   }
7943
7944   if ( $search =~ /^\s*(\d+)\s*$/
7945             || ( $conf->config('cust_main-agent_custid-format') eq 'ww?d+'
7946                  && $search =~ /^\s*(\w\w?\d+)\s*$/
7947                )
7948           )
7949   {
7950
7951     my $num = $1;
7952
7953     if ( $num <= 2147483647 ) { #need a bigint custnum?  wow.
7954       push @cust_main, qsearch( {
7955         'table'     => 'cust_main',
7956         'hashref'   => { 'custnum' => $num, %options },
7957         'extra_sql' => " AND $agentnums_sql", #agent virtualization
7958       } );
7959     }
7960
7961     push @cust_main, qsearch( {
7962       'table'     => 'cust_main',
7963       'hashref'   => { 'agent_custid' => $num, %options },
7964       'extra_sql' => " AND $agentnums_sql", #agent virtualization
7965     } );
7966
7967   } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
7968
7969     my($company, $last, $first) = ( $1, $2, $3 );
7970
7971     # "Company (Last, First)"
7972     #this is probably something a browser remembered,
7973     #so just do an exact search
7974
7975     foreach my $prefix ( '', 'ship_' ) {
7976       push @cust_main, qsearch( {
7977         'table'     => 'cust_main',
7978         'hashref'   => { $prefix.'first'   => $first,
7979                          $prefix.'last'    => $last,
7980                          $prefix.'company' => $company,
7981                          %options,
7982                        },
7983         'extra_sql' => " AND $agentnums_sql",
7984       } );
7985     }
7986
7987   } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
7988                                               # try (ship_){last,company}
7989
7990     my $value = lc($1);
7991
7992     # # remove "(Last, First)" in "Company (Last, First)", otherwise the
7993     # # full strings the browser remembers won't work
7994     # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
7995
7996     use Lingua::EN::NameParse;
7997     my $NameParse = new Lingua::EN::NameParse(
7998              auto_clean     => 1,
7999              allow_reversed => 1,
8000     );
8001
8002     my($last, $first) = ( '', '' );
8003     #maybe disable this too and just rely on NameParse?
8004     if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
8005
8006       ($last, $first) = ( $1, $2 );
8007
8008     #} elsif  ( $value =~ /^(.+)\s+(.+)$/ ) {
8009     } elsif ( ! $NameParse->parse($value) ) {
8010
8011       my %name = $NameParse->components;
8012       $first = $name{'given_name_1'};
8013       $last  = $name{'surname_1'};
8014
8015     }
8016
8017     if ( $first && $last ) {
8018
8019       my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
8020
8021       #exact
8022       my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
8023       $sql .= "
8024         (     ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
8025            OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
8026         )";
8027
8028       push @cust_main, qsearch( {
8029         'table'     => 'cust_main',
8030         'hashref'   => \%options,
8031         'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
8032       } );
8033
8034       # or it just be something that was typed in... (try that in a sec)
8035
8036     }
8037
8038     my $q_value = dbh->quote($value);
8039
8040     #exact
8041     my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
8042     $sql .= " (    LOWER(last)         = $q_value
8043                 OR LOWER(company)      = $q_value
8044                 OR LOWER(ship_last)    = $q_value
8045                 OR LOWER(ship_company) = $q_value
8046               )";
8047
8048     push @cust_main, qsearch( {
8049       'table'     => 'cust_main',
8050       'hashref'   => \%options,
8051       'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
8052     } );
8053
8054     #no exact match, trying substring/fuzzy
8055     #always do substring & fuzzy (unless they're explicity config'ed off)
8056     #getting complaints searches are not returning enough
8057     unless ( @cust_main  && $skip_fuzzy || $conf->exists('disable-fuzzy') ) {
8058
8059       #still some false laziness w/search_sql (was search/cust_main.cgi)
8060
8061       #substring
8062
8063       my @hashrefs = (
8064         { 'company'      => { op=>'ILIKE', value=>"%$value%" }, },
8065         { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
8066       );
8067
8068       if ( $first && $last ) {
8069
8070         push @hashrefs,
8071           { 'first'        => { op=>'ILIKE', value=>"%$first%" },
8072             'last'         => { op=>'ILIKE', value=>"%$last%" },
8073           },
8074           { 'ship_first'   => { op=>'ILIKE', value=>"%$first%" },
8075             'ship_last'    => { op=>'ILIKE', value=>"%$last%" },
8076           },
8077         ;
8078
8079       } else {
8080
8081         push @hashrefs,
8082           { 'last'         => { op=>'ILIKE', value=>"%$value%" }, },
8083           { 'ship_last'    => { op=>'ILIKE', value=>"%$value%" }, },
8084         ;
8085       }
8086
8087       foreach my $hashref ( @hashrefs ) {
8088
8089         push @cust_main, qsearch( {
8090           'table'     => 'cust_main',
8091           'hashref'   => { %$hashref,
8092                            %options,
8093                          },
8094           'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
8095         } );
8096
8097       }
8098
8099       #fuzzy
8100       my @fuzopts = (
8101         \%options,                #hashref
8102         '',                       #select
8103         " AND $agentnums_sql",    #extra_sql  #agent virtualization
8104       );
8105
8106       if ( $first && $last ) {
8107         push @cust_main, FS::cust_main->fuzzy_search(
8108           { 'last'   => $last,    #fuzzy hashref
8109             'first'  => $first }, #
8110           @fuzopts
8111         );
8112       }
8113       foreach my $field ( 'last', 'company' ) {
8114         push @cust_main,
8115           FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
8116       }
8117
8118     }
8119
8120   }
8121
8122   #eliminate duplicates
8123   my %saw = ();
8124   @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
8125
8126   @cust_main;
8127
8128 }
8129
8130 =item email_search
8131
8132 Accepts the following options: I<email>, the email address to search for.  The
8133 email address will be searched for as an email invoice destination and as an
8134 svc_acct account.
8135
8136 #Any additional options are treated as an additional qualifier on the search
8137 #(i.e. I<agentnum>).
8138
8139 Returns a (possibly empty) array of FS::cust_main objects (but usually just
8140 none or one).
8141
8142 =cut
8143
8144 sub email_search {
8145   my %options = @_;
8146
8147   local($DEBUG) = 1;
8148
8149   my $email = delete $options{'email'};
8150
8151   #we're only being used by RT at the moment... no agent virtualization yet
8152   #my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
8153
8154   my @cust_main = ();
8155
8156   if ( $email =~ /([^@]+)\@([^@]+)/ ) {
8157
8158     my ( $user, $domain ) = ( $1, $2 );
8159
8160     warn "$me smart_search: searching for $user in domain $domain"
8161       if $DEBUG;
8162
8163     push @cust_main,
8164       map $_->cust_main,
8165           qsearch( {
8166                      'table'     => 'cust_main_invoice',
8167                      'hashref'   => { 'dest' => $email },
8168                    }
8169                  );
8170
8171     push @cust_main,
8172       map  $_->cust_main,
8173       grep $_,
8174       map  $_->cust_svc->cust_pkg,
8175           qsearch( {
8176                      'table'     => 'svc_acct',
8177                      'hashref'   => { 'username' => $user, },
8178                      'extra_sql' =>
8179                        'AND ( SELECT domain FROM svc_domain
8180                                 WHERE svc_acct.domsvc = svc_domain.svcnum
8181                             ) = '. dbh->quote($domain),
8182                    }
8183                  );
8184   }
8185
8186   my %saw = ();
8187   @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
8188
8189   warn "$me smart_search: found ". scalar(@cust_main). " unique customers"
8190     if $DEBUG;
8191
8192   @cust_main;
8193
8194 }
8195
8196 =item check_and_rebuild_fuzzyfiles
8197
8198 =cut
8199
8200 use vars qw(@fuzzyfields);
8201 @fuzzyfields = ( 'last', 'first', 'company' );
8202
8203 sub check_and_rebuild_fuzzyfiles {
8204   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
8205   rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
8206 }
8207
8208 =item rebuild_fuzzyfiles
8209
8210 =cut
8211
8212 sub rebuild_fuzzyfiles {
8213
8214   use Fcntl qw(:flock);
8215
8216   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
8217   mkdir $dir, 0700 unless -d $dir;
8218
8219   foreach my $fuzzy ( @fuzzyfields ) {
8220
8221     open(LOCK,">>$dir/cust_main.$fuzzy")
8222       or die "can't open $dir/cust_main.$fuzzy: $!";
8223     flock(LOCK,LOCK_EX)
8224       or die "can't lock $dir/cust_main.$fuzzy: $!";
8225
8226     open (CACHE,">$dir/cust_main.$fuzzy.tmp")
8227       or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
8228
8229     foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
8230       my $sth = dbh->prepare("SELECT $field FROM cust_main".
8231                              " WHERE $field != '' AND $field IS NOT NULL");
8232       $sth->execute or die $sth->errstr;
8233
8234       while ( my $row = $sth->fetchrow_arrayref ) {
8235         print CACHE $row->[0]. "\n";
8236       }
8237
8238     }
8239
8240     close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
8241
8242     rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
8243     close LOCK;
8244   }
8245
8246 }
8247
8248 =item all_X
8249
8250 =cut
8251
8252 sub all_X {
8253   my( $self, $field ) = @_;
8254   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
8255   open(CACHE,"<$dir/cust_main.$field")
8256     or die "can't open $dir/cust_main.$field: $!";
8257   my @array = map { chomp; $_; } <CACHE>;
8258   close CACHE;
8259   \@array;
8260 }
8261
8262 =item append_fuzzyfiles LASTNAME COMPANY
8263
8264 =cut
8265
8266 sub append_fuzzyfiles {
8267   #my( $first, $last, $company ) = @_;
8268
8269   &check_and_rebuild_fuzzyfiles;
8270
8271   use Fcntl qw(:flock);
8272
8273   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
8274
8275   foreach my $field (qw( first last company )) {
8276     my $value = shift;
8277
8278     if ( $value ) {
8279
8280       open(CACHE,">>$dir/cust_main.$field")
8281         or die "can't open $dir/cust_main.$field: $!";
8282       flock(CACHE,LOCK_EX)
8283         or die "can't lock $dir/cust_main.$field: $!";
8284
8285       print CACHE "$value\n";
8286
8287       flock(CACHE,LOCK_UN)
8288         or die "can't unlock $dir/cust_main.$field: $!";
8289       close CACHE;
8290     }
8291
8292   }
8293
8294   1;
8295 }
8296
8297 =item batch_charge
8298
8299 =cut
8300
8301 sub batch_charge {
8302   my $param = shift;
8303   #warn join('-',keys %$param);
8304   my $fh = $param->{filehandle};
8305   my @fields = @{$param->{fields}};
8306
8307   eval "use Text::CSV_XS;";
8308   die $@ if $@;
8309
8310   my $csv = new Text::CSV_XS;
8311   #warn $csv;
8312   #warn $fh;
8313
8314   my $imported = 0;
8315   #my $columns;
8316
8317   local $SIG{HUP} = 'IGNORE';
8318   local $SIG{INT} = 'IGNORE';
8319   local $SIG{QUIT} = 'IGNORE';
8320   local $SIG{TERM} = 'IGNORE';
8321   local $SIG{TSTP} = 'IGNORE';
8322   local $SIG{PIPE} = 'IGNORE';
8323
8324   my $oldAutoCommit = $FS::UID::AutoCommit;
8325   local $FS::UID::AutoCommit = 0;
8326   my $dbh = dbh;
8327
8328   #while ( $columns = $csv->getline($fh) ) {
8329   my $line;
8330   while ( defined($line=<$fh>) ) {
8331
8332     $csv->parse($line) or do {
8333       $dbh->rollback if $oldAutoCommit;
8334       return "can't parse: ". $csv->error_input();
8335     };
8336
8337     my @columns = $csv->fields();
8338     #warn join('-',@columns);
8339
8340     my %row = ();
8341     foreach my $field ( @fields ) {
8342       $row{$field} = shift @columns;
8343     }
8344
8345     my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
8346     unless ( $cust_main ) {
8347       $dbh->rollback if $oldAutoCommit;
8348       return "unknown custnum $row{'custnum'}";
8349     }
8350
8351     if ( $row{'amount'} > 0 ) {
8352       my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
8353       if ( $error ) {
8354         $dbh->rollback if $oldAutoCommit;
8355         return $error;
8356       }
8357       $imported++;
8358     } elsif ( $row{'amount'} < 0 ) {
8359       my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
8360                                       $row{'pkg'}                         );
8361       if ( $error ) {
8362         $dbh->rollback if $oldAutoCommit;
8363         return $error;
8364       }
8365       $imported++;
8366     } else {
8367       #hmm?
8368     }
8369
8370   }
8371
8372   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
8373
8374   return "Empty file!" unless $imported;
8375
8376   ''; #no error
8377
8378 }
8379
8380 =item notify CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
8381
8382 Sends a templated email notification to the customer (see L<Text::Template>).
8383
8384 OPTIONS is a hash and may include
8385
8386 I<from> - the email sender (default is invoice_from)
8387
8388 I<to> - comma-separated scalar or arrayref of recipients
8389    (default is invoicing_list)
8390
8391 I<subject> - The subject line of the sent email notification
8392    (default is "Notice from company_name")
8393
8394 I<extra_fields> - a hashref of name/value pairs which will be substituted
8395    into the template
8396
8397 The following variables are vavailable in the template.
8398
8399 I<$first> - the customer first name
8400 I<$last> - the customer last name
8401 I<$company> - the customer company
8402 I<$payby> - a description of the method of payment for the customer
8403             # would be nice to use FS::payby::shortname
8404 I<$payinfo> - the account information used to collect for this customer
8405 I<$expdate> - the expiration of the customer payment in seconds from epoch
8406
8407 =cut
8408
8409 sub notify {
8410   my ($self, $template, %options) = @_;
8411
8412   return unless $conf->exists($template);
8413
8414   my $from = $conf->config('invoice_from', $self->agentnum)
8415     if $conf->exists('invoice_from', $self->agentnum);
8416   $from = $options{from} if exists($options{from});
8417
8418   my $to = join(',', $self->invoicing_list_emailonly);
8419   $to = $options{to} if exists($options{to});
8420
8421   my $subject = "Notice from " . $conf->config('company_name', $self->agentnum)
8422     if $conf->exists('company_name', $self->agentnum);
8423   $subject = $options{subject} if exists($options{subject});
8424
8425   my $notify_template = new Text::Template (TYPE => 'ARRAY',
8426                                             SOURCE => [ map "$_\n",
8427                                               $conf->config($template)]
8428                                            )
8429     or die "can't create new Text::Template object: Text::Template::ERROR";
8430   $notify_template->compile()
8431     or die "can't compile template: Text::Template::ERROR";
8432
8433   $FS::notify_template::_template::company_name =
8434     $conf->config('company_name', $self->agentnum);
8435   $FS::notify_template::_template::company_address =
8436     join("\n", $conf->config('company_address', $self->agentnum) ). "\n";
8437
8438   my $paydate = $self->paydate || '2037-12-31';
8439   $FS::notify_template::_template::first = $self->first;
8440   $FS::notify_template::_template::last = $self->last;
8441   $FS::notify_template::_template::company = $self->company;
8442   $FS::notify_template::_template::payinfo = $self->mask_payinfo;
8443   my $payby = $self->payby;
8444   my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
8445   my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
8446
8447   #credit cards expire at the end of the month/year of their exp date
8448   if ($payby eq 'CARD' || $payby eq 'DCRD') {
8449     $FS::notify_template::_template::payby = 'credit card';
8450     ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
8451     $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
8452     $expire_time--;
8453   }elsif ($payby eq 'COMP') {
8454     $FS::notify_template::_template::payby = 'complimentary account';
8455   }else{
8456     $FS::notify_template::_template::payby = 'current method';
8457   }
8458   $FS::notify_template::_template::expdate = $expire_time;
8459
8460   for (keys %{$options{extra_fields}}){
8461     no strict "refs";
8462     ${"FS::notify_template::_template::$_"} = $options{extra_fields}->{$_};
8463   }
8464
8465   send_email(from => $from,
8466              to => $to,
8467              subject => $subject,
8468              body => $notify_template->fill_in( PACKAGE =>
8469                                                 'FS::notify_template::_template'                                              ),
8470             );
8471
8472 }
8473
8474 =item generate_letter CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
8475
8476 Generates a templated notification to the customer (see L<Text::Template>).
8477
8478 OPTIONS is a hash and may include
8479
8480 I<extra_fields> - a hashref of name/value pairs which will be substituted
8481    into the template.  These values may override values mentioned below
8482    and those from the customer record.
8483
8484 The following variables are available in the template instead of or in addition
8485 to the fields of the customer record.
8486
8487 I<$payby> - a description of the method of payment for the customer
8488             # would be nice to use FS::payby::shortname
8489 I<$payinfo> - the masked account information used to collect for this customer
8490 I<$expdate> - the expiration of the customer payment method in seconds from epoch
8491 I<$returnaddress> - the return address defaults to invoice_latexreturnaddress or company_address
8492
8493 =cut
8494
8495 sub generate_letter {
8496   my ($self, $template, %options) = @_;
8497
8498   return unless $conf->exists($template);
8499
8500   my $letter_template = new Text::Template
8501                         ( TYPE       => 'ARRAY',
8502                           SOURCE     => [ map "$_\n", $conf->config($template)],
8503                           DELIMITERS => [ '[@--', '--@]' ],
8504                         )
8505     or die "can't create new Text::Template object: Text::Template::ERROR";
8506
8507   $letter_template->compile()
8508     or die "can't compile template: Text::Template::ERROR";
8509
8510   my %letter_data = map { $_ => $self->$_ } $self->fields;
8511   $letter_data{payinfo} = $self->mask_payinfo;
8512
8513   #my $paydate = $self->paydate || '2037-12-31';
8514   my $paydate = $self->paydate =~ /^\S+$/ ? $self->paydate : '2037-12-31';
8515
8516   my $payby = $self->payby;
8517   my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
8518   my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
8519
8520   #credit cards expire at the end of the month/year of their exp date
8521   if ($payby eq 'CARD' || $payby eq 'DCRD') {
8522     $letter_data{payby} = 'credit card';
8523     ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
8524     $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
8525     $expire_time--;
8526   }elsif ($payby eq 'COMP') {
8527     $letter_data{payby} = 'complimentary account';
8528   }else{
8529     $letter_data{payby} = 'current method';
8530   }
8531   $letter_data{expdate} = $expire_time;
8532
8533   for (keys %{$options{extra_fields}}){
8534     $letter_data{$_} = $options{extra_fields}->{$_};
8535   }
8536
8537   unless(exists($letter_data{returnaddress})){
8538     my $retadd = join("\n", $conf->config_orbase( 'invoice_latexreturnaddress',
8539                                                   $self->agent_template)
8540                      );
8541     if ( length($retadd) ) {
8542       $letter_data{returnaddress} = $retadd;
8543     } elsif ( grep /\S/, $conf->config('company_address', $self->agentnum) ) {
8544       $letter_data{returnaddress} =
8545         join( '\\*'."\n", map s/( {2,})/'~' x length($1)/eg,
8546                           $conf->config('company_address', $self->agentnum)
8547         );
8548     } else {
8549       $letter_data{returnaddress} = '~';
8550     }
8551   }
8552
8553   $letter_data{conf_dir} = "$FS::UID::conf_dir/conf.$FS::UID::datasrc";
8554
8555   $letter_data{company_name} = $conf->config('company_name', $self->agentnum);
8556
8557   my $dir = $FS::UID::conf_dir."/cache.". $FS::UID::datasrc;
8558   my $fh = new File::Temp( TEMPLATE => 'letter.'. $self->custnum. '.XXXXXXXX',
8559                            DIR      => $dir,
8560                            SUFFIX   => '.tex',
8561                            UNLINK   => 0,
8562                          ) or die "can't open temp file: $!\n";
8563
8564   $letter_template->fill_in( OUTPUT => $fh, HASH => \%letter_data );
8565   close $fh;
8566   $fh->filename =~ /^(.*).tex$/ or die "unparsable filename: ". $fh->filename;
8567   return $1;
8568 }
8569
8570 =item print_ps TEMPLATE
8571
8572 Returns an postscript letter filled in from TEMPLATE, as a scalar.
8573
8574 =cut
8575
8576 sub print_ps {
8577   my $self = shift;
8578   my $file = $self->generate_letter(@_);
8579   FS::Misc::generate_ps($file);
8580 }
8581
8582 =item print TEMPLATE
8583
8584 Prints the filled in template.
8585
8586 TEMPLATE is the name of a L<Text::Template> to fill in and print.
8587
8588 =cut
8589
8590 sub queueable_print {
8591   my %opt = @_;
8592
8593   my $self = qsearchs('cust_main', { 'custnum' => $opt{custnum} } )
8594     or die "invalid customer number: " . $opt{custvnum};
8595
8596   my $error = $self->print( $opt{template} );
8597   die $error if $error;
8598 }
8599
8600 sub print {
8601   my ($self, $template) = (shift, shift);
8602   do_print [ $self->print_ps($template) ];
8603 }
8604
8605 #these three subs should just go away once agent stuff is all config overrides
8606
8607 sub agent_template {
8608   my $self = shift;
8609   $self->_agent_plandata('agent_templatename');
8610 }
8611
8612 sub agent_invoice_from {
8613   my $self = shift;
8614   $self->_agent_plandata('agent_invoice_from');
8615 }
8616
8617 sub _agent_plandata {
8618   my( $self, $option ) = @_;
8619
8620   #yuck.  this whole thing needs to be reconciled better with 1.9's idea of
8621   #agent-specific Conf
8622
8623   use FS::part_event::Condition;
8624
8625   my $agentnum = $self->agentnum;
8626
8627   my $regexp = '';
8628   if ( driver_name =~ /^Pg/i ) {
8629     $regexp = '~';
8630   } elsif ( driver_name =~ /^mysql/i ) {
8631     $regexp = 'REGEXP';
8632   } else {
8633     die "don't know how to use regular expressions in ". driver_name. " databases";
8634   }
8635
8636   my $part_event_option =
8637     qsearchs({
8638       'select'    => 'part_event_option.*',
8639       'table'     => 'part_event_option',
8640       'addl_from' => q{
8641         LEFT JOIN part_event USING ( eventpart )
8642         LEFT JOIN part_event_option AS peo_agentnum
8643           ON ( part_event.eventpart = peo_agentnum.eventpart
8644                AND peo_agentnum.optionname = 'agentnum'
8645                AND peo_agentnum.optionvalue }. $regexp. q{ '(^|,)}. $agentnum. q{(,|$)'
8646              )
8647         LEFT JOIN part_event_condition
8648           ON ( part_event.eventpart = part_event_condition.eventpart
8649                AND part_event_condition.conditionname = 'cust_bill_age'
8650              )
8651         LEFT JOIN part_event_condition_option
8652           ON ( part_event_condition.eventconditionnum = part_event_condition_option.eventconditionnum
8653                AND part_event_condition_option.optionname = 'age'
8654              )
8655       },
8656       #'hashref'   => { 'optionname' => $option },
8657       #'hashref'   => { 'part_event_option.optionname' => $option },
8658       'extra_sql' =>
8659         " WHERE part_event_option.optionname = ". dbh->quote($option).
8660         " AND action = 'cust_bill_send_agent' ".
8661         " AND ( disabled IS NULL OR disabled != 'Y' ) ".
8662         " AND peo_agentnum.optionname = 'agentnum' ".
8663         " AND ( agentnum IS NULL OR agentnum = $agentnum ) ".
8664         " ORDER BY
8665            CASE WHEN part_event_condition_option.optionname IS NULL
8666            THEN -1
8667            ELSE ". FS::part_event::Condition->age2seconds_sql('part_event_condition_option.optionvalue').
8668         " END
8669           , part_event.weight".
8670         " LIMIT 1"
8671     });
8672
8673   unless ( $part_event_option ) {
8674     return $self->agent->invoice_template || ''
8675       if $option eq 'agent_templatename';
8676     return '';
8677   }
8678
8679   $part_event_option->optionvalue;
8680
8681 }
8682
8683 sub queued_bill {
8684   ## actual sub, not a method, designed to be called from the queue.
8685   ## sets up the customer, and calls the bill_and_collect
8686   my (%args) = @_; #, ($time, $invoice_time, $check_freq, $resetup) = @_;
8687   my $cust_main = qsearchs( 'cust_main', { custnum => $args{'custnum'} } );
8688       $cust_main->bill_and_collect(
8689         %args,
8690       );
8691 }
8692
8693 sub _upgrade_data { #class method
8694   my ($class, %opts) = @_;
8695
8696   my $sql = 'UPDATE h_cust_main SET paycvv = NULL WHERE paycvv IS NOT NULL';
8697   my $sth = dbh->prepare($sql) or die dbh->errstr;
8698   $sth->execute or die $sth->errstr;
8699
8700 }
8701
8702 =back
8703
8704 =head1 BUGS
8705
8706 The delete method.
8707
8708 The delete method should possibly take an FS::cust_main object reference
8709 instead of a scalar customer number.
8710
8711 Bill and collect options should probably be passed as references instead of a
8712 list.
8713
8714 There should probably be a configuration file with a list of allowed credit
8715 card types.
8716
8717 No multiple currency support (probably a larger project than just this module).
8718
8719 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
8720
8721 Birthdates rely on negative epoch values.
8722
8723 The payby for card/check batches is broken.  With mixed batching, bad
8724 things will happen.
8725
8726 B<collect> I<invoice_time> should be renamed I<time>, like B<bill>.
8727
8728 =head1 SEE ALSO
8729
8730 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
8731 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
8732 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.
8733
8734 =cut
8735
8736 1;
8737