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