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 timelocal_nocheck);
  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       #change this bit to use Date::Manip? CAREFUL with timezones (see
2667       # mailing list archive)
2668       my ($sec,$min,$hour,$mday,$mon,$year) =
2669         (localtime($sdate) )[0,1,2,3,4,5];
2670
2671       #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
2672       # only for figuring next bill date, nothing else, so, reset $sdate again
2673       # here
2674       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2675       #no need, its in $hash{last_bill}# my $last_bill = $cust_pkg->last_bill;
2676       $cust_pkg->last_bill($sdate);
2677
2678       if ( $part_pkg->freq =~ /^\d+$/ ) {
2679         $mon += $part_pkg->freq;
2680         until ( $mon < 12 ) { $mon -= 12; $year++; }
2681       } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
2682         my $weeks = $1;
2683         $mday += $weeks * 7;
2684       } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
2685         my $days = $1;
2686         $mday += $days;
2687       } elsif ( $part_pkg->freq =~ /^(\d+)h$/ ) {
2688         my $hours = $1;
2689         $hour += $hours;
2690       } else {
2691         return "unparsable frequency: ". $part_pkg->freq;
2692       }
2693       $cust_pkg->setfield('bill',
2694         timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
2695
2696     }
2697
2698   }
2699
2700   warn "\$setup is undefined" unless defined($setup);
2701   warn "\$recur is undefined" unless defined($recur);
2702   warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
2703
2704   ###
2705   # If there's line items, create em cust_bill_pkg records
2706   # If $cust_pkg has been modified, update it (if we're a real pkgpart)
2707   ###
2708
2709   if ( $lineitems ) {
2710
2711     if ( $cust_pkg->modified && $cust_pkg->pkgpart == $real_pkgpart ) {
2712       # hmm.. and if just the options are modified in some weird price plan?
2713
2714       warn "  package ". $cust_pkg->pkgnum. " modified; updating\n"
2715         if $DEBUG >1;
2716
2717       my $error = $cust_pkg->replace( $old_cust_pkg,
2718                                       'options' => { $cust_pkg->options },
2719                                     );
2720       return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error"
2721         if $error; #just in case
2722     }
2723
2724     $setup = sprintf( "%.2f", $setup );
2725     $recur = sprintf( "%.2f", $recur );
2726     if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
2727       return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
2728     }
2729     if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
2730       return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
2731     }
2732
2733     if ( $setup != 0 || $recur != 0 ) {
2734
2735       warn "    charges (setup=$setup, recur=$recur); adding line items\n"
2736         if $DEBUG > 1;
2737
2738       my @cust_pkg_detail = map { $_->detail } $cust_pkg->cust_pkg_detail('I');
2739       if ( $DEBUG > 1 ) {
2740         warn "      adding customer package invoice detail: $_\n"
2741           foreach @cust_pkg_detail;
2742       }
2743       push @details, @cust_pkg_detail;
2744
2745       my $cust_bill_pkg = new FS::cust_bill_pkg {
2746         'pkgnum'    => $cust_pkg->pkgnum,
2747         'setup'     => $setup,
2748         'unitsetup' => $unitsetup,
2749         'recur'     => $recur,
2750         'unitrecur' => $unitrecur,
2751         'quantity'  => $cust_pkg->quantity,
2752         'details'   => \@details,
2753       };
2754
2755       if ( $part_pkg->option('recur_temporality', 1) eq 'preceding' ) {
2756         $cust_bill_pkg->sdate( $hash{last_bill} );
2757         $cust_bill_pkg->edate( $sdate - 86399   ); #60s*60m*24h-1
2758       } else { #if ( $part_pkg->option('recur_temporality', 1) eq 'upcoming' ) {
2759         $cust_bill_pkg->sdate( $sdate );
2760         $cust_bill_pkg->edate( $cust_pkg->bill );
2761       }
2762
2763       $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
2764         unless $part_pkg->pkgpart == $real_pkgpart;
2765
2766       $$total_setup += $setup;
2767       $$total_recur += $recur;
2768
2769       ###
2770       # handle taxes
2771       ###
2772
2773       my $error =
2774         $self->_handle_taxes($part_pkg, $taxlisthash, $cust_bill_pkg, $cust_pkg);
2775       return $error if $error;
2776
2777       push @$cust_bill_pkgs, $cust_bill_pkg;
2778
2779     } #if $setup != 0 || $recur != 0
2780
2781   } #if $line_items
2782
2783   '';
2784
2785 }
2786
2787 sub _handle_taxes {
2788   my $self = shift;
2789   my $part_pkg = shift;
2790   my $taxlisthash = shift;
2791   my $cust_bill_pkg = shift;
2792   my $cust_pkg = shift;
2793
2794   my %cust_bill_pkg = ();
2795   my %taxes = ();
2796
2797   my @classes;
2798   #push @classes, $cust_bill_pkg->usage_classes if $cust_bill_pkg->type eq 'U';
2799   push @classes, $cust_bill_pkg->usage_classes if $cust_bill_pkg->usage;
2800   push @classes, 'setup' if $cust_bill_pkg->setup;
2801   push @classes, 'recur' if $cust_bill_pkg->recur;
2802
2803   if ( $self->tax !~ /Y/i && $self->payby ne 'COMP' ) {
2804
2805     if ( $conf->exists('enable_taxproducts')
2806          && ( scalar($part_pkg->part_pkg_taxoverride)
2807               || $part_pkg->has_taxproduct
2808             )
2809        )
2810     {
2811
2812       if ( $conf->exists('tax-pkg_address') && $cust_pkg->locationnum ) {
2813         return "fatal: Can't (yet) use tax-pkg_address with taxproducts";
2814       }
2815
2816       foreach my $class (@classes) {
2817         my $err_or_ref = $self->_gather_taxes( $part_pkg, $class );
2818         return $err_or_ref unless ref($err_or_ref);
2819         $taxes{$class} = $err_or_ref;
2820       }
2821
2822       unless (exists $taxes{''}) {
2823         my $err_or_ref = $self->_gather_taxes( $part_pkg, '' );
2824         return $err_or_ref unless ref($err_or_ref);
2825         $taxes{''} = $err_or_ref;
2826       }
2827
2828     } else {
2829
2830       my @loc_keys = qw( state county country );
2831       my %taxhash;
2832       if ( $conf->exists('tax-pkg_address') && $cust_pkg->locationnum ) {
2833         my $cust_location = $cust_pkg->cust_location;
2834         %taxhash = map { $_ => $cust_location->$_()    } @loc_keys;
2835       } else {
2836         my $prefix =
2837           ( $conf->exists('tax-ship_address') && length($self->ship_last) )
2838           ? 'ship_'
2839           : '';
2840         %taxhash = map { $_ => $self->get("$prefix$_") } @loc_keys;
2841       }
2842
2843       $taxhash{'taxclass'} = $part_pkg->taxclass;
2844
2845       my @taxes = qsearch( 'cust_main_county', \%taxhash );
2846
2847       unless ( @taxes ) {
2848         $taxhash{'taxclass'} = '';
2849         @taxes =  qsearch( 'cust_main_county', \%taxhash );
2850       }
2851
2852       #one more try at a whole-country tax rate
2853       unless ( @taxes ) {
2854         $taxhash{$_} = '' foreach qw( state county );
2855         @taxes =  qsearch( 'cust_main_county', \%taxhash );
2856       }
2857
2858       if ( $conf->exists('tax-pkg_address') && $cust_pkg->locationnum ) {
2859         foreach (@taxes) {
2860           $_->set('pkgnum',      $cust_pkg->pkgnum );
2861           $_->set('locationnum', $cust_pkg->locationnum );
2862         }
2863       }
2864
2865       $taxes{''} = [ @taxes ];
2866       $taxes{'setup'} = [ @taxes ];
2867       $taxes{'recur'} = [ @taxes ];
2868       $taxes{$_} = [ @taxes ] foreach (@classes);
2869
2870       # maybe eliminate this entirely, along with all the 0% records
2871       unless ( @taxes ) {
2872         return
2873           "fatal: can't find tax rate for state/county/country/taxclass ".
2874           join('/', map $taxhash{$_}, qw(state county country taxclass) );
2875       }
2876
2877     } #if $conf->exists('enable_taxproducts') ...
2878
2879   }
2880
2881   my @display = ();
2882   if ( $conf->exists('separate_usage') ) {
2883     my $section = $cust_pkg->part_pkg->option('usage_section', 'Hush!');
2884     my $summary = $cust_pkg->part_pkg->option('summarize_usage', 'Hush!');
2885     push @display, new FS::cust_bill_pkg_display { type    => 'S' };
2886     push @display, new FS::cust_bill_pkg_display { type    => 'R' };
2887     push @display, new FS::cust_bill_pkg_display { type    => 'U',
2888                                                    section => $section
2889                                                  };
2890     if ($section && $summary) {
2891       $display[2]->post_total('Y');
2892       push @display, new FS::cust_bill_pkg_display { type    => 'U',
2893                                                      summary => 'Y',
2894                                                    }
2895     }
2896   }
2897   $cust_bill_pkg->set('display', \@display);
2898
2899   my %tax_cust_bill_pkg = $cust_bill_pkg->disintegrate;
2900   foreach my $key (keys %tax_cust_bill_pkg) {
2901     my @taxes = @{ $taxes{$key} || [] };
2902     my $tax_cust_bill_pkg = $tax_cust_bill_pkg{$key};
2903
2904     foreach my $tax ( @taxes ) {
2905
2906       my $taxname = ref( $tax ). ' taxnum'. $tax->taxnum;
2907 #      $taxname .= ' pkgnum'. $cust_pkg->pkgnum.
2908 #                  ' locationnum'. $cust_pkg->locationnum
2909 #        if $conf->exists('tax-pkg_address') && $cust_pkg->locationnum;
2910
2911       if ( exists( $taxlisthash->{ $taxname } ) ) {
2912         push @{ $taxlisthash->{ $taxname  } }, $tax_cust_bill_pkg;
2913       }else{
2914         $taxlisthash->{ $taxname } = [ $tax, $tax_cust_bill_pkg ];
2915       }
2916     }
2917   }
2918
2919   '';
2920 }
2921
2922 sub _gather_taxes {
2923   my $self = shift;
2924   my $part_pkg = shift;
2925   my $class = shift;
2926
2927   my @taxes = ();
2928   my $geocode = $self->geocode('cch');
2929
2930   my @taxclassnums = map { $_->taxclassnum }
2931                      $part_pkg->part_pkg_taxoverride($class);
2932
2933   unless (@taxclassnums) {
2934     @taxclassnums = map { $_->taxclassnum }
2935                     $part_pkg->part_pkg_taxrate('cch', $geocode, $class);
2936   }
2937   warn "Found taxclassnum values of ". join(',', @taxclassnums)
2938     if $DEBUG;
2939
2940   my $extra_sql =
2941     "AND (".
2942     join(' OR ', map { "taxclassnum = $_" } @taxclassnums ). ")";
2943
2944   @taxes = qsearch({ 'table' => 'tax_rate',
2945                      'hashref' => { 'geocode' => $geocode, },
2946                      'extra_sql' => $extra_sql,
2947                   })
2948     if scalar(@taxclassnums);
2949
2950   # maybe eliminate this entirely, along with all the 0% records
2951   unless ( @taxes ) {
2952     return
2953       "fatal: can't find tax rate for geocode/taxproduct/pkgpart ".
2954       join('/', $geocode,
2955                 $part_pkg->taxproduct_description,
2956                 $part_pkg->pkgpart
2957           );
2958   }
2959
2960   warn "Found taxes ".
2961        join(',', map{ ref($_). " ". $_->get($_->primary_key) } @taxes). "\n"
2962    if $DEBUG;
2963
2964   [ @taxes ];
2965
2966 }
2967
2968 =item collect OPTIONS
2969
2970 (Attempt to) collect money for this customer's outstanding invoices (see
2971 L<FS::cust_bill>).  Usually used after the bill method.
2972
2973 Actions are now triggered by billing events; see L<FS::part_event> and the
2974 billing events web interface.  Old-style invoice events (see
2975 L<FS::part_bill_event>) have been deprecated.
2976
2977 If there is an error, returns the error, otherwise returns false.
2978
2979 Options are passed as name-value pairs.
2980
2981 Currently available options are:
2982
2983 =over 4
2984
2985 =item invoice_time
2986
2987 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.
2988
2989 =item retry
2990
2991 Retry card/echeck/LEC transactions even when not scheduled by invoice events.
2992
2993 =item quiet
2994
2995 set true to surpress email card/ACH decline notices.
2996
2997 =item check_freq
2998
2999 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
3000
3001 =item payby
3002
3003 allows for one time override of normal customer billing method
3004
3005 =item debug
3006
3007 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)
3008
3009
3010 =back
3011
3012 =cut
3013
3014 sub collect {
3015   my( $self, %options ) = @_;
3016   my $invoice_time = $options{'invoice_time'} || time;
3017
3018   #put below somehow?
3019   local $SIG{HUP} = 'IGNORE';
3020   local $SIG{INT} = 'IGNORE';
3021   local $SIG{QUIT} = 'IGNORE';
3022   local $SIG{TERM} = 'IGNORE';
3023   local $SIG{TSTP} = 'IGNORE';
3024   local $SIG{PIPE} = 'IGNORE';
3025
3026   my $oldAutoCommit = $FS::UID::AutoCommit;
3027   local $FS::UID::AutoCommit = 0;
3028   my $dbh = dbh;
3029
3030   $self->select_for_update; #mutex
3031
3032   if ( $DEBUG ) {
3033     my $balance = $self->balance;
3034     warn "$me collect customer ". $self->custnum. ": balance $balance\n"
3035   }
3036
3037   if ( exists($options{'retry_card'}) ) {
3038     carp 'retry_card option passed to collect is deprecated; use retry';
3039     $options{'retry'} ||= $options{'retry_card'};
3040   }
3041   if ( exists($options{'retry'}) && $options{'retry'} ) {
3042     my $error = $self->retry_realtime;
3043     if ( $error ) {
3044       $dbh->rollback if $oldAutoCommit;
3045       return $error;
3046     }
3047   }
3048
3049   # false laziness w/pay_batch::import_results
3050
3051   my $due_cust_event = $self->due_cust_event(
3052     'debug'      => ( $options{'debug'} || 0 ),
3053     'time'       => $invoice_time,
3054     'check_freq' => $options{'check_freq'},
3055   );
3056   unless( ref($due_cust_event) ) {
3057     $dbh->rollback if $oldAutoCommit;
3058     return $due_cust_event;
3059   }
3060
3061   foreach my $cust_event ( @$due_cust_event ) {
3062
3063     #XXX lock event
3064
3065     #re-eval event conditions (a previous event could have changed things)
3066     unless ( $cust_event->test_conditions( 'time' => $invoice_time ) ) {
3067       #don't leave stray "new/locked" records around
3068       my $error = $cust_event->delete;
3069       if ( $error ) {
3070         #gah, even with transactions
3071         $dbh->commit if $oldAutoCommit; #well.
3072         return $error;
3073       }
3074       next;
3075     }
3076
3077     {
3078       local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
3079       warn "  running cust_event ". $cust_event->eventnum. "\n"
3080         if $DEBUG > 1;
3081
3082
3083       #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
3084       if ( my $error = $cust_event->do_event() ) {
3085         #XXX wtf is this?  figure out a proper dealio with return value
3086         #from do_event
3087           # gah, even with transactions.
3088           $dbh->commit if $oldAutoCommit; #well.
3089           return $error;
3090         }
3091     }
3092
3093   }
3094
3095   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3096   '';
3097
3098 }
3099
3100 =item due_cust_event [ HASHREF | OPTION => VALUE ... ]
3101
3102 Inserts database records for and returns an ordered listref of new events due
3103 for this customer, as FS::cust_event objects (see L<FS::cust_event>).  If no
3104 events are due, an empty listref is returned.  If there is an error, returns a
3105 scalar error message.
3106
3107 To actually run the events, call each event's test_condition method, and if
3108 still true, call the event's do_event method.
3109
3110 Options are passed as a hashref or as a list of name-value pairs.  Available
3111 options are:
3112
3113 =over 4
3114
3115 =item check_freq
3116
3117 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.
3118
3119 =item time
3120
3121 "Current time" for the events.
3122
3123 =item debug
3124
3125 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)
3126
3127 =item eventtable
3128
3129 Only return events for the specified eventtable (by default, events of all eventtables are returned)
3130
3131 =item objects
3132
3133 Explicitly pass the objects to be tested (typically used with eventtable).
3134
3135 =item testonly
3136
3137 Set to true to return the objects, but not actually insert them into the
3138 database.
3139
3140 =back
3141
3142 =cut
3143
3144 sub due_cust_event {
3145   my $self = shift;
3146   my %opt = ref($_[0]) ? %{ $_[0] } : @_;
3147
3148   #???
3149   #my $DEBUG = $opt{'debug'}
3150   local($DEBUG) = $opt{'debug'}
3151     if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG;
3152
3153   warn "$me due_cust_event called with options ".
3154        join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
3155     if $DEBUG;
3156
3157   $opt{'time'} ||= time;
3158
3159   local $SIG{HUP} = 'IGNORE';
3160   local $SIG{INT} = 'IGNORE';
3161   local $SIG{QUIT} = 'IGNORE';
3162   local $SIG{TERM} = 'IGNORE';
3163   local $SIG{TSTP} = 'IGNORE';
3164   local $SIG{PIPE} = 'IGNORE';
3165
3166   my $oldAutoCommit = $FS::UID::AutoCommit;
3167   local $FS::UID::AutoCommit = 0;
3168   my $dbh = dbh;
3169
3170   $self->select_for_update #mutex
3171     unless $opt{testonly};
3172
3173   ###
3174   # 1: find possible events (initial search)
3175   ###
3176
3177   my @cust_event = ();
3178
3179   my @eventtable = $opt{'eventtable'}
3180                      ? ( $opt{'eventtable'} )
3181                      : FS::part_event->eventtables_runorder;
3182
3183   foreach my $eventtable ( @eventtable ) {
3184
3185     my @objects;
3186     if ( $opt{'objects'} ) {
3187
3188       @objects = @{ $opt{'objects'} };
3189
3190     } else {
3191
3192       #my @objects = $self->eventtable(); # sub cust_main { @{ [ $self ] }; }
3193       @objects = ( $eventtable eq 'cust_main' )
3194                    ? ( $self )
3195                    : ( $self->$eventtable() );
3196
3197     }
3198
3199     my @e_cust_event = ();
3200
3201     my $cross = "CROSS JOIN $eventtable";
3202     $cross .= ' LEFT JOIN cust_main USING ( custnum )'
3203       unless $eventtable eq 'cust_main';
3204
3205     foreach my $object ( @objects ) {
3206
3207       #this first search uses the condition_sql magic for optimization.
3208       #the more possible events we can eliminate in this step the better
3209
3210       my $cross_where = '';
3211       my $pkey = $object->primary_key;
3212       $cross_where = "$eventtable.$pkey = ". $object->$pkey();
3213
3214       my $join = FS::part_event_condition->join_conditions_sql( $eventtable );
3215       my $extra_sql =
3216         FS::part_event_condition->where_conditions_sql( $eventtable,
3217                                                         'time'=>$opt{'time'}
3218                                                       );
3219       my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
3220
3221       $extra_sql = "AND $extra_sql" if $extra_sql;
3222
3223       #here is the agent virtualization
3224       $extra_sql .= " AND (    part_event.agentnum IS NULL
3225                             OR part_event.agentnum = ". $self->agentnum. ' )';
3226
3227       $extra_sql .= " $order";
3228
3229       warn "searching for events for $eventtable ". $object->$pkey. "\n"
3230         if $opt{'debug'} > 2;
3231       my @part_event = qsearch( {
3232         'debug'     => ( $opt{'debug'} > 3 ? 1 : 0 ),
3233         'select'    => 'part_event.*',
3234         'table'     => 'part_event',
3235         'addl_from' => "$cross $join",
3236         'hashref'   => { 'check_freq' => ( $opt{'check_freq'} || '1d' ),
3237                          'eventtable' => $eventtable,
3238                          'disabled'   => '',
3239                        },
3240         'extra_sql' => "AND $cross_where $extra_sql",
3241       } );
3242
3243       if ( $DEBUG > 2 ) {
3244         my $pkey = $object->primary_key;
3245         warn "      ". scalar(@part_event).
3246              " possible events found for $eventtable ". $object->$pkey(). "\n";
3247       }
3248
3249       push @e_cust_event, map { $_->new_cust_event($object) } @part_event;
3250
3251     }
3252
3253     warn "    ". scalar(@e_cust_event).
3254          " subtotal possible cust events found for $eventtable\n"
3255       if $DEBUG > 1;
3256
3257     push @cust_event, @e_cust_event;
3258
3259   }
3260
3261   warn "  ". scalar(@cust_event).
3262        " total possible cust events found in initial search\n"
3263     if $DEBUG; # > 1;
3264
3265   ##
3266   # 2: test conditions
3267   ##
3268
3269   my %unsat = ();
3270
3271   @cust_event = grep $_->test_conditions( 'time'          => $opt{'time'},
3272                                           'stats_hashref' => \%unsat ),
3273                      @cust_event;
3274
3275   warn "  ". scalar(@cust_event). " cust events left satisfying conditions\n"
3276     if $DEBUG; # > 1;
3277
3278   warn "    invalid conditions not eliminated with condition_sql:\n".
3279        join('', map "      $_: ".$unsat{$_}."\n", keys %unsat )
3280     if $DEBUG; # > 1;
3281
3282   ##
3283   # 3: insert
3284   ##
3285
3286   unless( $opt{testonly} ) {
3287     foreach my $cust_event ( @cust_event ) {
3288
3289       my $error = $cust_event->insert();
3290       if ( $error ) {
3291         $dbh->rollback if $oldAutoCommit;
3292         return $error;
3293       }
3294
3295     }
3296   }
3297
3298   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3299
3300   ##
3301   # 4: return
3302   ##
3303
3304   warn "  returning events: ". Dumper(@cust_event). "\n"
3305     if $DEBUG > 2;
3306
3307   \@cust_event;
3308
3309 }
3310
3311 =item retry_realtime
3312
3313 Schedules realtime / batch  credit card / electronic check / LEC billing
3314 events for for retry.  Useful if card information has changed or manual
3315 retry is desired.  The 'collect' method must be called to actually retry
3316 the transaction.
3317
3318 Implementation details: For either this customer, or for each of this
3319 customer's open invoices, changes the status of the first "done" (with
3320 statustext error) realtime processing event to "failed".
3321
3322 =cut
3323
3324 sub retry_realtime {
3325   my $self = shift;
3326
3327   local $SIG{HUP} = 'IGNORE';
3328   local $SIG{INT} = 'IGNORE';
3329   local $SIG{QUIT} = 'IGNORE';
3330   local $SIG{TERM} = 'IGNORE';
3331   local $SIG{TSTP} = 'IGNORE';
3332   local $SIG{PIPE} = 'IGNORE';
3333
3334   my $oldAutoCommit = $FS::UID::AutoCommit;
3335   local $FS::UID::AutoCommit = 0;
3336   my $dbh = dbh;
3337
3338   #a little false laziness w/due_cust_event (not too bad, really)
3339
3340   my $join = FS::part_event_condition->join_conditions_sql;
3341   my $order = FS::part_event_condition->order_conditions_sql;
3342   my $mine =
3343   '( '
3344    . join ( ' OR ' , map {
3345     "( part_event.eventtable = " . dbh->quote($_)
3346     . " AND tablenum IN( SELECT " . dbdef->table($_)->primary_key . " from $_ where custnum = " . dbh->quote( $self->custnum ) . "))" ;
3347    } FS::part_event->eventtables)
3348    . ') ';
3349
3350   #here is the agent virtualization
3351   my $agent_virt = " (    part_event.agentnum IS NULL
3352                        OR part_event.agentnum = ". $self->agentnum. ' )';
3353
3354   #XXX this shouldn't be hardcoded, actions should declare it...
3355   my @realtime_events = qw(
3356     cust_bill_realtime_card
3357     cust_bill_realtime_check
3358     cust_bill_realtime_lec
3359     cust_bill_batch
3360   );
3361
3362   my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'",
3363                                                   @realtime_events
3364                                      ).
3365                           ' ) ';
3366
3367   my @cust_event = qsearchs({
3368     'table'     => 'cust_event',
3369     'select'    => 'cust_event.*',
3370     'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
3371     'hashref'   => { 'status' => 'done' },
3372     'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ".
3373                    " AND $mine AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
3374   });
3375
3376   my %seen_invnum = ();
3377   foreach my $cust_event (@cust_event) {
3378
3379     #max one for the customer, one for each open invoice
3380     my $cust_X = $cust_event->cust_X;
3381     next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
3382                           ? $cust_X->invnum
3383                           : 0
3384                         }++
3385          or $cust_event->part_event->eventtable eq 'cust_bill'
3386             && ! $cust_X->owed;
3387
3388     my $error = $cust_event->retry;
3389     if ( $error ) {
3390       $dbh->rollback if $oldAutoCommit;
3391       return "error scheduling event for retry: $error";
3392     }
3393
3394   }
3395
3396   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3397   '';
3398
3399 }
3400
3401 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
3402
3403 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
3404 via a Business::OnlinePayment realtime gateway.  See
3405 L<http://420.am/business-onlinepayment> for supported gateways.
3406
3407 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3408
3409 Available options are: I<description>, I<invnum>, I<quiet>, I<paynum_ref>, I<payunique>
3410
3411 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3412 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
3413 if set, will override the value from the customer record.
3414
3415 I<description> is a free-text field passed to the gateway.  It defaults to
3416 "Internet services".
3417
3418 If an I<invnum> is specified, this payment (if successful) is applied to the
3419 specified invoice.  If you don't specify an I<invnum> you might want to
3420 call the B<apply_payments> method.
3421
3422 I<quiet> can be set true to surpress email decline notices.
3423
3424 I<paynum_ref> can be set to a scalar reference.  It will be filled in with the
3425 resulting paynum, if any.
3426
3427 I<payunique> is a unique identifier for this payment.
3428
3429 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
3430
3431 =cut
3432
3433 sub realtime_bop {
3434   my( $self, $method, $amount, %options ) = @_;
3435   if ( $DEBUG ) {
3436     warn "$me realtime_bop: $method $amount\n";
3437     warn "  $_ => $options{$_}\n" foreach keys %options;
3438   }
3439
3440   $options{'description'} ||= 'Internet services';
3441
3442   return $self->fake_bop($method, $amount, %options) if $options{'fake'};
3443
3444   eval "use Business::OnlinePayment";
3445   die $@ if $@;
3446
3447   my $payinfo = exists($options{'payinfo'})
3448                   ? $options{'payinfo'}
3449                   : $self->payinfo;
3450
3451   my %method2payby = (
3452     'CC'     => 'CARD',
3453     'ECHECK' => 'CHEK',
3454     'LEC'    => 'LECB',
3455   );
3456
3457   ###
3458   # check for banned credit card/ACH
3459   ###
3460
3461   my $ban = qsearchs('banned_pay', {
3462     'payby'   => $method2payby{$method},
3463     'payinfo' => md5_base64($payinfo),
3464   } );
3465   return "Banned credit card" if $ban;
3466
3467   ###
3468   # select a gateway
3469   ###
3470
3471   my $taxclass = '';
3472   if ( $options{'invnum'} ) {
3473     my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
3474     die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
3475     my @taxclasses =
3476       map  { $_->part_pkg->taxclass }
3477       grep { $_ }
3478       map  { $_->cust_pkg }
3479       $cust_bill->cust_bill_pkg;
3480     unless ( grep { $taxclasses[0] ne $_ } @taxclasses ) { #unless there are
3481                                                            #different taxclasses
3482       $taxclass = $taxclasses[0];
3483     }
3484   }
3485
3486   #look for an agent gateway override first
3487   my $cardtype;
3488   if ( $method eq 'CC' ) {
3489     $cardtype = cardtype($payinfo);
3490   } elsif ( $method eq 'ECHECK' ) {
3491     $cardtype = 'ACH';
3492   } else {
3493     $cardtype = $method;
3494   }
3495
3496   my $override =
3497        qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3498                                            cardtype => $cardtype,
3499                                            taxclass => $taxclass,       } )
3500     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3501                                            cardtype => '',
3502                                            taxclass => $taxclass,       } )
3503     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3504                                            cardtype => $cardtype,
3505                                            taxclass => '',              } )
3506     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3507                                            cardtype => '',
3508                                            taxclass => '',              } );
3509
3510   my $payment_gateway = '';
3511   my( $processor, $login, $password, $action, @bop_options );
3512   if ( $override ) { #use a payment gateway override
3513
3514     $payment_gateway = $override->payment_gateway;
3515
3516     $processor   = $payment_gateway->gateway_module;
3517     $login       = $payment_gateway->gateway_username;
3518     $password    = $payment_gateway->gateway_password;
3519     $action      = $payment_gateway->gateway_action;
3520     @bop_options = $payment_gateway->options;
3521
3522   } else { #use the standard settings from the config
3523
3524     ( $processor, $login, $password, $action, @bop_options ) =
3525       $self->default_payment_gateway($method);
3526
3527   }
3528
3529   ###
3530   # massage data
3531   ###
3532
3533   my $address = exists($options{'address1'})
3534                     ? $options{'address1'}
3535                     : $self->address1;
3536   my $address2 = exists($options{'address2'})
3537                     ? $options{'address2'}
3538                     : $self->address2;
3539   $address .= ", ". $address2 if length($address2);
3540
3541   my $o_payname = exists($options{'payname'})
3542                     ? $options{'payname'}
3543                     : $self->payname;
3544   my($payname, $payfirst, $paylast);
3545   if ( $o_payname && $method ne 'ECHECK' ) {
3546     ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3547       or return "Illegal payname $payname";
3548     ($payfirst, $paylast) = ($1, $2);
3549   } else {
3550     $payfirst = $self->getfield('first');
3551     $paylast = $self->getfield('last');
3552     $payname =  "$payfirst $paylast";
3553   }
3554
3555   my @invoicing_list = $self->invoicing_list_emailonly;
3556   if ( $conf->exists('emailinvoiceautoalways')
3557        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3558        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3559     push @invoicing_list, $self->all_emails;
3560   }
3561
3562   my $email = ($conf->exists('business-onlinepayment-email-override'))
3563               ? $conf->config('business-onlinepayment-email-override')
3564               : $invoicing_list[0];
3565
3566   my %content = ();
3567
3568   my $payip = exists($options{'payip'})
3569                 ? $options{'payip'}
3570                 : $self->payip;
3571   $content{customer_ip} = $payip
3572     if length($payip);
3573
3574   $content{invoice_number} = $options{'invnum'}
3575     if exists($options{'invnum'}) && length($options{'invnum'});
3576
3577   $content{email_customer} =
3578     (    $conf->exists('business-onlinepayment-email_customer')
3579       || $conf->exists('business-onlinepayment-email-override') );
3580
3581   my $paydate = '';
3582   if ( $method eq 'CC' ) {
3583
3584     $content{card_number} = $payinfo;
3585     $paydate = exists($options{'paydate'})
3586                     ? $options{'paydate'}
3587                     : $self->paydate;
3588     $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3589     $content{expiration} = "$2/$1";
3590
3591     my $paycvv = exists($options{'paycvv'})
3592                    ? $options{'paycvv'}
3593                    : $self->paycvv;
3594     $content{cvv2} = $paycvv
3595       if length($paycvv);
3596
3597     my $paystart_month = exists($options{'paystart_month'})
3598                            ? $options{'paystart_month'}
3599                            : $self->paystart_month;
3600
3601     my $paystart_year  = exists($options{'paystart_year'})
3602                            ? $options{'paystart_year'}
3603                            : $self->paystart_year;
3604
3605     $content{card_start} = "$paystart_month/$paystart_year"
3606       if $paystart_month && $paystart_year;
3607
3608     my $payissue       = exists($options{'payissue'})
3609                            ? $options{'payissue'}
3610                            : $self->payissue;
3611     $content{issue_number} = $payissue if $payissue;
3612
3613     $content{recurring_billing} = 'YES'
3614       if qsearch('cust_pay', { 'custnum' => $self->custnum,
3615                                'payby'   => 'CARD',
3616                                'payinfo' => $payinfo,
3617                              } )
3618       || qsearch('cust_pay', { 'custnum' => $self->custnum,
3619                                'payby'   => 'CARD',
3620                                'paymask' => $self->mask_payinfo('CARD', $payinfo),
3621                              } );
3622
3623
3624   } elsif ( $method eq 'ECHECK' ) {
3625     ( $content{account_number}, $content{routing_code} ) =
3626       split('@', $payinfo);
3627     $content{bank_name} = $o_payname;
3628     $content{bank_state} = exists($options{'paystate'})
3629                              ? $options{'paystate'}
3630                              : $self->getfield('paystate');
3631     $content{account_type} = exists($options{'paytype'})
3632                                ? uc($options{'paytype'}) || 'CHECKING'
3633                                : uc($self->getfield('paytype')) || 'CHECKING';
3634     $content{account_name} = $payname;
3635     $content{customer_org} = $self->company ? 'B' : 'I';
3636     $content{state_id}       = exists($options{'stateid'})
3637                                  ? $options{'stateid'}
3638                                  : $self->getfield('stateid');
3639     $content{state_id_state} = exists($options{'stateid_state'})
3640                                  ? $options{'stateid_state'}
3641                                  : $self->getfield('stateid_state');
3642     $content{customer_ssn} = exists($options{'ss'})
3643                                ? $options{'ss'}
3644                                : $self->ss;
3645   } elsif ( $method eq 'LEC' ) {
3646     $content{phone} = $payinfo;
3647   }
3648
3649   ###
3650   # run transaction(s)
3651   ###
3652
3653   my $balance = exists( $options{'balance'} )
3654                   ? $options{'balance'}
3655                   : $self->balance;
3656
3657   $self->select_for_update; #mutex ... just until we get our pending record in
3658
3659   #the checks here are intended to catch concurrent payments
3660   #double-form-submission prevention is taken care of in cust_pay_pending::check
3661
3662   #check the balance
3663   return "The customer's balance has changed; $method transaction aborted."
3664     if $self->balance < $balance;
3665     #&& $self->balance < $amount; #might as well anyway?
3666
3667   #also check and make sure there aren't *other* pending payments for this cust
3668
3669   my @pending = qsearch('cust_pay_pending', {
3670     'custnum' => $self->custnum,
3671     'status'  => { op=>'!=', value=>'done' }
3672   });
3673   return "A payment is already being processed for this customer (".
3674          join(', ', map 'paypendingnum '. $_->paypendingnum, @pending ).
3675          "); $method transaction aborted."
3676     if scalar(@pending);
3677
3678   #okay, good to go, if we're a duplicate, cust_pay_pending will kick us out
3679
3680   my $cust_pay_pending = new FS::cust_pay_pending {
3681     'custnum'    => $self->custnum,
3682     #'invnum'     => $options{'invnum'},
3683     'paid'       => $amount,
3684     '_date'      => '',
3685     'payby'      => $method2payby{$method},
3686     'payinfo'    => $payinfo,
3687     'paydate'    => $paydate,
3688     'status'     => 'new',
3689     'gatewaynum' => ( $payment_gateway ? $payment_gateway->gatewaynum : '' ),
3690   };
3691   $cust_pay_pending->payunique( $options{payunique} )
3692     if defined($options{payunique}) && length($options{payunique});
3693   my $cpp_new_err = $cust_pay_pending->insert; #mutex lost when this is inserted
3694   return $cpp_new_err if $cpp_new_err;
3695
3696   my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
3697
3698   my $transaction = new Business::OnlinePayment( $processor, @bop_options );
3699   $transaction->content(
3700     'type'           => $method,
3701     'login'          => $login,
3702     'password'       => $password,
3703     'action'         => $action1,
3704     'description'    => $options{'description'},
3705     'amount'         => $amount,
3706     #'invoice_number' => $options{'invnum'},
3707     'customer_id'    => $self->custnum,
3708     'last_name'      => $paylast,
3709     'first_name'     => $payfirst,
3710     'name'           => $payname,
3711     'address'        => $address,
3712     'city'           => ( exists($options{'city'})
3713                             ? $options{'city'}
3714                             : $self->city          ),
3715     'state'          => ( exists($options{'state'})
3716                             ? $options{'state'}
3717                             : $self->state          ),
3718     'zip'            => ( exists($options{'zip'})
3719                             ? $options{'zip'}
3720                             : $self->zip          ),
3721     'country'        => ( exists($options{'country'})
3722                             ? $options{'country'}
3723                             : $self->country          ),
3724     'referer'        => 'http://cleanwhisker.420.am/',
3725     'email'          => $email,
3726     'phone'          => $self->daytime || $self->night,
3727     %content, #after
3728   );
3729
3730   $cust_pay_pending->status('pending');
3731   my $cpp_pending_err = $cust_pay_pending->replace;
3732   return $cpp_pending_err if $cpp_pending_err;
3733
3734   #config?
3735   my $BOP_TESTING = 0;
3736   my $BOP_TESTING_SUCCESS = 1;
3737
3738   unless ( $BOP_TESTING ) {
3739     $transaction->submit();
3740   } else {
3741     if ( $BOP_TESTING_SUCCESS ) {
3742       $transaction->is_success(1);
3743       $transaction->authorization('fake auth');
3744     } else {
3745       $transaction->is_success(0);
3746       $transaction->error_message('fake failure');
3747     }
3748   }
3749
3750   if ( $transaction->is_success() && $action2 ) {
3751
3752     $cust_pay_pending->status('authorized');
3753     my $cpp_authorized_err = $cust_pay_pending->replace;
3754     return $cpp_authorized_err if $cpp_authorized_err;
3755
3756     my $auth = $transaction->authorization;
3757     my $ordernum = $transaction->can('order_number')
3758                    ? $transaction->order_number
3759                    : '';
3760
3761     my $capture =
3762       new Business::OnlinePayment( $processor, @bop_options );
3763
3764     my %capture = (
3765       %content,
3766       type           => $method,
3767       action         => $action2,
3768       login          => $login,
3769       password       => $password,
3770       order_number   => $ordernum,
3771       amount         => $amount,
3772       authorization  => $auth,
3773       description    => $options{'description'},
3774     );
3775
3776     foreach my $field (qw( authorization_source_code returned_ACI
3777                            transaction_identifier validation_code
3778                            transaction_sequence_num local_transaction_date
3779                            local_transaction_time AVS_result_code          )) {
3780       $capture{$field} = $transaction->$field() if $transaction->can($field);
3781     }
3782
3783     $capture->content( %capture );
3784
3785     $capture->submit();
3786
3787     unless ( $capture->is_success ) {
3788       my $e = "Authorization successful but capture failed, custnum #".
3789               $self->custnum. ': '.  $capture->result_code.
3790               ": ". $capture->error_message;
3791       warn $e;
3792       return $e;
3793     }
3794
3795   }
3796
3797   $cust_pay_pending->status($transaction->is_success() ? 'captured' : 'declined');
3798   my $cpp_captured_err = $cust_pay_pending->replace;
3799   return $cpp_captured_err if $cpp_captured_err;
3800
3801   ###
3802   # remove paycvv after initial transaction
3803   ###
3804
3805   #false laziness w/misc/process/payment.cgi - check both to make sure working
3806   # correctly
3807   if ( defined $self->dbdef_table->column('paycvv')
3808        && length($self->paycvv)
3809        && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
3810   ) {
3811     my $error = $self->remove_cvv;
3812     if ( $error ) {
3813       warn "WARNING: error removing cvv: $error\n";
3814     }
3815   }
3816
3817   ###
3818   # result handling
3819   ###
3820
3821   if ( $transaction->is_success() ) {
3822
3823     my $paybatch = '';
3824     if ( $payment_gateway ) { # agent override
3825       $paybatch = $payment_gateway->gatewaynum. '-';
3826     }
3827
3828     $paybatch .= "$processor:". $transaction->authorization;
3829
3830     $paybatch .= ':'. $transaction->order_number
3831       if $transaction->can('order_number')
3832       && length($transaction->order_number);
3833
3834     my $cust_pay = new FS::cust_pay ( {
3835        'custnum'  => $self->custnum,
3836        'invnum'   => $options{'invnum'},
3837        'paid'     => $amount,
3838        '_date'    => '',
3839        'payby'    => $method2payby{$method},
3840        'payinfo'  => $payinfo,
3841        'paybatch' => $paybatch,
3842        'paydate'  => $paydate,
3843     } );
3844     #doesn't hurt to know, even though the dup check is in cust_pay_pending now
3845     $cust_pay->payunique( $options{payunique} )
3846       if defined($options{payunique}) && length($options{payunique});
3847
3848     my $oldAutoCommit = $FS::UID::AutoCommit;
3849     local $FS::UID::AutoCommit = 0;
3850     my $dbh = dbh;
3851
3852     #start a transaction, insert the cust_pay and set cust_pay_pending.status to done in a single transction
3853
3854     my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3855
3856     if ( $error ) {
3857       $cust_pay->invnum(''); #try again with no specific invnum
3858       my $error2 = $cust_pay->insert( $options{'manual'} ?
3859                                       ( 'manual' => 1 ) : ()
3860                                     );
3861       if ( $error2 ) {
3862         # gah.  but at least we have a record of the state we had to abort in
3863         # from cust_pay_pending now.
3864         my $e = "WARNING: $method captured but payment not recorded - ".
3865                 "error inserting payment ($processor): $error2".
3866                 " (previously tried insert with invnum #$options{'invnum'}" .
3867                 ": $error ) - pending payment saved as paypendingnum ".
3868                 $cust_pay_pending->paypendingnum. "\n";
3869         warn $e;
3870         return $e;
3871       }
3872     }
3873
3874     if ( $options{'paynum_ref'} ) {
3875       ${ $options{'paynum_ref'} } = $cust_pay->paynum;
3876     }
3877
3878     $cust_pay_pending->status('done');
3879     $cust_pay_pending->statustext('captured');
3880     my $cpp_done_err = $cust_pay_pending->replace;
3881
3882     if ( $cpp_done_err ) {
3883
3884       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
3885       my $e = "WARNING: $method captured but payment not recorded - ".
3886               "error updating status for paypendingnum ".
3887               $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3888       warn $e;
3889       return $e;
3890
3891     } else {
3892
3893       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3894       return ''; #no error
3895
3896     }
3897
3898   } else {
3899
3900     my $perror = "$processor error: ". $transaction->error_message;
3901
3902     unless ( $transaction->error_message ) {
3903
3904       my $t_response;
3905       if ( $transaction->can('response_page') ) {
3906         $t_response = {
3907                         'page'    => ( $transaction->can('response_page')
3908                                          ? $transaction->response_page
3909                                          : ''
3910                                      ),
3911                         'code'    => ( $transaction->can('response_code')
3912                                          ? $transaction->response_code
3913                                          : ''
3914                                      ),
3915                         'headers' => ( $transaction->can('response_headers')
3916                                          ? $transaction->response_headers
3917                                          : ''
3918                                      ),
3919                       };
3920       } else {
3921         $t_response .=
3922           "No additional debugging information available for $processor";
3923       }
3924
3925       $perror .= "No error_message returned from $processor -- ".
3926                  ( ref($t_response) ? Dumper($t_response) : $t_response );
3927
3928     }
3929
3930     if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
3931          && $conf->exists('emaildecline')
3932          && grep { $_ ne 'POST' } $self->invoicing_list
3933          && ! grep { $transaction->error_message =~ /$_/ }
3934                    $conf->config('emaildecline-exclude')
3935     ) {
3936       my @templ = $conf->config('declinetemplate');
3937       my $template = new Text::Template (
3938         TYPE   => 'ARRAY',
3939         SOURCE => [ map "$_\n", @templ ],
3940       ) or return "($perror) can't create template: $Text::Template::ERROR";
3941       $template->compile()
3942         or return "($perror) can't compile template: $Text::Template::ERROR";
3943
3944       my $templ_hash = { error => $transaction->error_message };
3945
3946       my $error = send_email(
3947         'from'    => $conf->config('invoice_from', $self->agentnum ),
3948         'to'      => [ grep { $_ ne 'POST' } $self->invoicing_list ],
3949         'subject' => 'Your payment could not be processed',
3950         'body'    => [ $template->fill_in(HASH => $templ_hash) ],
3951       );
3952
3953       $perror .= " (also received error sending decline notification: $error)"
3954         if $error;
3955
3956     }
3957
3958     $cust_pay_pending->status('done');
3959     $cust_pay_pending->statustext("declined: $perror");
3960     my $cpp_done_err = $cust_pay_pending->replace;
3961     if ( $cpp_done_err ) {
3962       my $e = "WARNING: $method declined but pending payment not resolved - ".
3963               "error updating status for paypendingnum ".
3964               $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3965       warn $e;
3966       $perror = "$e ($perror)";
3967     }
3968
3969     return $perror;
3970   }
3971
3972 }
3973
3974 =item fake_bop
3975
3976 =cut
3977
3978 sub fake_bop {
3979   my( $self, $method, $amount, %options ) = @_;
3980
3981   if ( $options{'fake_failure'} ) {
3982      return "Error: No error; test failure requested with fake_failure";
3983   }
3984
3985   my %method2payby = (
3986     'CC'     => 'CARD',
3987     'ECHECK' => 'CHEK',
3988     'LEC'    => 'LECB',
3989   );
3990
3991   #my $paybatch = '';
3992   #if ( $payment_gateway ) { # agent override
3993   #  $paybatch = $payment_gateway->gatewaynum. '-';
3994   #}
3995   #
3996   #$paybatch .= "$processor:". $transaction->authorization;
3997   #
3998   #$paybatch .= ':'. $transaction->order_number
3999   #  if $transaction->can('order_number')
4000   #  && length($transaction->order_number);
4001
4002   my $paybatch = 'FakeProcessor:54:32';
4003
4004   my $cust_pay = new FS::cust_pay ( {
4005      'custnum'  => $self->custnum,
4006      'invnum'   => $options{'invnum'},
4007      'paid'     => $amount,
4008      '_date'    => '',
4009      'payby'    => $method2payby{$method},
4010      #'payinfo'  => $payinfo,
4011      'payinfo'  => '4111111111111111',
4012      'paybatch' => $paybatch,
4013      #'paydate'  => $paydate,
4014      'paydate'  => '2012-05-01',
4015   } );
4016   $cust_pay->payunique( $options{payunique} ) if length($options{payunique});
4017
4018   my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
4019
4020   if ( $error ) {
4021     $cust_pay->invnum(''); #try again with no specific invnum
4022     my $error2 = $cust_pay->insert( $options{'manual'} ?
4023                                     ( 'manual' => 1 ) : ()
4024                                   );
4025     if ( $error2 ) {
4026       # gah, even with transactions.
4027       my $e = 'WARNING: Card/ACH debited but database not updated - '.
4028               "error inserting (fake!) payment: $error2".
4029               " (previously tried insert with invnum #$options{'invnum'}" .
4030               ": $error )";
4031       warn $e;
4032       return $e;
4033     }
4034   }
4035
4036   if ( $options{'paynum_ref'} ) {
4037     ${ $options{'paynum_ref'} } = $cust_pay->paynum;
4038   }
4039
4040   return ''; #no error
4041
4042 }
4043
4044 =item default_payment_gateway
4045
4046 =cut
4047
4048 sub default_payment_gateway {
4049   my( $self, $method ) = @_;
4050
4051   die "Real-time processing not enabled\n"
4052     unless $conf->exists('business-onlinepayment');
4053
4054   #load up config
4055   my $bop_config = 'business-onlinepayment';
4056   $bop_config .= '-ach'
4057     if $method =~ /^(ECHECK|CHEK)$/ && $conf->exists($bop_config. '-ach');
4058   my ( $processor, $login, $password, $action, @bop_options ) =
4059     $conf->config($bop_config);
4060   $action ||= 'normal authorization';
4061   pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
4062   die "No real-time processor is enabled - ".
4063       "did you set the business-onlinepayment configuration value?\n"
4064     unless $processor;
4065
4066   ( $processor, $login, $password, $action, @bop_options )
4067 }
4068
4069 =item remove_cvv
4070
4071 Removes the I<paycvv> field from the database directly.
4072
4073 If there is an error, returns the error, otherwise returns false.
4074
4075 =cut
4076
4077 sub remove_cvv {
4078   my $self = shift;
4079   my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
4080     or return dbh->errstr;
4081   $sth->execute($self->custnum)
4082     or return $sth->errstr;
4083   $self->paycvv('');
4084   '';
4085 }
4086
4087 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
4088
4089 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
4090 via a Business::OnlinePayment realtime gateway.  See
4091 L<http://420.am/business-onlinepayment> for supported gateways.
4092
4093 Available methods are: I<CC>, I<ECHECK> and I<LEC>
4094
4095 Available options are: I<amount>, I<reason>, I<paynum>, I<paydate>
4096
4097 Most gateways require a reference to an original payment transaction to refund,
4098 so you probably need to specify a I<paynum>.
4099
4100 I<amount> defaults to the original amount of the payment if not specified.
4101
4102 I<reason> specifies a reason for the refund.
4103
4104 I<paydate> specifies the expiration date for a credit card overriding the
4105 value from the customer record or the payment record. Specified as yyyy-mm-dd
4106
4107 Implementation note: If I<amount> is unspecified or equal to the amount of the
4108 orignal payment, first an attempt is made to "void" the transaction via
4109 the gateway (to cancel a not-yet settled transaction) and then if that fails,
4110 the normal attempt is made to "refund" ("credit") the transaction via the
4111 gateway is attempted.
4112
4113 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
4114 #I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
4115 #if set, will override the value from the customer record.
4116
4117 #If an I<invnum> is specified, this payment (if successful) is applied to the
4118 #specified invoice.  If you don't specify an I<invnum> you might want to
4119 #call the B<apply_payments> method.
4120
4121 =cut
4122
4123 #some false laziness w/realtime_bop, not enough to make it worth merging
4124 #but some useful small subs should be pulled out
4125 sub realtime_refund_bop {
4126   my( $self, $method, %options ) = @_;
4127   if ( $DEBUG ) {
4128     warn "$me realtime_refund_bop: $method refund\n";
4129     warn "  $_ => $options{$_}\n" foreach keys %options;
4130   }
4131
4132   eval "use Business::OnlinePayment";
4133   die $@ if $@;
4134
4135   ###
4136   # look up the original payment and optionally a gateway for that payment
4137   ###
4138
4139   my $cust_pay = '';
4140   my $amount = $options{'amount'};
4141
4142   my( $processor, $login, $password, @bop_options ) ;
4143   my( $auth, $order_number ) = ( '', '', '' );
4144
4145   if ( $options{'paynum'} ) {
4146
4147     warn "  paynum: $options{paynum}\n" if $DEBUG > 1;
4148     $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
4149       or return "Unknown paynum $options{'paynum'}";
4150     $amount ||= $cust_pay->paid;
4151
4152     $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-\/ ]*)(:([\w\-]+))?$/
4153       or return "Can't parse paybatch for paynum $options{'paynum'}: ".
4154                 $cust_pay->paybatch;
4155     my $gatewaynum = '';
4156     ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
4157
4158     if ( $gatewaynum ) { #gateway for the payment to be refunded
4159
4160       my $payment_gateway =
4161         qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
4162       die "payment gateway $gatewaynum not found"
4163         unless $payment_gateway;
4164
4165       $processor   = $payment_gateway->gateway_module;
4166       $login       = $payment_gateway->gateway_username;
4167       $password    = $payment_gateway->gateway_password;
4168       @bop_options = $payment_gateway->options;
4169
4170     } else { #try the default gateway
4171
4172       my( $conf_processor, $unused_action );
4173       ( $conf_processor, $login, $password, $unused_action, @bop_options ) =
4174         $self->default_payment_gateway($method);
4175
4176       return "processor of payment $options{'paynum'} $processor does not".
4177              " match default processor $conf_processor"
4178         unless $processor eq $conf_processor;
4179
4180     }
4181
4182
4183   } else { # didn't specify a paynum, so look for agent gateway overrides
4184            # like a normal transaction
4185
4186     my $cardtype;
4187     if ( $method eq 'CC' ) {
4188       $cardtype = cardtype($self->payinfo);
4189     } elsif ( $method eq 'ECHECK' ) {
4190       $cardtype = 'ACH';
4191     } else {
4192       $cardtype = $method;
4193     }
4194     my $override =
4195            qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
4196                                                cardtype => $cardtype,
4197                                                taxclass => '',              } )
4198         || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
4199                                                cardtype => '',
4200                                                taxclass => '',              } );
4201
4202     if ( $override ) { #use a payment gateway override
4203
4204       my $payment_gateway = $override->payment_gateway;
4205
4206       $processor   = $payment_gateway->gateway_module;
4207       $login       = $payment_gateway->gateway_username;
4208       $password    = $payment_gateway->gateway_password;
4209       #$action      = $payment_gateway->gateway_action;
4210       @bop_options = $payment_gateway->options;
4211
4212     } else { #use the standard settings from the config
4213
4214       my $unused_action;
4215       ( $processor, $login, $password, $unused_action, @bop_options ) =
4216         $self->default_payment_gateway($method);
4217
4218     }
4219
4220   }
4221   return "neither amount nor paynum specified" unless $amount;
4222
4223   my %content = (
4224     'type'           => $method,
4225     'login'          => $login,
4226     'password'       => $password,
4227     'order_number'   => $order_number,
4228     'amount'         => $amount,
4229     'referer'        => 'http://cleanwhisker.420.am/',
4230   );
4231   $content{authorization} = $auth
4232     if length($auth); #echeck/ACH transactions have an order # but no auth
4233                       #(at least with authorize.net)
4234
4235   my $disable_void_after;
4236   if ($conf->exists('disable_void_after')
4237       && $conf->config('disable_void_after') =~ /^(\d+)$/) {
4238     $disable_void_after = $1;
4239   }
4240
4241   #first try void if applicable
4242   if ( $cust_pay && $cust_pay->paid == $amount
4243     && (
4244       ( not defined($disable_void_after) )
4245       || ( time < ($cust_pay->_date + $disable_void_after ) )
4246     )
4247   ) {
4248     warn "  attempting void\n" if $DEBUG > 1;
4249     my $void = new Business::OnlinePayment( $processor, @bop_options );
4250     $void->content( 'action' => 'void', %content );
4251     $void->submit();
4252     if ( $void->is_success ) {
4253       my $error = $cust_pay->void($options{'reason'});
4254       if ( $error ) {
4255         # gah, even with transactions.
4256         my $e = 'WARNING: Card/ACH voided but database not updated - '.
4257                 "error voiding payment: $error";
4258         warn $e;
4259         return $e;
4260       }
4261       warn "  void successful\n" if $DEBUG > 1;
4262       return '';
4263     }
4264   }
4265
4266   warn "  void unsuccessful, trying refund\n"
4267     if $DEBUG > 1;
4268
4269   #massage data
4270   my $address = $self->address1;
4271   $address .= ", ". $self->address2 if $self->address2;
4272
4273   my($payname, $payfirst, $paylast);
4274   if ( $self->payname && $method ne 'ECHECK' ) {
4275     $payname = $self->payname;
4276     $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
4277       or return "Illegal payname $payname";
4278     ($payfirst, $paylast) = ($1, $2);
4279   } else {
4280     $payfirst = $self->getfield('first');
4281     $paylast = $self->getfield('last');
4282     $payname =  "$payfirst $paylast";
4283   }
4284
4285   my @invoicing_list = $self->invoicing_list_emailonly;
4286   if ( $conf->exists('emailinvoiceautoalways')
4287        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
4288        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
4289     push @invoicing_list, $self->all_emails;
4290   }
4291
4292   my $email = ($conf->exists('business-onlinepayment-email-override'))
4293               ? $conf->config('business-onlinepayment-email-override')
4294               : $invoicing_list[0];
4295
4296   my $payip = exists($options{'payip'})
4297                 ? $options{'payip'}
4298                 : $self->payip;
4299   $content{customer_ip} = $payip
4300     if length($payip);
4301
4302   my $payinfo = '';
4303   if ( $method eq 'CC' ) {
4304
4305     if ( $cust_pay ) {
4306       $content{card_number} = $payinfo = $cust_pay->payinfo;
4307       (exists($options{'paydate'}) ? $options{'paydate'} : $cust_pay->paydate)
4308         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/ &&
4309         ($content{expiration} = "$2/$1");  # where available
4310     } else {
4311       $content{card_number} = $payinfo = $self->payinfo;
4312       (exists($options{'paydate'}) ? $options{'paydate'} : $self->paydate)
4313         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
4314       $content{expiration} = "$2/$1";
4315     }
4316
4317   } elsif ( $method eq 'ECHECK' ) {
4318
4319     if ( $cust_pay ) {
4320       $payinfo = $cust_pay->payinfo;
4321     } else {
4322       $payinfo = $self->payinfo;
4323     }
4324     ( $content{account_number}, $content{routing_code} )= split('@', $payinfo );
4325     $content{bank_name} = $self->payname;
4326     $content{account_type} = 'CHECKING';
4327     $content{account_name} = $payname;
4328     $content{customer_org} = $self->company ? 'B' : 'I';
4329     $content{customer_ssn} = $self->ss;
4330   } elsif ( $method eq 'LEC' ) {
4331     $content{phone} = $payinfo = $self->payinfo;
4332   }
4333
4334   #then try refund
4335   my $refund = new Business::OnlinePayment( $processor, @bop_options );
4336   my %sub_content = $refund->content(
4337     'action'         => 'credit',
4338     'customer_id'    => $self->custnum,
4339     'last_name'      => $paylast,
4340     'first_name'     => $payfirst,
4341     'name'           => $payname,
4342     'address'        => $address,
4343     'city'           => $self->city,
4344     'state'          => $self->state,
4345     'zip'            => $self->zip,
4346     'country'        => $self->country,
4347     'email'          => $email,
4348     'phone'          => $self->daytime || $self->night,
4349     %content, #after
4350   );
4351   warn join('', map { "  $_ => $sub_content{$_}\n" } keys %sub_content )
4352     if $DEBUG > 1;
4353   $refund->submit();
4354
4355   return "$processor error: ". $refund->error_message
4356     unless $refund->is_success();
4357
4358   my %method2payby = (
4359     'CC'     => 'CARD',
4360     'ECHECK' => 'CHEK',
4361     'LEC'    => 'LECB',
4362   );
4363
4364   my $paybatch = "$processor:". $refund->authorization;
4365   $paybatch .= ':'. $refund->order_number
4366     if $refund->can('order_number') && $refund->order_number;
4367
4368   while ( $cust_pay && $cust_pay->unapplied < $amount ) {
4369     my @cust_bill_pay = $cust_pay->cust_bill_pay;
4370     last unless @cust_bill_pay;
4371     my $cust_bill_pay = pop @cust_bill_pay;
4372     my $error = $cust_bill_pay->delete;
4373     last if $error;
4374   }
4375
4376   my $cust_refund = new FS::cust_refund ( {
4377     'custnum'  => $self->custnum,
4378     'paynum'   => $options{'paynum'},
4379     'refund'   => $amount,
4380     '_date'    => '',
4381     'payby'    => $method2payby{$method},
4382     'payinfo'  => $payinfo,
4383     'paybatch' => $paybatch,
4384     'reason'   => $options{'reason'} || 'card or ACH refund',
4385   } );
4386   my $error = $cust_refund->insert;
4387   if ( $error ) {
4388     $cust_refund->paynum(''); #try again with no specific paynum
4389     my $error2 = $cust_refund->insert;
4390     if ( $error2 ) {
4391       # gah, even with transactions.
4392       my $e = 'WARNING: Card/ACH refunded but database not updated - '.
4393               "error inserting refund ($processor): $error2".
4394               " (previously tried insert with paynum #$options{'paynum'}" .
4395               ": $error )";
4396       warn $e;
4397       return $e;
4398     }
4399   }
4400
4401   ''; #no error
4402
4403 }
4404
4405 =item batch_card OPTION => VALUE...
4406
4407 Adds a payment for this invoice to the pending credit card batch (see
4408 L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value,
4409 runs the payment using a realtime gateway.
4410
4411 =cut
4412
4413 sub batch_card {
4414   my ($self, %options) = @_;
4415
4416   my $amount;
4417   if (exists($options{amount})) {
4418     $amount = $options{amount};
4419   }else{
4420     $amount = sprintf("%.2f", $self->balance - $self->in_transit_payments);
4421   }
4422   return '' unless $amount > 0;
4423
4424   my $invnum = delete $options{invnum};
4425   my $payby = $options{invnum} || $self->payby;  #dubious
4426
4427   if ($options{'realtime'}) {
4428     return $self->realtime_bop( FS::payby->payby2bop($self->payby),
4429                                 $amount,
4430                                 %options,
4431                               );
4432   }
4433
4434   my $oldAutoCommit = $FS::UID::AutoCommit;
4435   local $FS::UID::AutoCommit = 0;
4436   my $dbh = dbh;
4437
4438   #this needs to handle mysql as well as Pg, like svc_acct.pm
4439   #(make it into a common function if folks need to do batching with mysql)
4440   $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE")
4441     or return "Cannot lock pay_batch: " . $dbh->errstr;
4442
4443   my %pay_batch = (
4444     'status' => 'O',
4445     'payby'  => FS::payby->payby2payment($payby),
4446   );
4447
4448   my $pay_batch = qsearchs( 'pay_batch', \%pay_batch );
4449
4450   unless ( $pay_batch ) {
4451     $pay_batch = new FS::pay_batch \%pay_batch;
4452     my $error = $pay_batch->insert;
4453     if ( $error ) {
4454       $dbh->rollback if $oldAutoCommit;
4455       die "error creating new batch: $error\n";
4456     }
4457   }
4458
4459   my $old_cust_pay_batch = qsearchs('cust_pay_batch', {
4460       'batchnum' => $pay_batch->batchnum,
4461       'custnum'  => $self->custnum,
4462   } );
4463
4464   foreach (qw( address1 address2 city state zip country payby payinfo paydate
4465                payname )) {
4466     $options{$_} = '' unless exists($options{$_});
4467   }
4468
4469   my $cust_pay_batch = new FS::cust_pay_batch ( {
4470     'batchnum' => $pay_batch->batchnum,
4471     'invnum'   => $invnum || 0,                    # is there a better value?
4472                                                    # this field should be
4473                                                    # removed...
4474                                                    # cust_bill_pay_batch now
4475     'custnum'  => $self->custnum,
4476     'last'     => $self->getfield('last'),
4477     'first'    => $self->getfield('first'),
4478     'address1' => $options{address1} || $self->address1,
4479     'address2' => $options{address2} || $self->address2,
4480     'city'     => $options{city}     || $self->city,
4481     'state'    => $options{state}    || $self->state,
4482     'zip'      => $options{zip}      || $self->zip,
4483     'country'  => $options{country}  || $self->country,
4484     'payby'    => $options{payby}    || $self->payby,
4485     'payinfo'  => $options{payinfo}  || $self->payinfo,
4486     'exp'      => $options{paydate}  || $self->paydate,
4487     'payname'  => $options{payname}  || $self->payname,
4488     'amount'   => $amount,                         # consolidating
4489   } );
4490
4491   $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum)
4492     if $old_cust_pay_batch;
4493
4494   my $error;
4495   if ($old_cust_pay_batch) {
4496     $error = $cust_pay_batch->replace($old_cust_pay_batch)
4497   } else {
4498     $error = $cust_pay_batch->insert;
4499   }
4500
4501   if ( $error ) {
4502     $dbh->rollback if $oldAutoCommit;
4503     die $error;
4504   }
4505
4506   my $unapplied =   $self->total_unapplied_credits
4507                   + $self->total_unapplied_payments
4508                   + $self->in_transit_payments;
4509   foreach my $cust_bill ($self->open_cust_bill) {
4510     #$dbh->commit or die $dbh->errstr if $oldAutoCommit;
4511     my $cust_bill_pay_batch = new FS::cust_bill_pay_batch {
4512       'invnum' => $cust_bill->invnum,
4513       'paybatchnum' => $cust_pay_batch->paybatchnum,
4514       'amount' => $cust_bill->owed,
4515       '_date' => time,
4516     };
4517     if ($unapplied >= $cust_bill_pay_batch->amount){
4518       $unapplied -= $cust_bill_pay_batch->amount;
4519       next;
4520     }else{
4521       $cust_bill_pay_batch->amount(sprintf ( "%.2f",
4522                                    $cust_bill_pay_batch->amount - $unapplied ));      $unapplied = 0;
4523     }
4524     $error = $cust_bill_pay_batch->insert;
4525     if ( $error ) {
4526       $dbh->rollback if $oldAutoCommit;
4527       die $error;
4528     }
4529   }
4530
4531   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4532   '';
4533 }
4534
4535 =item apply_payments_and_credits
4536
4537 Applies unapplied payments and credits.
4538
4539 In most cases, this new method should be used in place of sequential
4540 apply_payments and apply_credits methods.
4541
4542 If there is an error, returns the error, otherwise returns false.
4543
4544 =cut
4545
4546 sub apply_payments_and_credits {
4547   my $self = shift;
4548
4549   local $SIG{HUP} = 'IGNORE';
4550   local $SIG{INT} = 'IGNORE';
4551   local $SIG{QUIT} = 'IGNORE';
4552   local $SIG{TERM} = 'IGNORE';
4553   local $SIG{TSTP} = 'IGNORE';
4554   local $SIG{PIPE} = 'IGNORE';
4555
4556   my $oldAutoCommit = $FS::UID::AutoCommit;
4557   local $FS::UID::AutoCommit = 0;
4558   my $dbh = dbh;
4559
4560   $self->select_for_update; #mutex
4561
4562   foreach my $cust_bill ( $self->open_cust_bill ) {
4563     my $error = $cust_bill->apply_payments_and_credits;
4564     if ( $error ) {
4565       $dbh->rollback if $oldAutoCommit;
4566       return "Error applying: $error";
4567     }
4568   }
4569
4570   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4571   ''; #no error
4572
4573 }
4574
4575 =item apply_credits OPTION => VALUE ...
4576
4577 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
4578 to outstanding invoice balances in chronological order (or reverse
4579 chronological order if the I<order> option is set to B<newest>) and returns the
4580 value of any remaining unapplied credits available for refund (see
4581 L<FS::cust_refund>).
4582
4583 Dies if there is an error.
4584
4585 =cut
4586
4587 sub apply_credits {
4588   my $self = shift;
4589   my %opt = @_;
4590
4591   local $SIG{HUP} = 'IGNORE';
4592   local $SIG{INT} = 'IGNORE';
4593   local $SIG{QUIT} = 'IGNORE';
4594   local $SIG{TERM} = 'IGNORE';
4595   local $SIG{TSTP} = 'IGNORE';
4596   local $SIG{PIPE} = 'IGNORE';
4597
4598   my $oldAutoCommit = $FS::UID::AutoCommit;
4599   local $FS::UID::AutoCommit = 0;
4600   my $dbh = dbh;
4601
4602   $self->select_for_update; #mutex
4603
4604   unless ( $self->total_unapplied_credits ) {
4605     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4606     return 0;
4607   }
4608
4609   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
4610       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
4611
4612   my @invoices = $self->open_cust_bill;
4613   @invoices = sort { $b->_date <=> $a->_date } @invoices
4614     if defined($opt{'order'}) && $opt{'order'} eq 'newest';
4615
4616   my $credit;
4617   foreach my $cust_bill ( @invoices ) {
4618     my $amount;
4619
4620     if ( !defined($credit) || $credit->credited == 0) {
4621       $credit = pop @credits or last;
4622     }
4623
4624     if ($cust_bill->owed >= $credit->credited) {
4625       $amount=$credit->credited;
4626     }else{
4627       $amount=$cust_bill->owed;
4628     }
4629
4630     my $cust_credit_bill = new FS::cust_credit_bill ( {
4631       'crednum' => $credit->crednum,
4632       'invnum'  => $cust_bill->invnum,
4633       'amount'  => $amount,
4634     } );
4635     my $error = $cust_credit_bill->insert;
4636     if ( $error ) {
4637       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4638       die $error;
4639     }
4640
4641     redo if ($cust_bill->owed > 0);
4642
4643   }
4644
4645   my $total_unapplied_credits = $self->total_unapplied_credits;
4646
4647   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4648
4649   return $total_unapplied_credits;
4650 }
4651
4652 =item apply_payments
4653
4654 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
4655 to outstanding invoice balances in chronological order.
4656
4657  #and returns the value of any remaining unapplied payments.
4658
4659 Dies if there is an error.
4660
4661 =cut
4662
4663 sub apply_payments {
4664   my $self = shift;
4665
4666   local $SIG{HUP} = 'IGNORE';
4667   local $SIG{INT} = 'IGNORE';
4668   local $SIG{QUIT} = 'IGNORE';
4669   local $SIG{TERM} = 'IGNORE';
4670   local $SIG{TSTP} = 'IGNORE';
4671   local $SIG{PIPE} = 'IGNORE';
4672
4673   my $oldAutoCommit = $FS::UID::AutoCommit;
4674   local $FS::UID::AutoCommit = 0;
4675   my $dbh = dbh;
4676
4677   $self->select_for_update; #mutex
4678
4679   #return 0 unless
4680
4681   my @payments = sort { $b->_date <=> $a->_date }
4682                  grep { $_->unapplied > 0 }
4683                  $self->cust_pay;
4684
4685   my @invoices = sort { $a->_date <=> $b->_date}
4686                  grep { $_->owed > 0 }
4687                  $self->cust_bill;
4688
4689   my $payment;
4690
4691   foreach my $cust_bill ( @invoices ) {
4692     my $amount;
4693
4694     if ( !defined($payment) || $payment->unapplied == 0 ) {
4695       $payment = pop @payments or last;
4696     }
4697
4698     if ( $cust_bill->owed >= $payment->unapplied ) {
4699       $amount = $payment->unapplied;
4700     } else {
4701       $amount = $cust_bill->owed;
4702     }
4703
4704     my $cust_bill_pay = new FS::cust_bill_pay ( {
4705       'paynum' => $payment->paynum,
4706       'invnum' => $cust_bill->invnum,
4707       'amount' => $amount,
4708     } );
4709     my $error = $cust_bill_pay->insert;
4710     if ( $error ) {
4711       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4712       die $error;
4713     }
4714
4715     redo if ( $cust_bill->owed > 0);
4716
4717   }
4718
4719   my $total_unapplied_payments = $self->total_unapplied_payments;
4720
4721   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4722
4723   return $total_unapplied_payments;
4724 }
4725
4726 =item total_owed
4727
4728 Returns the total owed for this customer on all invoices
4729 (see L<FS::cust_bill/owed>).
4730
4731 =cut
4732
4733 sub total_owed {
4734   my $self = shift;
4735   $self->total_owed_date(2145859200); #12/31/2037
4736 }
4737
4738 =item total_owed_date TIME
4739
4740 Returns the total owed for this customer on all invoices with date earlier than
4741 TIME.  TIME is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also
4742 see L<Time::Local> and L<Date::Parse> for conversion functions.
4743
4744 =cut
4745
4746 sub total_owed_date {
4747   my $self = shift;
4748   my $time = shift;
4749   my $total_bill = 0;
4750   foreach my $cust_bill (
4751     grep { $_->_date <= $time }
4752       qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4753   ) {
4754     $total_bill += $cust_bill->owed;
4755   }
4756   sprintf( "%.2f", $total_bill );
4757 }
4758
4759 =item total_paid
4760
4761 Returns the total amount of all payments.
4762
4763 =cut
4764
4765 sub total_paid {
4766   my $self = shift;
4767   my $total = 0;
4768   $total += $_->paid foreach $self->cust_pay;
4769   sprintf( "%.2f", $total );
4770 }
4771
4772 =item total_unapplied_credits
4773
4774 Returns the total outstanding credit (see L<FS::cust_credit>) for this
4775 customer.  See L<FS::cust_credit/credited>.
4776
4777 =item total_credited
4778
4779 Old name for total_unapplied_credits.  Don't use.
4780
4781 =cut
4782
4783 sub total_credited {
4784   #carp "total_credited deprecated, use total_unapplied_credits";
4785   shift->total_unapplied_credits(@_);
4786 }
4787
4788 sub total_unapplied_credits {
4789   my $self = shift;
4790   my $total_credit = 0;
4791   $total_credit += $_->credited foreach $self->cust_credit;
4792   sprintf( "%.2f", $total_credit );
4793 }
4794
4795 =item total_unapplied_payments
4796
4797 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
4798 See L<FS::cust_pay/unapplied>.
4799
4800 =cut
4801
4802 sub total_unapplied_payments {
4803   my $self = shift;
4804   my $total_unapplied = 0;
4805   $total_unapplied += $_->unapplied foreach $self->cust_pay;
4806   sprintf( "%.2f", $total_unapplied );
4807 }
4808
4809 =item total_unapplied_refunds
4810
4811 Returns the total unrefunded refunds (see L<FS::cust_refund>) for this
4812 customer.  See L<FS::cust_refund/unapplied>.
4813
4814 =cut
4815
4816 sub total_unapplied_refunds {
4817   my $self = shift;
4818   my $total_unapplied = 0;
4819   $total_unapplied += $_->unapplied foreach $self->cust_refund;
4820   sprintf( "%.2f", $total_unapplied );
4821 }
4822
4823 =item balance
4824
4825 Returns the balance for this customer (total_owed plus total_unrefunded, minus
4826 total_unapplied_credits minus total_unapplied_payments).
4827
4828 =cut
4829
4830 sub balance {
4831   my $self = shift;
4832   sprintf( "%.2f",
4833       $self->total_owed
4834     + $self->total_unapplied_refunds
4835     - $self->total_unapplied_credits
4836     - $self->total_unapplied_payments
4837   );
4838 }
4839
4840 =item balance_date TIME
4841
4842 Returns the balance for this customer, only considering invoices with date
4843 earlier than TIME (total_owed_date minus total_credited minus
4844 total_unapplied_payments).  TIME is specified as a UNIX timestamp; see
4845 L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion
4846 functions.
4847
4848 =cut
4849
4850 sub balance_date {
4851   my $self = shift;
4852   my $time = shift;
4853   sprintf( "%.2f",
4854         $self->total_owed_date($time)
4855       + $self->total_unapplied_refunds
4856       - $self->total_unapplied_credits
4857       - $self->total_unapplied_payments
4858   );
4859 }
4860
4861 =item in_transit_payments
4862
4863 Returns the total of requests for payments for this customer pending in
4864 batches in transit to the bank.  See L<FS::pay_batch> and L<FS::cust_pay_batch>
4865
4866 =cut
4867
4868 sub in_transit_payments {
4869   my $self = shift;
4870   my $in_transit_payments = 0;
4871   foreach my $pay_batch ( qsearch('pay_batch', {
4872     'status' => 'I',
4873   } ) ) {
4874     foreach my $cust_pay_batch ( qsearch('cust_pay_batch', {
4875       'batchnum' => $pay_batch->batchnum,
4876       'custnum' => $self->custnum,
4877     } ) ) {
4878       $in_transit_payments += $cust_pay_batch->amount;
4879     }
4880   }
4881   sprintf( "%.2f", $in_transit_payments );
4882 }
4883
4884 =item paydate_monthyear
4885
4886 Returns a two-element list consisting of the month and year of this customer's
4887 paydate (credit card expiration date for CARD customers)
4888
4889 =cut
4890
4891 sub paydate_monthyear {
4892   my $self = shift;
4893   if ( $self->paydate  =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
4894     ( $2, $1 );
4895   } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
4896     ( $1, $3 );
4897   } else {
4898     ('', '');
4899   }
4900 }
4901
4902 =item invoicing_list [ ARRAYREF ]
4903
4904 If an arguement is given, sets these email addresses as invoice recipients
4905 (see L<FS::cust_main_invoice>).  Errors are not fatal and are not reported
4906 (except as warnings), so use check_invoicing_list first.
4907
4908 Returns a list of email addresses (with svcnum entries expanded).
4909
4910 Note: You can clear the invoicing list by passing an empty ARRAYREF.  You can
4911 check it without disturbing anything by passing nothing.
4912
4913 This interface may change in the future.
4914
4915 =cut
4916
4917 sub invoicing_list {
4918   my( $self, $arrayref ) = @_;
4919
4920   if ( $arrayref ) {
4921     my @cust_main_invoice;
4922     if ( $self->custnum ) {
4923       @cust_main_invoice =
4924         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4925     } else {
4926       @cust_main_invoice = ();
4927     }
4928     foreach my $cust_main_invoice ( @cust_main_invoice ) {
4929       #warn $cust_main_invoice->destnum;
4930       unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
4931         #warn $cust_main_invoice->destnum;
4932         my $error = $cust_main_invoice->delete;
4933         warn $error if $error;
4934       }
4935     }
4936     if ( $self->custnum ) {
4937       @cust_main_invoice =
4938         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4939     } else {
4940       @cust_main_invoice = ();
4941     }
4942     my %seen = map { $_->address => 1 } @cust_main_invoice;
4943     foreach my $address ( @{$arrayref} ) {
4944       next if exists $seen{$address} && $seen{$address};
4945       $seen{$address} = 1;
4946       my $cust_main_invoice = new FS::cust_main_invoice ( {
4947         'custnum' => $self->custnum,
4948         'dest'    => $address,
4949       } );
4950       my $error = $cust_main_invoice->insert;
4951       warn $error if $error;
4952     }
4953   }
4954
4955   if ( $self->custnum ) {
4956     map { $_->address }
4957       qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4958   } else {
4959     ();
4960   }
4961
4962 }
4963
4964 =item check_invoicing_list ARRAYREF
4965
4966 Checks these arguements as valid input for the invoicing_list method.  If there
4967 is an error, returns the error, otherwise returns false.
4968
4969 =cut
4970
4971 sub check_invoicing_list {
4972   my( $self, $arrayref ) = @_;
4973
4974   foreach my $address ( @$arrayref ) {
4975
4976     if ($address eq 'FAX' and $self->getfield('fax') eq '') {
4977       return 'Can\'t add FAX invoice destination with a blank FAX number.';
4978     }
4979
4980     my $cust_main_invoice = new FS::cust_main_invoice ( {
4981       'custnum' => $self->custnum,
4982       'dest'    => $address,
4983     } );
4984     my $error = $self->custnum
4985                 ? $cust_main_invoice->check
4986                 : $cust_main_invoice->checkdest
4987     ;
4988     return $error if $error;
4989
4990   }
4991
4992   return "Email address required"
4993     if $conf->exists('cust_main-require_invoicing_list_email')
4994     && ! grep { $_ !~ /^([A-Z]+)$/ } @$arrayref;
4995
4996   '';
4997 }
4998
4999 =item set_default_invoicing_list
5000
5001 Sets the invoicing list to all accounts associated with this customer,
5002 overwriting any previous invoicing list.
5003
5004 =cut
5005
5006 sub set_default_invoicing_list {
5007   my $self = shift;
5008   $self->invoicing_list($self->all_emails);
5009 }
5010
5011 =item all_emails
5012
5013 Returns the email addresses of all accounts provisioned for this customer.
5014
5015 =cut
5016
5017 sub all_emails {
5018   my $self = shift;
5019   my %list;
5020   foreach my $cust_pkg ( $self->all_pkgs ) {
5021     my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
5022     my @svc_acct =
5023       map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
5024         grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
5025           @cust_svc;
5026     $list{$_}=1 foreach map { $_->email } @svc_acct;
5027   }
5028   keys %list;
5029 }
5030
5031 =item invoicing_list_addpost
5032
5033 Adds postal invoicing to this customer.  If this customer is already configured
5034 to receive postal invoices, does nothing.
5035
5036 =cut
5037
5038 sub invoicing_list_addpost {
5039   my $self = shift;
5040   return if grep { $_ eq 'POST' } $self->invoicing_list;
5041   my @invoicing_list = $self->invoicing_list;
5042   push @invoicing_list, 'POST';
5043   $self->invoicing_list(\@invoicing_list);
5044 }
5045
5046 =item invoicing_list_emailonly
5047
5048 Returns the list of email invoice recipients (invoicing_list without non-email
5049 destinations such as POST and FAX).
5050
5051 =cut
5052
5053 sub invoicing_list_emailonly {
5054   my $self = shift;
5055   warn "$me invoicing_list_emailonly called"
5056     if $DEBUG;
5057   grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list;
5058 }
5059
5060 =item invoicing_list_emailonly_scalar
5061
5062 Returns the list of email invoice recipients (invoicing_list without non-email
5063 destinations such as POST and FAX) as a comma-separated scalar.
5064
5065 =cut
5066
5067 sub invoicing_list_emailonly_scalar {
5068   my $self = shift;
5069   warn "$me invoicing_list_emailonly_scalar called"
5070     if $DEBUG;
5071   join(', ', $self->invoicing_list_emailonly);
5072 }
5073
5074 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
5075
5076 Returns an array of customers referred by this customer (referral_custnum set
5077 to this custnum).  If DEPTH is given, recurses up to the given depth, returning
5078 customers referred by customers referred by this customer and so on, inclusive.
5079 The default behavior is DEPTH 1 (no recursion).
5080
5081 =cut
5082
5083 sub referral_cust_main {
5084   my $self = shift;
5085   my $depth = @_ ? shift : 1;
5086   my $exclude = @_ ? shift : {};
5087
5088   my @cust_main =
5089     map { $exclude->{$_->custnum}++; $_; }
5090       grep { ! $exclude->{ $_->custnum } }
5091         qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
5092
5093   if ( $depth > 1 ) {
5094     push @cust_main,
5095       map { $_->referral_cust_main($depth-1, $exclude) }
5096         @cust_main;
5097   }
5098
5099   @cust_main;
5100 }
5101
5102 =item referral_cust_main_ncancelled
5103
5104 Same as referral_cust_main, except only returns customers with uncancelled
5105 packages.
5106
5107 =cut
5108
5109 sub referral_cust_main_ncancelled {
5110   my $self = shift;
5111   grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
5112 }
5113
5114 =item referral_cust_pkg [ DEPTH ]
5115
5116 Like referral_cust_main, except returns a flat list of all unsuspended (and
5117 uncancelled) packages for each customer.  The number of items in this list may
5118 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
5119
5120 =cut
5121
5122 sub referral_cust_pkg {
5123   my $self = shift;
5124   my $depth = @_ ? shift : 1;
5125
5126   map { $_->unsuspended_pkgs }
5127     grep { $_->unsuspended_pkgs }
5128       $self->referral_cust_main($depth);
5129 }
5130
5131 =item referring_cust_main
5132
5133 Returns the single cust_main record for the customer who referred this customer
5134 (referral_custnum), or false.
5135
5136 =cut
5137
5138 sub referring_cust_main {
5139   my $self = shift;
5140   return '' unless $self->referral_custnum;
5141   qsearchs('cust_main', { 'custnum' => $self->referral_custnum } );
5142 }
5143
5144 =item credit AMOUNT, REASON [ , OPTION => VALUE ... ]
5145
5146 Applies a credit to this customer.  If there is an error, returns the error,
5147 otherwise returns false.
5148
5149 REASON can be a text string, an FS::reason object, or a scalar reference to
5150 a reasonnum.  If a text string, it will be automatically inserted as a new
5151 reason, and a 'reason_type' option must be passed to indicate the
5152 FS::reason_type for the new reason.
5153
5154 An I<addlinfo> option may be passed to set the credit's I<addlinfo> field.
5155
5156 Any other options are passed to FS::cust_credit::insert.
5157
5158 =cut
5159
5160 sub credit {
5161   my( $self, $amount, $reason, %options ) = @_;
5162
5163   my $cust_credit = new FS::cust_credit {
5164     'custnum' => $self->custnum,
5165     'amount'  => $amount,
5166   };
5167
5168   if ( ref($reason) ) {
5169
5170     if ( ref($reason) eq 'SCALAR' ) {
5171       $cust_credit->reasonnum( $$reason );
5172     } else {
5173       $cust_credit->reasonnum( $reason->reasonnum );
5174     }
5175
5176   } else {
5177     $cust_credit->set('reason', $reason)
5178   }
5179
5180   $cust_credit->addlinfo( delete $options{'addlinfo'} )
5181     if exists($options{'addlinfo'});
5182
5183   $cust_credit->insert(%options);
5184
5185 }
5186
5187 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
5188
5189 Creates a one-time charge for this customer.  If there is an error, returns
5190 the error, otherwise returns false.
5191
5192 =cut
5193
5194 sub charge {
5195   my $self = shift;
5196   my ( $amount, $quantity, $pkg, $comment, $taxclass, $additional, $classnum );
5197   my ( $taxproduct, $override );
5198   if ( ref( $_[0] ) ) {
5199     $amount     = $_[0]->{amount};
5200     $quantity   = exists($_[0]->{quantity}) ? $_[0]->{quantity} : 1;
5201     $pkg        = exists($_[0]->{pkg}) ? $_[0]->{pkg} : 'One-time charge';
5202     $comment    = exists($_[0]->{comment}) ? $_[0]->{comment}
5203                                            : '$'. sprintf("%.2f",$amount);
5204     $taxclass   = exists($_[0]->{taxclass}) ? $_[0]->{taxclass} : '';
5205     $classnum   = exists($_[0]->{classnum}) ? $_[0]->{classnum} : '';
5206     $additional = $_[0]->{additional};
5207     $taxproduct = $_[0]->{taxproductnum};
5208     $override   = { '' => $_[0]->{tax_override} };
5209   }else{
5210     $amount     = shift;
5211     $quantity   = 1;
5212     $pkg        = @_ ? shift : 'One-time charge';
5213     $comment    = @_ ? shift : '$'. sprintf("%.2f",$amount);
5214     $taxclass   = @_ ? shift : '';
5215     $additional = [];
5216   }
5217
5218   local $SIG{HUP} = 'IGNORE';
5219   local $SIG{INT} = 'IGNORE';
5220   local $SIG{QUIT} = 'IGNORE';
5221   local $SIG{TERM} = 'IGNORE';
5222   local $SIG{TSTP} = 'IGNORE';
5223   local $SIG{PIPE} = 'IGNORE';
5224
5225   my $oldAutoCommit = $FS::UID::AutoCommit;
5226   local $FS::UID::AutoCommit = 0;
5227   my $dbh = dbh;
5228
5229   my $part_pkg = new FS::part_pkg ( {
5230     'pkg'           => $pkg,
5231     'comment'       => $comment,
5232     'plan'          => 'flat',
5233     'freq'          => 0,
5234     'disabled'      => 'Y',
5235     'classnum'      => $classnum ? $classnum : '',
5236     'taxclass'      => $taxclass,
5237     'taxproductnum' => $taxproduct,
5238   } );
5239
5240   my %options = ( ( map { ("additional_info$_" => $additional->[$_] ) }
5241                         ( 0 .. @$additional - 1 )
5242                   ),
5243                   'additional_count' => scalar(@$additional),
5244                   'setup_fee' => $amount,
5245                 );
5246
5247   my $error = $part_pkg->insert( options       => \%options,
5248                                  tax_overrides => $override,
5249                                );
5250   if ( $error ) {
5251     $dbh->rollback if $oldAutoCommit;
5252     return $error;
5253   }
5254
5255   my $pkgpart = $part_pkg->pkgpart;
5256   my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
5257   unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
5258     my $type_pkgs = new FS::type_pkgs \%type_pkgs;
5259     $error = $type_pkgs->insert;
5260     if ( $error ) {
5261       $dbh->rollback if $oldAutoCommit;
5262       return $error;
5263     }
5264   }
5265
5266   my $cust_pkg = new FS::cust_pkg ( {
5267     'custnum'  => $self->custnum,
5268     'pkgpart'  => $pkgpart,
5269     'quantity' => $quantity,
5270   } );
5271
5272   $error = $cust_pkg->insert;
5273   if ( $error ) {
5274     $dbh->rollback if $oldAutoCommit;
5275     return $error;
5276   }
5277
5278   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5279   '';
5280
5281 }
5282
5283 #=item charge_postal_fee
5284 #
5285 #Applies a one time charge this customer.  If there is an error,
5286 #returns the error, returns the cust_pkg charge object or false
5287 #if there was no charge.
5288 #
5289 #=cut
5290 #
5291 # This should be a customer event.  For that to work requires that bill
5292 # also be a customer event.
5293
5294 sub charge_postal_fee {
5295   my $self = shift;
5296
5297   my $pkgpart = $conf->config('postal_invoice-fee_pkgpart');
5298   return '' unless ($pkgpart && grep { $_ eq 'POST' } $self->invoicing_list);
5299
5300   my $cust_pkg = new FS::cust_pkg ( {
5301     'custnum'  => $self->custnum,
5302     'pkgpart'  => $pkgpart,
5303     'quantity' => 1,
5304   } );
5305
5306   my $error = $cust_pkg->insert;
5307   $error ? $error : $cust_pkg;
5308 }
5309
5310 =item cust_bill
5311
5312 Returns all the invoices (see L<FS::cust_bill>) for this customer.
5313
5314 =cut
5315
5316 sub cust_bill {
5317   my $self = shift;
5318   sort { $a->_date <=> $b->_date }
5319     qsearch('cust_bill', { 'custnum' => $self->custnum, } )
5320 }
5321
5322 =item open_cust_bill
5323
5324 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
5325 customer.
5326
5327 =cut
5328
5329 sub open_cust_bill {
5330   my $self = shift;
5331   grep { $_->owed > 0 } $self->cust_bill;
5332 }
5333
5334 =item cust_credit
5335
5336 Returns all the credits (see L<FS::cust_credit>) for this customer.
5337
5338 =cut
5339
5340 sub cust_credit {
5341   my $self = shift;
5342   sort { $a->_date <=> $b->_date }
5343     qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
5344 }
5345
5346 =item cust_pay
5347
5348 Returns all the payments (see L<FS::cust_pay>) for this customer.
5349
5350 =cut
5351
5352 sub cust_pay {
5353   my $self = shift;
5354   sort { $a->_date <=> $b->_date }
5355     qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
5356 }
5357
5358 =item cust_pay_void
5359
5360 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
5361
5362 =cut
5363
5364 sub cust_pay_void {
5365   my $self = shift;
5366   sort { $a->_date <=> $b->_date }
5367     qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
5368 }
5369
5370 =item cust_pay_batch
5371
5372 Returns all batched payments (see L<FS::cust_pay_void>) for this customer.
5373
5374 =cut
5375
5376 sub cust_pay_batch {
5377   my $self = shift;
5378   sort { $a->_date <=> $b->_date }
5379     qsearch( 'cust_pay_batch', { 'custnum' => $self->custnum } )
5380 }
5381
5382 =item cust_refund
5383
5384 Returns all the refunds (see L<FS::cust_refund>) for this customer.
5385
5386 =cut
5387
5388 sub cust_refund {
5389   my $self = shift;
5390   sort { $a->_date <=> $b->_date }
5391     qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
5392 }
5393
5394 =item display_custnum
5395
5396 Returns the displayed customer number for this customer: agent_custid if
5397 cust_main-default_agent_custid is set and it has a value, custnum otherwise.
5398
5399 =cut
5400
5401 sub display_custnum {
5402   my $self = shift;
5403   if ( $conf->exists('cust_main-default_agent_custid') && $self->agent_custid ){
5404     return $self->agent_custid;
5405   } else {
5406     return $self->custnum;
5407   }
5408 }
5409
5410 =item name
5411
5412 Returns a name string for this customer, either "Company (Last, First)" or
5413 "Last, First".
5414
5415 =cut
5416
5417 sub name {
5418   my $self = shift;
5419   my $name = $self->contact;
5420   $name = $self->company. " ($name)" if $self->company;
5421   $name;
5422 }
5423
5424 =item ship_name
5425
5426 Returns a name string for this (service/shipping) contact, either
5427 "Company (Last, First)" or "Last, First".
5428
5429 =cut
5430
5431 sub ship_name {
5432   my $self = shift;
5433   if ( $self->get('ship_last') ) {
5434     my $name = $self->ship_contact;
5435     $name = $self->ship_company. " ($name)" if $self->ship_company;
5436     $name;
5437   } else {
5438     $self->name;
5439   }
5440 }
5441
5442 =item name_short
5443
5444 Returns a name string for this customer, either "Company" or "First Last".
5445
5446 =cut
5447
5448 sub name_short {
5449   my $self = shift;
5450   $self->company !~ /^\s*$/ ? $self->company : $self->contact_firstlast;
5451 }
5452
5453 =item ship_name_short
5454
5455 Returns a name string for this (service/shipping) contact, either "Company"
5456 or "First Last".
5457
5458 =cut
5459
5460 sub ship_name_short {
5461   my $self = shift;
5462   if ( $self->get('ship_last') ) {
5463     $self->ship_company !~ /^\s*$/
5464       ? $self->ship_company
5465       : $self->ship_contact_firstlast;
5466   } else {
5467     $self->name_company_or_firstlast;
5468   }
5469 }
5470
5471 =item contact
5472
5473 Returns this customer's full (billing) contact name only, "Last, First"
5474
5475 =cut
5476
5477 sub contact {
5478   my $self = shift;
5479   $self->get('last'). ', '. $self->first;
5480 }
5481
5482 =item ship_contact
5483
5484 Returns this customer's full (shipping) contact name only, "Last, First"
5485
5486 =cut
5487
5488 sub ship_contact {
5489   my $self = shift;
5490   $self->get('ship_last')
5491     ? $self->get('ship_last'). ', '. $self->ship_first
5492     : $self->contact;
5493 }
5494
5495 =item contact_firstlast
5496
5497 Returns this customers full (billing) contact name only, "First Last".
5498
5499 =cut
5500
5501 sub contact_firstlast {
5502   my $self = shift;
5503   $self->first. ' '. $self->get('last');
5504 }
5505
5506 =item ship_contact_firstlast
5507
5508 Returns this customer's full (shipping) contact name only, "First Last".
5509
5510 =cut
5511
5512 sub ship_contact_firstlast {
5513   my $self = shift;
5514   $self->get('ship_last')
5515     ? $self->first. ' '. $self->get('ship_last')
5516     : $self->contact_firstlast;
5517 }
5518
5519 =item country_full
5520
5521 Returns this customer's full country name
5522
5523 =cut
5524
5525 sub country_full {
5526   my $self = shift;
5527   code2country($self->country);
5528 }
5529
5530 =item geocode DATA_VENDOR
5531
5532 Returns a value for the customer location as encoded by DATA_VENDOR.
5533 Currently this only makes sense for "CCH" as DATA_VENDOR.
5534
5535 =cut
5536
5537 sub geocode {
5538   my ($self, $data_vendor) = (shift, shift);  #always cch for now
5539
5540   my $geocode = $self->get('geocode');  #XXX only one data_vendor for geocode
5541   return $geocode if $geocode;
5542
5543   my $prefix = ( $conf->exists('tax-ship_address') && length($self->ship_last) )
5544                ? 'ship_'
5545                : '';
5546
5547   my ($zip,$plus4) = split /-/, $self->get("${prefix}zip")
5548     if $self->country eq 'US';
5549
5550   #CCH specific location stuff
5551   my $extra_sql = "AND plus4lo <= '$plus4' AND plus4hi >= '$plus4'";
5552
5553   my @cust_tax_location =
5554     qsearch( {
5555                'table'     => 'cust_tax_location',
5556                'hashref'   => { 'zip' => $zip, 'data_vendor' => $data_vendor },
5557                'extra_sql' => $extra_sql,
5558                'order_by'  => 'ORDER BY plus4hi',#overlapping with distinct ends
5559              }
5560            );
5561   $geocode = $cust_tax_location[0]->geocode
5562     if scalar(@cust_tax_location);
5563
5564   $geocode;
5565 }
5566
5567 =item cust_status
5568
5569 =item status
5570
5571 Returns a status string for this customer, currently:
5572
5573 =over 4
5574
5575 =item prospect - No packages have ever been ordered
5576
5577 =item active - One or more recurring packages is active
5578
5579 =item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled)
5580
5581 =item suspended - All non-cancelled recurring packages are suspended
5582
5583 =item cancelled - All recurring packages are cancelled
5584
5585 =back
5586
5587 =cut
5588
5589 sub status { shift->cust_status(@_); }
5590
5591 sub cust_status {
5592   my $self = shift;
5593   for my $status (qw( prospect active inactive suspended cancelled )) {
5594     my $method = $status.'_sql';
5595     my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
5596     my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
5597     $sth->execute( ($self->custnum) x $numnum )
5598       or die "Error executing 'SELECT $sql': ". $sth->errstr;
5599     return $status if $sth->fetchrow_arrayref->[0];
5600   }
5601 }
5602
5603 =item ucfirst_cust_status
5604
5605 =item ucfirst_status
5606
5607 Returns the status with the first character capitalized.
5608
5609 =cut
5610
5611 sub ucfirst_status { shift->ucfirst_cust_status(@_); }
5612
5613 sub ucfirst_cust_status {
5614   my $self = shift;
5615   ucfirst($self->cust_status);
5616 }
5617
5618 =item statuscolor
5619
5620 Returns a hex triplet color string for this customer's status.
5621
5622 =cut
5623
5624 use vars qw(%statuscolor);
5625 tie %statuscolor, 'Tie::IxHash',
5626   'prospect'  => '7e0079', #'000000', #black?  naw, purple
5627   'active'    => '00CC00', #green
5628   'inactive'  => '0000CC', #blue
5629   'suspended' => 'FF9900', #yellow
5630   'cancelled' => 'FF0000', #red
5631 ;
5632
5633 sub statuscolor { shift->cust_statuscolor(@_); }
5634
5635 sub cust_statuscolor {
5636   my $self = shift;
5637   $statuscolor{$self->cust_status};
5638 }
5639
5640 =item tickets
5641
5642 Returns an array of hashes representing the customer's RT tickets.
5643
5644 =cut
5645
5646 sub tickets {
5647   my $self = shift;
5648
5649   my $num = $conf->config('cust_main-max_tickets') || 10;
5650   my @tickets = ();
5651
5652   if ( $conf->config('ticket_system') ) {
5653     unless ( $conf->config('ticket_system-custom_priority_field') ) {
5654
5655       @tickets = @{ FS::TicketSystem->customer_tickets($self->custnum, $num) };
5656
5657     } else {
5658
5659       foreach my $priority (
5660         $conf->config('ticket_system-custom_priority_field-values'), ''
5661       ) {
5662         last if scalar(@tickets) >= $num;
5663         push @tickets,
5664           @{ FS::TicketSystem->customer_tickets( $self->custnum,
5665                                                  $num - scalar(@tickets),
5666                                                  $priority,
5667                                                )
5668            };
5669       }
5670     }
5671   }
5672   (@tickets);
5673 }
5674
5675 # Return services representing svc_accts in customer support packages
5676 sub support_services {
5677   my $self = shift;
5678   my %packages = map { $_ => 1 } $conf->config('support_packages');
5679
5680   grep { $_->pkg_svc && $_->pkg_svc->primary_svc eq 'Y' }
5681     grep { $_->part_svc->svcdb eq 'svc_acct' }
5682     map { $_->cust_svc }
5683     grep { exists $packages{ $_->pkgpart } }
5684     $self->ncancelled_pkgs;
5685
5686 }
5687
5688 =back
5689
5690 =head1 CLASS METHODS
5691
5692 =over 4
5693
5694 =item statuses
5695
5696 Class method that returns the list of possible status strings for customers
5697 (see L<the status method|/status>).  For example:
5698
5699   @statuses = FS::cust_main->statuses();
5700
5701 =cut
5702
5703 sub statuses {
5704   #my $self = shift; #could be class...
5705   keys %statuscolor;
5706 }
5707
5708 =item prospect_sql
5709
5710 Returns an SQL expression identifying prospective cust_main records (customers
5711 with no packages ever ordered)
5712
5713 =cut
5714
5715 use vars qw($select_count_pkgs);
5716 $select_count_pkgs =
5717   "SELECT COUNT(*) FROM cust_pkg
5718     WHERE cust_pkg.custnum = cust_main.custnum";
5719
5720 sub select_count_pkgs_sql {
5721   $select_count_pkgs;
5722 }
5723
5724 sub prospect_sql { "
5725   0 = ( $select_count_pkgs )
5726 "; }
5727
5728 =item active_sql
5729
5730 Returns an SQL expression identifying active cust_main records (customers with
5731 active recurring packages).
5732
5733 =cut
5734
5735 sub active_sql { "
5736   0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. "
5737       )
5738 "; }
5739
5740 =item inactive_sql
5741
5742 Returns an SQL expression identifying inactive cust_main records (customers with
5743 no active recurring packages, but otherwise unsuspended/uncancelled).
5744
5745 =cut
5746
5747 sub inactive_sql { "
5748   0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5749   AND
5750   0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
5751 "; }
5752
5753 =item susp_sql
5754 =item suspended_sql
5755
5756 Returns an SQL expression identifying suspended cust_main records.
5757
5758 =cut
5759
5760
5761 sub suspended_sql { susp_sql(@_); }
5762 sub susp_sql { "
5763     0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " )
5764     AND
5765     0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5766 "; }
5767
5768 =item cancel_sql
5769 =item cancelled_sql
5770
5771 Returns an SQL expression identifying cancelled cust_main records.
5772
5773 =cut
5774
5775 sub cancelled_sql { cancel_sql(@_); }
5776 sub cancel_sql {
5777
5778   my $recurring_sql = FS::cust_pkg->recurring_sql;
5779   my $cancelled_sql = FS::cust_pkg->cancelled_sql;
5780
5781   "
5782         0 < ( $select_count_pkgs )
5783     AND 0 < ( $select_count_pkgs AND $recurring_sql AND $cancelled_sql   )
5784     AND 0 = ( $select_count_pkgs AND $recurring_sql
5785                   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5786             )
5787     AND 0 = (  $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
5788   ";
5789
5790 }
5791
5792 =item uncancel_sql
5793 =item uncancelled_sql
5794
5795 Returns an SQL expression identifying un-cancelled cust_main records.
5796
5797 =cut
5798
5799 sub uncancelled_sql { uncancel_sql(@_); }
5800 sub uncancel_sql { "
5801   ( 0 < ( $select_count_pkgs
5802                    AND ( cust_pkg.cancel IS NULL
5803                          OR cust_pkg.cancel = 0
5804                        )
5805         )
5806     OR 0 = ( $select_count_pkgs )
5807   )
5808 "; }
5809
5810 =item balance_sql
5811
5812 Returns an SQL fragment to retreive the balance.
5813
5814 =cut
5815
5816 sub balance_sql { "
5817     ( SELECT COALESCE( SUM(charged), 0 ) FROM cust_bill
5818         WHERE cust_bill.custnum   = cust_main.custnum     )
5819   - ( SELECT COALESCE( SUM(paid),    0 ) FROM cust_pay
5820         WHERE cust_pay.custnum    = cust_main.custnum     )
5821   - ( SELECT COALESCE( SUM(amount),  0 ) FROM cust_credit
5822         WHERE cust_credit.custnum = cust_main.custnum     )
5823   + ( SELECT COALESCE( SUM(refund),  0 ) FROM cust_refund
5824         WHERE cust_refund.custnum = cust_main.custnum     )
5825 "; }
5826
5827 =item balance_date_sql START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5828
5829 Returns an SQL fragment to retreive the balance for this customer, only
5830 considering invoices with date earlier than START_TIME, and optionally not
5831 later than END_TIME (total_owed_date minus total_unapplied_credits minus
5832 total_unapplied_payments).
5833
5834 Times are specified as SQL fragments or numeric
5835 UNIX timestamps; see L<perlfunc/"time">).  Also see L<Time::Local> and
5836 L<Date::Parse> for conversion functions.  The empty string can be passed
5837 to disable that time constraint completely.
5838
5839 Available options are:
5840
5841 =over 4
5842
5843 =item unapplied_date
5844
5845 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)
5846
5847 =item total
5848
5849 (unused.  obsolete?)
5850 set to true to remove all customer comparison clauses, for totals
5851
5852 =item where
5853
5854 (unused.  obsolete?)
5855 WHERE clause hashref (elements "AND"ed together) (typically used with the total option)
5856
5857 =item join
5858
5859 (unused.  obsolete?)
5860 JOIN clause (typically used with the total option)
5861
5862 =back
5863
5864 =cut
5865
5866 sub balance_date_sql {
5867   my( $class, $start, $end, %opt ) = @_;
5868
5869   my $owed         = FS::cust_bill->owed_sql;
5870   my $unapp_refund = FS::cust_refund->unapplied_sql;
5871   my $unapp_credit = FS::cust_credit->unapplied_sql;
5872   my $unapp_pay    = FS::cust_pay->unapplied_sql;
5873
5874   my $j = $opt{'join'} || '';
5875
5876   my $owed_wh   = $class->_money_table_where( 'cust_bill',   $start,$end,%opt );
5877   my $refund_wh = $class->_money_table_where( 'cust_refund', $start,$end,%opt );
5878   my $credit_wh = $class->_money_table_where( 'cust_credit', $start,$end,%opt );
5879   my $pay_wh    = $class->_money_table_where( 'cust_pay',    $start,$end,%opt );
5880
5881   "   ( SELECT COALESCE(SUM($owed),         0) FROM cust_bill   $j $owed_wh   )
5882     + ( SELECT COALESCE(SUM($unapp_refund), 0) FROM cust_refund $j $refund_wh )
5883     - ( SELECT COALESCE(SUM($unapp_credit), 0) FROM cust_credit $j $credit_wh )
5884     - ( SELECT COALESCE(SUM($unapp_pay),    0) FROM cust_pay    $j $pay_wh    )
5885   ";
5886
5887 }
5888
5889 =item _money_table_where TABLE START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5890
5891 Helper method for balance_date_sql; name (and usage) subject to change
5892 (suggestions welcome).
5893
5894 Returns a WHERE clause for the specified monetary TABLE (cust_bill,
5895 cust_refund, cust_credit or cust_pay).
5896
5897 If TABLE is "cust_bill" or the unapplied_date option is true, only
5898 considers records with date earlier than START_TIME, and optionally not
5899 later than END_TIME .
5900
5901 =cut
5902
5903 sub _money_table_where {
5904   my( $class, $table, $start, $end, %opt ) = @_;
5905
5906   my @where = ();
5907   push @where, "cust_main.custnum = $table.custnum" unless $opt{'total'};
5908   if ( $table eq 'cust_bill' || $opt{'unapplied_date'} ) {
5909     push @where, "$table._date <= $start" if defined($start) && length($start);
5910     push @where, "$table._date >  $end"   if defined($end)   && length($end);
5911   }
5912   push @where, @{$opt{'where'}} if $opt{'where'};
5913   my $where = scalar(@where) ? 'WHERE '. join(' AND ', @where ) : '';
5914
5915   $where;
5916
5917 }
5918
5919 =item search_sql HASHREF
5920
5921 (Class method)
5922
5923 Returns a qsearch hash expression to search for parameters specified in HREF.
5924 Valid parameters are
5925
5926 =over 4
5927
5928 =item agentnum
5929
5930 =item status
5931
5932 =item cancelled_pkgs
5933
5934 bool
5935
5936 =item signupdate
5937
5938 listref of start date, end date
5939
5940 =item payby
5941
5942 listref
5943
5944 =item current_balance
5945
5946 listref (list returned by FS::UI::Web::parse_lt_gt($cgi, 'current_balance'))
5947
5948 =item cust_fields
5949
5950 =item flattened_pkgs
5951
5952 bool
5953
5954 =back
5955
5956 =cut
5957
5958 sub search_sql {
5959   my ($class, $params) = @_;
5960
5961   my $dbh = dbh;
5962
5963   my @where = ();
5964   my $orderby;
5965
5966   ##
5967   # parse agent
5968   ##
5969
5970   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
5971     push @where,
5972       "cust_main.agentnum = $1";
5973   }
5974
5975   ##
5976   # parse status
5977   ##
5978
5979   #prospect active inactive suspended cancelled
5980   if ( grep { $params->{'status'} eq $_ } FS::cust_main->statuses() ) {
5981     my $method = $params->{'status'}. '_sql';
5982     #push @where, $class->$method();
5983     push @where, FS::cust_main->$method();
5984   }
5985
5986   ##
5987   # parse cancelled package checkbox
5988   ##
5989
5990   my $pkgwhere = "";
5991
5992   $pkgwhere .= "AND (cancel = 0 or cancel is null)"
5993     unless $params->{'cancelled_pkgs'};
5994
5995   ##
5996   # dates
5997   ##
5998
5999   foreach my $field (qw( signupdate )) {
6000
6001     next unless exists($params->{$field});
6002
6003     my($beginning, $ending) = @{$params->{$field}};
6004
6005     push @where,
6006       "cust_main.$field IS NOT NULL",
6007       "cust_main.$field >= $beginning",
6008       "cust_main.$field <= $ending";
6009
6010     $orderby ||= "ORDER BY cust_main.$field";
6011
6012   }
6013
6014   ###
6015   # payby
6016   ###
6017
6018   my @payby = grep /^([A-Z]{4})$/, @{ $params->{'payby'} };
6019   if ( @payby ) {
6020     push @where, '( '. join(' OR ', map "cust_main.payby = '$_'", @payby). ' )';
6021   }
6022
6023   ##
6024   # amounts
6025   ##
6026
6027   #my $balance_sql = $class->balance_sql();
6028   my $balance_sql = FS::cust_main->balance_sql();
6029
6030   push @where, map { s/current_balance/$balance_sql/; $_ }
6031                    @{ $params->{'current_balance'} };
6032
6033   ##
6034   # custbatch
6035   ##
6036
6037   if ( $params->{'custbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
6038     push @where,
6039       "cust_main.custbatch = '$1'";
6040   }
6041
6042   ##
6043   # setup queries, subs, etc. for the search
6044   ##
6045
6046   $orderby ||= 'ORDER BY custnum';
6047
6048   # here is the agent virtualization
6049   push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
6050
6051   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
6052
6053   my $addl_from = 'LEFT JOIN cust_pkg USING ( custnum  ) ';
6054
6055   my $count_query = "SELECT COUNT(*) FROM cust_main $extra_sql";
6056
6057   my $select = join(', ',
6058                  'cust_main.custnum',
6059                  FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
6060                );
6061
6062   my(@extra_headers) = ();
6063   my(@extra_fields)  = ();
6064
6065   if ($params->{'flattened_pkgs'}) {
6066
6067     if ($dbh->{Driver}->{Name} eq 'Pg') {
6068
6069       $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";
6070
6071     }elsif ($dbh->{Driver}->{Name} =~ /^mysql/i) {
6072       $select .= ", GROUP_CONCAT(pkg SEPARATOR '|') as magic";
6073       $addl_from .= " LEFT JOIN part_pkg using ( pkgpart )";
6074     }else{
6075       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
6076            "omitting packing information from report.";
6077     }
6078
6079     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";
6080
6081     my $sth = dbh->prepare($header_query) or die dbh->errstr;
6082     $sth->execute() or die $sth->errstr;
6083     my $headerrow = $sth->fetchrow_arrayref;
6084     my $headercount = $headerrow ? $headerrow->[0] : 0;
6085     while($headercount) {
6086       unshift @extra_headers, "Package ". $headercount;
6087       unshift @extra_fields, eval q!sub {my $c = shift;
6088                                          my @a = split '\|', $c->magic;
6089                                          my $p = $a[!.--$headercount. q!];
6090                                          $p;
6091                                         };!;
6092     }
6093
6094   }
6095
6096   my $sql_query = {
6097     'table'         => 'cust_main',
6098     'select'        => $select,
6099     'hashref'       => {},
6100     'extra_sql'     => $extra_sql,
6101     'order_by'      => $orderby,
6102     'count_query'   => $count_query,
6103     'extra_headers' => \@extra_headers,
6104     'extra_fields'  => \@extra_fields,
6105   };
6106
6107 }
6108
6109 =item email_search_sql HASHREF
6110
6111 (Class method)
6112
6113 Emails a notice to the specified customers.
6114
6115 Valid parameters are those of the L<search_sql> method, plus the following:
6116
6117 =over 4
6118
6119 =item from
6120
6121 From: address
6122
6123 =item subject
6124
6125 Email Subject:
6126
6127 =item html_body
6128
6129 HTML body
6130
6131 =item text_body
6132
6133 Text body
6134
6135 =item job
6136
6137 Optional job queue job for status updates.
6138
6139 =back
6140
6141 Returns an error message, or false for success.
6142
6143 If an error occurs during any email, stops the enture send and returns that
6144 error.  Presumably if you're getting SMTP errors aborting is better than
6145 retrying everything.
6146
6147 =cut
6148
6149 sub email_search_sql {
6150   my($class, $params) = @_;
6151
6152   my $from = delete $params->{from};
6153   my $subject = delete $params->{subject};
6154   my $html_body = delete $params->{html_body};
6155   my $text_body = delete $params->{text_body};
6156
6157   my $job = delete $params->{'job'};
6158
6159   my $sql_query = $class->search_sql($params);
6160
6161   my $count_query   = delete($sql_query->{'count_query'});
6162   my $count_sth = dbh->prepare($count_query)
6163     or die "Error preparing $count_query: ". dbh->errstr;
6164   $count_sth->execute
6165     or die "Error executing $count_query: ". $count_sth->errstr;
6166   my $count_arrayref = $count_sth->fetchrow_arrayref;
6167   my $num_cust = $count_arrayref->[0];
6168
6169   #my @extra_headers = @{ delete($sql_query->{'extra_headers'}) };
6170   #my @extra_fields  = @{ delete($sql_query->{'extra_fields'})  };
6171
6172
6173   my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
6174
6175   #eventually order+limit magic to reduce memory use?
6176   foreach my $cust_main ( qsearch($sql_query) ) {
6177
6178     my $to = $cust_main->invoicing_list_emailonly_scalar;
6179     next unless $to;
6180
6181     my $error = send_email(
6182       generate_email(
6183         'from'      => $from,
6184         'to'        => $to,
6185         'subject'   => $subject,
6186         'html_body' => $html_body,
6187         'text_body' => $text_body,
6188       )
6189     );
6190     return $error if $error;
6191
6192     if ( $job ) { #progressbar foo
6193       $num++;
6194       if ( time - $min_sec > $last ) {
6195         my $error = $job->update_statustext(
6196           int( 100 * $num / $num_cust )
6197         );
6198         die $error if $error;
6199         $last = time;
6200       }
6201     }
6202
6203   }
6204
6205   return '';
6206 }
6207
6208 use Storable qw(thaw);
6209 use Data::Dumper;
6210 use MIME::Base64;
6211 sub process_email_search_sql {
6212   my $job = shift;
6213   #warn "$me process_re_X $method for job $job\n" if $DEBUG;
6214
6215   my $param = thaw(decode_base64(shift));
6216   warn Dumper($param) if $DEBUG;
6217
6218   $param->{'job'} = $job;
6219
6220   my $error = FS::cust_main->email_search_sql( $param );
6221   die $error if $error;
6222
6223 }
6224
6225 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
6226
6227 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
6228 records.  Currently, I<first>, I<last> and/or I<company> may be specified (the
6229 appropriate ship_ field is also searched).
6230
6231 Additional options are the same as FS::Record::qsearch
6232
6233 =cut
6234
6235 sub fuzzy_search {
6236   my( $self, $fuzzy, $hash, @opt) = @_;
6237   #$self
6238   $hash ||= {};
6239   my @cust_main = ();
6240
6241   check_and_rebuild_fuzzyfiles();
6242   foreach my $field ( keys %$fuzzy ) {
6243
6244     my $all = $self->all_X($field);
6245     next unless scalar(@$all);
6246
6247     my %match = ();
6248     $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) );
6249
6250     my @fcust = ();
6251     foreach ( keys %match ) {
6252       push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
6253       push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
6254     }
6255     my %fsaw = ();
6256     push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
6257   }
6258
6259   # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
6260   my %saw = ();
6261   @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
6262
6263   @cust_main;
6264
6265 }
6266
6267 =item masked FIELD
6268
6269 Returns a masked version of the named field
6270
6271 =cut
6272
6273 sub masked {
6274 my ($self,$field) = @_;
6275
6276 # Show last four
6277
6278 'x'x(length($self->getfield($field))-4).
6279   substr($self->getfield($field), (length($self->getfield($field))-4));
6280
6281 }
6282
6283 =back
6284
6285 =head1 SUBROUTINES
6286
6287 =over 4
6288
6289 =item smart_search OPTION => VALUE ...
6290
6291 Accepts the following options: I<search>, the string to search for.  The string
6292 will be searched for as a customer number, phone number, name or company name,
6293 as an exact, or, in some cases, a substring or fuzzy match (see the source code
6294 for the exact heuristics used); I<no_fuzzy_on_exact>, causes smart_search to
6295 skip fuzzy matching when an exact match is found.
6296
6297 Any additional options are treated as an additional qualifier on the search
6298 (i.e. I<agentnum>).
6299
6300 Returns a (possibly empty) array of FS::cust_main objects.
6301
6302 =cut
6303
6304 sub smart_search {
6305   my %options = @_;
6306
6307   #here is the agent virtualization
6308   my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
6309
6310   my @cust_main = ();
6311
6312   my $skip_fuzzy = delete $options{'no_fuzzy_on_exact'};
6313   my $search = delete $options{'search'};
6314   ( my $alphanum_search = $search ) =~ s/\W//g;
6315
6316   if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
6317
6318     #false laziness w/Record::ut_phone
6319     my $phonen = "$1-$2-$3";
6320     $phonen .= " x$4" if $4;
6321
6322     push @cust_main, qsearch( {
6323       'table'   => 'cust_main',
6324       'hashref' => { %options },
6325       'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
6326                      ' ( '.
6327                          join(' OR ', map "$_ = '$phonen'",
6328                                           qw( daytime night fax
6329                                               ship_daytime ship_night ship_fax )
6330                              ).
6331                      ' ) '.
6332                      " AND $agentnums_sql", #agent virtualization
6333     } );
6334
6335     unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
6336       #try looking for matches with extensions unless one was specified
6337
6338       push @cust_main, qsearch( {
6339         'table'   => 'cust_main',
6340         'hashref' => { %options },
6341         'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
6342                        ' ( '.
6343                            join(' OR ', map "$_ LIKE '$phonen\%'",
6344                                             qw( daytime night
6345                                                 ship_daytime ship_night )
6346                                ).
6347                        ' ) '.
6348                        " AND $agentnums_sql", #agent virtualization
6349       } );
6350
6351     }
6352
6353   # custnum search (also try agent_custid), with some tweaking options if your
6354   # legacy cust "numbers" have letters
6355   }
6356
6357   if ( $search =~ /^\s*(\d+)\s*$/
6358             || ( $conf->config('cust_main-agent_custid-format') eq 'ww?d+'
6359                  && $search =~ /^\s*(\w\w?\d+)\s*$/
6360                )
6361           )
6362   {
6363
6364     my $num = $1;
6365
6366     if ( $num <= 2147483647 ) { #need a bigint custnum?  wow.
6367       push @cust_main, qsearch( {
6368         'table'     => 'cust_main',
6369         'hashref'   => { 'custnum' => $num, %options },
6370         'extra_sql' => " AND $agentnums_sql", #agent virtualization
6371       } );
6372     }
6373
6374     push @cust_main, qsearch( {
6375       'table'     => 'cust_main',
6376       'hashref'   => { 'agent_custid' => $num, %options },
6377       'extra_sql' => " AND $agentnums_sql", #agent virtualization
6378     } );
6379
6380   } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
6381
6382     my($company, $last, $first) = ( $1, $2, $3 );
6383
6384     # "Company (Last, First)"
6385     #this is probably something a browser remembered,
6386     #so just do an exact search
6387
6388     foreach my $prefix ( '', 'ship_' ) {
6389       push @cust_main, qsearch( {
6390         'table'     => 'cust_main',
6391         'hashref'   => { $prefix.'first'   => $first,
6392                          $prefix.'last'    => $last,
6393                          $prefix.'company' => $company,
6394                          %options,
6395                        },
6396         'extra_sql' => " AND $agentnums_sql",
6397       } );
6398     }
6399
6400   } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
6401                                               # try (ship_){last,company}
6402
6403     my $value = lc($1);
6404
6405     # # remove "(Last, First)" in "Company (Last, First)", otherwise the
6406     # # full strings the browser remembers won't work
6407     # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
6408
6409     use Lingua::EN::NameParse;
6410     my $NameParse = new Lingua::EN::NameParse(
6411              auto_clean     => 1,
6412              allow_reversed => 1,
6413     );
6414
6415     my($last, $first) = ( '', '' );
6416     #maybe disable this too and just rely on NameParse?
6417     if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
6418
6419       ($last, $first) = ( $1, $2 );
6420
6421     #} elsif  ( $value =~ /^(.+)\s+(.+)$/ ) {
6422     } elsif ( ! $NameParse->parse($value) ) {
6423
6424       my %name = $NameParse->components;
6425       $first = $name{'given_name_1'};
6426       $last  = $name{'surname_1'};
6427
6428     }
6429
6430     if ( $first && $last ) {
6431
6432       my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
6433
6434       #exact
6435       my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
6436       $sql .= "
6437         (     ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
6438            OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
6439         )";
6440
6441       push @cust_main, qsearch( {
6442         'table'     => 'cust_main',
6443         'hashref'   => \%options,
6444         'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
6445       } );
6446
6447       # or it just be something that was typed in... (try that in a sec)
6448
6449     }
6450
6451     my $q_value = dbh->quote($value);
6452
6453     #exact
6454     my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
6455     $sql .= " (    LOWER(last)         = $q_value
6456                 OR LOWER(company)      = $q_value
6457                 OR LOWER(ship_last)    = $q_value
6458                 OR LOWER(ship_company) = $q_value
6459               )";
6460
6461     push @cust_main, qsearch( {
6462       'table'     => 'cust_main',
6463       'hashref'   => \%options,
6464       'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
6465     } );
6466
6467     #no exact match, trying substring/fuzzy
6468     #always do substring & fuzzy (unless they're explicity config'ed off)
6469     #getting complaints searches are not returning enough
6470     unless ( @cust_main  && $skip_fuzzy || $conf->exists('disable-fuzzy') ) {
6471
6472       #still some false laziness w/search_sql (was search/cust_main.cgi)
6473
6474       #substring
6475
6476       my @hashrefs = (
6477         { 'company'      => { op=>'ILIKE', value=>"%$value%" }, },
6478         { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
6479       );
6480
6481       if ( $first && $last ) {
6482
6483         push @hashrefs,
6484           { 'first'        => { op=>'ILIKE', value=>"%$first%" },
6485             'last'         => { op=>'ILIKE', value=>"%$last%" },
6486           },
6487           { 'ship_first'   => { op=>'ILIKE', value=>"%$first%" },
6488             'ship_last'    => { op=>'ILIKE', value=>"%$last%" },
6489           },
6490         ;
6491
6492       } else {
6493
6494         push @hashrefs,
6495           { 'last'         => { op=>'ILIKE', value=>"%$value%" }, },
6496           { 'ship_last'    => { op=>'ILIKE', value=>"%$value%" }, },
6497         ;
6498       }
6499
6500       foreach my $hashref ( @hashrefs ) {
6501
6502         push @cust_main, qsearch( {
6503           'table'     => 'cust_main',
6504           'hashref'   => { %$hashref,
6505                            %options,
6506                          },
6507           'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
6508         } );
6509
6510       }
6511
6512       #fuzzy
6513       my @fuzopts = (
6514         \%options,                #hashref
6515         '',                       #select
6516         " AND $agentnums_sql",    #extra_sql  #agent virtualization
6517       );
6518
6519       if ( $first && $last ) {
6520         push @cust_main, FS::cust_main->fuzzy_search(
6521           { 'last'   => $last,    #fuzzy hashref
6522             'first'  => $first }, #
6523           @fuzopts
6524         );
6525       }
6526       foreach my $field ( 'last', 'company' ) {
6527         push @cust_main,
6528           FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
6529       }
6530
6531     }
6532
6533     #eliminate duplicates
6534     my %saw = ();
6535     @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
6536
6537   }
6538
6539   @cust_main;
6540
6541 }
6542
6543 =item email_search
6544
6545 Accepts the following options: I<email>, the email address to search for.  The
6546 email address will be searched for as an email invoice destination and as an
6547 svc_acct account.
6548
6549 #Any additional options are treated as an additional qualifier on the search
6550 #(i.e. I<agentnum>).
6551
6552 Returns a (possibly empty) array of FS::cust_main objects (but usually just
6553 none or one).
6554
6555 =cut
6556
6557 sub email_search {
6558   my %options = @_;
6559
6560   local($DEBUG) = 1;
6561
6562   my $email = delete $options{'email'};
6563
6564   #we're only being used by RT at the moment... no agent virtualization yet
6565   #my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
6566
6567   my @cust_main = ();
6568
6569   if ( $email =~ /([^@]+)\@([^@]+)/ ) {
6570
6571     my ( $user, $domain ) = ( $1, $2 );
6572
6573     warn "$me smart_search: searching for $user in domain $domain"
6574       if $DEBUG;
6575
6576     push @cust_main,
6577       map $_->cust_main,
6578           qsearch( {
6579                      'table'     => 'cust_main_invoice',
6580                      'hashref'   => { 'dest' => $email },
6581                    }
6582                  );
6583
6584     push @cust_main,
6585       map  $_->cust_main,
6586       grep $_,
6587       map  $_->cust_svc->cust_pkg,
6588           qsearch( {
6589                      'table'     => 'svc_acct',
6590                      'hashref'   => { 'username' => $user, },
6591                      'extra_sql' =>
6592                        'AND ( SELECT domain FROM svc_domain
6593                                 WHERE svc_acct.domsvc = svc_domain.svcnum
6594                             ) = '. dbh->quote($domain),
6595                    }
6596                  );
6597   }
6598
6599   my %saw = ();
6600   @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
6601
6602   warn "$me smart_search: found ". scalar(@cust_main). " unique customers"
6603     if $DEBUG;
6604
6605   @cust_main;
6606
6607 }
6608
6609 =item check_and_rebuild_fuzzyfiles
6610
6611 =cut
6612
6613 use vars qw(@fuzzyfields);
6614 @fuzzyfields = ( 'last', 'first', 'company' );
6615
6616 sub check_and_rebuild_fuzzyfiles {
6617   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6618   rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
6619 }
6620
6621 =item rebuild_fuzzyfiles
6622
6623 =cut
6624
6625 sub rebuild_fuzzyfiles {
6626
6627   use Fcntl qw(:flock);
6628
6629   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6630   mkdir $dir, 0700 unless -d $dir;
6631
6632   foreach my $fuzzy ( @fuzzyfields ) {
6633
6634     open(LOCK,">>$dir/cust_main.$fuzzy")
6635       or die "can't open $dir/cust_main.$fuzzy: $!";
6636     flock(LOCK,LOCK_EX)
6637       or die "can't lock $dir/cust_main.$fuzzy: $!";
6638
6639     open (CACHE,">$dir/cust_main.$fuzzy.tmp")
6640       or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
6641
6642     foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
6643       my $sth = dbh->prepare("SELECT $field FROM cust_main".
6644                              " WHERE $field != '' AND $field IS NOT NULL");
6645       $sth->execute or die $sth->errstr;
6646
6647       while ( my $row = $sth->fetchrow_arrayref ) {
6648         print CACHE $row->[0]. "\n";
6649       }
6650
6651     }
6652
6653     close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
6654
6655     rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
6656     close LOCK;
6657   }
6658
6659 }
6660
6661 =item all_X
6662
6663 =cut
6664
6665 sub all_X {
6666   my( $self, $field ) = @_;
6667   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6668   open(CACHE,"<$dir/cust_main.$field")
6669     or die "can't open $dir/cust_main.$field: $!";
6670   my @array = map { chomp; $_; } <CACHE>;
6671   close CACHE;
6672   \@array;
6673 }
6674
6675 =item append_fuzzyfiles LASTNAME COMPANY
6676
6677 =cut
6678
6679 sub append_fuzzyfiles {
6680   #my( $first, $last, $company ) = @_;
6681
6682   &check_and_rebuild_fuzzyfiles;
6683
6684   use Fcntl qw(:flock);
6685
6686   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6687
6688   foreach my $field (qw( first last company )) {
6689     my $value = shift;
6690
6691     if ( $value ) {
6692
6693       open(CACHE,">>$dir/cust_main.$field")
6694         or die "can't open $dir/cust_main.$field: $!";
6695       flock(CACHE,LOCK_EX)
6696         or die "can't lock $dir/cust_main.$field: $!";
6697
6698       print CACHE "$value\n";
6699
6700       flock(CACHE,LOCK_UN)
6701         or die "can't unlock $dir/cust_main.$field: $!";
6702       close CACHE;
6703     }
6704
6705   }
6706
6707   1;
6708 }
6709
6710 =item batch_charge
6711
6712 =cut
6713
6714 sub batch_charge {
6715   my $param = shift;
6716   #warn join('-',keys %$param);
6717   my $fh = $param->{filehandle};
6718   my @fields = @{$param->{fields}};
6719
6720   eval "use Text::CSV_XS;";
6721   die $@ if $@;
6722
6723   my $csv = new Text::CSV_XS;
6724   #warn $csv;
6725   #warn $fh;
6726
6727   my $imported = 0;
6728   #my $columns;
6729
6730   local $SIG{HUP} = 'IGNORE';
6731   local $SIG{INT} = 'IGNORE';
6732   local $SIG{QUIT} = 'IGNORE';
6733   local $SIG{TERM} = 'IGNORE';
6734   local $SIG{TSTP} = 'IGNORE';
6735   local $SIG{PIPE} = 'IGNORE';
6736
6737   my $oldAutoCommit = $FS::UID::AutoCommit;
6738   local $FS::UID::AutoCommit = 0;
6739   my $dbh = dbh;
6740
6741   #while ( $columns = $csv->getline($fh) ) {
6742   my $line;
6743   while ( defined($line=<$fh>) ) {
6744
6745     $csv->parse($line) or do {
6746       $dbh->rollback if $oldAutoCommit;
6747       return "can't parse: ". $csv->error_input();
6748     };
6749
6750     my @columns = $csv->fields();
6751     #warn join('-',@columns);
6752
6753     my %row = ();
6754     foreach my $field ( @fields ) {
6755       $row{$field} = shift @columns;
6756     }
6757
6758     my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
6759     unless ( $cust_main ) {
6760       $dbh->rollback if $oldAutoCommit;
6761       return "unknown custnum $row{'custnum'}";
6762     }
6763
6764     if ( $row{'amount'} > 0 ) {
6765       my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
6766       if ( $error ) {
6767         $dbh->rollback if $oldAutoCommit;
6768         return $error;
6769       }
6770       $imported++;
6771     } elsif ( $row{'amount'} < 0 ) {
6772       my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
6773                                       $row{'pkg'}                         );
6774       if ( $error ) {
6775         $dbh->rollback if $oldAutoCommit;
6776         return $error;
6777       }
6778       $imported++;
6779     } else {
6780       #hmm?
6781     }
6782
6783   }
6784
6785   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6786
6787   return "Empty file!" unless $imported;
6788
6789   ''; #no error
6790
6791 }
6792
6793 =item notify CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6794
6795 Sends a templated email notification to the customer (see L<Text::Template>).
6796
6797 OPTIONS is a hash and may include
6798
6799 I<from> - the email sender (default is invoice_from)
6800
6801 I<to> - comma-separated scalar or arrayref of recipients
6802    (default is invoicing_list)
6803
6804 I<subject> - The subject line of the sent email notification
6805    (default is "Notice from company_name")
6806
6807 I<extra_fields> - a hashref of name/value pairs which will be substituted
6808    into the template
6809
6810 The following variables are vavailable in the template.
6811
6812 I<$first> - the customer first name
6813 I<$last> - the customer last name
6814 I<$company> - the customer company
6815 I<$payby> - a description of the method of payment for the customer
6816             # would be nice to use FS::payby::shortname
6817 I<$payinfo> - the account information used to collect for this customer
6818 I<$expdate> - the expiration of the customer payment in seconds from epoch
6819
6820 =cut
6821
6822 sub notify {
6823   my ($self, $template, %options) = @_;
6824
6825   return unless $conf->exists($template);
6826
6827   my $from = $conf->config('invoice_from', $self->agentnum)
6828     if $conf->exists('invoice_from', $self->agentnum);
6829   $from = $options{from} if exists($options{from});
6830
6831   my $to = join(',', $self->invoicing_list_emailonly);
6832   $to = $options{to} if exists($options{to});
6833
6834   my $subject = "Notice from " . $conf->config('company_name', $self->agentnum)
6835     if $conf->exists('company_name', $self->agentnum);
6836   $subject = $options{subject} if exists($options{subject});
6837
6838   my $notify_template = new Text::Template (TYPE => 'ARRAY',
6839                                             SOURCE => [ map "$_\n",
6840                                               $conf->config($template)]
6841                                            )
6842     or die "can't create new Text::Template object: Text::Template::ERROR";
6843   $notify_template->compile()
6844     or die "can't compile template: Text::Template::ERROR";
6845
6846   $FS::notify_template::_template::company_name =
6847     $conf->config('company_name', $self->agentnum);
6848   $FS::notify_template::_template::company_address =
6849     join("\n", $conf->config('company_address', $self->agentnum) ). "\n";
6850
6851   my $paydate = $self->paydate || '2037-12-31';
6852   $FS::notify_template::_template::first = $self->first;
6853   $FS::notify_template::_template::last = $self->last;
6854   $FS::notify_template::_template::company = $self->company;
6855   $FS::notify_template::_template::payinfo = $self->mask_payinfo;
6856   my $payby = $self->payby;
6857   my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6858   my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6859
6860   #credit cards expire at the end of the month/year of their exp date
6861   if ($payby eq 'CARD' || $payby eq 'DCRD') {
6862     $FS::notify_template::_template::payby = 'credit card';
6863     ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6864     $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6865     $expire_time--;
6866   }elsif ($payby eq 'COMP') {
6867     $FS::notify_template::_template::payby = 'complimentary account';
6868   }else{
6869     $FS::notify_template::_template::payby = 'current method';
6870   }
6871   $FS::notify_template::_template::expdate = $expire_time;
6872
6873   for (keys %{$options{extra_fields}}){
6874     no strict "refs";
6875     ${"FS::notify_template::_template::$_"} = $options{extra_fields}->{$_};
6876   }
6877
6878   send_email(from => $from,
6879              to => $to,
6880              subject => $subject,
6881              body => $notify_template->fill_in( PACKAGE =>
6882                                                 'FS::notify_template::_template'                                              ),
6883             );
6884
6885 }
6886
6887 =item generate_letter CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6888
6889 Generates a templated notification to the customer (see L<Text::Template>).
6890
6891 OPTIONS is a hash and may include
6892
6893 I<extra_fields> - a hashref of name/value pairs which will be substituted
6894    into the template.  These values may override values mentioned below
6895    and those from the customer record.
6896
6897 The following variables are available in the template instead of or in addition
6898 to the fields of the customer record.
6899
6900 I<$payby> - a description of the method of payment for the customer
6901             # would be nice to use FS::payby::shortname
6902 I<$payinfo> - the masked account information used to collect for this customer
6903 I<$expdate> - the expiration of the customer payment method in seconds from epoch
6904 I<$returnaddress> - the return address defaults to invoice_latexreturnaddress or company_address
6905
6906 =cut
6907
6908 sub generate_letter {
6909   my ($self, $template, %options) = @_;
6910
6911   return unless $conf->exists($template);
6912
6913   my $letter_template = new Text::Template
6914                         ( TYPE       => 'ARRAY',
6915                           SOURCE     => [ map "$_\n", $conf->config($template)],
6916                           DELIMITERS => [ '[@--', '--@]' ],
6917                         )
6918     or die "can't create new Text::Template object: Text::Template::ERROR";
6919
6920   $letter_template->compile()
6921     or die "can't compile template: Text::Template::ERROR";
6922
6923   my %letter_data = map { $_ => $self->$_ } $self->fields;
6924   $letter_data{payinfo} = $self->mask_payinfo;
6925
6926   #my $paydate = $self->paydate || '2037-12-31';
6927   my $paydate = $self->paydate =~ /^\S+$/ ? $self->paydate : '2037-12-31';
6928
6929   my $payby = $self->payby;
6930   my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6931   my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6932
6933   #credit cards expire at the end of the month/year of their exp date
6934   if ($payby eq 'CARD' || $payby eq 'DCRD') {
6935     $letter_data{payby} = 'credit card';
6936     ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6937     $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6938     $expire_time--;
6939   }elsif ($payby eq 'COMP') {
6940     $letter_data{payby} = 'complimentary account';
6941   }else{
6942     $letter_data{payby} = 'current method';
6943   }
6944   $letter_data{expdate} = $expire_time;
6945
6946   for (keys %{$options{extra_fields}}){
6947     $letter_data{$_} = $options{extra_fields}->{$_};
6948   }
6949
6950   unless(exists($letter_data{returnaddress})){
6951     my $retadd = join("\n", $conf->config_orbase( 'invoice_latexreturnaddress',
6952                                                   $self->agent_template)
6953                      );
6954     if ( length($retadd) ) {
6955       $letter_data{returnaddress} = $retadd;
6956     } elsif ( grep /\S/, $conf->config('company_address', $self->agentnum) ) {
6957       $letter_data{returnaddress} =
6958         join( '\\*'."\n", map s/( {2,})/'~' x length($1)/eg,
6959                           $conf->config('company_address', $self->agentnum)
6960         );
6961     } else {
6962       $letter_data{returnaddress} = '~';
6963     }
6964   }
6965
6966   $letter_data{conf_dir} = "$FS::UID::conf_dir/conf.$FS::UID::datasrc";
6967
6968   $letter_data{company_name} = $conf->config('company_name', $self->agentnum);
6969
6970   my $dir = $FS::UID::conf_dir."/cache.". $FS::UID::datasrc;
6971   my $fh = new File::Temp( TEMPLATE => 'letter.'. $self->custnum. '.XXXXXXXX',
6972                            DIR      => $dir,
6973                            SUFFIX   => '.tex',
6974                            UNLINK   => 0,
6975                          ) or die "can't open temp file: $!\n";
6976
6977   $letter_template->fill_in( OUTPUT => $fh, HASH => \%letter_data );
6978   close $fh;
6979   $fh->filename =~ /^(.*).tex$/ or die "unparsable filename: ". $fh->filename;
6980   return $1;
6981 }
6982
6983 =item print_ps TEMPLATE
6984
6985 Returns an postscript letter filled in from TEMPLATE, as a scalar.
6986
6987 =cut
6988
6989 sub print_ps {
6990   my $self = shift;
6991   my $file = $self->generate_letter(@_);
6992   FS::Misc::generate_ps($file);
6993 }
6994
6995 =item print TEMPLATE
6996
6997 Prints the filled in template.
6998
6999 TEMPLATE is the name of a L<Text::Template> to fill in and print.
7000
7001 =cut
7002
7003 sub queueable_print {
7004   my %opt = @_;
7005
7006   my $self = qsearchs('cust_main', { 'custnum' => $opt{custnum} } )
7007     or die "invalid customer number: " . $opt{custvnum};
7008
7009   my $error = $self->print( $opt{template} );
7010   die $error if $error;
7011 }
7012
7013 sub print {
7014   my ($self, $template) = (shift, shift);
7015   do_print [ $self->print_ps($template) ];
7016 }
7017
7018 #these three subs should just go away once agent stuff is all config overrides
7019
7020 sub agent_template {
7021   my $self = shift;
7022   $self->_agent_plandata('agent_templatename');
7023 }
7024
7025 sub agent_invoice_from {
7026   my $self = shift;
7027   $self->_agent_plandata('agent_invoice_from');
7028 }
7029
7030 sub _agent_plandata {
7031   my( $self, $option ) = @_;
7032
7033   #yuck.  this whole thing needs to be reconciled better with 1.9's idea of
7034   #agent-specific Conf
7035
7036   use FS::part_event::Condition;
7037
7038   my $agentnum = $self->agentnum;
7039
7040   my $regexp = '';
7041   if ( driver_name =~ /^Pg/i ) {
7042     $regexp = '~';
7043   } elsif ( driver_name =~ /^mysql/i ) {
7044     $regexp = 'REGEXP';
7045   } else {
7046     die "don't know how to use regular expressions in ". driver_name. " databases";
7047   }
7048
7049   my $part_event_option =
7050     qsearchs({
7051       'select'    => 'part_event_option.*',
7052       'table'     => 'part_event_option',
7053       'addl_from' => q{
7054         LEFT JOIN part_event USING ( eventpart )
7055         LEFT JOIN part_event_option AS peo_agentnum
7056           ON ( part_event.eventpart = peo_agentnum.eventpart
7057                AND peo_agentnum.optionname = 'agentnum'
7058                AND peo_agentnum.optionvalue }. $regexp. q{ '(^|,)}. $agentnum. q{(,|$)'
7059              )
7060         LEFT JOIN part_event_condition
7061           ON ( part_event.eventpart = part_event_condition.eventpart
7062                AND part_event_condition.conditionname = 'cust_bill_age'
7063              )
7064         LEFT JOIN part_event_condition_option
7065           ON ( part_event_condition.eventconditionnum = part_event_condition_option.eventconditionnum
7066                AND part_event_condition_option.optionname = 'age'
7067              )
7068       },
7069       #'hashref'   => { 'optionname' => $option },
7070       #'hashref'   => { 'part_event_option.optionname' => $option },
7071       'extra_sql' =>
7072         " WHERE part_event_option.optionname = ". dbh->quote($option).
7073         " AND action = 'cust_bill_send_agent' ".
7074         " AND ( disabled IS NULL OR disabled != 'Y' ) ".
7075         " AND peo_agentnum.optionname = 'agentnum' ".
7076         " AND ( agentnum IS NULL OR agentnum = $agentnum ) ".
7077         " ORDER BY
7078            CASE WHEN part_event_condition_option.optionname IS NULL
7079            THEN -1
7080            ELSE ". FS::part_event::Condition->age2seconds_sql('part_event_condition_option.optionvalue').
7081         " END
7082           , part_event.weight".
7083         " LIMIT 1"
7084     });
7085
7086   unless ( $part_event_option ) {
7087     return $self->agent->invoice_template || ''
7088       if $option eq 'agent_templatename';
7089     return '';
7090   }
7091
7092   $part_event_option->optionvalue;
7093
7094 }
7095
7096 sub queued_bill {
7097   ## actual sub, not a method, designed to be called from the queue.
7098   ## sets up the customer, and calls the bill_and_collect
7099   my (%args) = @_; #, ($time, $invoice_time, $check_freq, $resetup) = @_;
7100   my $cust_main = qsearchs( 'cust_main', { custnum => $args{'custnum'} } );
7101       $cust_main->bill_and_collect(
7102         %args,
7103       );
7104 }
7105
7106 =back
7107
7108 =head1 BUGS
7109
7110 The delete method.
7111
7112 The delete method should possibly take an FS::cust_main object reference
7113 instead of a scalar customer number.
7114
7115 Bill and collect options should probably be passed as references instead of a
7116 list.
7117
7118 There should probably be a configuration file with a list of allowed credit
7119 card types.
7120
7121 No multiple currency support (probably a larger project than just this module).
7122
7123 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
7124
7125 Birthdates rely on negative epoch values.
7126
7127 The payby for card/check batches is broken.  With mixed batching, bad
7128 things will happen.
7129
7130 B<collect> I<invoice_time> should be renamed I<time>, like B<bill>.
7131
7132 =head1 SEE ALSO
7133
7134 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
7135 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
7136 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.
7137
7138 =cut
7139
7140 1;
7141