FS/FS/cust_main.pm

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