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