FS/FS/cust_main.pm

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