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