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 Time::Local qw(timelocal_nocheck);
  12 use Data::Dumper;
  13 use Tie::IxHash;
  14 use Digest::MD5 qw(md5_base64);
  15 use Date::Format;
  16 use Date::Parse;
  17 #use Date::Manip;
  18 use String::Approx qw(amatch);
  19 use Business::CreditCard 0.28;
  20 use Locale::Country;
  21 use Data::Dumper;
  22 use FS::UID qw( getotaker dbh );
  23 use FS::Record qw( qsearchs qsearch dbdef );
  24 use FS::Misc qw( 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_void;
  32 use FS::cust_pay_batch;
  33 use FS::cust_credit;
  34 use FS::cust_refund;
  35 use FS::part_referral;
  36 use FS::cust_main_county;
  37 use FS::agent;
  38 use FS::cust_main_invoice;
  39 use FS::cust_credit_bill;
  40 use FS::cust_bill_pay;
  41 use FS::prepay_credit;
  42 use FS::queue;
  43 use FS::part_pkg;
  44 use FS::part_event;
  45 use FS::part_event_condition;
  46 #use FS::cust_event;
  47 use FS::cust_tax_exempt;
  48 use FS::cust_tax_exempt_pkg;
  49 use FS::type_pkgs;
  50 use FS::payment_gateway;
  51 use FS::agent_payment_gateway;
  52 use FS::banned_pay;
  53 use FS::payinfo_Mixin;
  54 use FS::TicketSystem;
  55
  56 @ISA = qw( FS::Record FS::payinfo_Mixin );
  57
  58 @EXPORT_OK = qw( smart_search );
  59
  60 $realtime_bop_decline_quiet = 0;
  61
  62 # 1 is mostly method/subroutine entry and options
  63 # 2 traces progress of some operations
  64 # 3 is even more information including possibly sensitive data
  65 $DEBUG = 0;
  66 $me = '[FS::cust_main]';
  67
  68 $import = 0;
  69 $skip_fuzzyfiles = 0;
  70 $ignore_expired_card = 0;
  71
  72 @encrypted_fields = ('payinfo', 'paycvv');
  73 @paytypes = ('', 'Personal checking', 'Personal savings', 'Business checking', 'Business savings');
  74
  75 #ask FS::UID to run this stuff for us later
  76 #$FS::UID::callback{'FS::cust_main'} = sub {
  77 install_callback FS::UID sub {
  78   $conf = new FS::Conf;
  79   #yes, need it for stuff below (prolly should be cached)
  80 };
  81
  82 sub _cache {
  83   my $self = shift;
  84   my ( $hashref, $cache ) = @_;
  85   if ( exists $hashref->{'pkgnum'} ) {
  86     #@{ $self->{'_pkgnum'} } = ();
  87     my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum});
  88     $self->{'_pkgnum'} = $subcache;
  89     #push @{ $self->{'_pkgnum'} },
  90     FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum};
  91   }
  92 }
  93
  94 =head1 NAME
  95
  96 FS::cust_main - Object methods for cust_main records
  97
  98 =head1 SYNOPSIS
  99
 100   use FS::cust_main;
 101
 102   $record = new FS::cust_main \%hash;
 103   $record = new FS::cust_main { 'column' => 'value' };
 104
 105   $error = $record->insert;
 106
 107   $error = $new_record->replace($old_record);
 108
 109   $error = $record->delete;
 110
 111   $error = $record->check;
 112
 113   @cust_pkg = $record->all_pkgs;
 114
 115   @cust_pkg = $record->ncancelled_pkgs;
 116
 117   @cust_pkg = $record->suspended_pkgs;
 118
 119   $error = $record->bill;
 120   $error = $record->bill %options;
 121   $error = $record->bill 'time' => $time;
 122
 123   $error = $record->collect;
 124   $error = $record->collect %options;
 125   $error = $record->collect 'invoice_time'   => $time,
 126                           ;
 127
 128 =head1 DESCRIPTION
 129
 130 An FS::cust_main object represents a customer.  FS::cust_main inherits from
 131 FS::Record.  The following fields are currently supported:
 132
 133 =over 4
 134
 135 =item custnum - primary key (assigned automatically for new customers)
 136
 137 =item agentnum - agent (see L<FS::agent>)
 138
 139 =item refnum - Advertising source (see L<FS::part_referral>)
 140
 141 =item first - name
 142
 143 =item last - name
 144
 145 =item ss - social security number (optional)
 146
 147 =item company - (optional)
 148
 149 =item address1
 150
 151 =item address2 - (optional)
 152
 153 =item city
 154
 155 =item county - (optional, see L<FS::cust_main_county>)
 156
 157 =item state - (see L<FS::cust_main_county>)
 158
 159 =item zip
 160
 161 =item country - (see L<FS::cust_main_county>)
 162
 163 =item daytime - phone (optional)
 164
 165 =item night - phone (optional)
 166
 167 =item fax - phone (optional)
 168
 169 =item ship_first - name
 170
 171 =item ship_last - name
 172
 173 =item ship_company - (optional)
 174
 175 =item ship_address1
 176
 177 =item ship_address2 - (optional)
 178
 179 =item ship_city
 180
 181 =item ship_county - (optional, see L<FS::cust_main_county>)
 182
 183 =item ship_state - (see L<FS::cust_main_county>)
 184
 185 =item ship_zip
 186
 187 =item ship_country - (see L<FS::cust_main_county>)
 188
 189 =item ship_daytime - phone (optional)
 190
 191 =item ship_night - phone (optional)
 192
 193 =item ship_fax - phone (optional)
 194
 195 =item payby - Payment Type (See L<FS::payinfo_Mixin> for valid payby values)
 196
 197 =item payinfo - Payment Information (See L<FS::payinfo_Mixin> for data format)
 198
 199 =item paymask - Masked payinfo (See L<FS::payinfo_Mixin> for how this works)
 200
 201 =item paycvv
 202
 203 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
 204
 205 =item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy
 206
 207 =item paystart_month - start date month (maestro/solo cards only)
 208
 209 =item paystart_year - start date year (maestro/solo cards only)
 210
 211 =item payissue - issue number (maestro/solo cards only)
 212
 213 =item payname - name on card or billing name
 214
 215 =item payip - IP address from which payment information was received
 216
 217 =item tax - tax exempt, empty or `Y'
 218
 219 =item otaker - order taker (assigned automatically, see L<FS::UID>)
 220
 221 =item comments - comments (optional)
 222
 223 =item referral_custnum - referring customer number
 224
 225 =item spool_cdr - Enable individual CDR spooling, empty or `Y'
 226
 227 =back
 228
 229 =head1 METHODS
 230
 231 =over 4
 232
 233 =item new HASHREF
 234
 235 Creates a new customer.  To add the customer to the database, see L<"insert">.
 236
 237 Note that this stores the hash reference, not a distinct copy of the hash it
 238 points to.  You can ask the object for a copy with the I<hash> method.
 239
 240 =cut
 241
 242 sub table { 'cust_main'; }
 243
 244 =item insert [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
 245
 246 Adds this customer to the database.  If there is an error, returns the error,
 247 otherwise returns false.
 248
 249 CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert
 250 method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records
 251 are inserted atomicly, or the transaction is rolled back.  Passing an empty
 252 hash reference is equivalent to not supplying this parameter.  There should be
 253 a better explanation of this, but until then, here's an example:
 254
 255   use Tie::RefHash;
 256   tie %hash, 'Tie::RefHash'; #this part is important
 257   %hash = (
 258     $cust_pkg => [ $svc_acct ],
 259     ...
 260   );
 261   $cust_main->insert( \%hash );
 262
 263 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
 264 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
 265 expected and rollback the entire transaction; it is not necessary to call
 266 check_invoicing_list first.  The invoicing_list is set after the records in the
 267 CUST_PKG_HASHREF above are inserted, so it is now possible to set an
 268 invoicing_list destination to the newly-created svc_acct.  Here's an example:
 269
 270   $cust_main->insert( {}, [ $email, 'POST' ] );
 271
 272 Currently available options are: I<depend_jobnum> and I<noexport>.
 273
 274 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 275 on the supplied jobnum (they will not run until the specific job completes).
 276 This can be used to defer provisioning until some action completes (such
 277 as running the customer's credit card successfully).
 278
 279 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 280 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 281 the B<reexport> method.)
 282
 283 =cut
 284
 285 sub insert {
 286   my $self = shift;
 287   my $cust_pkgs = @_ ? shift : {};
 288   my $invoicing_list = @_ ? shift : '';
 289   my %options = @_;
 290   warn "$me insert called with options ".
 291        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 292     if $DEBUG;
 293
 294   local $SIG{HUP} = 'IGNORE';
 295   local $SIG{INT} = 'IGNORE';
 296   local $SIG{QUIT} = 'IGNORE';
 297   local $SIG{TERM} = 'IGNORE';
 298   local $SIG{TSTP} = 'IGNORE';
 299   local $SIG{PIPE} = 'IGNORE';
 300
 301   my $oldAutoCommit = $FS::UID::AutoCommit;
 302   local $FS::UID::AutoCommit = 0;
 303   my $dbh = dbh;
 304
 305   my $prepay_identifier = '';
 306   my( $amount, $seconds ) = ( 0, 0 );
 307   my $payby = '';
 308   if ( $self->payby eq 'PREPAY' ) {
 309
 310     $self->payby('BILL');
 311     $prepay_identifier = $self->payinfo;
 312     $self->payinfo('');
 313
 314     warn "  looking up prepaid card $prepay_identifier\n"
 315       if $DEBUG > 1;
 316
 317     my $error = $self->get_prepay($prepay_identifier, \$amount, \$seconds);
 318     if ( $error ) {
 319       $dbh->rollback if $oldAutoCommit;
 320       #return "error applying prepaid card (transaction rolled back): $error";
 321       return $error;
 322     }
 323
 324     $payby = 'PREP' if $amount;
 325
 326   } elsif ( $self->payby =~ /^(CASH|WEST|MCRD)$/ ) {
 327
 328     $payby = $1;
 329     $self->payby('BILL');
 330     $amount = $self->paid;
 331
 332   }
 333
 334   warn "  inserting $self\n"
 335     if $DEBUG > 1;
 336
 337   $self->signupdate(time) unless $self->signupdate;
 338
 339   my $error = $self->SUPER::insert;
 340   if ( $error ) {
 341     $dbh->rollback if $oldAutoCommit;
 342     #return "inserting cust_main record (transaction rolled back): $error";
 343     return $error;
 344   }
 345
 346   warn "  setting invoicing list\n"
 347     if $DEBUG > 1;
 348
 349   if ( $invoicing_list ) {
 350     $error = $self->check_invoicing_list( $invoicing_list );
 351     if ( $error ) {
 352       $dbh->rollback if $oldAutoCommit;
 353       return "checking invoicing_list (transaction rolled back): $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   my $old = shift;
1072   my @param = @_;
1073   warn "$me replace called\n"
1074     if $DEBUG;
1075
1076   local $SIG{HUP} = 'IGNORE';
1077   local $SIG{INT} = 'IGNORE';
1078   local $SIG{QUIT} = 'IGNORE';
1079   local $SIG{TERM} = 'IGNORE';
1080   local $SIG{TSTP} = 'IGNORE';
1081   local $SIG{PIPE} = 'IGNORE';
1082
1083   # We absolutely have to have an old vs. new record to make this work.
1084   if (!defined($old)) {
1085     $old = qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1086   }
1087
1088   my $curuser = $FS::CurrentUser::CurrentUser;
1089   if (    $self->payby eq 'COMP'
1090        && $self->payby ne $old->payby
1091        && ! $curuser->access_right('Complimentary customer')
1092      )
1093   {
1094     return "You are not permitted to create complimentary accounts.";
1095   }
1096
1097   local($ignore_expired_card) = 1
1098     if $old->payby  =~ /^(CARD|DCRD)$/
1099     && $self->payby =~ /^(CARD|DCRD)$/
1100     && ( $old->payinfo eq $self->payinfo || $old->paymask eq $self->paymask );
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   my @addfields = qw(
1278     last first company address1 address2 city county state zip
1279     country daytime night fax
1280   );
1281
1282   if ( defined $self->dbdef_table->column('ship_last') ) {
1283     if ( scalar ( grep { $self->getfield($_) ne $self->getfield("ship_$_") }
1284                        @addfields )
1285          && scalar ( grep { $self->getfield("ship_$_") ne '' } @addfields )
1286        )
1287     {
1288       my $error =
1289         $self->ut_name('ship_last')
1290         || $self->ut_name('ship_first')
1291         || $self->ut_textn('ship_company')
1292         || $self->ut_text('ship_address1')
1293         || $self->ut_textn('ship_address2')
1294         || $self->ut_text('ship_city')
1295         || $self->ut_textn('ship_county')
1296         || $self->ut_textn('ship_state')
1297         || $self->ut_country('ship_country')
1298       ;
1299       return $error if $error;
1300
1301       #false laziness with above
1302       unless ( qsearchs('cust_main_county', {
1303         'country' => $self->ship_country,
1304         'state'   => '',
1305        } ) ) {
1306         return "Unknown ship_state/ship_county/ship_country: ".
1307           $self->ship_state. "/". $self->ship_county. "/". $self->ship_country
1308           unless qsearch('cust_main_county',{
1309             'state'   => $self->ship_state,
1310             'county'  => $self->ship_county,
1311             'country' => $self->ship_country,
1312           } );
1313       }
1314       #eofalse
1315
1316       $error =
1317         $self->ut_phonen('ship_daytime', $self->ship_country)
1318         || $self->ut_phonen('ship_night', $self->ship_country)
1319         || $self->ut_phonen('ship_fax', $self->ship_country)
1320         || $self->ut_zip('ship_zip', $self->ship_country)
1321       ;
1322       return $error if $error;
1323
1324     } else { # ship_ info eq billing info, so don't store dup info in database
1325       $self->setfield("ship_$_", '')
1326         foreach qw( last first company address1 address2 city county state zip
1327                     country daytime night fax );
1328     }
1329   }
1330
1331   #$self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY|CASH|WEST|MCRD)$/
1332   #  or return "Illegal payby: ". $self->payby;
1333   #$self->payby($1);
1334   FS::payby->can_payby($self->table, $self->payby)
1335     or return "Illegal payby: ". $self->payby;
1336
1337   $error =    $self->ut_numbern('paystart_month')
1338            || $self->ut_numbern('paystart_year')
1339            || $self->ut_numbern('payissue')
1340            || $self->ut_textn('paytype')
1341   ;
1342   return $error if $error;
1343
1344   if ( $self->payip eq '' ) {
1345     $self->payip('');
1346   } else {
1347     $error = $self->ut_ip('payip');
1348     return $error if $error;
1349   }
1350
1351   # If it is encrypted and the private key is not availaible then we can't
1352   # check the credit card.
1353
1354   my $check_payinfo = 1;
1355
1356   if ($self->is_encrypted($self->payinfo)) {
1357     $check_payinfo = 0;
1358   }
1359
1360   if ( $check_payinfo && $self->payby =~ /^(CARD|DCRD)$/ ) {
1361
1362     my $payinfo = $self->payinfo;
1363     $payinfo =~ s/\D//g;
1364     $payinfo =~ /^(\d{13,16})$/
1365       or return gettext('invalid_card'); # . ": ". $self->payinfo;
1366     $payinfo = $1;
1367     $self->payinfo($payinfo);
1368     validate($payinfo)
1369       or return gettext('invalid_card'); # . ": ". $self->payinfo;
1370
1371     return gettext('unknown_card_type')
1372       if cardtype($self->payinfo) eq "Unknown";
1373
1374     my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1375     if ( $ban ) {
1376       return 'Banned credit card: banned on '.
1377              time2str('%a %h %o at %r', $ban->_date).
1378              ' by '. $ban->otaker.
1379              ' (ban# '. $ban->bannum. ')';
1380     }
1381
1382     if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) {
1383       if ( cardtype($self->payinfo) eq 'American Express card' ) {
1384         $self->paycvv =~ /^(\d{4})$/
1385           or return "CVV2 (CID) for American Express cards is four digits.";
1386         $self->paycvv($1);
1387       } else {
1388         $self->paycvv =~ /^(\d{3})$/
1389           or return "CVV2 (CVC2/CID) is three digits.";
1390         $self->paycvv($1);
1391       }
1392     } else {
1393       $self->paycvv('');
1394     }
1395
1396     my $cardtype = cardtype($payinfo);
1397     if ( $cardtype =~ /^(Switch|Solo)$/i ) {
1398
1399       return "Start date or issue number is required for $cardtype cards"
1400         unless $self->paystart_month && $self->paystart_year or $self->payissue;
1401
1402       return "Start month must be between 1 and 12"
1403         if $self->paystart_month
1404            and $self->paystart_month < 1 || $self->paystart_month > 12;
1405
1406       return "Start year must be 1990 or later"
1407         if $self->paystart_year
1408            and $self->paystart_year < 1990;
1409
1410       return "Issue number must be beween 1 and 99"
1411         if $self->payissue
1412           and $self->payissue < 1 || $self->payissue > 99;
1413
1414     } else {
1415       $self->paystart_month('');
1416       $self->paystart_year('');
1417       $self->payissue('');
1418     }
1419
1420   } elsif ( $check_payinfo && $self->payby =~ /^(CHEK|DCHK)$/ ) {
1421
1422     my $payinfo = $self->payinfo;
1423     $payinfo =~ s/[^\d\@]//g;
1424     if ( $conf->exists('echeck-nonus') ) {
1425       $payinfo =~ /^(\d+)\@(\d+)$/ or return 'invalid echeck account@aba';
1426     } else {
1427       $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba';
1428     }
1429     $payinfo = "$1\@$2";
1430     $self->payinfo($payinfo);
1431     $self->paycvv('');
1432
1433     my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1434     if ( $ban ) {
1435       return 'Banned ACH account: banned on '.
1436              time2str('%a %h %o at %r', $ban->_date).
1437              ' by '. $ban->otaker.
1438              ' (ban# '. $ban->bannum. ')';
1439     }
1440
1441   } elsif ( $self->payby eq 'LECB' ) {
1442
1443     my $payinfo = $self->payinfo;
1444     $payinfo =~ s/\D//g;
1445     $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number';
1446     $payinfo = $1;
1447     $self->payinfo($payinfo);
1448     $self->paycvv('');
1449
1450   } elsif ( $self->payby eq 'BILL' ) {
1451
1452     $error = $self->ut_textn('payinfo');
1453     return "Illegal P.O. number: ". $self->payinfo if $error;
1454     $self->paycvv('');
1455
1456   } elsif ( $self->payby eq 'COMP' ) {
1457
1458     my $curuser = $FS::CurrentUser::CurrentUser;
1459     if (    ! $self->custnum
1460          && ! $curuser->access_right('Complimentary customer')
1461        )
1462     {
1463       return "You are not permitted to create complimentary accounts."
1464     }
1465
1466     $error = $self->ut_textn('payinfo');
1467     return "Illegal comp account issuer: ". $self->payinfo if $error;
1468     $self->paycvv('');
1469
1470   } elsif ( $self->payby eq 'PREPAY' ) {
1471
1472     my $payinfo = $self->payinfo;
1473     $payinfo =~ s/\W//g; #anything else would just confuse things
1474     $self->payinfo($payinfo);
1475     $error = $self->ut_alpha('payinfo');
1476     return "Illegal prepayment identifier: ". $self->payinfo if $error;
1477     return "Unknown prepayment identifier"
1478       unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } );
1479     $self->paycvv('');
1480
1481   }
1482
1483   if ( $self->paydate eq '' || $self->paydate eq '-' ) {
1484     return "Expiration date required"
1485       unless $self->payby =~ /^(BILL|PREPAY|CHEK|DCHK|LECB|CASH|WEST|MCRD)$/;
1486     $self->paydate('');
1487   } else {
1488     my( $m, $y );
1489     if ( $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) {
1490       ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" );
1491     } elsif ( $self->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) {
1492       ( $m, $y ) = ( $3, "20$2" );
1493     } else {
1494       return "Illegal expiration date: ". $self->paydate;
1495     }
1496     $self->paydate("$y-$m-01");
1497     my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
1498     return gettext('expired_card')
1499       if !$import
1500       && !$ignore_expired_card
1501       && ( $y<$nowy || ( $y==$nowy && $1<$nowm ) );
1502   }
1503
1504   if ( $self->payname eq '' && $self->payby !~ /^(CHEK|DCHK)$/ &&
1505        ( ! $conf->exists('require_cardname')
1506          || $self->payby !~ /^(CARD|DCRD)$/  )
1507   ) {
1508     $self->payname( $self->first. " ". $self->getfield('last') );
1509   } else {
1510     $self->payname =~ /^([\w \,\.\-\'\&]+)$/
1511       or return gettext('illegal_name'). " payname: ". $self->payname;
1512     $self->payname($1);
1513   }
1514
1515   foreach my $flag (qw( tax spool_cdr )) {
1516     $self->$flag() =~ /^(Y?)$/ or return "Illegal $flag: ". $self->$flag();
1517     $self->$flag($1);
1518   }
1519
1520   $self->otaker(getotaker) unless $self->otaker;
1521
1522   warn "$me check AFTER: \n". $self->_dump
1523     if $DEBUG > 2;
1524
1525   $self->SUPER::check;
1526 }
1527
1528 =item all_pkgs
1529
1530 Returns all packages (see L<FS::cust_pkg>) for this customer.
1531
1532 =cut
1533
1534 sub all_pkgs {
1535   my $self = shift;
1536
1537   return $self->num_pkgs unless wantarray;
1538
1539   my @cust_pkg = ();
1540   if ( $self->{'_pkgnum'} ) {
1541     @cust_pkg = values %{ $self->{'_pkgnum'}->cache };
1542   } else {
1543     @cust_pkg = qsearch( 'cust_pkg', { 'custnum' => $self->custnum });
1544   }
1545
1546   sort sort_packages @cust_pkg;
1547 }
1548
1549 =item cust_pkg
1550
1551 Synonym for B<all_pkgs>.
1552
1553 =cut
1554
1555 sub cust_pkg {
1556   shift->all_pkgs(@_);
1557 }
1558
1559 =item ncancelled_pkgs
1560
1561 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
1562
1563 =cut
1564
1565 sub ncancelled_pkgs {
1566   my $self = shift;
1567
1568   return $self->num_ncancelled_pkgs unless wantarray;
1569
1570   my @cust_pkg = ();
1571   if ( $self->{'_pkgnum'} ) {
1572
1573     warn "$me ncancelled_pkgs: returning cached objects"
1574       if $DEBUG > 1;
1575
1576     @cust_pkg = grep { ! $_->getfield('cancel') }
1577                 values %{ $self->{'_pkgnum'}->cache };
1578
1579   } else {
1580
1581     warn "$me ncancelled_pkgs: searching for packages for custnum ".
1582          $self->custnum
1583       if $DEBUG > 1;
1584
1585     @cust_pkg =
1586       qsearch( 'cust_pkg', {
1587                              'custnum' => $self->custnum,
1588                              'cancel'  => '',
1589                            });
1590     push @cust_pkg,
1591       qsearch( 'cust_pkg', {
1592                              'custnum' => $self->custnum,
1593                              'cancel'  => 0,
1594                            });
1595   }
1596
1597   sort sort_packages @cust_pkg;
1598
1599 }
1600
1601 # This should be generalized to use config options to determine order.
1602 sub sort_packages {
1603   if ( $a->get('cancel') and $b->get('cancel') ) {
1604     $a->pkgnum <=> $b->pkgnum;
1605   } elsif ( $a->get('cancel') or $b->get('cancel') ) {
1606     return -1 if $b->get('cancel');
1607     return  1 if $a->get('cancel');
1608     return 0;
1609   } else {
1610     $a->pkgnum <=> $b->pkgnum;
1611   }
1612 }
1613
1614 =item suspended_pkgs
1615
1616 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
1617
1618 =cut
1619
1620 sub suspended_pkgs {
1621   my $self = shift;
1622   grep { $_->susp } $self->ncancelled_pkgs;
1623 }
1624
1625 =item unflagged_suspended_pkgs
1626
1627 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
1628 customer (thouse packages without the `manual_flag' set).
1629
1630 =cut
1631
1632 sub unflagged_suspended_pkgs {
1633   my $self = shift;
1634   return $self->suspended_pkgs
1635     unless dbdef->table('cust_pkg')->column('manual_flag');
1636   grep { ! $_->manual_flag } $self->suspended_pkgs;
1637 }
1638
1639 =item unsuspended_pkgs
1640
1641 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
1642 this customer.
1643
1644 =cut
1645
1646 sub unsuspended_pkgs {
1647   my $self = shift;
1648   grep { ! $_->susp } $self->ncancelled_pkgs;
1649 }
1650
1651 =item num_cancelled_pkgs
1652
1653 Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
1654 customer.
1655
1656 =cut
1657
1658 sub num_cancelled_pkgs {
1659   shift->num_pkgs("cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0");
1660 }
1661
1662 sub num_ncancelled_pkgs {
1663   shift->num_pkgs("( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )");
1664 }
1665
1666 sub num_pkgs {
1667   my( $self, $sql ) = @_;
1668   $sql = "AND $sql" if $sql && $sql !~ /^\s*$/ && $sql !~ /^\s*AND/i;
1669   my $sth = dbh->prepare(
1670     "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? $sql"
1671   ) or die dbh->errstr;
1672   $sth->execute($self->custnum) or die $sth->errstr;
1673   $sth->fetchrow_arrayref->[0];
1674 }
1675
1676 =item unsuspend
1677
1678 Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
1679 and L<FS::cust_pkg>) for this customer.  Always returns a list: an empty list
1680 on success or a list of errors.
1681
1682 =cut
1683
1684 sub unsuspend {
1685   my $self = shift;
1686   grep { $_->unsuspend } $self->suspended_pkgs;
1687 }
1688
1689 =item suspend
1690
1691 Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
1692
1693 Returns a list: an empty list on success or a list of errors.
1694
1695 =cut
1696
1697 sub suspend {
1698   my $self = shift;
1699   grep { $_->suspend(@_) } $self->unsuspended_pkgs;
1700 }
1701
1702 =item suspend_if_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
1703
1704 Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
1705 PKGPARTs (see L<FS::part_pkg>).  Preferred usage is to pass a hashref instead
1706 of a list of pkgparts; the hashref has the following keys:
1707
1708 =over 4
1709
1710 =item pkgparts - listref of pkgparts
1711
1712 =item (other options are passed to the suspend method)
1713
1714 =back
1715
1716
1717 Returns a list: an empty list on success or a list of errors.
1718
1719 =cut
1720
1721 sub suspend_if_pkgpart {
1722   my $self = shift;
1723   my (@pkgparts, %opt);
1724   if (ref($_[0]) eq 'HASH'){
1725     @pkgparts = @{$_[0]{pkgparts}};
1726     %opt      = %{$_[0]};
1727   }else{
1728     @pkgparts = @_;
1729   }
1730   grep { $_->suspend(%opt) }
1731     grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
1732       $self->unsuspended_pkgs;
1733 }
1734
1735 =item suspend_unless_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
1736
1737 Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
1738 given PKGPARTs (see L<FS::part_pkg>).  Preferred usage is to pass a hashref
1739 instead of a list of pkgparts; the hashref has the following keys:
1740
1741 =over 4
1742
1743 =item pkgparts - listref of pkgparts
1744
1745 =item (other options are passed to the suspend method)
1746
1747 =back
1748
1749 Returns a list: an empty list on success or a list of errors.
1750
1751 =cut
1752
1753 sub suspend_unless_pkgpart {
1754   my $self = shift;
1755   my (@pkgparts, %opt);
1756   if (ref($_[0]) eq 'HASH'){
1757     @pkgparts = @{$_[0]{pkgparts}};
1758     %opt      = %{$_[0]};
1759   }else{
1760     @pkgparts = @_;
1761   }
1762   grep { $_->suspend(%opt) }
1763     grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
1764       $self->unsuspended_pkgs;
1765 }
1766
1767 =item cancel [ OPTION => VALUE ... ]
1768
1769 Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
1770
1771 Available options are:
1772
1773 =over 4
1774
1775 =item quiet - can be set true to supress email cancellation notices.
1776
1777 =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.
1778
1779 =item ban - can be set true to ban this customer's credit card or ACH information, if present.
1780
1781 =back
1782
1783 Always returns a list: an empty list on success or a list of errors.
1784
1785 =cut
1786
1787 sub cancel {
1788   my( $self, %opt ) = @_;
1789
1790   warn "$me cancel called on customer ". $self->custnum. " with options ".
1791        join(', ', map { "$_: $opt{$_}" } keys %opt ). "\n"
1792     if $DEBUG;
1793
1794   return ( 'access denied' )
1795     unless $FS::CurrentUser::CurrentUser->access_right('Cancel customer');
1796
1797   if ( $opt{'ban'} && $self->payby =~ /^(CARD|DCRD|CHEK|DCHK)$/ ) {
1798
1799     #should try decryption (we might have the private key)
1800     # and if not maybe queue a job for the server that does?
1801     return ( "Can't (yet) ban encrypted credit cards" )
1802       if $self->is_encrypted($self->payinfo);
1803
1804     my $ban = new FS::banned_pay $self->_banned_pay_hashref;
1805     my $error = $ban->insert;
1806     return ( $error ) if $error;
1807
1808   }
1809
1810   my @pkgs = $self->ncancelled_pkgs;
1811
1812   warn "$me cancelling ". scalar($self->ncancelled_pkgs). "/".
1813        scalar(@pkgs). " packages for customer ". $self->custnum. "\n"
1814     if $DEBUG;
1815
1816   grep { $_ } map { $_->cancel(%opt) } $self->ncancelled_pkgs;
1817 }
1818
1819 sub _banned_pay_hashref {
1820   my $self = shift;
1821
1822   my %payby2ban = (
1823     'CARD' => 'CARD',
1824     'DCRD' => 'CARD',
1825     'CHEK' => 'CHEK',
1826     'DCHK' => 'CHEK'
1827   );
1828
1829   {
1830     'payby'   => $payby2ban{$self->payby},
1831     'payinfo' => md5_base64($self->payinfo),
1832     #don't ever *search* on reason! #'reason'  =>
1833   };
1834 }
1835
1836 =item notes
1837
1838 Returns all notes (see L<FS::cust_main_note>) for this customer.
1839
1840 =cut
1841
1842 sub notes {
1843   my $self = shift;
1844   #order by?
1845   qsearch( 'cust_main_note',
1846            { 'custnum' => $self->custnum },
1847            '',
1848            'ORDER BY _DATE DESC'
1849          );
1850 }
1851
1852 =item agent
1853
1854 Returns the agent (see L<FS::agent>) for this customer.
1855
1856 =cut
1857
1858 sub agent {
1859   my $self = shift;
1860   qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1861 }
1862
1863 =item bill_and_collect
1864
1865 Cancels and suspends any packages due, generates bills, applies payments and
1866 cred
1867
1868 Warns on errors (Does not currently: If there is an error, returns the error, otherwise returns false.)
1869
1870 Options are passed as name-value pairs.  Currently available options are:
1871
1872 =over 4
1873
1874 =item time - 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:
1875
1876  use Date::Parse;
1877  ...
1878  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
1879
1880 =item invoice_time - 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.
1881
1882 =item check_freq - "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
1883
1884 =item resetup - if set true, re-charges setup fees.
1885
1886 =back
1887
1888 =cut
1889
1890 sub bill_and_collect {
1891   my( $self, %options ) = @_;
1892
1893   ###
1894   # cancel packages
1895   ###
1896
1897   #$^T not $options{time} because freeside-daily -d is for pre-printing invoices
1898   foreach my $cust_pkg (
1899     grep { $_->expire && $_->expire <= $^T } $self->ncancelled_pkgs
1900   ) {
1901     my $error = $cust_pkg->cancel;
1902     warn "Error cancelling expired pkg ". $cust_pkg->pkgnum.
1903          " for custnum ". $self->custnum. ": $error"
1904       if $error;
1905   }
1906
1907   ###
1908   # suspend packages
1909   ###
1910
1911   #$^T not $options{time} because freeside-daily -d is for pre-printing invoices
1912   foreach my $cust_pkg (
1913     grep { (    $_->part_pkg->is_prepaid && $_->bill && $_->bill < $^T
1914              || $_->adjourn && $_->adjourn <= $^T
1915            )
1916            && ! $_->susp
1917          }
1918          $self->ncancelled_pkgs
1919   ) {
1920     my $error = $cust_pkg->suspend;
1921     warn "Error suspending package ". $cust_pkg->pkgnum.
1922          " for custnum ". $self->custnum. ": $error"
1923       if $error;
1924   }
1925
1926   ###
1927   # bill and collect
1928   ###
1929
1930   my $error = $self->bill( %options );
1931   warn "Error billing, custnum ". $self->custnum. ": $error" if $error;
1932
1933   $self->apply_payments_and_credits;
1934
1935   $error = $self->collect( %options );
1936   warn "Error collecting, custnum". $self->custnum. ": $error" if $error;
1937
1938 }
1939
1940 =item bill OPTIONS
1941
1942 Generates invoices (see L<FS::cust_bill>) for this customer.  Usually used in
1943 conjunction with the collect method by calling B<bill_and_collect>.
1944
1945 If there is an error, returns the error, otherwise returns false.
1946
1947 Options are passed as name-value pairs.  Currently available options are:
1948
1949 =over 4
1950
1951 =item resetup - if set true, re-charges setup fees.
1952
1953 =item time - 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:
1954
1955  use Date::Parse;
1956  ...
1957  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
1958
1959 =item pkg_list - An array ref of specific packages (objects) to attempt billing, instead trying all of them.
1960
1961  $cust_main->bill( pkg_list => [$pkg1, $pkg2] );
1962
1963 =item invoice_time - 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.
1964
1965 =back
1966
1967 =cut
1968
1969 sub bill {
1970   my( $self, %options ) = @_;
1971   return '' if $self->payby eq 'COMP';
1972   warn "$me bill customer ". $self->custnum. "\n"
1973     if $DEBUG;
1974
1975   my $time = $options{'time'} || time;
1976
1977   my $error;
1978
1979   #put below somehow?
1980   local $SIG{HUP} = 'IGNORE';
1981   local $SIG{INT} = 'IGNORE';
1982   local $SIG{QUIT} = 'IGNORE';
1983   local $SIG{TERM} = 'IGNORE';
1984   local $SIG{TSTP} = 'IGNORE';
1985   local $SIG{PIPE} = 'IGNORE';
1986
1987   my $oldAutoCommit = $FS::UID::AutoCommit;
1988   local $FS::UID::AutoCommit = 0;
1989   my $dbh = dbh;
1990
1991   $self->select_for_update; #mutex
1992
1993   #create a new invoice
1994   #(we'll remove it later if it doesn't actually need to be generated [contains
1995   # no line items] and we're inside a transaciton so nothing else will see it)
1996   my $cust_bill = new FS::cust_bill ( {
1997     'custnum' => $self->custnum,
1998     '_date'   => ( $options{'invoice_time'} || $time ),
1999     #'charged' => $charged,
2000     'charged' => 0,
2001   } );
2002   $error = $cust_bill->insert;
2003   if ( $error ) {
2004     $dbh->rollback if $oldAutoCommit;
2005     return "can't create invoice for customer #". $self->custnum. ": $error";
2006   }
2007   my $invnum = $cust_bill->invnum;
2008
2009   ###
2010   # find the packages which are due for billing, find out how much they are
2011   # & generate invoice database.
2012   ###
2013
2014   my( $total_setup, $total_recur ) = ( 0, 0 );
2015   my %tax;
2016   my @precommit_hooks = ();
2017
2018   foreach my $cust_pkg (
2019     qsearch('cust_pkg', { 'custnum' => $self->custnum } )
2020   ) {
2021
2022     #NO!! next if $cust_pkg->cancel;
2023     next if $cust_pkg->getfield('cancel');
2024
2025     warn "  bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG > 1;
2026
2027     #? to avoid use of uninitialized value errors... ?
2028     $cust_pkg->setfield('bill', '')
2029       unless defined($cust_pkg->bill);
2030
2031     my $part_pkg = $cust_pkg->part_pkg;
2032
2033     my %hash = $cust_pkg->hash;
2034     my $old_cust_pkg = new FS::cust_pkg \%hash;
2035
2036     my @details = ();
2037
2038     ###
2039     # bill setup
2040     ###
2041
2042     my $setup = 0;
2043     if ( ! $cust_pkg->setup &&
2044          (
2045            ( $conf->exists('disable_setup_suspended_pkgs') &&
2046             ! $cust_pkg->getfield('susp')
2047           ) || ! $conf->exists('disable_setup_suspended_pkgs')
2048          )
2049       || $options{'resetup'}
2050     ) {
2051
2052       warn "    bill setup\n" if $DEBUG > 1;
2053
2054       $setup = eval { $cust_pkg->calc_setup( $time, \@details ) };
2055       if ( $@ ) {
2056         $dbh->rollback if $oldAutoCommit;
2057         return "$@ running calc_setup for $cust_pkg\n";
2058       }
2059
2060       $cust_pkg->setfield('setup', $time) unless $cust_pkg->setup;
2061     }
2062
2063     ###
2064     # bill recurring fee
2065     ###
2066
2067     my $recur = 0;
2068     my $sdate;
2069     if ( $part_pkg->getfield('freq') ne '0' &&
2070          ! $cust_pkg->getfield('susp') &&
2071          ( $cust_pkg->getfield('bill') || 0 ) <= $time
2072     ) {
2073
2074       # XXX should this be a package event?  probably.  events are called
2075       # at collection time at the moment, though...
2076       if ( $part_pkg->can('reset_usage') ) {
2077         warn "    resetting usage counters" if $DEBUG > 1;
2078         $part_pkg->reset_usage($cust_pkg);
2079       }
2080
2081       warn "    bill recur\n" if $DEBUG > 1;
2082
2083       # XXX shared with $recur_prog
2084       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2085
2086       #over two params!  lets at least switch to a hashref for the rest...
2087       my %param = ( 'precommit_hooks' => \@precommit_hooks, );
2088
2089       $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details, \%param ) };
2090       if ( $@ ) {
2091         $dbh->rollback if $oldAutoCommit;
2092         return "$@ running calc_recur for $cust_pkg\n";
2093       }
2094
2095       #change this bit to use Date::Manip? CAREFUL with timezones (see
2096       # mailing list archive)
2097       my ($sec,$min,$hour,$mday,$mon,$year) =
2098         (localtime($sdate) )[0,1,2,3,4,5];
2099
2100       #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
2101       # only for figuring next bill date, nothing else, so, reset $sdate again
2102       # here
2103       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2104       $cust_pkg->last_bill($sdate)
2105         if $cust_pkg->dbdef_table->column('last_bill');
2106
2107       if ( $part_pkg->freq =~ /^\d+$/ ) {
2108         $mon += $part_pkg->freq;
2109         until ( $mon < 12 ) { $mon -= 12; $year++; }
2110       } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
2111         my $weeks = $1;
2112         $mday += $weeks * 7;
2113       } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
2114         my $days = $1;
2115         $mday += $days;
2116       } elsif ( $part_pkg->freq =~ /^(\d+)h$/ ) {
2117         my $hours = $1;
2118         $hour += $hours;
2119       } else {
2120         $dbh->rollback if $oldAutoCommit;
2121         return "unparsable frequency: ". $part_pkg->freq;
2122       }
2123       $cust_pkg->setfield('bill',
2124         timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
2125     }
2126
2127     warn "\$setup is undefined" unless defined($setup);
2128     warn "\$recur is undefined" unless defined($recur);
2129     warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
2130
2131     ###
2132     # If $cust_pkg has been modified, update it and create cust_bill_pkg records
2133     ###
2134
2135     if ( $cust_pkg->modified ) {  # hmmm.. and if the options are modified?
2136
2137       warn "  package ". $cust_pkg->pkgnum. " modified; updating\n"
2138         if $DEBUG >1;
2139
2140       $error=$cust_pkg->replace($old_cust_pkg,
2141                                 options => { $cust_pkg->options },
2142                                );
2143       if ( $error ) { #just in case
2144         $dbh->rollback if $oldAutoCommit;
2145         return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error";
2146       }
2147
2148       $setup = sprintf( "%.2f", $setup );
2149       $recur = sprintf( "%.2f", $recur );
2150       if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
2151         $dbh->rollback if $oldAutoCommit;
2152         return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
2153       }
2154       if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
2155         $dbh->rollback if $oldAutoCommit;
2156         return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
2157       }
2158
2159       if ( $setup != 0 || $recur != 0 ) {
2160
2161         warn "    charges (setup=$setup, recur=$recur); adding line items\n"
2162           if $DEBUG > 1;
2163         my $cust_bill_pkg = new FS::cust_bill_pkg ({
2164           'invnum'  => $invnum,
2165           'pkgnum'  => $cust_pkg->pkgnum,
2166           'setup'   => $setup,
2167           'recur'   => $recur,
2168           'sdate'   => $sdate,
2169           'edate'   => $cust_pkg->bill,
2170           'details' => \@details,
2171         });
2172         $error = $cust_bill_pkg->insert;
2173         if ( $error ) {
2174           $dbh->rollback if $oldAutoCommit;
2175           return "can't create invoice line item for invoice #$invnum: $error";
2176         }
2177         $total_setup += $setup;
2178         $total_recur += $recur;
2179
2180         ###
2181         # handle taxes
2182         ###
2183
2184         unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
2185
2186           my $prefix =
2187             ( $conf->exists('tax-ship_address') && length($self->ship_last) )
2188             ? 'ship_'
2189             : '';
2190           my %taxhash = map { $_ => $self->get("$prefix$_") }
2191                             qw( state county country );
2192
2193           $taxhash{'taxclass'} = $part_pkg->taxclass;
2194
2195           my @taxes = qsearch( 'cust_main_county', \%taxhash );
2196
2197           unless ( @taxes ) {
2198             $taxhash{'taxclass'} = '';
2199             @taxes =  qsearch( 'cust_main_county', \%taxhash );
2200           }
2201
2202           #one more try at a whole-country tax rate
2203           unless ( @taxes ) {
2204             $taxhash{$_} = '' foreach qw( state county );
2205             @taxes =  qsearch( 'cust_main_county', \%taxhash );
2206           }
2207
2208           # maybe eliminate this entirely, along with all the 0% records
2209           unless ( @taxes ) {
2210             $dbh->rollback if $oldAutoCommit;
2211             return
2212               "fatal: can't find tax rate for state/county/country/taxclass ".
2213               join('/', ( map $self->get("$prefix$_"),
2214                               qw(state county country)
2215                         ),
2216                         $part_pkg->taxclass ). "\n";
2217           }
2218
2219           foreach my $tax ( @taxes ) {
2220
2221             my $taxable_charged = 0;
2222             $taxable_charged += $setup
2223               unless $part_pkg->setuptax =~ /^Y$/i
2224                   || $tax->setuptax =~ /^Y$/i;
2225             $taxable_charged += $recur
2226               unless $part_pkg->recurtax =~ /^Y$/i
2227                   || $tax->recurtax =~ /^Y$/i;
2228             next unless $taxable_charged;
2229
2230             if ( $tax->exempt_amount && $tax->exempt_amount > 0 ) {
2231               #my ($mon,$year) = (localtime($sdate) )[4,5];
2232               my ($mon,$year) = (localtime( $sdate || $cust_bill->_date ) )[4,5];
2233               $mon++;
2234               my $freq = $part_pkg->freq || 1;
2235               if ( $freq !~ /(\d+)$/ ) {
2236                 $dbh->rollback if $oldAutoCommit;
2237                 return "daily/weekly package definitions not (yet?)".
2238                        " compatible with monthly tax exemptions";
2239               }
2240               my $taxable_per_month =
2241                 sprintf("%.2f", $taxable_charged / $freq );
2242
2243               #call the whole thing off if this customer has any old
2244               #exemption records...
2245               my @cust_tax_exempt =
2246                 qsearch( 'cust_tax_exempt' => { custnum=> $self->custnum } );
2247               if ( @cust_tax_exempt ) {
2248                 $dbh->rollback if $oldAutoCommit;
2249                 return
2250                   'this customer still has old-style tax exemption records; '.
2251                   'run bin/fs-migrate-cust_tax_exempt?';
2252               }
2253
2254               foreach my $which_month ( 1 .. $freq ) {
2255
2256                 #maintain the new exemption table now
2257                 my $sql = "
2258                   SELECT SUM(amount)
2259                     FROM cust_tax_exempt_pkg
2260                       LEFT JOIN cust_bill_pkg USING ( billpkgnum )
2261                       LEFT JOIN cust_bill     USING ( invnum     )
2262                     WHERE custnum = ?
2263                       AND taxnum  = ?
2264                       AND year    = ?
2265                       AND month   = ?
2266                 ";
2267                 my $sth = dbh->prepare($sql) or do {
2268                   $dbh->rollback if $oldAutoCommit;
2269                   return "fatal: can't lookup exising exemption: ". dbh->errstr;
2270                 };
2271                 $sth->execute(
2272                   $self->custnum,
2273                   $tax->taxnum,
2274                   1900+$year,
2275                   $mon,
2276                 ) or do {
2277                   $dbh->rollback if $oldAutoCommit;
2278                   return "fatal: can't lookup exising exemption: ". dbh->errstr;
2279                 };
2280                 my $existing_exemption = $sth->fetchrow_arrayref->[0] || 0;
2281
2282                 my $remaining_exemption =
2283                   $tax->exempt_amount - $existing_exemption;
2284                 if ( $remaining_exemption > 0 ) {
2285                   my $addl = $remaining_exemption > $taxable_per_month
2286                     ? $taxable_per_month
2287                     : $remaining_exemption;
2288                   $taxable_charged -= $addl;
2289
2290                   my $cust_tax_exempt_pkg = new FS::cust_tax_exempt_pkg ( {
2291                     'billpkgnum' => $cust_bill_pkg->billpkgnum,
2292                     'taxnum'     => $tax->taxnum,
2293                     'year'       => 1900+$year,
2294                     'month'      => $mon,
2295                     'amount'     => sprintf("%.2f", $addl ),
2296                   } );
2297                   $error = $cust_tax_exempt_pkg->insert;
2298                   if ( $error ) {
2299                     $dbh->rollback if $oldAutoCommit;
2300                     return "fatal: can't insert cust_tax_exempt_pkg: $error";
2301                   }
2302                 } # if $remaining_exemption > 0
2303
2304                 #++
2305                 $mon++;
2306                 #until ( $mon < 12 ) { $mon -= 12; $year++; }
2307                 until ( $mon < 13 ) { $mon -= 12; $year++; }
2308
2309               } #foreach $which_month
2310
2311             } #if $tax->exempt_amount
2312
2313             $taxable_charged = sprintf( "%.2f", $taxable_charged);
2314
2315             #$tax += $taxable_charged * $cust_main_county->tax / 100
2316             $tax{ $tax->taxname || 'Tax' } +=
2317               $taxable_charged * $tax->tax / 100
2318
2319           } #foreach my $tax ( @taxes )
2320
2321         } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2322
2323       } #if $setup != 0 || $recur != 0
2324
2325     } #if $cust_pkg->modified
2326
2327   } #foreach my $cust_pkg
2328
2329   unless ( $cust_bill->cust_bill_pkg ) {
2330     $cust_bill->delete; #don't create an invoice w/o line items
2331
2332    # XXX this seems to be broken
2333    #( DBD::Pg::st execute failed: ERROR:  syntax error at or near "hcb" )
2334 #   # get rid of our fake history too, waste of unecessary space
2335 #    my $h_cleanup_query = q{
2336 #      DELETE FROM h_cust_bill hcb
2337 #       WHERE hcb.invnum = ?
2338 #      AND NOT EXISTS ( SELECT 1 FROM cust_bill cb where cb.invnum = hcb.invnum )
2339 #    };
2340 #    my $h_sth = $dbh->prepare($h_cleanup_query);
2341 #    $h_sth->execute($invnum);
2342
2343     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2344     return '';
2345   }
2346
2347   my $charged = sprintf( "%.2f", $total_setup + $total_recur );
2348
2349   foreach my $taxname ( grep { $tax{$_} > 0 } keys %tax ) {
2350     my $tax = sprintf("%.2f", $tax{$taxname} );
2351     $charged = sprintf( "%.2f", $charged+$tax );
2352
2353     my $cust_bill_pkg = new FS::cust_bill_pkg ({
2354       'invnum'   => $invnum,
2355       'pkgnum'   => 0,
2356       'setup'    => $tax,
2357       'recur'    => 0,
2358       'sdate'    => '',
2359       'edate'    => '',
2360       'itemdesc' => $taxname,
2361     });
2362     $error = $cust_bill_pkg->insert;
2363     if ( $error ) {
2364       $dbh->rollback if $oldAutoCommit;
2365       return "can't create invoice line item for invoice #$invnum: $error";
2366     }
2367     $total_setup += $tax;
2368
2369   }
2370
2371   $cust_bill->charged( sprintf( "%.2f", $total_setup + $total_recur ) );
2372   $error = $cust_bill->replace;
2373   if ( $error ) {
2374     $dbh->rollback if $oldAutoCommit;
2375     return "can't update charged for invoice #$invnum: $error";
2376   }
2377
2378   foreach my $hook ( @precommit_hooks ) {
2379     eval {
2380       &{$hook}; #($self) ?
2381     };
2382     if ( $@ ) {
2383       $dbh->rollback if $oldAutoCommit;
2384       return "$@ running precommit hook $hook\n";
2385     }
2386   }
2387
2388   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2389   ''; #no error
2390 }
2391
2392 =item collect OPTIONS
2393
2394 (Attempt to) collect money for this customer's outstanding invoices (see
2395 L<FS::cust_bill>).  Usually used after the bill method.
2396
2397 Actions are now triggered by billing events; see L<FS::part_event> and the
2398 billing events web interface.  Old-style invoice events (see
2399 L<FS::part_bill_event>) have been deprecated.
2400
2401 If there is an error, returns the error, otherwise returns false.
2402
2403 Options are passed as name-value pairs.
2404
2405 Currently available options are:
2406
2407 =over 4
2408
2409 =item invoice_time - 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.
2410
2411 =item retry - Retry card/echeck/LEC transactions even when not scheduled by invoice events.
2412
2413 =item quiet - set true to surpress email card/ACH decline notices.
2414
2415 =item check_freq - "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
2416
2417 =item payby - allows for one time override of normal customer billing method
2418
2419 =cut
2420
2421 sub collect {
2422   my( $self, %options ) = @_;
2423   my $invoice_time = $options{'invoice_time'} || time;
2424
2425   #put below somehow?
2426   local $SIG{HUP} = 'IGNORE';
2427   local $SIG{INT} = 'IGNORE';
2428   local $SIG{QUIT} = 'IGNORE';
2429   local $SIG{TERM} = 'IGNORE';
2430   local $SIG{TSTP} = 'IGNORE';
2431   local $SIG{PIPE} = 'IGNORE';
2432
2433   my $oldAutoCommit = $FS::UID::AutoCommit;
2434   local $FS::UID::AutoCommit = 0;
2435   my $dbh = dbh;
2436
2437   $self->select_for_update; #mutex
2438
2439   if ( $DEBUG ) {
2440     my $balance = $self->balance;
2441     warn "$me collect customer ". $self->custnum. ": balance $balance\n"
2442   }
2443
2444   if ( exists($options{'retry_card'}) ) {
2445     carp 'retry_card option passed to collect is deprecated; use retry';
2446     $options{'retry'} ||= $options{'retry_card'};
2447   }
2448   if ( exists($options{'retry'}) && $options{'retry'} ) {
2449     my $error = $self->retry_realtime;
2450     if ( $error ) {
2451       $dbh->rollback if $oldAutoCommit;
2452       return $error;
2453     }
2454   }
2455
2456   # false laziness w/pay_batch::import_results
2457
2458   my $due_cust_event = $self->due_cust_event(
2459     'time'       => $invoice_time,
2460     'check_freq' => $options{'check_freq'},
2461   );
2462   unless( ref($due_cust_event) ) {
2463     $dbh->rollback if $oldAutoCommit;
2464     return $due_cust_event;
2465   }
2466
2467   foreach my $cust_event ( @$due_cust_event ) {
2468
2469     #XXX lock event
2470
2471     #re-eval event conditions (a previous event could have changed things)
2472     next unless $cust_event->test_conditions( 'time' => $invoice_time );
2473
2474     {
2475       local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
2476       warn "  running cust_event ". $cust_event->eventnum. "\n"
2477         if $DEBUG > 1;
2478
2479
2480       #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
2481       if ( my $error = $cust_event->do_event() ) {
2482         #XXX wtf is this?  figure out a proper dealio with return value
2483         #from do_event
2484           # gah, even with transactions.
2485           $dbh->commit if $oldAutoCommit; #well.
2486           return $error;
2487         }
2488     }
2489
2490   }
2491
2492   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2493   '';
2494
2495 }
2496
2497 =item due_cust_event [ HASHREF | OPTION => VALUE ... ]
2498
2499 Inserts database records for and returns an ordered listref of new events due
2500 for this customer, as FS::cust_event objects (see L<FS::cust_event>).  If no
2501 events are due, an empty listref is returned.  If there is an error, returns a
2502 scalar error message.
2503
2504 To actually run the events, call each event's test_condition method, and if
2505 still true, call the event's do_event method.
2506
2507 Options are passed as a hashref or as a list of name-value pairs.  Available
2508 options are:
2509
2510 =over 4
2511
2512 =item check_freq - 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.
2513
2514 =item time - "Current time" for the events.
2515
2516 =item debug - Debugging level.  Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), or 3 (more information)
2517
2518 =item eventtable - Only return events for the specified eventtable (by default, events of all eventtables are returned)
2519
2520 =item objects - Explicitly pass the objects to be tested (typically used with eventtable).
2521
2522 =back
2523
2524 =cut
2525
2526 sub due_cust_event {
2527   my $self = shift;
2528   my %opt = ref($_[0]) ? %{ $_[0] } : @_;
2529
2530   #???
2531   #my $DEBUG = $opt{'debug'}
2532   local($DEBUG) = $opt{'debug'}
2533     if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG;
2534
2535   warn "$me due_cust_event called with options ".
2536        join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
2537     if $DEBUG;
2538
2539   $opt{'time'} ||= time;
2540
2541   local $SIG{HUP} = 'IGNORE';
2542   local $SIG{INT} = 'IGNORE';
2543   local $SIG{QUIT} = 'IGNORE';
2544   local $SIG{TERM} = 'IGNORE';
2545   local $SIG{TSTP} = 'IGNORE';
2546   local $SIG{PIPE} = 'IGNORE';
2547
2548   my $oldAutoCommit = $FS::UID::AutoCommit;
2549   local $FS::UID::AutoCommit = 0;
2550   my $dbh = dbh;
2551
2552   $self->select_for_update; #mutex
2553
2554   ###
2555   # 1: find possible events (initial search)
2556   ###
2557
2558   my @cust_event = ();
2559
2560   my @eventtable = $opt{'eventtable'}
2561                      ? ( $opt{'eventtable'} )
2562                      : FS::part_event->eventtables_runorder;
2563
2564   foreach my $eventtable ( @eventtable ) {
2565
2566     my @objects;
2567     if ( $opt{'objects'} ) {
2568
2569       @objects = @{ $opt{'objects'} };
2570
2571     } else {
2572
2573       #my @objects = $self->eventtable(); # sub cust_main { @{ [ $self ] }; }
2574       @objects = ( $eventtable eq 'cust_main' )
2575                    ? ( $self )
2576                    : ( $self->$eventtable() );
2577
2578     }
2579
2580     my @e_cust_event = ();
2581
2582     my $cross = "CROSS JOIN $eventtable";
2583     $cross .= ' LEFT JOIN cust_main USING ( custnum )'
2584       unless $eventtable eq 'cust_main';
2585
2586     foreach my $object ( @objects ) {
2587
2588       #this first search uses the condition_sql magic for optimization.
2589       #the more possible events we can eliminate in this step the better
2590
2591       my $cross_where = '';
2592       my $pkey = $object->primary_key;
2593       $cross_where = "$eventtable.$pkey = ". $object->$pkey();
2594
2595       my $join = FS::part_event_condition->join_conditions_sql( $eventtable );
2596       my $extra_sql =
2597         FS::part_event_condition->where_conditions_sql( $eventtable,
2598                                                         'time'=>$opt{'time'}
2599                                                       );
2600       my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
2601
2602       $extra_sql = "AND $extra_sql" if $extra_sql;
2603
2604       #here is the agent virtualization
2605       $extra_sql .= " AND (    part_event.agentnum IS NULL
2606                             OR part_event.agentnum = ". $self->agentnum. ' )';
2607
2608       $extra_sql .= " $order";
2609
2610       my @part_event = qsearch( {
2611         'select'    => 'part_event.*',
2612         'table'     => 'part_event',
2613         'addl_from' => "$cross $join",
2614         'hashref'   => { 'check_freq' => ( $opt{'check_freq'} || '1d' ),
2615                          'eventtable' => $eventtable,
2616                          'disabled'   => '',
2617                        },
2618         'extra_sql' => "AND $cross_where $extra_sql",
2619       } );
2620
2621       if ( $DEBUG > 2 ) {
2622         my $pkey = $object->primary_key;
2623         warn "      ". scalar(@part_event).
2624              " possible events found for $eventtable ". $object->$pkey(). "\n";
2625       }
2626
2627       push @e_cust_event, map { $_->new_cust_event($object) } @part_event;
2628
2629     }
2630
2631     warn "    ". scalar(@e_cust_event).
2632          " subtotal possible cust events found for $eventtable"
2633       if $DEBUG > 1;
2634
2635     push @cust_event, @e_cust_event;
2636
2637   }
2638
2639   warn "  ". scalar(@cust_event).
2640        " total possible cust events found in initial search\n"
2641     if $DEBUG; # > 1;
2642
2643   ##
2644   # 2: test conditions
2645   ##
2646
2647   my %unsat = ();
2648
2649   @cust_event = grep $_->test_conditions( 'time'          => $opt{'time'},
2650                                           'stats_hashref' => \%unsat ),
2651                      @cust_event;
2652
2653   warn "  ". scalar(@cust_event). " cust events left satisfying conditions\n"
2654     if $DEBUG; # > 1;
2655
2656   warn "    invalid conditions not eliminated with condition_sql:\n".
2657        join('', map "      $_: ".$unsat{$_}."\n", keys %unsat );
2658
2659   ##
2660   # 3: insert
2661   ##
2662
2663   foreach my $cust_event ( @cust_event ) {
2664
2665     my $error = $cust_event->insert();
2666     if ( $error ) {
2667       $dbh->rollback if $oldAutoCommit;
2668       return $error;
2669     }
2670
2671   }
2672
2673   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2674
2675   ##
2676   # 4: return
2677   ##
2678
2679   warn "  returning events: ". Dumper(@cust_event). "\n"
2680     if $DEBUG > 2;
2681
2682   \@cust_event;
2683
2684 }
2685
2686 =item retry_realtime
2687
2688 Schedules realtime / batch  credit card / electronic check / LEC billing
2689 events for for retry.  Useful if card information has changed or manual
2690 retry is desired.  The 'collect' method must be called to actually retry
2691 the transaction.
2692
2693 Implementation details: For either this customer, or for each of this
2694 customer's open invoices, changes the status of the first "done" (with
2695 statustext error) realtime processing event to "failed".
2696
2697 =cut
2698
2699 sub retry_realtime {
2700   my $self = shift;
2701
2702   local $SIG{HUP} = 'IGNORE';
2703   local $SIG{INT} = 'IGNORE';
2704   local $SIG{QUIT} = 'IGNORE';
2705   local $SIG{TERM} = 'IGNORE';
2706   local $SIG{TSTP} = 'IGNORE';
2707   local $SIG{PIPE} = 'IGNORE';
2708
2709   my $oldAutoCommit = $FS::UID::AutoCommit;
2710   local $FS::UID::AutoCommit = 0;
2711   my $dbh = dbh;
2712
2713   #a little false laziness w/due_cust_event (not too bad, really)
2714
2715   my $join = FS::part_event_condition->join_conditions_sql;
2716   my $order = FS::part_event_condition->order_conditions_sql;
2717
2718   #here is the agent virtualization
2719   my $agent_virt = " (    part_event.agentnum IS NULL
2720                        OR part_event.agentnum = ". $self->agentnum. ' )';
2721
2722   #XXX this shouldn't be hardcoded, actions should declare it...
2723   my @realtime_events = qw(
2724     cust_bill_realtime_card
2725     cust_bill_realtime_check
2726     cust_bill_realtime_lec
2727     cust_bill_batch
2728   );
2729
2730   my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'",
2731                                                   @realtime_events
2732                                      ).
2733                           ' ) ';
2734
2735   my @cust_event = qsearchs({
2736     'table'     => 'cust_event',
2737     'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
2738     'hashref'   => { 'status' => 'done' },
2739     'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ".
2740                    " AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
2741   });
2742
2743   my %seen_invnum = ();
2744   foreach my $cust_event (@cust_event) {
2745
2746     #max one for the customer, one for each open invoice
2747     my $cust_X = $cust_event->cust_X;
2748     next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
2749                           ? $cust_X->invnum
2750                           : 0
2751                         }++
2752          or $cust_event->part_event->eventtable eq 'cust_bill'
2753             && ! $cust_X->owed;
2754
2755     my $error = $cust_event->retry;
2756     if ( $error ) {
2757       $dbh->rollback if $oldAutoCommit;
2758       return "error scheduling event for retry: $error";
2759     }
2760
2761   }
2762
2763   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2764   '';
2765
2766 }
2767
2768 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
2769
2770 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
2771 via a Business::OnlinePayment realtime gateway.  See
2772 L<http://420.am/business-onlinepayment> for supported gateways.
2773
2774 Available methods are: I<CC>, I<ECHECK> and I<LEC>
2775
2776 Available options are: I<description>, I<invnum>, I<quiet>
2777
2778 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
2779 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
2780 if set, will override the value from the customer record.
2781
2782 I<description> is a free-text field passed to the gateway.  It defaults to
2783 "Internet services".
2784
2785 If an I<invnum> is specified, this payment (if successful) is applied to the
2786 specified invoice.  If you don't specify an I<invnum> you might want to
2787 call the B<apply_payments> method.
2788
2789 I<quiet> can be set true to surpress email decline notices.
2790
2791 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
2792
2793 =cut
2794
2795 sub realtime_bop {
2796   my( $self, $method, $amount, %options ) = @_;
2797   if ( $DEBUG ) {
2798     warn "$me realtime_bop: $method $amount\n";
2799     warn "  $_ => $options{$_}\n" foreach keys %options;
2800   }
2801
2802   $options{'description'} ||= 'Internet services';
2803
2804   eval "use Business::OnlinePayment";
2805   die $@ if $@;
2806
2807   my $payinfo = exists($options{'payinfo'})
2808                   ? $options{'payinfo'}
2809                   : $self->payinfo;
2810
2811   my %method2payby = (
2812     'CC'     => 'CARD',
2813     'ECHECK' => 'CHEK',
2814     'LEC'    => 'LECB',
2815   );
2816
2817   ###
2818   # check for banned credit card/ACH
2819   ###
2820
2821   my $ban = qsearchs('banned_pay', {
2822     'payby'   => $method2payby{$method},
2823     'payinfo' => md5_base64($payinfo),
2824   } );
2825   return "Banned credit card" if $ban;
2826
2827   ###
2828   # select a gateway
2829   ###
2830
2831   my $taxclass = '';
2832   if ( $options{'invnum'} ) {
2833     my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
2834     die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
2835     my @taxclasses =
2836       map  { $_->part_pkg->taxclass }
2837       grep { $_ }
2838       map  { $_->cust_pkg }
2839       $cust_bill->cust_bill_pkg;
2840     unless ( grep { $taxclasses[0] ne $_ } @taxclasses ) { #unless there are
2841                                                            #different taxclasses
2842       $taxclass = $taxclasses[0];
2843     }
2844   }
2845
2846   #look for an agent gateway override first
2847   my $cardtype;
2848   if ( $method eq 'CC' ) {
2849     $cardtype = cardtype($payinfo);
2850   } elsif ( $method eq 'ECHECK' ) {
2851     $cardtype = 'ACH';
2852   } else {
2853     $cardtype = $method;
2854   }
2855
2856   my $override =
2857        qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2858                                            cardtype => $cardtype,
2859                                            taxclass => $taxclass,       } )
2860     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2861                                            cardtype => '',
2862                                            taxclass => $taxclass,       } )
2863     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2864                                            cardtype => $cardtype,
2865                                            taxclass => '',              } )
2866     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2867                                            cardtype => '',
2868                                            taxclass => '',              } );
2869
2870   my $payment_gateway = '';
2871   my( $processor, $login, $password, $action, @bop_options );
2872   if ( $override ) { #use a payment gateway override
2873
2874     $payment_gateway = $override->payment_gateway;
2875
2876     $processor   = $payment_gateway->gateway_module;
2877     $login       = $payment_gateway->gateway_username;
2878     $password    = $payment_gateway->gateway_password;
2879     $action      = $payment_gateway->gateway_action;
2880     @bop_options = $payment_gateway->options;
2881
2882   } else { #use the standard settings from the config
2883
2884     ( $processor, $login, $password, $action, @bop_options ) =
2885       $self->default_payment_gateway($method);
2886
2887   }
2888
2889   ###
2890   # massage data
2891   ###
2892
2893   my $address = exists($options{'address1'})
2894                     ? $options{'address1'}
2895                     : $self->address1;
2896   my $address2 = exists($options{'address2'})
2897                     ? $options{'address2'}
2898                     : $self->address2;
2899   $address .= ", ". $address2 if length($address2);
2900
2901   my $o_payname = exists($options{'payname'})
2902                     ? $options{'payname'}
2903                     : $self->payname;
2904   my($payname, $payfirst, $paylast);
2905   if ( $o_payname && $method ne 'ECHECK' ) {
2906     ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
2907       or return "Illegal payname $payname";
2908     ($payfirst, $paylast) = ($1, $2);
2909   } else {
2910     $payfirst = $self->getfield('first');
2911     $paylast = $self->getfield('last');
2912     $payname =  "$payfirst $paylast";
2913   }
2914
2915   my @invoicing_list = $self->invoicing_list_emailonly;
2916   if ( $conf->exists('emailinvoiceautoalways')
2917        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
2918        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
2919     push @invoicing_list, $self->all_emails;
2920   }
2921
2922   my $email = ($conf->exists('business-onlinepayment-email-override'))
2923               ? $conf->config('business-onlinepayment-email-override')
2924               : $invoicing_list[0];
2925
2926   my %content = ();
2927
2928   my $payip = exists($options{'payip'})
2929                 ? $options{'payip'}
2930                 : $self->payip;
2931   $content{customer_ip} = $payip
2932     if length($payip);
2933
2934   $content{invoice_number} = $options{'invnum'}
2935     if exists($options{'invnum'}) && length($options{'invnum'});
2936
2937   my $paydate = '';
2938   if ( $method eq 'CC' ) {
2939
2940     $content{card_number} = $payinfo;
2941     $paydate = exists($options{'paydate'})
2942                     ? $options{'paydate'}
2943                     : $self->paydate;
2944     $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
2945     $content{expiration} = "$2/$1";
2946
2947     my $paycvv = exists($options{'paycvv'})
2948                    ? $options{'paycvv'}
2949                    : $self->paycvv;
2950     $content{cvv2} = $self->paycvv
2951       if length($paycvv);
2952
2953     my $paystart_month = exists($options{'paystart_month'})
2954                            ? $options{'paystart_month'}
2955                            : $self->paystart_month;
2956
2957     my $paystart_year  = exists($options{'paystart_year'})
2958                            ? $options{'paystart_year'}
2959                            : $self->paystart_year;
2960
2961     $content{card_start} = "$paystart_month/$paystart_year"
2962       if $paystart_month && $paystart_year;
2963
2964     my $payissue       = exists($options{'payissue'})
2965                            ? $options{'payissue'}
2966                            : $self->payissue;
2967     $content{issue_number} = $payissue if $payissue;
2968
2969     $content{recurring_billing} = 'YES'
2970       if qsearch('cust_pay', { 'custnum' => $self->custnum,
2971                                'payby'   => 'CARD',
2972                                'payinfo' => $payinfo,
2973                              } )
2974       || qsearch('cust_pay', { 'custnum' => $self->custnum,
2975                                'payby'   => 'CARD',
2976                                'paymask' => $self->mask_payinfo('CARD', $payinfo),
2977                              } );
2978
2979
2980   } elsif ( $method eq 'ECHECK' ) {
2981     ( $content{account_number}, $content{routing_code} ) =
2982       split('@', $payinfo);
2983     $content{bank_name} = $o_payname;
2984     $content{bank_state} = exists($options{'paystate'})
2985                              ? $options{'paystate'}
2986                              : $self->getfield('paystate');
2987     $content{account_type} = exists($options{'paytype'})
2988                                ? uc($options{'paytype'}) || 'CHECKING'
2989                                : uc($self->getfield('paytype')) || 'CHECKING';
2990     $content{account_name} = $payname;
2991     $content{customer_org} = $self->company ? 'B' : 'I';
2992     $content{state_id}       = exists($options{'stateid'})
2993                                  ? $options{'stateid'}
2994                                  : $self->getfield('stateid');
2995     $content{state_id_state} = exists($options{'stateid_state'})
2996                                  ? $options{'stateid_state'}
2997                                  : $self->getfield('stateid_state');
2998     $content{customer_ssn} = exists($options{'ss'})
2999                                ? $options{'ss'}
3000                                : $self->ss;
3001   } elsif ( $method eq 'LEC' ) {
3002     $content{phone} = $payinfo;
3003   }
3004
3005   ###
3006   # run transaction(s)
3007   ###
3008
3009   my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
3010
3011   my $transaction = new Business::OnlinePayment( $processor, @bop_options );
3012   $transaction->content(
3013     'type'           => $method,
3014     'login'          => $login,
3015     'password'       => $password,
3016     'action'         => $action1,
3017     'description'    => $options{'description'},
3018     'amount'         => $amount,
3019     #'invoice_number' => $options{'invnum'},
3020     'customer_id'    => $self->custnum,
3021     'last_name'      => $paylast,
3022     'first_name'     => $payfirst,
3023     'name'           => $payname,
3024     'address'        => $address,
3025     'city'           => ( exists($options{'city'})
3026                             ? $options{'city'}
3027                             : $self->city          ),
3028     'state'          => ( exists($options{'state'})
3029                             ? $options{'state'}
3030                             : $self->state          ),
3031     'zip'            => ( exists($options{'zip'})
3032                             ? $options{'zip'}
3033                             : $self->zip          ),
3034     'country'        => ( exists($options{'country'})
3035                             ? $options{'country'}
3036                             : $self->country          ),
3037     'referer'        => 'http://cleanwhisker.420.am/',
3038     'email'          => $email,
3039     'phone'          => $self->daytime || $self->night,
3040     %content, #after
3041   );
3042   $transaction->submit();
3043
3044   if ( $transaction->is_success() && $action2 ) {
3045     my $auth = $transaction->authorization;
3046     my $ordernum = $transaction->can('order_number')
3047                    ? $transaction->order_number
3048                    : '';
3049
3050     my $capture =
3051       new Business::OnlinePayment( $processor, @bop_options );
3052
3053     my %capture = (
3054       %content,
3055       type           => $method,
3056       action         => $action2,
3057       login          => $login,
3058       password       => $password,
3059       order_number   => $ordernum,
3060       amount         => $amount,
3061       authorization  => $auth,
3062       description    => $options{'description'},
3063     );
3064
3065     foreach my $field (qw( authorization_source_code returned_ACI
3066                            transaction_identifier validation_code
3067                            transaction_sequence_num local_transaction_date
3068                            local_transaction_time AVS_result_code          )) {
3069       $capture{$field} = $transaction->$field() if $transaction->can($field);
3070     }
3071
3072     $capture->content( %capture );
3073
3074     $capture->submit();
3075
3076     unless ( $capture->is_success ) {
3077       my $e = "Authorization successful but capture failed, custnum #".
3078               $self->custnum. ': '.  $capture->result_code.
3079               ": ". $capture->error_message;
3080       warn $e;
3081       return $e;
3082     }
3083
3084   }
3085
3086   ###
3087   # remove paycvv after initial transaction
3088   ###
3089
3090   #false laziness w/misc/process/payment.cgi - check both to make sure working
3091   # correctly
3092   if ( defined $self->dbdef_table->column('paycvv')
3093        && length($self->paycvv)
3094        && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
3095   ) {
3096     my $error = $self->remove_cvv;
3097     if ( $error ) {
3098       warn "WARNING: error removing cvv: $error\n";
3099     }
3100   }
3101
3102   ###
3103   # result handling
3104   ###
3105
3106   if ( $transaction->is_success() ) {
3107
3108     my %method2payby = (
3109       'CC'     => 'CARD',
3110       'ECHECK' => 'CHEK',
3111       'LEC'    => 'LECB',
3112     );
3113
3114     my $paybatch = '';
3115     if ( $payment_gateway ) { # agent override
3116       $paybatch = $payment_gateway->gatewaynum. '-';
3117     }
3118
3119     $paybatch .= "$processor:". $transaction->authorization;
3120
3121     $paybatch .= ':'. $transaction->order_number
3122       if $transaction->can('order_number')
3123       && length($transaction->order_number);
3124
3125     my $cust_pay = new FS::cust_pay ( {
3126        'custnum'  => $self->custnum,
3127        'invnum'   => $options{'invnum'},
3128        'paid'     => $amount,
3129        '_date'     => '',
3130        'payby'    => $method2payby{$method},
3131        'payinfo'  => $payinfo,
3132        'paybatch' => $paybatch,
3133        'paydate'  => $paydate,
3134     } );
3135     $cust_pay->payunique( $options{payunique} ) if length($options{payunique});
3136
3137     my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3138
3139     if ( $error ) {
3140       $cust_pay->invnum(''); #try again with no specific invnum
3141       my $error2 = $cust_pay->insert( $options{'manual'} ?
3142                                       ( 'manual' => 1 ) : ()
3143                                     );
3144       if ( $error2 ) {
3145         # gah, even with transactions.
3146         my $e = 'WARNING: Card/ACH debited but database not updated - '.
3147                 "error inserting payment ($processor): $error2".
3148                 " (previously tried insert with invnum #$options{'invnum'}" .
3149                 ": $error )";
3150         warn $e;
3151         return $e;
3152       }
3153     }
3154     return ''; #no error
3155
3156   } else {
3157
3158     my $perror = "$processor error: ". $transaction->error_message;
3159
3160     unless ( $transaction->error_message ) {
3161
3162       my $t_response;
3163       if ( $transaction->can('response_page') ) {
3164         $t_response = {
3165                         'page'    => ( $transaction->can('response_page')
3166                                          ? $transaction->response_page
3167                                          : ''
3168                                      ),
3169                         'code'    => ( $transaction->can('response_code')
3170                                          ? $transaction->response_code
3171                                          : ''
3172                                      ),
3173                         'headers' => ( $transaction->can('response_headers')
3174                                          ? $transaction->response_headers
3175                                          : ''
3176                                      ),
3177                       };
3178       } else {
3179         $t_response .=
3180           "No additional debugging information available for $processor";
3181       }
3182
3183       $perror .= "No error_message returned from $processor -- ".
3184                  ( ref($t_response) ? Dumper($t_response) : $t_response );
3185
3186     }
3187
3188     if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
3189          && $conf->exists('emaildecline')
3190          && grep { $_ ne 'POST' } $self->invoicing_list
3191          && ! grep { $transaction->error_message =~ /$_/ }
3192                    $conf->config('emaildecline-exclude')
3193     ) {
3194       my @templ = $conf->config('declinetemplate');
3195       my $template = new Text::Template (
3196         TYPE   => 'ARRAY',
3197         SOURCE => [ map "$_\n", @templ ],
3198       ) or return "($perror) can't create template: $Text::Template::ERROR";
3199       $template->compile()
3200         or return "($perror) can't compile template: $Text::Template::ERROR";
3201
3202       my $templ_hash = { error => $transaction->error_message };
3203
3204       my $error = send_email(
3205         'from'    => $conf->config('invoice_from'),
3206         'to'      => [ grep { $_ ne 'POST' } $self->invoicing_list ],
3207         'subject' => 'Your payment could not be processed',
3208         'body'    => [ $template->fill_in(HASH => $templ_hash) ],
3209       );
3210
3211       $perror .= " (also received error sending decline notification: $error)"
3212         if $error;
3213
3214     }
3215
3216     return $perror;
3217   }
3218
3219 }
3220
3221 =item default_payment_gateway
3222
3223 =cut
3224
3225 sub default_payment_gateway {
3226   my( $self, $method ) = @_;
3227
3228   die "Real-time processing not enabled\n"
3229     unless $conf->exists('business-onlinepayment');
3230
3231   #load up config
3232   my $bop_config = 'business-onlinepayment';
3233   $bop_config .= '-ach'
3234     if $method eq 'ECHECK' && $conf->exists($bop_config. '-ach');
3235   my ( $processor, $login, $password, $action, @bop_options ) =
3236     $conf->config($bop_config);
3237   $action ||= 'normal authorization';
3238   pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
3239   die "No real-time processor is enabled - ".
3240       "did you set the business-onlinepayment configuration value?\n"
3241     unless $processor;
3242
3243   ( $processor, $login, $password, $action, @bop_options )
3244 }
3245
3246 =item remove_cvv
3247
3248 Removes the I<paycvv> field from the database directly.
3249
3250 If there is an error, returns the error, otherwise returns false.
3251
3252 =cut
3253
3254 sub remove_cvv {
3255   my $self = shift;
3256   my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
3257     or return dbh->errstr;
3258   $sth->execute($self->custnum)
3259     or return $sth->errstr;
3260   $self->paycvv('');
3261   '';
3262 }
3263
3264 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
3265
3266 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
3267 via a Business::OnlinePayment realtime gateway.  See
3268 L<http://420.am/business-onlinepayment> for supported gateways.
3269
3270 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3271
3272 Available options are: I<amount>, I<reason>, I<paynum>, I<paydate>
3273
3274 Most gateways require a reference to an original payment transaction to refund,
3275 so you probably need to specify a I<paynum>.
3276
3277 I<amount> defaults to the original amount of the payment if not specified.
3278
3279 I<reason> specifies a reason for the refund.
3280
3281 I<paydate> specifies the expiration date for a credit card overriding the
3282 value from the customer record or the payment record. Specified as yyyy-mm-dd
3283
3284 Implementation note: If I<amount> is unspecified or equal to the amount of the
3285 orignal payment, first an attempt is made to "void" the transaction via
3286 the gateway (to cancel a not-yet settled transaction) and then if that fails,
3287 the normal attempt is made to "refund" ("credit") the transaction via the
3288 gateway is attempted.
3289
3290 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3291 #I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
3292 #if set, will override the value from the customer record.
3293
3294 #If an I<invnum> is specified, this payment (if successful) is applied to the
3295 #specified invoice.  If you don't specify an I<invnum> you might want to
3296 #call the B<apply_payments> method.
3297
3298 =cut
3299
3300 #some false laziness w/realtime_bop, not enough to make it worth merging
3301 #but some useful small subs should be pulled out
3302 sub realtime_refund_bop {
3303   my( $self, $method, %options ) = @_;
3304   if ( $DEBUG ) {
3305     warn "$me realtime_refund_bop: $method refund\n";
3306     warn "  $_ => $options{$_}\n" foreach keys %options;
3307   }
3308
3309   eval "use Business::OnlinePayment";
3310   die $@ if $@;
3311
3312   ###
3313   # look up the original payment and optionally a gateway for that payment
3314   ###
3315
3316   my $cust_pay = '';
3317   my $amount = $options{'amount'};
3318
3319   my( $processor, $login, $password, @bop_options ) ;
3320   my( $auth, $order_number ) = ( '', '', '' );
3321
3322   if ( $options{'paynum'} ) {
3323
3324     warn "  paynum: $options{paynum}\n" if $DEBUG > 1;
3325     $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
3326       or return "Unknown paynum $options{'paynum'}";
3327     $amount ||= $cust_pay->paid;
3328
3329     $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-\/ ]*)(:([\w\-]+))?$/
3330       or return "Can't parse paybatch for paynum $options{'paynum'}: ".
3331                 $cust_pay->paybatch;
3332     my $gatewaynum = '';
3333     ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
3334
3335     if ( $gatewaynum ) { #gateway for the payment to be refunded
3336
3337       my $payment_gateway =
3338         qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
3339       die "payment gateway $gatewaynum not found"
3340         unless $payment_gateway;
3341
3342       $processor   = $payment_gateway->gateway_module;
3343       $login       = $payment_gateway->gateway_username;
3344       $password    = $payment_gateway->gateway_password;
3345       @bop_options = $payment_gateway->options;
3346
3347     } else { #try the default gateway
3348
3349       my( $conf_processor, $unused_action );
3350       ( $conf_processor, $login, $password, $unused_action, @bop_options ) =
3351         $self->default_payment_gateway($method);
3352
3353       return "processor of payment $options{'paynum'} $processor does not".
3354              " match default processor $conf_processor"
3355         unless $processor eq $conf_processor;
3356
3357     }
3358
3359
3360   } else { # didn't specify a paynum, so look for agent gateway overrides
3361            # like a normal transaction
3362
3363     my $cardtype;
3364     if ( $method eq 'CC' ) {
3365       $cardtype = cardtype($self->payinfo);
3366     } elsif ( $method eq 'ECHECK' ) {
3367       $cardtype = 'ACH';
3368     } else {
3369       $cardtype = $method;
3370     }
3371     my $override =
3372            qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3373                                                cardtype => $cardtype,
3374                                                taxclass => '',              } )
3375         || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3376                                                cardtype => '',
3377                                                taxclass => '',              } );
3378
3379     if ( $override ) { #use a payment gateway override
3380
3381       my $payment_gateway = $override->payment_gateway;
3382
3383       $processor   = $payment_gateway->gateway_module;
3384       $login       = $payment_gateway->gateway_username;
3385       $password    = $payment_gateway->gateway_password;
3386       #$action      = $payment_gateway->gateway_action;
3387       @bop_options = $payment_gateway->options;
3388
3389     } else { #use the standard settings from the config
3390
3391       my $unused_action;
3392       ( $processor, $login, $password, $unused_action, @bop_options ) =
3393         $self->default_payment_gateway($method);
3394
3395     }
3396
3397   }
3398   return "neither amount nor paynum specified" unless $amount;
3399
3400   my %content = (
3401     'type'           => $method,
3402     'login'          => $login,
3403     'password'       => $password,
3404     'order_number'   => $order_number,
3405     'amount'         => $amount,
3406     'referer'        => 'http://cleanwhisker.420.am/',
3407   );
3408   $content{authorization} = $auth
3409     if length($auth); #echeck/ACH transactions have an order # but no auth
3410                       #(at least with authorize.net)
3411
3412   my $disable_void_after;
3413   if ($conf->exists('disable_void_after')
3414       && $conf->config('disable_void_after') =~ /^(\d+)$/) {
3415     $disable_void_after = $1;
3416   }
3417
3418   #first try void if applicable
3419   if ( $cust_pay && $cust_pay->paid == $amount
3420     && (
3421       ( not defined($disable_void_after) )
3422       || ( time < ($cust_pay->_date + $disable_void_after ) )
3423     )
3424   ) {
3425     warn "  attempting void\n" if $DEBUG > 1;
3426     my $void = new Business::OnlinePayment( $processor, @bop_options );
3427     $void->content( 'action' => 'void', %content );
3428     $void->submit();
3429     if ( $void->is_success ) {
3430       my $error = $cust_pay->void($options{'reason'});
3431       if ( $error ) {
3432         # gah, even with transactions.
3433         my $e = 'WARNING: Card/ACH voided but database not updated - '.
3434                 "error voiding payment: $error";
3435         warn $e;
3436         return $e;
3437       }
3438       warn "  void successful\n" if $DEBUG > 1;
3439       return '';
3440     }
3441   }
3442
3443   warn "  void unsuccessful, trying refund\n"
3444     if $DEBUG > 1;
3445
3446   #massage data
3447   my $address = $self->address1;
3448   $address .= ", ". $self->address2 if $self->address2;
3449
3450   my($payname, $payfirst, $paylast);
3451   if ( $self->payname && $method ne 'ECHECK' ) {
3452     $payname = $self->payname;
3453     $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3454       or return "Illegal payname $payname";
3455     ($payfirst, $paylast) = ($1, $2);
3456   } else {
3457     $payfirst = $self->getfield('first');
3458     $paylast = $self->getfield('last');
3459     $payname =  "$payfirst $paylast";
3460   }
3461
3462   my @invoicing_list = $self->invoicing_list_emailonly;
3463   if ( $conf->exists('emailinvoiceautoalways')
3464        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3465        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3466     push @invoicing_list, $self->all_emails;
3467   }
3468
3469   my $email = ($conf->exists('business-onlinepayment-email-override'))
3470               ? $conf->config('business-onlinepayment-email-override')
3471               : $invoicing_list[0];
3472
3473   my $payip = exists($options{'payip'})
3474                 ? $options{'payip'}
3475                 : $self->payip;
3476   $content{customer_ip} = $payip
3477     if length($payip);
3478
3479   my $payinfo = '';
3480   if ( $method eq 'CC' ) {
3481
3482     if ( $cust_pay ) {
3483       $content{card_number} = $payinfo = $cust_pay->payinfo;
3484       (exists($options{'paydate'}) ? $options{'paydate'} : $cust_pay->paydate)
3485         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/ &&
3486         ($content{expiration} = "$2/$1");  # where available
3487     } else {
3488       $content{card_number} = $payinfo = $self->payinfo;
3489       (exists($options{'paydate'}) ? $options{'paydate'} : $self->paydate)
3490         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3491       $content{expiration} = "$2/$1";
3492     }
3493
3494   } elsif ( $method eq 'ECHECK' ) {
3495
3496     if ( $cust_pay ) {
3497       $payinfo = $cust_pay->payinfo;
3498     } else {
3499       $payinfo = $self->payinfo;
3500     }
3501     ( $content{account_number}, $content{routing_code} )= split('@', $payinfo );
3502     $content{bank_name} = $self->payname;
3503     $content{account_type} = 'CHECKING';
3504     $content{account_name} = $payname;
3505     $content{customer_org} = $self->company ? 'B' : 'I';
3506     $content{customer_ssn} = $self->ss;
3507   } elsif ( $method eq 'LEC' ) {
3508     $content{phone} = $payinfo = $self->payinfo;
3509   }
3510
3511   #then try refund
3512   my $refund = new Business::OnlinePayment( $processor, @bop_options );
3513   my %sub_content = $refund->content(
3514     'action'         => 'credit',
3515     'customer_id'    => $self->custnum,
3516     'last_name'      => $paylast,
3517     'first_name'     => $payfirst,
3518     'name'           => $payname,
3519     'address'        => $address,
3520     'city'           => $self->city,
3521     'state'          => $self->state,
3522     'zip'            => $self->zip,
3523     'country'        => $self->country,
3524     'email'          => $email,
3525     'phone'          => $self->daytime || $self->night,
3526     %content, #after
3527   );
3528   warn join('', map { "  $_ => $sub_content{$_}\n" } keys %sub_content )
3529     if $DEBUG > 1;
3530   $refund->submit();
3531
3532   return "$processor error: ". $refund->error_message
3533     unless $refund->is_success();
3534
3535   my %method2payby = (
3536     'CC'     => 'CARD',
3537     'ECHECK' => 'CHEK',
3538     'LEC'    => 'LECB',
3539   );
3540
3541   my $paybatch = "$processor:". $refund->authorization;
3542   $paybatch .= ':'. $refund->order_number
3543     if $refund->can('order_number') && $refund->order_number;
3544
3545   while ( $cust_pay && $cust_pay->unapplied < $amount ) {
3546     my @cust_bill_pay = $cust_pay->cust_bill_pay;
3547     last unless @cust_bill_pay;
3548     my $cust_bill_pay = pop @cust_bill_pay;
3549     my $error = $cust_bill_pay->delete;
3550     last if $error;
3551   }
3552
3553   my $cust_refund = new FS::cust_refund ( {
3554     'custnum'  => $self->custnum,
3555     'paynum'   => $options{'paynum'},
3556     'refund'   => $amount,
3557     '_date'    => '',
3558     'payby'    => $method2payby{$method},
3559     'payinfo'  => $payinfo,
3560     'paybatch' => $paybatch,
3561     'reason'   => $options{'reason'} || 'card or ACH refund',
3562   } );
3563   my $error = $cust_refund->insert;
3564   if ( $error ) {
3565     $cust_refund->paynum(''); #try again with no specific paynum
3566     my $error2 = $cust_refund->insert;
3567     if ( $error2 ) {
3568       # gah, even with transactions.
3569       my $e = 'WARNING: Card/ACH refunded but database not updated - '.
3570               "error inserting refund ($processor): $error2".
3571               " (previously tried insert with paynum #$options{'paynum'}" .
3572               ": $error )";
3573       warn $e;
3574       return $e;
3575     }
3576   }
3577
3578   ''; #no error
3579
3580 }
3581
3582 =item batch_card OPTION => VALUE...
3583
3584 Adds a payment for this invoice to the pending credit card batch (see
3585 L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value,
3586 runs the payment using a realtime gateway.
3587
3588 =cut
3589
3590 sub batch_card {
3591   my ($self, %options) = @_;
3592
3593   my $amount;
3594   if (exists($options{amount})) {
3595     $amount = $options{amount};
3596   }else{
3597     $amount = sprintf("%.2f", $self->balance - $self->in_transit_payments);
3598   }
3599   return '' unless $amount > 0;
3600
3601   my $invnum = delete $options{invnum};
3602   my $payby = $options{invnum} || $self->payby;  #dubious
3603
3604   if ($options{'realtime'}) {
3605     return $self->realtime_bop( FS::payby->payby2bop($self->payby),
3606                                 $amount,
3607                                 %options,
3608                               );
3609   }
3610
3611   my $oldAutoCommit = $FS::UID::AutoCommit;
3612   local $FS::UID::AutoCommit = 0;
3613   my $dbh = dbh;
3614
3615   $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE")
3616     or return "Cannot lock pay_batch: " . $dbh->errstr;
3617
3618   my %pay_batch = (
3619     'status' => 'O',
3620     'payby'  => FS::payby->payby2payment($payby),
3621   );
3622
3623   my $pay_batch = qsearchs( 'pay_batch', \%pay_batch );
3624
3625   unless ( $pay_batch ) {
3626     $pay_batch = new FS::pay_batch \%pay_batch;
3627     my $error = $pay_batch->insert;
3628     if ( $error ) {
3629       $dbh->rollback if $oldAutoCommit;
3630       die "error creating new batch: $error\n";
3631     }
3632   }
3633
3634   my $old_cust_pay_batch = qsearchs('cust_pay_batch', {
3635       'batchnum' => $pay_batch->batchnum,
3636       'custnum'  => $self->custnum,
3637   } );
3638
3639   foreach (qw( address1 address2 city state zip country payby payinfo paydate
3640                payname )) {
3641     $options{$_} = '' unless exists($options{$_});
3642   }
3643
3644   my $cust_pay_batch = new FS::cust_pay_batch ( {
3645     'batchnum' => $pay_batch->batchnum,
3646     'invnum'   => $invnum || 0,                    # is there a better value?
3647                                                    # this field should be
3648                                                    # removed...
3649                                                    # cust_bill_pay_batch now
3650     'custnum'  => $self->custnum,
3651     'last'     => $self->getfield('last'),
3652     'first'    => $self->getfield('first'),
3653     'address1' => $options{address1} || $self->address1,
3654     'address2' => $options{address2} || $self->address2,
3655     'city'     => $options{city}     || $self->city,
3656     'state'    => $options{state}    || $self->state,
3657     'zip'      => $options{zip}      || $self->zip,
3658     'country'  => $options{country}  || $self->country,
3659     'payby'    => $options{payby}    || $self->payby,
3660     'payinfo'  => $options{payinfo}  || $self->payinfo,
3661     'exp'      => $options{paydate}  || $self->paydate,
3662     'payname'  => $options{payname}  || $self->payname,
3663     'amount'   => $amount,                         # consolidating
3664   } );
3665
3666   $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum)
3667     if $old_cust_pay_batch;
3668
3669   my $error;
3670   if ($old_cust_pay_batch) {
3671     $error = $cust_pay_batch->replace($old_cust_pay_batch)
3672   } else {
3673     $error = $cust_pay_batch->insert;
3674   }
3675
3676   if ( $error ) {
3677     $dbh->rollback if $oldAutoCommit;
3678     die $error;
3679   }
3680
3681   my $unapplied = $self->total_credited + $self->total_unapplied_payments + $self->in_transit_payments;
3682   foreach my $cust_bill ($self->open_cust_bill) {
3683     #$dbh->commit or die $dbh->errstr if $oldAutoCommit;
3684     my $cust_bill_pay_batch = new FS::cust_bill_pay_batch {
3685       'invnum' => $cust_bill->invnum,
3686       'paybatchnum' => $cust_pay_batch->paybatchnum,
3687       'amount' => $cust_bill->owed,
3688       '_date' => time,
3689     };
3690     if ($unapplied >= $cust_bill_pay_batch->amount){
3691       $unapplied -= $cust_bill_pay_batch->amount;
3692       next;
3693     }else{
3694       $cust_bill_pay_batch->amount(sprintf ( "%.2f",
3695                                    $cust_bill_pay_batch->amount - $unapplied ));      $unapplied = 0;
3696     }
3697     $error = $cust_bill_pay_batch->insert;
3698     if ( $error ) {
3699       $dbh->rollback if $oldAutoCommit;
3700       die $error;
3701     }
3702   }
3703
3704   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3705   '';
3706 }
3707
3708 =item total_owed
3709
3710 Returns the total owed for this customer on all invoices
3711 (see L<FS::cust_bill/owed>).
3712
3713 =cut
3714
3715 sub total_owed {
3716   my $self = shift;
3717   $self->total_owed_date(2145859200); #12/31/2037
3718 }
3719
3720 =item total_owed_date TIME
3721
3722 Returns the total owed for this customer on all invoices with date earlier than
3723 TIME.  TIME is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also
3724 see L<Time::Local> and L<Date::Parse> for conversion functions.
3725
3726 =cut
3727
3728 sub total_owed_date {
3729   my $self = shift;
3730   my $time = shift;
3731   my $total_bill = 0;
3732   foreach my $cust_bill (
3733     grep { $_->_date <= $time }
3734       qsearch('cust_bill', { 'custnum' => $self->custnum, } )
3735   ) {
3736     $total_bill += $cust_bill->owed;
3737   }
3738   sprintf( "%.2f", $total_bill );
3739 }
3740
3741 =item apply_payments_and_credits
3742
3743 Applies unapplied payments and credits.
3744
3745 In most cases, this new method should be used in place of sequential
3746 apply_payments and apply_credits methods.
3747
3748 If there is an error, returns the error, otherwise returns false.
3749
3750 =cut
3751
3752 sub apply_payments_and_credits {
3753   my $self = shift;
3754
3755   local $SIG{HUP} = 'IGNORE';
3756   local $SIG{INT} = 'IGNORE';
3757   local $SIG{QUIT} = 'IGNORE';
3758   local $SIG{TERM} = 'IGNORE';
3759   local $SIG{TSTP} = 'IGNORE';
3760   local $SIG{PIPE} = 'IGNORE';
3761
3762   my $oldAutoCommit = $FS::UID::AutoCommit;
3763   local $FS::UID::AutoCommit = 0;
3764   my $dbh = dbh;
3765
3766   $self->select_for_update; #mutex
3767
3768   foreach my $cust_bill ( $self->open_cust_bill ) {
3769     my $error = $cust_bill->apply_payments_and_credits;
3770     if ( $error ) {
3771       $dbh->rollback if $oldAutoCommit;
3772       return "Error applying: $error";
3773     }
3774   }
3775
3776   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3777   ''; #no error
3778
3779 }
3780
3781 =item apply_credits OPTION => VALUE ...
3782
3783 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
3784 to outstanding invoice balances in chronological order (or reverse
3785 chronological order if the I<order> option is set to B<newest>) and returns the
3786 value of any remaining unapplied credits available for refund (see
3787 L<FS::cust_refund>).
3788
3789 Dies if there is an error.
3790
3791 =cut
3792
3793 sub apply_credits {
3794   my $self = shift;
3795   my %opt = @_;
3796
3797   local $SIG{HUP} = 'IGNORE';
3798   local $SIG{INT} = 'IGNORE';
3799   local $SIG{QUIT} = 'IGNORE';
3800   local $SIG{TERM} = 'IGNORE';
3801   local $SIG{TSTP} = 'IGNORE';
3802   local $SIG{PIPE} = 'IGNORE';
3803
3804   my $oldAutoCommit = $FS::UID::AutoCommit;
3805   local $FS::UID::AutoCommit = 0;
3806   my $dbh = dbh;
3807
3808   $self->select_for_update; #mutex
3809
3810   unless ( $self->total_credited ) {
3811     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3812     return 0;
3813   }
3814
3815   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
3816       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
3817
3818   my @invoices = $self->open_cust_bill;
3819   @invoices = sort { $b->_date <=> $a->_date } @invoices
3820     if defined($opt{'order'}) && $opt{'order'} eq 'newest';
3821
3822   my $credit;
3823   foreach my $cust_bill ( @invoices ) {
3824     my $amount;
3825
3826     if ( !defined($credit) || $credit->credited == 0) {
3827       $credit = pop @credits or last;
3828     }
3829
3830     if ($cust_bill->owed >= $credit->credited) {
3831       $amount=$credit->credited;
3832     }else{
3833       $amount=$cust_bill->owed;
3834     }
3835
3836     my $cust_credit_bill = new FS::cust_credit_bill ( {
3837       'crednum' => $credit->crednum,
3838       'invnum'  => $cust_bill->invnum,
3839       'amount'  => $amount,
3840     } );
3841     my $error = $cust_credit_bill->insert;
3842     if ( $error ) {
3843       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
3844       die $error;
3845     }
3846
3847     redo if ($cust_bill->owed > 0);
3848
3849   }
3850
3851   my $total_credited = $self->total_credited;
3852
3853   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3854
3855   return $total_credited;
3856 }
3857
3858 =item apply_payments
3859
3860 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
3861 to outstanding invoice balances in chronological order.
3862
3863  #and returns the value of any remaining unapplied payments.
3864
3865 Dies if there is an error.
3866
3867 =cut
3868
3869 sub apply_payments {
3870   my $self = shift;
3871
3872   local $SIG{HUP} = 'IGNORE';
3873   local $SIG{INT} = 'IGNORE';
3874   local $SIG{QUIT} = 'IGNORE';
3875   local $SIG{TERM} = 'IGNORE';
3876   local $SIG{TSTP} = 'IGNORE';
3877   local $SIG{PIPE} = 'IGNORE';
3878
3879   my $oldAutoCommit = $FS::UID::AutoCommit;
3880   local $FS::UID::AutoCommit = 0;
3881   my $dbh = dbh;
3882
3883   $self->select_for_update; #mutex
3884
3885   #return 0 unless
3886
3887   my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
3888       qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
3889
3890   my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
3891       qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
3892
3893   my $payment;
3894
3895   foreach my $cust_bill ( @invoices ) {
3896     my $amount;
3897
3898     if ( !defined($payment) || $payment->unapplied == 0 ) {
3899       $payment = pop @payments or last;
3900     }
3901
3902     if ( $cust_bill->owed >= $payment->unapplied ) {
3903       $amount = $payment->unapplied;
3904     } else {
3905       $amount = $cust_bill->owed;
3906     }
3907
3908     my $cust_bill_pay = new FS::cust_bill_pay ( {
3909       'paynum' => $payment->paynum,
3910       'invnum' => $cust_bill->invnum,
3911       'amount' => $amount,
3912     } );
3913     my $error = $cust_bill_pay->insert;
3914     if ( $error ) {
3915       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
3916       die $error;
3917     }
3918
3919     redo if ( $cust_bill->owed > 0);
3920
3921   }
3922
3923   my $total_unapplied_payments = $self->total_unapplied_payments;
3924
3925   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3926
3927   return $total_unapplied_payments;
3928 }
3929
3930 =item total_credited
3931
3932 Returns the total outstanding credit (see L<FS::cust_credit>) for this
3933 customer.  See L<FS::cust_credit/credited>.
3934
3935 =cut
3936
3937 sub total_credited {
3938   my $self = shift;
3939   my $total_credit = 0;
3940   foreach my $cust_credit ( qsearch('cust_credit', {
3941     'custnum' => $self->custnum,
3942   } ) ) {
3943     $total_credit += $cust_credit->credited;
3944   }
3945   sprintf( "%.2f", $total_credit );
3946 }
3947
3948 =item total_unapplied_payments
3949
3950 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
3951 See L<FS::cust_pay/unapplied>.
3952
3953 =cut
3954
3955 sub total_unapplied_payments {
3956   my $self = shift;
3957   my $total_unapplied = 0;
3958   foreach my $cust_pay ( qsearch('cust_pay', {
3959     'custnum' => $self->custnum,
3960   } ) ) {
3961     $total_unapplied += $cust_pay->unapplied;
3962   }
3963   sprintf( "%.2f", $total_unapplied );
3964 }
3965
3966 =item total_unapplied_refunds
3967
3968 Returns the total unrefunded refunds (see L<FS::cust_refund>) for this
3969 customer.  See L<FS::cust_refund/unapplied>.
3970
3971 =cut
3972
3973 sub total_unapplied_refunds {
3974   my $self = shift;
3975   my $total_unapplied = 0;
3976   foreach my $cust_refund ( qsearch('cust_refund', {
3977     'custnum' => $self->custnum,
3978   } ) ) {
3979     $total_unapplied += $cust_refund->unapplied;
3980   }
3981   sprintf( "%.2f", $total_unapplied );
3982 }
3983
3984 =item balance
3985
3986 Returns the balance for this customer (total_owed plus total_unrefunded, minus
3987 total_credited minus total_unapplied_payments).
3988
3989 =cut
3990
3991 sub balance {
3992   my $self = shift;
3993   sprintf( "%.2f",
3994       $self->total_owed
3995     + $self->total_unapplied_refunds
3996     - $self->total_credited
3997     - $self->total_unapplied_payments
3998   );
3999 }
4000
4001 =item balance_date TIME
4002
4003 Returns the balance for this customer, only considering invoices with date
4004 earlier than TIME (total_owed_date minus total_credited minus
4005 total_unapplied_payments).  TIME is specified as a UNIX timestamp; see
4006 L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion
4007 functions.
4008
4009 =cut
4010
4011 sub balance_date {
4012   my $self = shift;
4013   my $time = shift;
4014   sprintf( "%.2f",
4015         $self->total_owed_date($time)
4016       + $self->total_unapplied_refunds
4017       - $self->total_credited
4018       - $self->total_unapplied_payments
4019   );
4020 }
4021
4022 =item in_transit_payments
4023
4024 Returns the total of requests for payments for this customer pending in
4025 batches in transit to the bank.  See L<FS::pay_batch> and L<FS::cust_pay_batch>
4026
4027 =cut
4028
4029 sub in_transit_payments {
4030   my $self = shift;
4031   my $in_transit_payments = 0;
4032   foreach my $pay_batch ( qsearch('pay_batch', {
4033     'status' => 'I',
4034   } ) ) {
4035     foreach my $cust_pay_batch ( qsearch('cust_pay_batch', {
4036       'batchnum' => $pay_batch->batchnum,
4037       'custnum' => $self->custnum,
4038     } ) ) {
4039       $in_transit_payments += $cust_pay_batch->amount;
4040     }
4041   }
4042   sprintf( "%.2f", $in_transit_payments );
4043 }
4044
4045 =item paydate_monthyear
4046
4047 Returns a two-element list consisting of the month and year of this customer's
4048 paydate (credit card expiration date for CARD customers)
4049
4050 =cut
4051
4052 sub paydate_monthyear {
4053   my $self = shift;
4054   if ( $self->paydate  =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
4055     ( $2, $1 );
4056   } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
4057     ( $1, $3 );
4058   } else {
4059     ('', '');
4060   }
4061 }
4062
4063 =item invoicing_list [ ARRAYREF ]
4064
4065 If an arguement is given, sets these email addresses as invoice recipients
4066 (see L<FS::cust_main_invoice>).  Errors are not fatal and are not reported
4067 (except as warnings), so use check_invoicing_list first.
4068
4069 Returns a list of email addresses (with svcnum entries expanded).
4070
4071 Note: You can clear the invoicing list by passing an empty ARRAYREF.  You can
4072 check it without disturbing anything by passing nothing.
4073
4074 This interface may change in the future.
4075
4076 =cut
4077
4078 sub invoicing_list {
4079   my( $self, $arrayref ) = @_;
4080
4081   if ( $arrayref ) {
4082     my @cust_main_invoice;
4083     if ( $self->custnum ) {
4084       @cust_main_invoice =
4085         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4086     } else {
4087       @cust_main_invoice = ();
4088     }
4089     foreach my $cust_main_invoice ( @cust_main_invoice ) {
4090       #warn $cust_main_invoice->destnum;
4091       unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
4092         #warn $cust_main_invoice->destnum;
4093         my $error = $cust_main_invoice->delete;
4094         warn $error if $error;
4095       }
4096     }
4097     if ( $self->custnum ) {
4098       @cust_main_invoice =
4099         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4100     } else {
4101       @cust_main_invoice = ();
4102     }
4103     my %seen = map { $_->address => 1 } @cust_main_invoice;
4104     foreach my $address ( @{$arrayref} ) {
4105       next if exists $seen{$address} && $seen{$address};
4106       $seen{$address} = 1;
4107       my $cust_main_invoice = new FS::cust_main_invoice ( {
4108         'custnum' => $self->custnum,
4109         'dest'    => $address,
4110       } );
4111       my $error = $cust_main_invoice->insert;
4112       warn $error if $error;
4113     }
4114   }
4115
4116   if ( $self->custnum ) {
4117     map { $_->address }
4118       qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4119   } else {
4120     ();
4121   }
4122
4123 }
4124
4125 =item check_invoicing_list ARRAYREF
4126
4127 Checks these arguements as valid input for the invoicing_list method.  If there
4128 is an error, returns the error, otherwise returns false.
4129
4130 =cut
4131
4132 sub check_invoicing_list {
4133   my( $self, $arrayref ) = @_;
4134   foreach my $address ( @{$arrayref} ) {
4135
4136     if ($address eq 'FAX' and $self->getfield('fax') eq '') {
4137       return 'Can\'t add FAX invoice destination with a blank FAX number.';
4138     }
4139
4140     my $cust_main_invoice = new FS::cust_main_invoice ( {
4141       'custnum' => $self->custnum,
4142       'dest'    => $address,
4143     } );
4144     my $error = $self->custnum
4145                 ? $cust_main_invoice->check
4146                 : $cust_main_invoice->checkdest
4147     ;
4148     return $error if $error;
4149   }
4150   '';
4151 }
4152
4153 =item set_default_invoicing_list
4154
4155 Sets the invoicing list to all accounts associated with this customer,
4156 overwriting any previous invoicing list.
4157
4158 =cut
4159
4160 sub set_default_invoicing_list {
4161   my $self = shift;
4162   $self->invoicing_list($self->all_emails);
4163 }
4164
4165 =item all_emails
4166
4167 Returns the email addresses of all accounts provisioned for this customer.
4168
4169 =cut
4170
4171 sub all_emails {
4172   my $self = shift;
4173   my %list;
4174   foreach my $cust_pkg ( $self->all_pkgs ) {
4175     my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
4176     my @svc_acct =
4177       map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4178         grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4179           @cust_svc;
4180     $list{$_}=1 foreach map { $_->email } @svc_acct;
4181   }
4182   keys %list;
4183 }
4184
4185 =item invoicing_list_addpost
4186
4187 Adds postal invoicing to this customer.  If this customer is already configured
4188 to receive postal invoices, does nothing.
4189
4190 =cut
4191
4192 sub invoicing_list_addpost {
4193   my $self = shift;
4194   return if grep { $_ eq 'POST' } $self->invoicing_list;
4195   my @invoicing_list = $self->invoicing_list;
4196   push @invoicing_list, 'POST';
4197   $self->invoicing_list(\@invoicing_list);
4198 }
4199
4200 =item invoicing_list_emailonly
4201
4202 Returns the list of email invoice recipients (invoicing_list without non-email
4203 destinations such as POST and FAX).
4204
4205 =cut
4206
4207 sub invoicing_list_emailonly {
4208   my $self = shift;
4209   warn "$me invoicing_list_emailonly called"
4210     if $DEBUG;
4211   grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list;
4212 }
4213
4214 =item invoicing_list_emailonly_scalar
4215
4216 Returns the list of email invoice recipients (invoicing_list without non-email
4217 destinations such as POST and FAX) as a comma-separated scalar.
4218
4219 =cut
4220
4221 sub invoicing_list_emailonly_scalar {
4222   my $self = shift;
4223   warn "$me invoicing_list_emailonly_scalar called"
4224     if $DEBUG;
4225   join(', ', $self->invoicing_list_emailonly);
4226 }
4227
4228 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
4229
4230 Returns an array of customers referred by this customer (referral_custnum set
4231 to this custnum).  If DEPTH is given, recurses up to the given depth, returning
4232 customers referred by customers referred by this customer and so on, inclusive.
4233 The default behavior is DEPTH 1 (no recursion).
4234
4235 =cut
4236
4237 sub referral_cust_main {
4238   my $self = shift;
4239   my $depth = @_ ? shift : 1;
4240   my $exclude = @_ ? shift : {};
4241
4242   my @cust_main =
4243     map { $exclude->{$_->custnum}++; $_; }
4244       grep { ! $exclude->{ $_->custnum } }
4245         qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
4246
4247   if ( $depth > 1 ) {
4248     push @cust_main,
4249       map { $_->referral_cust_main($depth-1, $exclude) }
4250         @cust_main;
4251   }
4252
4253   @cust_main;
4254 }
4255
4256 =item referral_cust_main_ncancelled
4257
4258 Same as referral_cust_main, except only returns customers with uncancelled
4259 packages.
4260
4261 =cut
4262
4263 sub referral_cust_main_ncancelled {
4264   my $self = shift;
4265   grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
4266 }
4267
4268 =item referral_cust_pkg [ DEPTH ]
4269
4270 Like referral_cust_main, except returns a flat list of all unsuspended (and
4271 uncancelled) packages for each customer.  The number of items in this list may
4272 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
4273
4274 =cut
4275
4276 sub referral_cust_pkg {
4277   my $self = shift;
4278   my $depth = @_ ? shift : 1;
4279
4280   map { $_->unsuspended_pkgs }
4281     grep { $_->unsuspended_pkgs }
4282       $self->referral_cust_main($depth);
4283 }
4284
4285 =item referring_cust_main
4286
4287 Returns the single cust_main record for the customer who referred this customer
4288 (referral_custnum), or false.
4289
4290 =cut
4291
4292 sub referring_cust_main {
4293   my $self = shift;
4294   return '' unless $self->referral_custnum;
4295   qsearchs('cust_main', { 'custnum' => $self->referral_custnum } );
4296 }
4297
4298 =item credit AMOUNT, REASON
4299
4300 Applies a credit to this customer.  If there is an error, returns the error,
4301 otherwise returns false.
4302
4303 =cut
4304
4305 sub credit {
4306   my( $self, $amount, $reason ) = @_;
4307   my $cust_credit = new FS::cust_credit {
4308     'custnum' => $self->custnum,
4309     'amount'  => $amount,
4310     'reason'  => $reason,
4311   };
4312   $cust_credit->insert;
4313 }
4314
4315 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
4316
4317 Creates a one-time charge for this customer.  If there is an error, returns
4318 the error, otherwise returns false.
4319
4320 =cut
4321
4322 sub charge {
4323   my $self = shift;
4324   my ( $amount, $pkg, $comment, $taxclass, $additional );
4325   if ( ref( $_[0] ) ) {
4326     $amount     = $_[0]->{amount};
4327     $pkg        = exists($_[0]->{pkg}) ? $_[0]->{pkg} : 'One-time charge';
4328     $comment    = exists($_[0]->{comment}) ? $_[0]->{comment}
4329                                            : '$'. sprintf("%.2f",$amount);
4330     $taxclass   = exists($_[0]->{taxclass}) ? $_[0]->{taxclass} : '';
4331     $additional = $_[0]->{additional};
4332   }else{
4333     $amount     = shift;
4334     $pkg        = @_ ? shift : 'One-time charge';
4335     $comment    = @_ ? shift : '$'. sprintf("%.2f",$amount);
4336     $taxclass   = @_ ? shift : '';
4337     $additional = [];
4338   }
4339
4340   local $SIG{HUP} = 'IGNORE';
4341   local $SIG{INT} = 'IGNORE';
4342   local $SIG{QUIT} = 'IGNORE';
4343   local $SIG{TERM} = 'IGNORE';
4344   local $SIG{TSTP} = 'IGNORE';
4345   local $SIG{PIPE} = 'IGNORE';
4346
4347   my $oldAutoCommit = $FS::UID::AutoCommit;
4348   local $FS::UID::AutoCommit = 0;
4349   my $dbh = dbh;
4350
4351   my $part_pkg = new FS::part_pkg ( {
4352     'pkg'      => $pkg,
4353     'comment'  => $comment,
4354     'plan'     => 'flat',
4355     'freq'     => 0,
4356     'disabled' => 'Y',
4357     'taxclass' => $taxclass,
4358   } );
4359
4360   my %options = ( ( map { ("additional_info$_" => $additional->[$_] ) }
4361                         ( 0 .. @$additional - 1 )
4362                   ),
4363                   'additional_count' => scalar(@$additional),
4364                   'setup_fee' => $amount,
4365                 );
4366
4367   my $error = $part_pkg->insert( options => \%options );
4368   if ( $error ) {
4369     $dbh->rollback if $oldAutoCommit;
4370     return $error;
4371   }
4372
4373   my $pkgpart = $part_pkg->pkgpart;
4374   my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
4375   unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
4376     my $type_pkgs = new FS::type_pkgs \%type_pkgs;
4377     $error = $type_pkgs->insert;
4378     if ( $error ) {
4379       $dbh->rollback if $oldAutoCommit;
4380       return $error;
4381     }
4382   }
4383
4384   my $cust_pkg = new FS::cust_pkg ( {
4385     'custnum' => $self->custnum,
4386     'pkgpart' => $pkgpart,
4387   } );
4388
4389   $error = $cust_pkg->insert;
4390   if ( $error ) {
4391     $dbh->rollback if $oldAutoCommit;
4392     return $error;
4393   }
4394
4395   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4396   '';
4397
4398 }
4399
4400 =item cust_bill
4401
4402 Returns all the invoices (see L<FS::cust_bill>) for this customer.
4403
4404 =cut
4405
4406 sub cust_bill {
4407   my $self = shift;
4408   sort { $a->_date <=> $b->_date }
4409     qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4410 }
4411
4412 =item open_cust_bill
4413
4414 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
4415 customer.
4416
4417 =cut
4418
4419 sub open_cust_bill {
4420   my $self = shift;
4421   grep { $_->owed > 0 } $self->cust_bill;
4422 }
4423
4424 =item cust_credit
4425
4426 Returns all the credits (see L<FS::cust_credit>) for this customer.
4427
4428 =cut
4429
4430 sub cust_credit {
4431   my $self = shift;
4432   sort { $a->_date <=> $b->_date }
4433     qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
4434 }
4435
4436 =item cust_pay
4437
4438 Returns all the payments (see L<FS::cust_pay>) for this customer.
4439
4440 =cut
4441
4442 sub cust_pay {
4443   my $self = shift;
4444   sort { $a->_date <=> $b->_date }
4445     qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
4446 }
4447
4448 =item cust_pay_void
4449
4450 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
4451
4452 =cut
4453
4454 sub cust_pay_void {
4455   my $self = shift;
4456   sort { $a->_date <=> $b->_date }
4457     qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
4458 }
4459
4460 =item cust_pay_batch
4461
4462 Returns all batched payments (see L<FS::cust_pay_void>) for this customer.
4463
4464 =cut
4465
4466 sub cust_pay_batch {
4467   my $self = shift;
4468   sort { $a->_date <=> $b->_date }
4469     qsearch( 'cust_pay_batch', { 'custnum' => $self->custnum } )
4470 }
4471
4472 =item cust_refund
4473
4474 Returns all the refunds (see L<FS::cust_refund>) for this customer.
4475
4476 =cut
4477
4478 sub cust_refund {
4479   my $self = shift;
4480   sort { $a->_date <=> $b->_date }
4481     qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
4482 }
4483
4484 =item name
4485
4486 Returns a name string for this customer, either "Company (Last, First)" or
4487 "Last, First".
4488
4489 =cut
4490
4491 sub name {
4492   my $self = shift;
4493   my $name = $self->contact;
4494   $name = $self->company. " ($name)" if $self->company;
4495   $name;
4496 }
4497
4498 =item ship_name
4499
4500 Returns a name string for this (service/shipping) contact, either
4501 "Company (Last, First)" or "Last, First".
4502
4503 =cut
4504
4505 sub ship_name {
4506   my $self = shift;
4507   if ( $self->get('ship_last') ) {
4508     my $name = $self->ship_contact;
4509     $name = $self->ship_company. " ($name)" if $self->ship_company;
4510     $name;
4511   } else {
4512     $self->name;
4513   }
4514 }
4515
4516 =item contact
4517
4518 Returns this customer's full (billing) contact name only, "Last, First"
4519
4520 =cut
4521
4522 sub contact {
4523   my $self = shift;
4524   $self->get('last'). ', '. $self->first;
4525 }
4526
4527 =item ship_contact
4528
4529 Returns this customer's full (shipping) contact name only, "Last, First"
4530
4531 =cut
4532
4533 sub ship_contact {
4534   my $self = shift;
4535   $self->get('ship_last')
4536     ? $self->get('ship_last'). ', '. $self->ship_first
4537     : $self->contact;
4538 }
4539
4540 =item country_full
4541
4542 Returns this customer's full country name
4543
4544 =cut
4545
4546 sub country_full {
4547   my $self = shift;
4548   code2country($self->country);
4549 }
4550
4551 =item cust_status
4552
4553 =item status
4554
4555 Returns a status string for this customer, currently:
4556
4557 =over 4
4558
4559 =item prospect - No packages have ever been ordered
4560
4561 =item active - One or more recurring packages is active
4562
4563 =item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled)
4564
4565 =item suspended - All non-cancelled recurring packages are suspended
4566
4567 =item cancelled - All recurring packages are cancelled
4568
4569 =back
4570
4571 =cut
4572
4573 sub status { shift->cust_status(@_); }
4574
4575 sub cust_status {
4576   my $self = shift;
4577   for my $status (qw( prospect active inactive suspended cancelled )) {
4578     my $method = $status.'_sql';
4579     my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
4580     my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
4581     $sth->execute( ($self->custnum) x $numnum )
4582       or die "Error executing 'SELECT $sql': ". $sth->errstr;
4583     return $status if $sth->fetchrow_arrayref->[0];
4584   }
4585 }
4586
4587 =item ucfirst_cust_status
4588
4589 =item ucfirst_status
4590
4591 Returns the status with the first character capitalized.
4592
4593 =cut
4594
4595 sub ucfirst_status { shift->ucfirst_cust_status(@_); }
4596
4597 sub ucfirst_cust_status {
4598   my $self = shift;
4599   ucfirst($self->cust_status);
4600 }
4601
4602 =item statuscolor
4603
4604 Returns a hex triplet color string for this customer's status.
4605
4606 =cut
4607
4608 use vars qw(%statuscolor);
4609 tie my %statuscolor, 'Tie::IxHash',
4610   'prospect'  => '7e0079', #'000000', #black?  naw, purple
4611   'active'    => '00CC00', #green
4612   'inactive'  => '0000CC', #blue
4613   'suspended' => 'FF9900', #yellow
4614   'cancelled' => 'FF0000', #red
4615 ;
4616
4617 sub statuscolor { shift->cust_statuscolor(@_); }
4618
4619 sub cust_statuscolor {
4620   my $self = shift;
4621   $statuscolor{$self->cust_status};
4622 }
4623
4624 =item tickets
4625
4626 Returns an array of hashes representing the customer's RT tickets.
4627
4628 =cut
4629
4630 sub tickets {
4631   my $self = shift;
4632
4633   my $num = $conf->config('cust_main-max_tickets') || 10;
4634   my @tickets = ();
4635
4636   unless ( $conf->config('ticket_system-custom_priority_field') ) {
4637
4638     @tickets = @{ FS::TicketSystem->customer_tickets($self->custnum, $num) };
4639
4640   } else {
4641
4642     foreach my $priority (
4643       $conf->config('ticket_system-custom_priority_field-values'), ''
4644     ) {
4645       last if scalar(@tickets) >= $num;
4646       push @tickets,
4647         @{ FS::TicketSystem->customer_tickets( $self->custnum,
4648                                                $num - scalar(@tickets),
4649                                                $priority,
4650                                              )
4651          };
4652     }
4653   }
4654   (@tickets);
4655 }
4656
4657 # Return services representing svc_accts in customer support packages
4658 sub support_services {
4659   my $self = shift;
4660   my %packages = map { $_ => 1 } $conf->config('support_packages');
4661
4662   grep { $_->pkg_svc && $_->pkg_svc->primary_svc eq 'Y' }
4663     grep { $_->part_svc->svcdb eq 'svc_acct' }
4664     map { $_->cust_svc }
4665     grep { exists $packages{ $_->pkgpart } }
4666     $self->ncancelled_pkgs;
4667
4668 }
4669
4670 =back
4671
4672 =head1 CLASS METHODS
4673
4674 =over 4
4675
4676 =item statuses
4677
4678 Class method that returns the list of possible status strings for customers
4679 (see L<the status method|/status>).  For example:
4680
4681   @statuses = FS::cust_main->statuses();
4682
4683 =cut
4684
4685 sub statuses {
4686   #my $self = shift; #could be class...
4687   keys %statuscolor;
4688 }
4689
4690 =item prospect_sql
4691
4692 Returns an SQL expression identifying prospective cust_main records (customers
4693 with no packages ever ordered)
4694
4695 =cut
4696
4697 use vars qw($select_count_pkgs);
4698 $select_count_pkgs =
4699   "SELECT COUNT(*) FROM cust_pkg
4700     WHERE cust_pkg.custnum = cust_main.custnum";
4701
4702 sub select_count_pkgs_sql {
4703   $select_count_pkgs;
4704 }
4705
4706 sub prospect_sql { "
4707   0 = ( $select_count_pkgs )
4708 "; }
4709
4710 =item active_sql
4711
4712 Returns an SQL expression identifying active cust_main records (customers with
4713 no active recurring packages, but otherwise unsuspended/uncancelled).
4714
4715 =cut
4716
4717 sub active_sql { "
4718   0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. "
4719       )
4720 "; }
4721
4722 =item inactive_sql
4723
4724 Returns an SQL expression identifying inactive cust_main records (customers with
4725 active recurring packages).
4726
4727 =cut
4728
4729 sub inactive_sql { "
4730   0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
4731   AND
4732   0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
4733 "; }
4734
4735 =item susp_sql
4736 =item suspended_sql
4737
4738 Returns an SQL expression identifying suspended cust_main records.
4739
4740 =cut
4741
4742
4743 sub suspended_sql { susp_sql(@_); }
4744 sub susp_sql { "
4745     0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " )
4746     AND
4747     0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
4748 "; }
4749
4750 =item cancel_sql
4751 =item cancelled_sql
4752
4753 Returns an SQL expression identifying cancelled cust_main records.
4754
4755 =cut
4756
4757 sub cancelled_sql { cancel_sql(@_); }
4758 sub cancel_sql {
4759
4760   my $recurring_sql = FS::cust_pkg->recurring_sql;
4761   #my $recurring_sql = "
4762   #  '0' != ( select freq from part_pkg
4763   #             where cust_pkg.pkgpart = part_pkg.pkgpart )
4764   #";
4765
4766   "
4767     0 < ( $select_count_pkgs )
4768     AND 0 = ( $select_count_pkgs AND $recurring_sql
4769                   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4770             )
4771   ";
4772 }
4773
4774 =item uncancel_sql
4775 =item uncancelled_sql
4776
4777 Returns an SQL expression identifying un-cancelled cust_main records.
4778
4779 =cut
4780
4781 sub uncancelled_sql { uncancel_sql(@_); }
4782 sub uncancel_sql { "
4783   ( 0 < ( $select_count_pkgs
4784                    AND ( cust_pkg.cancel IS NULL
4785                          OR cust_pkg.cancel = 0
4786                        )
4787         )
4788     OR 0 = ( $select_count_pkgs )
4789   )
4790 "; }
4791
4792 =item balance_sql
4793
4794 Returns an SQL fragment to retreive the balance.
4795
4796 =cut
4797
4798 sub balance_sql { "
4799     COALESCE( ( SELECT SUM(charged) FROM cust_bill
4800                   WHERE cust_bill.custnum   = cust_main.custnum ), 0)
4801   - COALESCE( ( SELECT SUM(paid)    FROM cust_pay
4802                   WHERE cust_pay.custnum    = cust_main.custnum ), 0)
4803   - COALESCE( ( SELECT SUM(amount)  FROM cust_credit
4804                   WHERE cust_credit.custnum = cust_main.custnum ), 0)
4805   + COALESCE( ( SELECT SUM(refund)  FROM cust_refund
4806                    WHERE cust_refund.custnum = cust_main.custnum ), 0)
4807 "; }
4808
4809 =item balance_date_sql TIME
4810
4811 Returns an SQL fragment to retreive the balance for this customer, only
4812 considering invoices with date earlier than TIME. (total_owed_date minus total_credited minus
4813 total_unapplied_payments).  TIME is specified as an SQL fragment or a numeric
4814 UNIX timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and
4815 L<Date::Parse> for conversion functions.
4816
4817 =cut
4818
4819 sub balance_date_sql {
4820   my( $class, $time ) = @_;
4821
4822   my $owed_sql         = FS::cust_bill->owed_sql;
4823   my $unapp_refund_sql = FS::cust_refund->unapplied_sql;
4824   #my $unapp_credit_sql = FS::cust_credit->unapplied_sql;
4825   my $unapp_credit_sql = FS::cust_credit->credited_sql;
4826   my $unapp_pay_sql    = FS::cust_pay->unapplied_sql;
4827
4828   "
4829       COALESCE( ( SELECT SUM($owed_sql) FROM cust_bill
4830                     WHERE cust_bill.custnum   = cust_main.custnum
4831                       AND cust_bill._date    <= $time             )
4832                 ,0
4833               )
4834     + COALESCE( ( SELECT SUM($unapp_refund_sql) FROM cust_refund
4835                     WHERE cust_refund.custnum = cust_main.custnum )
4836                 ,0
4837               )
4838     - COALESCE( ( SELECT SUM($unapp_credit_sql) FROM cust_credit
4839                     WHERE cust_credit.custnum = cust_main.custnum )
4840                 ,0
4841               )
4842     - COALESCE( ( SELECT SUM($unapp_pay_sql) FROM cust_pay
4843                     WHERE cust_pay.custnum = cust_main.custnum )
4844                 ,0
4845               )
4846
4847   ";
4848
4849 }
4850
4851 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
4852
4853 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
4854 records.  Currently, I<first>, I<last> and/or I<company> may be specified (the
4855 appropriate ship_ field is also searched).
4856
4857 Additional options are the same as FS::Record::qsearch
4858
4859 =cut
4860
4861 sub fuzzy_search {
4862   my( $self, $fuzzy, $hash, @opt) = @_;
4863   #$self
4864   $hash ||= {};
4865   my @cust_main = ();
4866
4867   check_and_rebuild_fuzzyfiles();
4868   foreach my $field ( keys %$fuzzy ) {
4869
4870     my $all = $self->all_X($field);
4871     next unless scalar(@$all);
4872
4873     my %match = ();
4874     $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) );
4875
4876     my @fcust = ();
4877     foreach ( keys %match ) {
4878       push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
4879       push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
4880     }
4881     my %fsaw = ();
4882     push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
4883   }
4884
4885   # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
4886   my %saw = ();
4887   @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
4888
4889   @cust_main;
4890
4891 }
4892
4893 =item masked FIELD
4894
4895 Returns a masked version of the named field
4896
4897 =cut
4898
4899 sub masked {
4900 my ($self,$field) = @_;
4901
4902 # Show last four
4903
4904 'x'x(length($self->getfield($field))-4).
4905   substr($self->getfield($field), (length($self->getfield($field))-4));
4906
4907 }
4908
4909 =back
4910
4911 =head1 SUBROUTINES
4912
4913 =over 4
4914
4915 =item smart_search OPTION => VALUE ...
4916
4917 Accepts the following options: I<search>, the string to search for.  The string
4918 will be searched for as a customer number, phone number, name or company name,
4919 as an exact, or, in some cases, a substring or fuzzy match (see the source code
4920 for the exact heuristics used); I<no_fuzzy_on_exact>, causes smart_search to
4921 skip fuzzy matching when an exact match is found.
4922
4923 Any additional options are treated as an additional qualifier on the search
4924 (i.e. I<agentnum>).
4925
4926 Returns a (possibly empty) array of FS::cust_main objects.
4927
4928 =cut
4929
4930 sub smart_search {
4931   my %options = @_;
4932
4933   #here is the agent virtualization
4934   my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
4935
4936   my @cust_main = ();
4937
4938   my $skip_fuzzy = delete $options{'no_fuzzy_on_exact'};
4939   my $search = delete $options{'search'};
4940   ( my $alphanum_search = $search ) =~ s/\W//g;
4941
4942   if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
4943
4944     #false laziness w/Record::ut_phone
4945     my $phonen = "$1-$2-$3";
4946     $phonen .= " x$4" if $4;
4947
4948     push @cust_main, qsearch( {
4949       'table'   => 'cust_main',
4950       'hashref' => { %options },
4951       'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
4952                      ' ( '.
4953                          join(' OR ', map "$_ = '$phonen'",
4954                                           qw( daytime night fax
4955                                               ship_daytime ship_night ship_fax )
4956                              ).
4957                      ' ) '.
4958                      " AND $agentnums_sql", #agent virtualization
4959     } );
4960
4961     unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
4962       #try looking for matches with extensions unless one was specified
4963
4964       push @cust_main, qsearch( {
4965         'table'   => 'cust_main',
4966         'hashref' => { %options },
4967         'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
4968                        ' ( '.
4969                            join(' OR ', map "$_ LIKE '$phonen\%'",
4970                                             qw( daytime night
4971                                                 ship_daytime ship_night )
4972                                ).
4973                        ' ) '.
4974                        " AND $agentnums_sql", #agent virtualization
4975       } );
4976
4977     }
4978
4979   } elsif ( $search =~ /^\s*(\d+)\s*$/ ) { # customer # search
4980
4981     push @cust_main, qsearch( {
4982       'table'     => 'cust_main',
4983       'hashref'   => { 'custnum' => $1, %options },
4984       'extra_sql' => " AND $agentnums_sql", #agent virtualization
4985     } );
4986
4987   } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
4988
4989     my($company, $last, $first) = ( $1, $2, $3 );
4990
4991     # "Company (Last, First)"
4992     #this is probably something a browser remembered,
4993     #so just do an exact search
4994
4995     foreach my $prefix ( '', 'ship_' ) {
4996       push @cust_main, qsearch( {
4997         'table'     => 'cust_main',
4998         'hashref'   => { $prefix.'first'   => $first,
4999                          $prefix.'last'    => $last,
5000                          $prefix.'company' => $company,
5001                          %options,
5002                        },
5003         'extra_sql' => " AND $agentnums_sql",
5004       } );
5005     }
5006
5007   } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
5008                                               # try (ship_){last,company}
5009
5010     my $value = lc($1);
5011
5012     # # remove "(Last, First)" in "Company (Last, First)", otherwise the
5013     # # full strings the browser remembers won't work
5014     # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
5015
5016     use Lingua::EN::NameParse;
5017     my $NameParse = new Lingua::EN::NameParse(
5018              auto_clean     => 1,
5019              allow_reversed => 1,
5020     );
5021
5022     my($last, $first) = ( '', '' );
5023     #maybe disable this too and just rely on NameParse?
5024     if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
5025
5026       ($last, $first) = ( $1, $2 );
5027
5028     #} elsif  ( $value =~ /^(.+)\s+(.+)$/ ) {
5029     } elsif ( ! $NameParse->parse($value) ) {
5030
5031       my %name = $NameParse->components;
5032       $first = $name{'given_name_1'};
5033       $last  = $name{'surname_1'};
5034
5035     }
5036
5037     if ( $first && $last ) {
5038
5039       my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
5040
5041       #exact
5042       my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5043       $sql .= "
5044         (     ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
5045            OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
5046         )";
5047
5048       push @cust_main, qsearch( {
5049         'table'     => 'cust_main',
5050         'hashref'   => \%options,
5051         'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5052       } );
5053
5054       # or it just be something that was typed in... (try that in a sec)
5055
5056     }
5057
5058     my $q_value = dbh->quote($value);
5059
5060     #exact
5061     my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5062     $sql .= " (    LOWER(last)         = $q_value
5063                 OR LOWER(company)      = $q_value
5064                 OR LOWER(ship_last)    = $q_value
5065                 OR LOWER(ship_company) = $q_value
5066               )";
5067
5068     push @cust_main, qsearch( {
5069       'table'     => 'cust_main',
5070       'hashref'   => \%options,
5071       'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5072     } );
5073
5074     #no exact match, trying substring/fuzzy
5075     #always do substring & fuzzy (unless they're explicity config'ed off)
5076     #getting complaints searches are not returning enough
5077     unless ( @cust_main  && $skip_fuzzy || $conf->exists('disable-fuzzy') ) {
5078
5079       #still some false laziness w/ search/cust_main.cgi
5080
5081       #substring
5082
5083       my @hashrefs = (
5084         { 'company'      => { op=>'ILIKE', value=>"%$value%" }, },
5085         { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
5086       );
5087
5088       if ( $first && $last ) {
5089
5090         push @hashrefs,
5091           { 'first'        => { op=>'ILIKE', value=>"%$first%" },
5092             'last'         => { op=>'ILIKE', value=>"%$last%" },
5093           },
5094           { 'ship_first'   => { op=>'ILIKE', value=>"%$first%" },
5095             'ship_last'    => { op=>'ILIKE', value=>"%$last%" },
5096           },
5097         ;
5098
5099       } else {
5100
5101         push @hashrefs,
5102           { 'last'         => { op=>'ILIKE', value=>"%$value%" }, },
5103           { 'ship_last'    => { op=>'ILIKE', value=>"%$value%" }, },
5104         ;
5105       }
5106
5107       foreach my $hashref ( @hashrefs ) {
5108
5109         push @cust_main, qsearch( {
5110           'table'     => 'cust_main',
5111           'hashref'   => { %$hashref,
5112                            %options,
5113                          },
5114           'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
5115         } );
5116
5117       }
5118
5119       #fuzzy
5120       my @fuzopts = (
5121         \%options,                #hashref
5122         '',                       #select
5123         " AND $agentnums_sql",    #extra_sql  #agent virtualization
5124       );
5125
5126       if ( $first && $last ) {
5127         push @cust_main, FS::cust_main->fuzzy_search(
5128           { 'last'   => $last,    #fuzzy hashref
5129             'first'  => $first }, #
5130           @fuzopts
5131         );
5132       }
5133       foreach my $field ( 'last', 'company' ) {
5134         push @cust_main,
5135           FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
5136       }
5137
5138     }
5139
5140     #eliminate duplicates
5141     my %saw = ();
5142     @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
5143
5144   }
5145
5146   @cust_main;
5147
5148 }
5149
5150 =item check_and_rebuild_fuzzyfiles
5151
5152 =cut
5153
5154 use vars qw(@fuzzyfields);
5155 @fuzzyfields = ( 'last', 'first', 'company' );
5156
5157 sub check_and_rebuild_fuzzyfiles {
5158   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
5159   rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
5160 }
5161
5162 =item rebuild_fuzzyfiles
5163
5164 =cut
5165
5166 sub rebuild_fuzzyfiles {
5167
5168   use Fcntl qw(:flock);
5169
5170   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
5171   mkdir $dir, 0700 unless -d $dir;
5172
5173   foreach my $fuzzy ( @fuzzyfields ) {
5174
5175     open(LOCK,">>$dir/cust_main.$fuzzy")
5176       or die "can't open $dir/cust_main.$fuzzy: $!";
5177     flock(LOCK,LOCK_EX)
5178       or die "can't lock $dir/cust_main.$fuzzy: $!";
5179
5180     open (CACHE,">$dir/cust_main.$fuzzy.tmp")
5181       or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
5182
5183     foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
5184       my $sth = dbh->prepare("SELECT $field FROM cust_main".
5185                              " WHERE $field != '' AND $field IS NOT NULL");
5186       $sth->execute or die $sth->errstr;
5187
5188       while ( my $row = $sth->fetchrow_arrayref ) {
5189         print CACHE $row->[0]. "\n";
5190       }
5191
5192     }
5193
5194     close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
5195
5196     rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
5197     close LOCK;
5198   }
5199
5200 }
5201
5202 =item all_X
5203
5204 =cut
5205
5206 sub all_X {
5207   my( $self, $field ) = @_;
5208   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
5209   open(CACHE,"<$dir/cust_main.$field")
5210     or die "can't open $dir/cust_main.$field: $!";
5211   my @array = map { chomp; $_; } <CACHE>;
5212   close CACHE;
5213   \@array;
5214 }
5215
5216 =item append_fuzzyfiles LASTNAME COMPANY
5217
5218 =cut
5219
5220 sub append_fuzzyfiles {
5221   #my( $first, $last, $company ) = @_;
5222
5223   &check_and_rebuild_fuzzyfiles;
5224
5225   use Fcntl qw(:flock);
5226
5227   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
5228
5229   foreach my $field (qw( first last company )) {
5230     my $value = shift;
5231
5232     if ( $value ) {
5233
5234       open(CACHE,">>$dir/cust_main.$field")
5235         or die "can't open $dir/cust_main.$field: $!";
5236       flock(CACHE,LOCK_EX)
5237         or die "can't lock $dir/cust_main.$field: $!";
5238
5239       print CACHE "$value\n";
5240
5241       flock(CACHE,LOCK_UN)
5242         or die "can't unlock $dir/cust_main.$field: $!";
5243       close CACHE;
5244     }
5245
5246   }
5247
5248   1;
5249 }
5250
5251 =item batch_import
5252
5253 =cut
5254
5255 sub batch_import {
5256   my $param = shift;
5257   #warn join('-',keys %$param);
5258   my $fh = $param->{filehandle};
5259   my $agentnum = $param->{agentnum};
5260
5261   my $refnum = $param->{refnum};
5262   my $pkgpart = $param->{pkgpart};
5263
5264   #my @fields = @{$param->{fields}};
5265   my $format = $param->{'format'};
5266   my @fields;
5267   my $payby;
5268   if ( $format eq 'simple' ) {
5269     @fields = qw( cust_pkg.setup dayphone first last
5270                   address1 address2 city state zip comments );
5271     $payby = 'BILL';
5272   } elsif ( $format eq 'extended' ) {
5273     @fields = qw( agent_custid refnum
5274                   last first address1 address2 city state zip country
5275                   daytime night
5276                   ship_last ship_first ship_address1 ship_address2
5277                   ship_city ship_state ship_zip ship_country
5278                   payinfo paycvv paydate
5279                   invoicing_list
5280                   cust_pkg.pkgpart
5281                   svc_acct.username svc_acct._password
5282                 );
5283     $payby = 'BILL';
5284   } else {
5285     die "unknown format $format";
5286   }
5287
5288   eval "use Text::CSV_XS;";
5289   die $@ if $@;
5290
5291   my $csv = new Text::CSV_XS;
5292   #warn $csv;
5293   #warn $fh;
5294
5295   my $imported = 0;
5296   #my $columns;
5297
5298   local $SIG{HUP} = 'IGNORE';
5299   local $SIG{INT} = 'IGNORE';
5300   local $SIG{QUIT} = 'IGNORE';
5301   local $SIG{TERM} = 'IGNORE';
5302   local $SIG{TSTP} = 'IGNORE';
5303   local $SIG{PIPE} = 'IGNORE';
5304
5305   my $oldAutoCommit = $FS::UID::AutoCommit;
5306   local $FS::UID::AutoCommit = 0;
5307   my $dbh = dbh;
5308
5309   #while ( $columns = $csv->getline($fh) ) {
5310   my $line;
5311   while ( defined($line=<$fh>) ) {
5312
5313     $csv->parse($line) or do {
5314       $dbh->rollback if $oldAutoCommit;
5315       return "can't parse: ". $csv->error_input();
5316     };
5317
5318     my @columns = $csv->fields();
5319     #warn join('-',@columns);
5320
5321     my %cust_main = (
5322       agentnum => $agentnum,
5323       refnum   => $refnum,
5324       country  => $conf->config('countrydefault') || 'US',
5325       payby    => $payby, #default
5326       paydate  => '12/2037', #default
5327     );
5328     my $billtime = time;
5329     my %cust_pkg = ( pkgpart => $pkgpart );
5330     my %svc_acct = ();
5331     foreach my $field ( @fields ) {
5332
5333       if ( $field =~ /^cust_pkg\.(pkgpart|setup|bill|susp|adjourn|expire|cancel)$/ ) {
5334
5335         #$cust_pkg{$1} = str2time( shift @$columns );
5336         if ( $1 eq 'pkgpart' ) {
5337           $cust_pkg{$1} = shift @columns;
5338         } elsif ( $1 eq 'setup' ) {
5339           $billtime = str2time(shift @columns);
5340         } else {
5341           $cust_pkg{$1} = str2time( shift @columns );
5342         }
5343
5344       } elsif ( $field =~ /^svc_acct\.(username|_password)$/ ) {
5345
5346         $svc_acct{$1} = shift @columns;
5347
5348       } else {
5349
5350         #refnum interception
5351         if ( $field eq 'refnum' && $columns[0] !~ /^\s*(\d+)\s*$/ ) {
5352
5353           my $referral = $columns[0];
5354           my %hash = ( 'referral' => $referral,
5355                        'agentnum' => $agentnum,
5356                        'disabled' => '',
5357                      );
5358
5359           my $part_referral = qsearchs('part_referral', \%hash )
5360                               || new FS::part_referral \%hash;
5361
5362           unless ( $part_referral->refnum ) {
5363             my $error = $part_referral->insert;
5364             if ( $error ) {
5365               $dbh->rollback if $oldAutoCommit;
5366               return "can't auto-insert advertising source: $referral: $error";
5367             }
5368           }
5369
5370           $columns[0] = $part_referral->refnum;
5371         }
5372
5373         #$cust_main{$field} = shift @$columns;
5374         $cust_main{$field} = shift @columns;
5375       }
5376     }
5377
5378     $cust_main{'payby'} = 'CARD' if length($cust_main{'payinfo'});
5379
5380     my $invoicing_list = $cust_main{'invoicing_list'}
5381                            ? [ delete $cust_main{'invoicing_list'} ]
5382                            : [];
5383
5384     my $cust_main = new FS::cust_main ( \%cust_main );
5385
5386     use Tie::RefHash;
5387     tie my %hash, 'Tie::RefHash'; #this part is important
5388
5389     if ( $cust_pkg{'pkgpart'} ) {
5390       my $cust_pkg = new FS::cust_pkg ( \%cust_pkg );
5391
5392       my @svc_acct = ();
5393       if ( $svc_acct{'username'} ) {
5394         my $part_pkg = $cust_pkg->part_pkg;
5395         unless ( $part_pkg ) {
5396           $dbh->rollback if $oldAutoCommit;
5397           return "unknown pkgpart: ". $cust_pkg{'pkgpart'};
5398         }
5399         $svc_acct{svcpart} = $part_pkg->svcpart( 'svc_acct' );
5400         push @svc_acct, new FS::svc_acct ( \%svc_acct )
5401       }
5402
5403       $hash{$cust_pkg} = \@svc_acct;
5404     }
5405
5406     my $error = $cust_main->insert( \%hash, $invoicing_list );
5407
5408     if ( $error ) {
5409       $dbh->rollback if $oldAutoCommit;
5410       return "can't insert customer for $line: $error";
5411     }
5412
5413     if ( $format eq 'simple' ) {
5414
5415       #false laziness w/bill.cgi
5416       $error = $cust_main->bill( 'time' => $billtime );
5417       if ( $error ) {
5418         $dbh->rollback if $oldAutoCommit;
5419         return "can't bill customer for $line: $error";
5420       }
5421
5422       $error = $cust_main->apply_payments_and_credits;
5423       if ( $error ) {
5424         $dbh->rollback if $oldAutoCommit;
5425         return "can't bill customer for $line: $error";
5426       }
5427
5428       $error = $cust_main->collect();
5429       if ( $error ) {
5430         $dbh->rollback if $oldAutoCommit;
5431         return "can't collect customer for $line: $error";
5432       }
5433
5434     }
5435
5436     $imported++;
5437   }
5438
5439   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5440
5441   return "Empty file!" unless $imported;
5442
5443   ''; #no error
5444
5445 }
5446
5447 =item batch_charge
5448
5449 =cut
5450
5451 sub batch_charge {
5452   my $param = shift;
5453   #warn join('-',keys %$param);
5454   my $fh = $param->{filehandle};
5455   my @fields = @{$param->{fields}};
5456
5457   eval "use Text::CSV_XS;";
5458   die $@ if $@;
5459
5460   my $csv = new Text::CSV_XS;
5461   #warn $csv;
5462   #warn $fh;
5463
5464   my $imported = 0;
5465   #my $columns;
5466
5467   local $SIG{HUP} = 'IGNORE';
5468   local $SIG{INT} = 'IGNORE';
5469   local $SIG{QUIT} = 'IGNORE';
5470   local $SIG{TERM} = 'IGNORE';
5471   local $SIG{TSTP} = 'IGNORE';
5472   local $SIG{PIPE} = 'IGNORE';
5473
5474   my $oldAutoCommit = $FS::UID::AutoCommit;
5475   local $FS::UID::AutoCommit = 0;
5476   my $dbh = dbh;
5477
5478   #while ( $columns = $csv->getline($fh) ) {
5479   my $line;
5480   while ( defined($line=<$fh>) ) {
5481
5482     $csv->parse($line) or do {
5483       $dbh->rollback if $oldAutoCommit;
5484       return "can't parse: ". $csv->error_input();
5485     };
5486
5487     my @columns = $csv->fields();
5488     #warn join('-',@columns);
5489
5490     my %row = ();
5491     foreach my $field ( @fields ) {
5492       $row{$field} = shift @columns;
5493     }
5494
5495     my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
5496     unless ( $cust_main ) {
5497       $dbh->rollback if $oldAutoCommit;
5498       return "unknown custnum $row{'custnum'}";
5499     }
5500
5501     if ( $row{'amount'} > 0 ) {
5502       my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
5503       if ( $error ) {
5504         $dbh->rollback if $oldAutoCommit;
5505         return $error;
5506       }
5507       $imported++;
5508     } elsif ( $row{'amount'} < 0 ) {
5509       my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
5510                                       $row{'pkg'}                         );
5511       if ( $error ) {
5512         $dbh->rollback if $oldAutoCommit;
5513         return $error;
5514       }
5515       $imported++;
5516     } else {
5517       #hmm?
5518     }
5519
5520   }
5521
5522   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5523
5524   return "Empty file!" unless $imported;
5525
5526   ''; #no error
5527
5528 }
5529
5530 =item notify CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
5531
5532 Sends a templated email notification to the customer (see L<Text::Template>).
5533
5534 OPTIONS is a hash and may include
5535
5536 I<from> - the email sender (default is invoice_from)
5537
5538 I<to> - comma-separated scalar or arrayref of recipients
5539    (default is invoicing_list)
5540
5541 I<subject> - The subject line of the sent email notification
5542    (default is "Notice from company_name")
5543
5544 I<extra_fields> - a hashref of name/value pairs which will be substituted
5545    into the template
5546
5547 The following variables are vavailable in the template.
5548
5549 I<$first> - the customer first name
5550 I<$last> - the customer last name
5551 I<$company> - the customer company
5552 I<$payby> - a description of the method of payment for the customer
5553             # would be nice to use FS::payby::shortname
5554 I<$payinfo> - the account information used to collect for this customer
5555 I<$expdate> - the expiration of the customer payment in seconds from epoch
5556
5557 =cut
5558
5559 sub notify {
5560   my ($customer, $template, %options) = @_;
5561
5562   return unless $conf->exists($template);
5563
5564   my $from = $conf->config('invoice_from') if $conf->exists('invoice_from');
5565   $from = $options{from} if exists($options{from});
5566
5567   my $to = join(',', $customer->invoicing_list_emailonly);
5568   $to = $options{to} if exists($options{to});
5569
5570   my $subject = "Notice from " . $conf->config('company_name')
5571     if $conf->exists('company_name');
5572   $subject = $options{subject} if exists($options{subject});
5573
5574   my $notify_template = new Text::Template (TYPE => 'ARRAY',
5575                                             SOURCE => [ map "$_\n",
5576                                               $conf->config($template)]
5577                                            )
5578     or die "can't create new Text::Template object: Text::Template::ERROR";
5579   $notify_template->compile()
5580     or die "can't compile template: Text::Template::ERROR";
5581
5582   my $paydate = $customer->paydate;
5583   $FS::notify_template::_template::first = $customer->first;
5584   $FS::notify_template::_template::last = $customer->last;
5585   $FS::notify_template::_template::company = $customer->company;
5586   $FS::notify_template::_template::payinfo = $customer->mask_payinfo;
5587   my $payby = $customer->payby;
5588   my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
5589   my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
5590
5591   #credit cards expire at the end of the month/year of their exp date
5592   if ($payby eq 'CARD' || $payby eq 'DCRD') {
5593     $FS::notify_template::_template::payby = 'credit card';
5594     ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
5595     $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
5596     $expire_time--;
5597   }elsif ($payby eq 'COMP') {
5598     $FS::notify_template::_template::payby = 'complimentary account';
5599   }else{
5600     $FS::notify_template::_template::payby = 'current method';
5601   }
5602   $FS::notify_template::_template::expdate = $expire_time;
5603
5604   for (keys %{$options{extra_fields}}){
5605     no strict "refs";
5606     ${"FS::notify_template::_template::$_"} = $options{extra_fields}->{$_};
5607   }
5608
5609   send_email(from => $from,
5610              to => $to,
5611              subject => $subject,
5612              body => $notify_template->fill_in( PACKAGE =>
5613                                                 'FS::notify_template::_template'                                              ),
5614             );
5615
5616 }
5617
5618 =item generate_letter CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
5619
5620 Generates a templated notification to the customer (see L<Text::Template>).
5621
5622 OPTIONS is a hash and may include
5623
5624 I<extra_fields> - a hashref of name/value pairs which will be substituted
5625    into the template.  These values may override values mentioned below
5626    and those from the customer record.
5627
5628 The following variables are available in the template instead of or in addition
5629 to the fields of the customer record.
5630
5631 I<$payby> - a description of the method of payment for the customer
5632             # would be nice to use FS::payby::shortname
5633 I<$payinfo> - the masked account information used to collect for this customer
5634 I<$expdate> - the expiration of the customer payment method in seconds from epoch
5635 I<$returnaddress> - the return address defaults to invoice_latexreturnaddress
5636
5637 =cut
5638
5639 sub generate_letter {
5640   my ($self, $template, %options) = @_;
5641
5642   return unless $conf->exists($template);
5643
5644   my $letter_template = new Text::Template
5645                         ( TYPE       => 'ARRAY',
5646                           SOURCE     => [ map "$_\n", $conf->config($template)],
5647                           DELIMITERS => [ '[@--', '--@]' ],
5648                         )
5649     or die "can't create new Text::Template object: Text::Template::ERROR";
5650
5651   $letter_template->compile()
5652     or die "can't compile template: Text::Template::ERROR";
5653
5654   my %letter_data = map { $_ => $self->$_ } $self->fields;
5655   $letter_data{payinfo} = $self->mask_payinfo;
5656
5657   my $paydate = $self->paydate || '2037-12';
5658   my $payby = $self->payby;
5659   my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
5660   my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
5661
5662   #credit cards expire at the end of the month/year of their exp date
5663   if ($payby eq 'CARD' || $payby eq 'DCRD') {
5664     $letter_data{payby} = 'credit card';
5665     ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
5666     $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
5667     $expire_time--;
5668   }elsif ($payby eq 'COMP') {
5669     $letter_data{payby} = 'complimentary account';
5670   }else{
5671     $letter_data{payby} = 'current method';
5672   }
5673   $letter_data{expdate} = $expire_time;
5674
5675   for (keys %{$options{extra_fields}}){
5676     $letter_data{$_} = $options{extra_fields}->{$_};
5677   }
5678
5679   unless(exists($letter_data{returnaddress})){
5680     my $retadd = join("\n", $conf->config_orbase( 'invoice_latexreturnaddress',
5681                                                   $self->agent_template)
5682                      );
5683
5684     $letter_data{returnaddress} = length($retadd) ? $retadd : '~';
5685   }
5686
5687   $letter_data{conf_dir} = "$FS::UID::conf_dir/conf.$FS::UID::datasrc";
5688
5689   my $dir = $FS::UID::conf_dir."cache.". $FS::UID::datasrc;
5690   my $fh = new File::Temp( TEMPLATE => 'letter.'. $self->custnum. '.XXXXXXXX',
5691                            DIR      => $dir,
5692                            SUFFIX   => '.tex',
5693                            UNLINK   => 0,
5694                          ) or die "can't open temp file: $!\n";
5695
5696   $letter_template->fill_in( OUTPUT => $fh, HASH => \%letter_data );
5697   close $fh;
5698   $fh->filename =~ /^(.*).tex$/ or die "unparsable filename: ". $fh->filename;
5699   return $1;
5700 }
5701
5702 =item print_ps TEMPLATE
5703
5704 Returns an postscript letter filled in from TEMPLATE, as a scalar.
5705
5706 =cut
5707
5708 sub print_ps {
5709   my $self = shift;
5710   my $file = $self->generate_letter(@_);
5711   FS::Misc::generate_ps($file);
5712 }
5713
5714 =item print TEMPLATE
5715
5716 Prints the filled in template.
5717
5718 TEMPLATE is the name of a L<Text::Template> to fill in and print.
5719
5720 =cut
5721
5722 sub queueable_print {
5723   my %opt = @_;
5724
5725   my $self = qsearchs('cust_main', { 'custnum' => $opt{custnum} } )
5726     or die "invalid customer number: " . $opt{custvnum};
5727
5728   my $error = $self->print( $opt{template} );
5729   die $error if $error;
5730 }
5731
5732 sub print {
5733   my ($self, $template) = (shift, shift);
5734   do_print [ $self->print_ps($template) ];
5735 }
5736
5737 sub agent_template {
5738   my $self = shift;
5739   $self->_agent_plandata('agent_templatename');
5740 }
5741
5742 sub agent_invoice_from {
5743   my $self = shift;
5744   $self->_agent_plandata('agent_invoice_from');
5745 }
5746
5747 sub _agent_plandata {
5748   my( $self, $option ) = @_;
5749
5750   #yuck.  this whole thing needs to be reconciled better with 1.9's idea of
5751   #agent-specific Conf
5752
5753   my $agentnum = $self->agentnum;
5754
5755   my $part_event_option =
5756     qsearchs({
5757       'table'     => 'part_event_option',
5758       'addl_from' => q{
5759         LEFT JOIN part_event USING ( eventpart )
5760         LEFT JOIN part_event_option AS peo_agentnum
5761           ON ( part_event.eventpart = peo_agentnum.eventpart
5762                AND peo_agentnum.optionname = 'agentnum'
5763                AND peo_agentnum.optionvalue ~ '(^|,)agentnum(,|$)'
5764              )
5765         LEFT JOIN part_event_option AS peo_cust_bill_age
5766           ON ( part_event.eventpart = peo_cust_bill_age.eventpart
5767                AND peo_cust_bill_age.optionname = 'cust_bill_age'
5768              )
5769       },
5770       #'hashref'   => { 'optionname' => $option },
5771       'hashref'   => { 'part_event_option.optionname' => $option },
5772       'extra_sql' => " AND event = 'cust_bill_send_agent' ".
5773                      " AND peo_agentnum.optionname = 'agentnum' ".
5774                      " AND agentnum IS NULL OR agentnum = $agentnum ".
5775                      " ORDER BY
5776                         CASE WHEN peo_cust_bill_age.optionname != 'cust_bill_age'
5777                         THEN -1
5778                         ELSE EXTRACT( EPOCH FROM
5779                                         REPLACE( peo_cust_bill_age.optionvalue,
5780                                                  'm',
5781                                                  'mon'
5782                                                )::interval
5783                                     )
5784                        END
5785                        , part_event.weight".
5786                      " LIMIT 1"
5787     });
5788
5789   unless ( $part_event_option ) {
5790     return $self->agent->invoice_template || ''
5791       if $option eq '$agent_templatename';
5792     return '';
5793   }
5794
5795   $part_event_option->optionvalue;
5796
5797 }
5798
5799 =back
5800
5801 =head1 BUGS
5802
5803 The delete method.
5804
5805 The delete method should possibly take an FS::cust_main object reference
5806 instead of a scalar customer number.
5807
5808 Bill and collect options should probably be passed as references instead of a
5809 list.
5810
5811 There should probably be a configuration file with a list of allowed credit
5812 card types.
5813
5814 No multiple currency support (probably a larger project than just this module).
5815
5816 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
5817
5818 Birthdates rely on negative epoch values.
5819
5820 The payby for card/check batches is broken.  With mixed batching, bad
5821 things will happen.
5822
5823 B<collect> I<invoice_time> should be renamed I<time>, like B<bill>.
5824
5825 =head1 SEE ALSO
5826
5827 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
5828 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
5829 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.
5830
5831 =cut
5832
5833 1;
5834