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