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