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