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