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