FS/FS/cust_main.pm

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