FS/FS/cust_main.pm

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