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 ) = ( 0, 0 );
2072   my %tax;
2073   my %taxlisthash;
2074   my %taxname;
2075   my @precommit_hooks = ();
2076
2077   foreach my $cust_pkg (
2078     qsearch('cust_pkg', { 'custnum' => $self->custnum } )
2079   ) {
2080
2081     #NO!! next if $cust_pkg->cancel;
2082     next if $cust_pkg->getfield('cancel');
2083
2084     warn "  bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG > 1;
2085
2086     #? to avoid use of uninitialized value errors... ?
2087     $cust_pkg->setfield('bill', '')
2088       unless defined($cust_pkg->bill);
2089
2090     #my $part_pkg = $cust_pkg->part_pkg;
2091
2092     my $real_pkgpart = $cust_pkg->pkgpart;
2093     my %hash = $cust_pkg->hash;
2094     my $old_cust_pkg = new FS::cust_pkg \%hash;
2095
2096     foreach my $part_pkg ( $cust_pkg->part_pkg->self_and_bill_linked ) {
2097
2098       $cust_pkg->pkgpart($part_pkg->pkgpart);
2099       $cust_pkg->set($_, $hash{$_}) foreach qw( setup last_bill bill );
2100
2101       my @details = ();
2102
2103       my $lineitems = 0;
2104
2105       ###
2106       # bill setup
2107       ###
2108
2109       my $setup = 0;
2110       my $unitsetup = 0;
2111       if ( ! $cust_pkg->setup &&
2112            (
2113              ( $conf->exists('disable_setup_suspended_pkgs') &&
2114               ! $cust_pkg->getfield('susp')
2115             ) || ! $conf->exists('disable_setup_suspended_pkgs')
2116            )
2117         || $options{'resetup'}
2118       ) {
2119
2120         warn "    bill setup\n" if $DEBUG > 1;
2121         $lineitems++;
2122
2123         $setup = eval { $cust_pkg->calc_setup( $time, \@details ) };
2124         if ( $@ ) {
2125           $dbh->rollback if $oldAutoCommit;
2126           return "$@ running calc_setup for $cust_pkg\n";
2127         }
2128
2129         $unitsetup = $cust_pkg->part_pkg->unit_setup || $setup; #XXX uuh
2130
2131         $cust_pkg->setfield('setup', $time)
2132           unless $cust_pkg->setup;
2133               #do need it, but it won't get written to the db
2134               #|| $cust_pkg->pkgpart != $real_pkgpart;
2135
2136       }
2137
2138       ###
2139       # bill recurring fee
2140       ###
2141
2142       #XXX unit stuff here too
2143       my $recur = 0;
2144       my $unitrecur = 0;
2145       my $sdate;
2146       if ( $part_pkg->getfield('freq') ne '0' &&
2147            ! $cust_pkg->getfield('susp') &&
2148            ( $cust_pkg->getfield('bill') || 0 ) <= $time
2149       ) {
2150
2151         # XXX should this be a package event?  probably.  events are called
2152         # at collection time at the moment, though...
2153         $part_pkg->reset_usage($cust_pkg, 'debug'=>$DEBUG)
2154           if $part_pkg->can('reset_usage');
2155           #don't want to reset usage just cause we want a line item??
2156           #&& $part_pkg->pkgpart == $real_pkgpart;
2157
2158         warn "    bill recur\n" if $DEBUG > 1;
2159         $lineitems++;
2160
2161         # XXX shared with $recur_prog
2162         $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2163
2164         #over two params!  lets at least switch to a hashref for the rest...
2165         my %param = ( 'precommit_hooks' => \@precommit_hooks, );
2166
2167         $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details, \%param ) };
2168         if ( $@ ) {
2169           $dbh->rollback if $oldAutoCommit;
2170           return "$@ running calc_recur for $cust_pkg\n";
2171         }
2172
2173
2174         #change this bit to use Date::Manip? CAREFUL with timezones (see
2175         # mailing list archive)
2176         my ($sec,$min,$hour,$mday,$mon,$year) =
2177           (localtime($sdate) )[0,1,2,3,4,5];
2178
2179         #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
2180         # only for figuring next bill date, nothing else, so, reset $sdate again
2181         # here
2182         $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2183         $cust_pkg->last_bill($sdate);
2184
2185         if ( $part_pkg->freq =~ /^\d+$/ ) {
2186           $mon += $part_pkg->freq;
2187           until ( $mon < 12 ) { $mon -= 12; $year++; }
2188         } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
2189           my $weeks = $1;
2190           $mday += $weeks * 7;
2191         } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
2192           my $days = $1;
2193           $mday += $days;
2194         } elsif ( $part_pkg->freq =~ /^(\d+)h$/ ) {
2195           my $hours = $1;
2196           $hour += $hours;
2197         } else {
2198           $dbh->rollback if $oldAutoCommit;
2199           return "unparsable frequency: ". $part_pkg->freq;
2200         }
2201         $cust_pkg->setfield('bill',
2202           timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
2203
2204       }
2205
2206       warn "\$setup is undefined" unless defined($setup);
2207       warn "\$recur is undefined" unless defined($recur);
2208       warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
2209
2210       ###
2211       # If there's line items, create em cust_bill_pkg records
2212       # If $cust_pkg has been modified, update it (if we're a real pkgpart)
2213       ###
2214
2215       if ( $lineitems ) {
2216
2217         if ( $cust_pkg->modified && $cust_pkg->pkgpart == $real_pkgpart ) {
2218           # hmm.. and if just the options are modified in some weird price plan?
2219
2220           warn "  package ". $cust_pkg->pkgnum. " modified; updating\n"
2221             if $DEBUG >1;
2222
2223           my $error = $cust_pkg->replace( $old_cust_pkg,
2224                                           'options' => { $cust_pkg->options },
2225                                         );
2226           if ( $error ) { #just in case
2227             $dbh->rollback if $oldAutoCommit;
2228             return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error";
2229           }
2230         }
2231
2232         $setup = sprintf( "%.2f", $setup );
2233         $recur = sprintf( "%.2f", $recur );
2234         if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
2235           $dbh->rollback if $oldAutoCommit;
2236           return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
2237         }
2238         if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
2239           $dbh->rollback if $oldAutoCommit;
2240           return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
2241         }
2242
2243         if ( $setup != 0 || $recur != 0 ) {
2244
2245           warn "    charges (setup=$setup, recur=$recur); adding line items\n"
2246             if $DEBUG > 1;
2247           my $cust_bill_pkg = new FS::cust_bill_pkg {
2248             'pkgnum'    => $cust_pkg->pkgnum,
2249             'setup'     => $setup,
2250             'unitsetup' => $unitsetup,
2251             'recur'     => $recur,
2252             'unitrecur' => $unitrecur,
2253             'quantity'  => $cust_pkg->quantity,
2254             'sdate'     => $sdate,
2255             'edate'     => $cust_pkg->bill,
2256             'details' => \@details,
2257           };
2258           $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
2259             unless $part_pkg->pkgpart == $real_pkgpart;
2260           push @cust_bill_pkg, $cust_bill_pkg;
2261
2262           $total_setup += $setup;
2263           $total_recur += $recur;
2264
2265           ###
2266           # handle taxes
2267           ###
2268
2269           unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
2270
2271             my @taxes = ();
2272             my @taxoverrides = $part_pkg->part_pkg_taxoverride;
2273
2274             my $prefix =
2275               ( $conf->exists('tax-ship_address') && length($self->ship_last) )
2276               ? 'ship_'
2277               : '';
2278
2279             if ( $conf->exists('enable_taxproducts')
2280                  && (scalar(@taxoverrides) || $part_pkg->taxproductnum )
2281                )
2282             {
2283
2284               my @taxclassnums = ();
2285               my $geocode = $self->geocode('cch');
2286
2287               if ( scalar( @taxoverrides ) ) {
2288                 @taxclassnums = map { $_->taxclassnum } @taxoverrides;
2289               }elsif ( $part_pkg->taxproductnum ) {
2290                 @taxclassnums = map { $_->taxclassnum }
2291                                 $part_pkg->part_pkg_taxrate('cch', $geocode);
2292               }
2293
2294               my $extra_sql =
2295                 "AND (".
2296                 join(' OR ', map { "taxclassnum = $_" } @taxclassnums ). ")";
2297
2298               @taxes = qsearch({ 'table' => 'tax_rate',
2299                                  'hashref' => { 'geocode' => $geocode, },
2300                                  'extra_sql' => $extra_sql,
2301                               })
2302                 if scalar(@taxclassnums);
2303
2304
2305             }else{
2306
2307               my %taxhash = map { $_ => $self->get("$prefix$_") }
2308                                 qw( state county country );
2309
2310               $taxhash{'taxclass'} = $part_pkg->taxclass;
2311
2312               @taxes = qsearch( 'cust_main_county', \%taxhash );
2313
2314             unless ( @taxes ) {
2315               $taxhash{'taxclass'} = '';
2316               @taxes =  qsearch( 'cust_main_county', \%taxhash );
2317             }
2318
2319             #one more try at a whole-country tax rate
2320             unless ( @taxes ) {
2321               $taxhash{$_} = '' foreach qw( state county );
2322               @taxes =  qsearch( 'cust_main_county', \%taxhash );
2323             }
2324
2325             } #if $conf->exists('enable_taxproducts')
2326
2327             # maybe eliminate this entirely, along with all the 0% records
2328             unless ( @taxes ) {
2329               $dbh->rollback if $oldAutoCommit;
2330               my $error;
2331               if ( $conf->exists('enable_taxproducts') ) {
2332                 $error =
2333                   "fatal: can't find tax rate for zip/taxproduct/pkgpart ".
2334                   join('/', ( map $self->get("$prefix$_"),
2335                                   qw(zip)
2336                             ),
2337                             $part_pkg->taxproduct_description,
2338                             $part_pkg->pkgpart ). "\n";
2339               } else {
2340                 $error =
2341                   "fatal: can't find tax rate for state/county/country/taxclass ".
2342                   join('/', ( map $self->get("$prefix$_"),
2343                                   qw(state county country)
2344                             ),
2345                             $part_pkg->taxclass ). "\n";
2346               }
2347               return $error;
2348             }
2349
2350             foreach my $tax ( @taxes ) {
2351               my $taxname = ref( $tax ). ' '. $tax->taxnum;
2352               if ( exists( $taxlisthash{ $taxname } ) ) {
2353                 push @{ $taxlisthash{ $taxname  } }, $cust_bill_pkg;
2354               }else{
2355                 $taxlisthash{ $taxname } = [ $tax, $cust_bill_pkg ];
2356               }
2357             }
2358
2359
2360           } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2361
2362         } #if $setup != 0 || $recur != 0
2363
2364       } #if $cust_pkg->modified
2365
2366     } #foreach my $part_pkg
2367
2368   } #foreach my $cust_pkg
2369
2370   unless ( @cust_bill_pkg ) { #don't create an invoice w/o line items
2371     #but do commit any package date cycling that happened
2372     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2373     return '';
2374   }
2375
2376   warn "having a look at the taxes we found...\n" if $DEBUG > 2;
2377   foreach my $tax ( keys %taxlisthash ) {
2378     my $tax_object = shift @{ $taxlisthash{$tax} };
2379     warn "found ". $tax_object->taxname. " as $tax\n" if $DEBUG > 2;
2380     my $listref_or_error = $tax_object->taxline( @{ $taxlisthash{$tax} } );
2381     unless (ref($listref_or_error)) {
2382       $dbh->rollback if $oldAutoCommit;
2383       return $listref_or_error;
2384     }
2385     unshift @{ $taxlisthash{$tax} }, $tax_object;
2386
2387     warn "adding ". $listref_or_error->[1].
2388          " as ". $listref_or_error->[0]. "\n"
2389       if $DEBUG > 2;
2390     $tax{ $tax_object->taxname } += $listref_or_error->[1];
2391     if ( $taxname{ $listref_or_error->[0] } ) {
2392       push @{ $taxname{ $listref_or_error->[0] } }, $tax_object->taxname;
2393     }else{
2394       $taxname{ $listref_or_error->[0] } = [ $tax_object->taxname ];
2395     }
2396
2397   }
2398
2399   #some taxes are taxed
2400   my %totlisthash;
2401
2402   warn "finding taxed taxes...\n" if $DEBUG > 2;
2403   foreach my $tax ( keys %taxlisthash ) {
2404     my $tax_object = shift @{ $taxlisthash{$tax} };
2405     warn "found possible taxed tax ". $tax_object->taxname. " we call $tax\n"
2406       if $DEBUG > 2;
2407     next unless $tax_object->can('tax_on_tax');
2408
2409     foreach my $tot ( $tax_object->tax_on_tax( $self ) ) {
2410       my $totname = ref( $tot ). ' '. $tot->taxnum;
2411
2412       warn "checking $totname which we call ". $tot->taxname. " as applicable\n"
2413         if $DEBUG > 2;
2414       next unless exists( $taxlisthash{ $totname } ); # only increase
2415                                                       # existing taxes
2416       warn "adding $totname to taxed taxes\n" if $DEBUG > 2;
2417       if ( exists( $totlisthash{ $totname } ) ) {
2418         push @{ $totlisthash{ $totname  } }, $tax{ $tax_object->taxname };
2419       }else{
2420         $totlisthash{ $totname } = [ $tot, $tax{ $tax_object->taxname } ];
2421       }
2422     }
2423   }
2424
2425   warn "having a look at taxed taxes...\n" if $DEBUG > 2;
2426   foreach my $tax ( keys %totlisthash ) {
2427     my $tax_object = shift @{ $totlisthash{$tax} };
2428     warn "found previously found taxed tax ". $tax_object->taxname. "\n"
2429       if $DEBUG > 2;
2430     my $listref_or_error = $tax_object->taxline( @{ $totlisthash{$tax} } );
2431     unless (ref($listref_or_error)) {
2432       $dbh->rollback if $oldAutoCommit;
2433       return $listref_or_error;
2434     }
2435
2436     warn "adding taxed tax amount ". $listref_or_error->[1].
2437          " as ". $tax_object->taxname. "\n"
2438       if $DEBUG;
2439     $tax{ $tax_object->taxname } += $listref_or_error->[1];
2440   }
2441
2442   #consolidate and create tax line items
2443   warn "consolidating and generating...\n" if $DEBUG > 2;
2444   foreach my $taxname ( keys %taxname ) {
2445     my $tax = 0;
2446     my %seen = ();
2447     warn "adding $taxname\n" if $DEBUG > 1;
2448     foreach my $taxitem ( @{ $taxname{$taxname} } ) {
2449       $tax += $tax{$taxitem} unless $seen{$taxitem};
2450       warn "adding $tax{$taxitem}\n" if $DEBUG > 1;
2451     }
2452     next unless $tax;
2453
2454     $tax = sprintf('%.2f', $tax );
2455     $total_setup = sprintf('%.2f', $total_setup+$tax );
2456
2457     push @cust_bill_pkg, new FS::cust_bill_pkg {
2458       'pkgnum'   => 0,
2459       'setup'    => $tax,
2460       'recur'    => 0,
2461       'sdate'    => '',
2462       'edate'    => '',
2463       'itemdesc' => $taxname,
2464     };
2465
2466   }
2467
2468   my $charged = sprintf('%.2f', $total_setup + $total_recur );
2469
2470   #create the new invoice
2471   my $cust_bill = new FS::cust_bill ( {
2472     'custnum' => $self->custnum,
2473     '_date'   => ( $options{'invoice_time'} || $time ),
2474     'charged' => $charged,
2475   } );
2476   my $error = $cust_bill->insert;
2477   if ( $error ) {
2478     $dbh->rollback if $oldAutoCommit;
2479     return "can't create invoice for customer #". $self->custnum. ": $error";
2480   }
2481
2482   foreach my $cust_bill_pkg ( @cust_bill_pkg ) {
2483     $cust_bill_pkg->invnum($cust_bill->invnum);
2484     my $error = $cust_bill_pkg->insert;
2485     if ( $error ) {
2486       $dbh->rollback if $oldAutoCommit;
2487       return "can't create invoice line item: $error";
2488     }
2489   }
2490
2491
2492   foreach my $hook ( @precommit_hooks ) {
2493     eval {
2494       &{$hook}; #($self) ?
2495     };
2496     if ( $@ ) {
2497       $dbh->rollback if $oldAutoCommit;
2498       return "$@ running precommit hook $hook\n";
2499     }
2500   }
2501
2502   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2503   ''; #no error
2504 }
2505
2506 =item collect OPTIONS
2507
2508 (Attempt to) collect money for this customer's outstanding invoices (see
2509 L<FS::cust_bill>).  Usually used after the bill method.
2510
2511 Actions are now triggered by billing events; see L<FS::part_event> and the
2512 billing events web interface.  Old-style invoice events (see
2513 L<FS::part_bill_event>) have been deprecated.
2514
2515 If there is an error, returns the error, otherwise returns false.
2516
2517 Options are passed as name-value pairs.
2518
2519 Currently available options are:
2520
2521 =over 4
2522
2523 =item invoice_time
2524
2525 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.
2526
2527 =item retry
2528
2529 Retry card/echeck/LEC transactions even when not scheduled by invoice events.
2530
2531 =item quiet
2532
2533 set true to surpress email card/ACH decline notices.
2534
2535 =item check_freq
2536
2537 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
2538
2539 =item payby
2540
2541 allows for one time override of normal customer billing method
2542
2543 =item debug
2544
2545 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)
2546
2547
2548 =back
2549
2550 =cut
2551
2552 sub collect {
2553   my( $self, %options ) = @_;
2554   my $invoice_time = $options{'invoice_time'} || time;
2555
2556   #put below somehow?
2557   local $SIG{HUP} = 'IGNORE';
2558   local $SIG{INT} = 'IGNORE';
2559   local $SIG{QUIT} = 'IGNORE';
2560   local $SIG{TERM} = 'IGNORE';
2561   local $SIG{TSTP} = 'IGNORE';
2562   local $SIG{PIPE} = 'IGNORE';
2563
2564   my $oldAutoCommit = $FS::UID::AutoCommit;
2565   local $FS::UID::AutoCommit = 0;
2566   my $dbh = dbh;
2567
2568   $self->select_for_update; #mutex
2569
2570   if ( $DEBUG ) {
2571     my $balance = $self->balance;
2572     warn "$me collect customer ". $self->custnum. ": balance $balance\n"
2573   }
2574
2575   if ( exists($options{'retry_card'}) ) {
2576     carp 'retry_card option passed to collect is deprecated; use retry';
2577     $options{'retry'} ||= $options{'retry_card'};
2578   }
2579   if ( exists($options{'retry'}) && $options{'retry'} ) {
2580     my $error = $self->retry_realtime;
2581     if ( $error ) {
2582       $dbh->rollback if $oldAutoCommit;
2583       return $error;
2584     }
2585   }
2586
2587   # false laziness w/pay_batch::import_results
2588
2589   my $due_cust_event = $self->due_cust_event(
2590     'debug'      => ( $options{'debug'} || 0 ),
2591     'time'       => $invoice_time,
2592     'check_freq' => $options{'check_freq'},
2593   );
2594   unless( ref($due_cust_event) ) {
2595     $dbh->rollback if $oldAutoCommit;
2596     return $due_cust_event;
2597   }
2598
2599   foreach my $cust_event ( @$due_cust_event ) {
2600
2601     #XXX lock event
2602
2603     #re-eval event conditions (a previous event could have changed things)
2604     unless ( $cust_event->test_conditions( 'time' => $invoice_time ) ) {
2605       #don't leave stray "new/locked" records around
2606       my $error = $cust_event->delete;
2607       if ( $error ) {
2608         #gah, even with transactions
2609         $dbh->commit if $oldAutoCommit; #well.
2610         return $error;
2611       }
2612       next;
2613     }
2614
2615     {
2616       local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
2617       warn "  running cust_event ". $cust_event->eventnum. "\n"
2618         if $DEBUG > 1;
2619
2620
2621       #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
2622       if ( my $error = $cust_event->do_event() ) {
2623         #XXX wtf is this?  figure out a proper dealio with return value
2624         #from do_event
2625           # gah, even with transactions.
2626           $dbh->commit if $oldAutoCommit; #well.
2627           return $error;
2628         }
2629     }
2630
2631   }
2632
2633   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2634   '';
2635
2636 }
2637
2638 =item due_cust_event [ HASHREF | OPTION => VALUE ... ]
2639
2640 Inserts database records for and returns an ordered listref of new events due
2641 for this customer, as FS::cust_event objects (see L<FS::cust_event>).  If no
2642 events are due, an empty listref is returned.  If there is an error, returns a
2643 scalar error message.
2644
2645 To actually run the events, call each event's test_condition method, and if
2646 still true, call the event's do_event method.
2647
2648 Options are passed as a hashref or as a list of name-value pairs.  Available
2649 options are:
2650
2651 =over 4
2652
2653 =item check_freq
2654
2655 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.
2656
2657 =item time
2658
2659 "Current time" for the events.
2660
2661 =item debug
2662
2663 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)
2664
2665 =item eventtable
2666
2667 Only return events for the specified eventtable (by default, events of all eventtables are returned)
2668
2669 =item objects
2670
2671 Explicitly pass the objects to be tested (typically used with eventtable).
2672
2673 =back
2674
2675 =cut
2676
2677 sub due_cust_event {
2678   my $self = shift;
2679   my %opt = ref($_[0]) ? %{ $_[0] } : @_;
2680
2681   #???
2682   #my $DEBUG = $opt{'debug'}
2683   local($DEBUG) = $opt{'debug'}
2684     if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG;
2685
2686   warn "$me due_cust_event called with options ".
2687        join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
2688     if $DEBUG;
2689
2690   $opt{'time'} ||= time;
2691
2692   local $SIG{HUP} = 'IGNORE';
2693   local $SIG{INT} = 'IGNORE';
2694   local $SIG{QUIT} = 'IGNORE';
2695   local $SIG{TERM} = 'IGNORE';
2696   local $SIG{TSTP} = 'IGNORE';
2697   local $SIG{PIPE} = 'IGNORE';
2698
2699   my $oldAutoCommit = $FS::UID::AutoCommit;
2700   local $FS::UID::AutoCommit = 0;
2701   my $dbh = dbh;
2702
2703   $self->select_for_update; #mutex
2704
2705   ###
2706   # 1: find possible events (initial search)
2707   ###
2708
2709   my @cust_event = ();
2710
2711   my @eventtable = $opt{'eventtable'}
2712                      ? ( $opt{'eventtable'} )
2713                      : FS::part_event->eventtables_runorder;
2714
2715   foreach my $eventtable ( @eventtable ) {
2716
2717     my @objects;
2718     if ( $opt{'objects'} ) {
2719
2720       @objects = @{ $opt{'objects'} };
2721
2722     } else {
2723
2724       #my @objects = $self->eventtable(); # sub cust_main { @{ [ $self ] }; }
2725       @objects = ( $eventtable eq 'cust_main' )
2726                    ? ( $self )
2727                    : ( $self->$eventtable() );
2728
2729     }
2730
2731     my @e_cust_event = ();
2732
2733     my $cross = "CROSS JOIN $eventtable";
2734     $cross .= ' LEFT JOIN cust_main USING ( custnum )'
2735       unless $eventtable eq 'cust_main';
2736
2737     foreach my $object ( @objects ) {
2738
2739       #this first search uses the condition_sql magic for optimization.
2740       #the more possible events we can eliminate in this step the better
2741
2742       my $cross_where = '';
2743       my $pkey = $object->primary_key;
2744       $cross_where = "$eventtable.$pkey = ". $object->$pkey();
2745
2746       my $join = FS::part_event_condition->join_conditions_sql( $eventtable );
2747       my $extra_sql =
2748         FS::part_event_condition->where_conditions_sql( $eventtable,
2749                                                         'time'=>$opt{'time'}
2750                                                       );
2751       my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
2752
2753       $extra_sql = "AND $extra_sql" if $extra_sql;
2754
2755       #here is the agent virtualization
2756       $extra_sql .= " AND (    part_event.agentnum IS NULL
2757                             OR part_event.agentnum = ". $self->agentnum. ' )';
2758
2759       $extra_sql .= " $order";
2760
2761       warn "searching for events for $eventtable ". $object->$pkey. "\n"
2762         if $opt{'debug'} > 2;
2763       my @part_event = qsearch( {
2764         'debug'     => ( $opt{'debug'} > 3 ? 1 : 0 ),
2765         'select'    => 'part_event.*',
2766         'table'     => 'part_event',
2767         'addl_from' => "$cross $join",
2768         'hashref'   => { 'check_freq' => ( $opt{'check_freq'} || '1d' ),
2769                          'eventtable' => $eventtable,
2770                          'disabled'   => '',
2771                        },
2772         'extra_sql' => "AND $cross_where $extra_sql",
2773       } );
2774
2775       if ( $DEBUG > 2 ) {
2776         my $pkey = $object->primary_key;
2777         warn "      ". scalar(@part_event).
2778              " possible events found for $eventtable ". $object->$pkey(). "\n";
2779       }
2780
2781       push @e_cust_event, map { $_->new_cust_event($object) } @part_event;
2782
2783     }
2784
2785     warn "    ". scalar(@e_cust_event).
2786          " subtotal possible cust events found for $eventtable\n"
2787       if $DEBUG > 1;
2788
2789     push @cust_event, @e_cust_event;
2790
2791   }
2792
2793   warn "  ". scalar(@cust_event).
2794        " total possible cust events found in initial search\n"
2795     if $DEBUG; # > 1;
2796
2797   ##
2798   # 2: test conditions
2799   ##
2800
2801   my %unsat = ();
2802
2803   @cust_event = grep $_->test_conditions( 'time'          => $opt{'time'},
2804                                           'stats_hashref' => \%unsat ),
2805                      @cust_event;
2806
2807   warn "  ". scalar(@cust_event). " cust events left satisfying conditions\n"
2808     if $DEBUG; # > 1;
2809
2810   warn "    invalid conditions not eliminated with condition_sql:\n".
2811        join('', map "      $_: ".$unsat{$_}."\n", keys %unsat )
2812     if $DEBUG; # > 1;
2813
2814   ##
2815   # 3: insert
2816   ##
2817
2818   foreach my $cust_event ( @cust_event ) {
2819
2820     my $error = $cust_event->insert();
2821     if ( $error ) {
2822       $dbh->rollback if $oldAutoCommit;
2823       return $error;
2824     }
2825
2826   }
2827
2828   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2829
2830   ##
2831   # 4: return
2832   ##
2833
2834   warn "  returning events: ". Dumper(@cust_event). "\n"
2835     if $DEBUG > 2;
2836
2837   \@cust_event;
2838
2839 }
2840
2841 =item retry_realtime
2842
2843 Schedules realtime / batch  credit card / electronic check / LEC billing
2844 events for for retry.  Useful if card information has changed or manual
2845 retry is desired.  The 'collect' method must be called to actually retry
2846 the transaction.
2847
2848 Implementation details: For either this customer, or for each of this
2849 customer's open invoices, changes the status of the first "done" (with
2850 statustext error) realtime processing event to "failed".
2851
2852 =cut
2853
2854 sub retry_realtime {
2855   my $self = shift;
2856
2857   local $SIG{HUP} = 'IGNORE';
2858   local $SIG{INT} = 'IGNORE';
2859   local $SIG{QUIT} = 'IGNORE';
2860   local $SIG{TERM} = 'IGNORE';
2861   local $SIG{TSTP} = 'IGNORE';
2862   local $SIG{PIPE} = 'IGNORE';
2863
2864   my $oldAutoCommit = $FS::UID::AutoCommit;
2865   local $FS::UID::AutoCommit = 0;
2866   my $dbh = dbh;
2867
2868   #a little false laziness w/due_cust_event (not too bad, really)
2869
2870   my $join = FS::part_event_condition->join_conditions_sql;
2871   my $order = FS::part_event_condition->order_conditions_sql;
2872   my $mine =
2873   '( '
2874    . join ( ' OR ' , map {
2875     "( part_event.eventtable = " . dbh->quote($_)
2876     . " AND tablenum IN( SELECT " . dbdef->table($_)->primary_key . " from $_ where custnum = " . dbh->quote( $self->custnum ) . "))" ;
2877    } FS::part_event->eventtables)
2878    . ') ';
2879
2880   #here is the agent virtualization
2881   my $agent_virt = " (    part_event.agentnum IS NULL
2882                        OR part_event.agentnum = ". $self->agentnum. ' )';
2883
2884   #XXX this shouldn't be hardcoded, actions should declare it...
2885   my @realtime_events = qw(
2886     cust_bill_realtime_card
2887     cust_bill_realtime_check
2888     cust_bill_realtime_lec
2889     cust_bill_batch
2890   );
2891
2892   my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'",
2893                                                   @realtime_events
2894                                      ).
2895                           ' ) ';
2896
2897   my @cust_event = qsearchs({
2898     'table'     => 'cust_event',
2899     'select'    => 'cust_event.*',
2900     'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
2901     'hashref'   => { 'status' => 'done' },
2902     'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ".
2903                    " AND $mine AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
2904   });
2905
2906   my %seen_invnum = ();
2907   foreach my $cust_event (@cust_event) {
2908
2909     #max one for the customer, one for each open invoice
2910     my $cust_X = $cust_event->cust_X;
2911     next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
2912                           ? $cust_X->invnum
2913                           : 0
2914                         }++
2915          or $cust_event->part_event->eventtable eq 'cust_bill'
2916             && ! $cust_X->owed;
2917
2918     my $error = $cust_event->retry;
2919     if ( $error ) {
2920       $dbh->rollback if $oldAutoCommit;
2921       return "error scheduling event for retry: $error";
2922     }
2923
2924   }
2925
2926   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2927   '';
2928
2929 }
2930
2931 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
2932
2933 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
2934 via a Business::OnlinePayment realtime gateway.  See
2935 L<http://420.am/business-onlinepayment> for supported gateways.
2936
2937 Available methods are: I<CC>, I<ECHECK> and I<LEC>
2938
2939 Available options are: I<description>, I<invnum>, I<quiet>, I<paynum_ref>, I<payunique>
2940
2941 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
2942 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
2943 if set, will override the value from the customer record.
2944
2945 I<description> is a free-text field passed to the gateway.  It defaults to
2946 "Internet services".
2947
2948 If an I<invnum> is specified, this payment (if successful) is applied to the
2949 specified invoice.  If you don't specify an I<invnum> you might want to
2950 call the B<apply_payments> method.
2951
2952 I<quiet> can be set true to surpress email decline notices.
2953
2954 I<paynum_ref> can be set to a scalar reference.  It will be filled in with the
2955 resulting paynum, if any.
2956
2957 I<payunique> is a unique identifier for this payment.
2958
2959 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
2960
2961 =cut
2962
2963 sub realtime_bop {
2964   my( $self, $method, $amount, %options ) = @_;
2965   if ( $DEBUG ) {
2966     warn "$me realtime_bop: $method $amount\n";
2967     warn "  $_ => $options{$_}\n" foreach keys %options;
2968   }
2969
2970   $options{'description'} ||= 'Internet services';
2971
2972   return $self->fake_bop($method, $amount, %options) if $options{'fake'};
2973
2974   eval "use Business::OnlinePayment";
2975   die $@ if $@;
2976
2977   my $payinfo = exists($options{'payinfo'})
2978                   ? $options{'payinfo'}
2979                   : $self->payinfo;
2980
2981   my %method2payby = (
2982     'CC'     => 'CARD',
2983     'ECHECK' => 'CHEK',
2984     'LEC'    => 'LECB',
2985   );
2986
2987   ###
2988   # check for banned credit card/ACH
2989   ###
2990
2991   my $ban = qsearchs('banned_pay', {
2992     'payby'   => $method2payby{$method},
2993     'payinfo' => md5_base64($payinfo),
2994   } );
2995   return "Banned credit card" if $ban;
2996
2997   ###
2998   # select a gateway
2999   ###
3000
3001   my $taxclass = '';
3002   if ( $options{'invnum'} ) {
3003     my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
3004     die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
3005     my @taxclasses =
3006       map  { $_->part_pkg->taxclass }
3007       grep { $_ }
3008       map  { $_->cust_pkg }
3009       $cust_bill->cust_bill_pkg;
3010     unless ( grep { $taxclasses[0] ne $_ } @taxclasses ) { #unless there are
3011                                                            #different taxclasses
3012       $taxclass = $taxclasses[0];
3013     }
3014   }
3015
3016   #look for an agent gateway override first
3017   my $cardtype;
3018   if ( $method eq 'CC' ) {
3019     $cardtype = cardtype($payinfo);
3020   } elsif ( $method eq 'ECHECK' ) {
3021     $cardtype = 'ACH';
3022   } else {
3023     $cardtype = $method;
3024   }
3025
3026   my $override =
3027        qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3028                                            cardtype => $cardtype,
3029                                            taxclass => $taxclass,       } )
3030     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3031                                            cardtype => '',
3032                                            taxclass => $taxclass,       } )
3033     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3034                                            cardtype => $cardtype,
3035                                            taxclass => '',              } )
3036     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3037                                            cardtype => '',
3038                                            taxclass => '',              } );
3039
3040   my $payment_gateway = '';
3041   my( $processor, $login, $password, $action, @bop_options );
3042   if ( $override ) { #use a payment gateway override
3043
3044     $payment_gateway = $override->payment_gateway;
3045
3046     $processor   = $payment_gateway->gateway_module;
3047     $login       = $payment_gateway->gateway_username;
3048     $password    = $payment_gateway->gateway_password;
3049     $action      = $payment_gateway->gateway_action;
3050     @bop_options = $payment_gateway->options;
3051
3052   } else { #use the standard settings from the config
3053
3054     ( $processor, $login, $password, $action, @bop_options ) =
3055       $self->default_payment_gateway($method);
3056
3057   }
3058
3059   ###
3060   # massage data
3061   ###
3062
3063   my $address = exists($options{'address1'})
3064                     ? $options{'address1'}
3065                     : $self->address1;
3066   my $address2 = exists($options{'address2'})
3067                     ? $options{'address2'}
3068                     : $self->address2;
3069   $address .= ", ". $address2 if length($address2);
3070
3071   my $o_payname = exists($options{'payname'})
3072                     ? $options{'payname'}
3073                     : $self->payname;
3074   my($payname, $payfirst, $paylast);
3075   if ( $o_payname && $method ne 'ECHECK' ) {
3076     ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3077       or return "Illegal payname $payname";
3078     ($payfirst, $paylast) = ($1, $2);
3079   } else {
3080     $payfirst = $self->getfield('first');
3081     $paylast = $self->getfield('last');
3082     $payname =  "$payfirst $paylast";
3083   }
3084
3085   my @invoicing_list = $self->invoicing_list_emailonly;
3086   if ( $conf->exists('emailinvoiceautoalways')
3087        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3088        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3089     push @invoicing_list, $self->all_emails;
3090   }
3091
3092   my $email = ($conf->exists('business-onlinepayment-email-override'))
3093               ? $conf->config('business-onlinepayment-email-override')
3094               : $invoicing_list[0];
3095
3096   my %content = ();
3097
3098   my $payip = exists($options{'payip'})
3099                 ? $options{'payip'}
3100                 : $self->payip;
3101   $content{customer_ip} = $payip
3102     if length($payip);
3103
3104   $content{invoice_number} = $options{'invnum'}
3105     if exists($options{'invnum'}) && length($options{'invnum'});
3106
3107   $content{email_customer} =
3108     (    $conf->exists('business-onlinepayment-email_customer')
3109       || $conf->exists('business-onlinepayment-email-override') );
3110
3111   my $paydate = '';
3112   if ( $method eq 'CC' ) {
3113
3114     $content{card_number} = $payinfo;
3115     $paydate = exists($options{'paydate'})
3116                     ? $options{'paydate'}
3117                     : $self->paydate;
3118     $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3119     $content{expiration} = "$2/$1";
3120
3121     my $paycvv = exists($options{'paycvv'})
3122                    ? $options{'paycvv'}
3123                    : $self->paycvv;
3124     $content{cvv2} = $paycvv
3125       if length($paycvv);
3126
3127     my $paystart_month = exists($options{'paystart_month'})
3128                            ? $options{'paystart_month'}
3129                            : $self->paystart_month;
3130
3131     my $paystart_year  = exists($options{'paystart_year'})
3132                            ? $options{'paystart_year'}
3133                            : $self->paystart_year;
3134
3135     $content{card_start} = "$paystart_month/$paystart_year"
3136       if $paystart_month && $paystart_year;
3137
3138     my $payissue       = exists($options{'payissue'})
3139                            ? $options{'payissue'}
3140                            : $self->payissue;
3141     $content{issue_number} = $payissue if $payissue;
3142
3143     $content{recurring_billing} = 'YES'
3144       if qsearch('cust_pay', { 'custnum' => $self->custnum,
3145                                'payby'   => 'CARD',
3146                                'payinfo' => $payinfo,
3147                              } )
3148       || qsearch('cust_pay', { 'custnum' => $self->custnum,
3149                                'payby'   => 'CARD',
3150                                'paymask' => $self->mask_payinfo('CARD', $payinfo),
3151                              } );
3152
3153
3154   } elsif ( $method eq 'ECHECK' ) {
3155     ( $content{account_number}, $content{routing_code} ) =
3156       split('@', $payinfo);
3157     $content{bank_name} = $o_payname;
3158     $content{bank_state} = exists($options{'paystate'})
3159                              ? $options{'paystate'}
3160                              : $self->getfield('paystate');
3161     $content{account_type} = exists($options{'paytype'})
3162                                ? uc($options{'paytype'}) || 'CHECKING'
3163                                : uc($self->getfield('paytype')) || 'CHECKING';
3164     $content{account_name} = $payname;
3165     $content{customer_org} = $self->company ? 'B' : 'I';
3166     $content{state_id}       = exists($options{'stateid'})
3167                                  ? $options{'stateid'}
3168                                  : $self->getfield('stateid');
3169     $content{state_id_state} = exists($options{'stateid_state'})
3170                                  ? $options{'stateid_state'}
3171                                  : $self->getfield('stateid_state');
3172     $content{customer_ssn} = exists($options{'ss'})
3173                                ? $options{'ss'}
3174                                : $self->ss;
3175   } elsif ( $method eq 'LEC' ) {
3176     $content{phone} = $payinfo;
3177   }
3178
3179   ###
3180   # run transaction(s)
3181   ###
3182
3183   my $balance = exists( $options{'balance'} )
3184                   ? $options{'balance'}
3185                   : $self->balance;
3186
3187   $self->select_for_update; #mutex ... just until we get our pending record in
3188
3189   #the checks here are intended to catch concurrent payments
3190   #double-form-submission prevention is taken care of in cust_pay_pending::check
3191
3192   #check the balance
3193   return "The customer's balance has changed; $method transaction aborted."
3194     if $self->balance < $balance;
3195     #&& $self->balance < $amount; #might as well anyway?
3196
3197   #also check and make sure there aren't *other* pending payments for this cust
3198
3199   my @pending = qsearch('cust_pay_pending', {
3200     'custnum' => $self->custnum,
3201     'status'  => { op=>'!=', value=>'done' }
3202   });
3203   return "A payment is already being processed for this customer (".
3204          join(', ', map 'paypendingnum '. $_->paypendingnum, @pending ).
3205          "); $method transaction aborted."
3206     if scalar(@pending);
3207
3208   #okay, good to go, if we're a duplicate, cust_pay_pending will kick us out
3209
3210   my $cust_pay_pending = new FS::cust_pay_pending {
3211     'custnum'    => $self->custnum,
3212     #'invnum'     => $options{'invnum'},
3213     'paid'       => $amount,
3214     '_date'      => '',
3215     'payby'      => $method2payby{$method},
3216     'payinfo'    => $payinfo,
3217     'paydate'    => $paydate,
3218     'status'     => 'new',
3219     'gatewaynum' => ( $payment_gateway ? $payment_gateway->gatewaynum : '' ),
3220   };
3221   $cust_pay_pending->payunique( $options{payunique} )
3222     if defined($options{payunique}) && length($options{payunique});
3223   my $cpp_new_err = $cust_pay_pending->insert; #mutex lost when this is inserted
3224   return $cpp_new_err if $cpp_new_err;
3225
3226   my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
3227
3228   my $transaction = new Business::OnlinePayment( $processor, @bop_options );
3229   $transaction->content(
3230     'type'           => $method,
3231     'login'          => $login,
3232     'password'       => $password,
3233     'action'         => $action1,
3234     'description'    => $options{'description'},
3235     'amount'         => $amount,
3236     #'invoice_number' => $options{'invnum'},
3237     'customer_id'    => $self->custnum,
3238     'last_name'      => $paylast,
3239     'first_name'     => $payfirst,
3240     'name'           => $payname,
3241     'address'        => $address,
3242     'city'           => ( exists($options{'city'})
3243                             ? $options{'city'}
3244                             : $self->city          ),
3245     'state'          => ( exists($options{'state'})
3246                             ? $options{'state'}
3247                             : $self->state          ),
3248     'zip'            => ( exists($options{'zip'})
3249                             ? $options{'zip'}
3250                             : $self->zip          ),
3251     'country'        => ( exists($options{'country'})
3252                             ? $options{'country'}
3253                             : $self->country          ),
3254     'referer'        => 'http://cleanwhisker.420.am/',
3255     'email'          => $email,
3256     'phone'          => $self->daytime || $self->night,
3257     %content, #after
3258   );
3259
3260   $cust_pay_pending->status('pending');
3261   my $cpp_pending_err = $cust_pay_pending->replace;
3262   return $cpp_pending_err if $cpp_pending_err;
3263
3264   #config?
3265   my $BOP_TESTING = 0;
3266   my $BOP_TESTING_SUCCESS = 1;
3267
3268   unless ( $BOP_TESTING ) {
3269     $transaction->submit();
3270   } else {
3271     if ( $BOP_TESTING_SUCCESS ) {
3272       $transaction->is_success(1);
3273       $transaction->authorization('fake auth');
3274     } else {
3275       $transaction->is_success(0);
3276       $transaction->error_message('fake failure');
3277     }
3278   }
3279
3280   if ( $transaction->is_success() && $action2 ) {
3281
3282     $cust_pay_pending->status('authorized');
3283     my $cpp_authorized_err = $cust_pay_pending->replace;
3284     return $cpp_authorized_err if $cpp_authorized_err;
3285
3286     my $auth = $transaction->authorization;
3287     my $ordernum = $transaction->can('order_number')
3288                    ? $transaction->order_number
3289                    : '';
3290
3291     my $capture =
3292       new Business::OnlinePayment( $processor, @bop_options );
3293
3294     my %capture = (
3295       %content,
3296       type           => $method,
3297       action         => $action2,
3298       login          => $login,
3299       password       => $password,
3300       order_number   => $ordernum,
3301       amount         => $amount,
3302       authorization  => $auth,
3303       description    => $options{'description'},
3304     );
3305
3306     foreach my $field (qw( authorization_source_code returned_ACI
3307                            transaction_identifier validation_code
3308                            transaction_sequence_num local_transaction_date
3309                            local_transaction_time AVS_result_code          )) {
3310       $capture{$field} = $transaction->$field() if $transaction->can($field);
3311     }
3312
3313     $capture->content( %capture );
3314
3315     $capture->submit();
3316
3317     unless ( $capture->is_success ) {
3318       my $e = "Authorization successful but capture failed, custnum #".
3319               $self->custnum. ': '.  $capture->result_code.
3320               ": ". $capture->error_message;
3321       warn $e;
3322       return $e;
3323     }
3324
3325   }
3326
3327   $cust_pay_pending->status($transaction->is_success() ? 'captured' : 'declined');
3328   my $cpp_captured_err = $cust_pay_pending->replace;
3329   return $cpp_captured_err if $cpp_captured_err;
3330
3331   ###
3332   # remove paycvv after initial transaction
3333   ###
3334
3335   #false laziness w/misc/process/payment.cgi - check both to make sure working
3336   # correctly
3337   if ( defined $self->dbdef_table->column('paycvv')
3338        && length($self->paycvv)
3339        && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
3340   ) {
3341     my $error = $self->remove_cvv;
3342     if ( $error ) {
3343       warn "WARNING: error removing cvv: $error\n";
3344     }
3345   }
3346
3347   ###
3348   # result handling
3349   ###
3350
3351   if ( $transaction->is_success() ) {
3352
3353     my $paybatch = '';
3354     if ( $payment_gateway ) { # agent override
3355       $paybatch = $payment_gateway->gatewaynum. '-';
3356     }
3357
3358     $paybatch .= "$processor:". $transaction->authorization;
3359
3360     $paybatch .= ':'. $transaction->order_number
3361       if $transaction->can('order_number')
3362       && length($transaction->order_number);
3363
3364     my $cust_pay = new FS::cust_pay ( {
3365        'custnum'  => $self->custnum,
3366        'invnum'   => $options{'invnum'},
3367        'paid'     => $amount,
3368        '_date'    => '',
3369        'payby'    => $method2payby{$method},
3370        'payinfo'  => $payinfo,
3371        'paybatch' => $paybatch,
3372        'paydate'  => $paydate,
3373     } );
3374     #doesn't hurt to know, even though the dup check is in cust_pay_pending now
3375     $cust_pay->payunique( $options{payunique} )
3376       if defined($options{payunique}) && length($options{payunique});
3377
3378     my $oldAutoCommit = $FS::UID::AutoCommit;
3379     local $FS::UID::AutoCommit = 0;
3380     my $dbh = dbh;
3381
3382     #start a transaction, insert the cust_pay and set cust_pay_pending.status to done in a single transction
3383
3384     my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3385
3386     if ( $error ) {
3387       $cust_pay->invnum(''); #try again with no specific invnum
3388       my $error2 = $cust_pay->insert( $options{'manual'} ?
3389                                       ( 'manual' => 1 ) : ()
3390                                     );
3391       if ( $error2 ) {
3392         # gah.  but at least we have a record of the state we had to abort in
3393         # from cust_pay_pending now.
3394         my $e = "WARNING: $method captured but payment not recorded - ".
3395                 "error inserting payment ($processor): $error2".
3396                 " (previously tried insert with invnum #$options{'invnum'}" .
3397                 ": $error ) - pending payment saved as paypendingnum ".
3398                 $cust_pay_pending->paypendingnum. "\n";
3399         warn $e;
3400         return $e;
3401       }
3402     }
3403
3404     if ( $options{'paynum_ref'} ) {
3405       ${ $options{'paynum_ref'} } = $cust_pay->paynum;
3406     }
3407
3408     $cust_pay_pending->status('done');
3409     $cust_pay_pending->statustext('captured');
3410     my $cpp_done_err = $cust_pay_pending->replace;
3411
3412     if ( $cpp_done_err ) {
3413
3414       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
3415       my $e = "WARNING: $method captured but payment not recorded - ".
3416               "error updating status for paypendingnum ".
3417               $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3418       warn $e;
3419       return $e;
3420
3421     } else {
3422
3423       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3424       return ''; #no error
3425
3426     }
3427
3428   } else {
3429
3430     my $perror = "$processor error: ". $transaction->error_message;
3431
3432     unless ( $transaction->error_message ) {
3433
3434       my $t_response;
3435       if ( $transaction->can('response_page') ) {
3436         $t_response = {
3437                         'page'    => ( $transaction->can('response_page')
3438                                          ? $transaction->response_page
3439                                          : ''
3440                                      ),
3441                         'code'    => ( $transaction->can('response_code')
3442                                          ? $transaction->response_code
3443                                          : ''
3444                                      ),
3445                         'headers' => ( $transaction->can('response_headers')
3446                                          ? $transaction->response_headers
3447                                          : ''
3448                                      ),
3449                       };
3450       } else {
3451         $t_response .=
3452           "No additional debugging information available for $processor";
3453       }
3454
3455       $perror .= "No error_message returned from $processor -- ".
3456                  ( ref($t_response) ? Dumper($t_response) : $t_response );
3457
3458     }
3459
3460     if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
3461          && $conf->exists('emaildecline')
3462          && grep { $_ ne 'POST' } $self->invoicing_list
3463          && ! grep { $transaction->error_message =~ /$_/ }
3464                    $conf->config('emaildecline-exclude')
3465     ) {
3466       my @templ = $conf->config('declinetemplate');
3467       my $template = new Text::Template (
3468         TYPE   => 'ARRAY',
3469         SOURCE => [ map "$_\n", @templ ],
3470       ) or return "($perror) can't create template: $Text::Template::ERROR";
3471       $template->compile()
3472         or return "($perror) can't compile template: $Text::Template::ERROR";
3473
3474       my $templ_hash = { error => $transaction->error_message };
3475
3476       my $error = send_email(
3477         'from'    => $conf->config('invoice_from'),
3478         'to'      => [ grep { $_ ne 'POST' } $self->invoicing_list ],
3479         'subject' => 'Your payment could not be processed',
3480         'body'    => [ $template->fill_in(HASH => $templ_hash) ],
3481       );
3482
3483       $perror .= " (also received error sending decline notification: $error)"
3484         if $error;
3485
3486     }
3487
3488     $cust_pay_pending->status('done');
3489     $cust_pay_pending->statustext("declined: $perror");
3490     my $cpp_done_err = $cust_pay_pending->replace;
3491     if ( $cpp_done_err ) {
3492       my $e = "WARNING: $method declined but pending payment not resolved - ".
3493               "error updating status for paypendingnum ".
3494               $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3495       warn $e;
3496       $perror = "$e ($perror)";
3497     }
3498
3499     return $perror;
3500   }
3501
3502 }
3503
3504 =item fake_bop
3505
3506 =cut
3507
3508 sub fake_bop {
3509   my( $self, $method, $amount, %options ) = @_;
3510
3511   if ( $options{'fake_failure'} ) {
3512      return "Error: No error; test failure requested with fake_failure";
3513   }
3514
3515   my %method2payby = (
3516     'CC'     => 'CARD',
3517     'ECHECK' => 'CHEK',
3518     'LEC'    => 'LECB',
3519   );
3520
3521   #my $paybatch = '';
3522   #if ( $payment_gateway ) { # agent override
3523   #  $paybatch = $payment_gateway->gatewaynum. '-';
3524   #}
3525   #
3526   #$paybatch .= "$processor:". $transaction->authorization;
3527   #
3528   #$paybatch .= ':'. $transaction->order_number
3529   #  if $transaction->can('order_number')
3530   #  && length($transaction->order_number);
3531
3532   my $paybatch = 'FakeProcessor:54:32';
3533
3534   my $cust_pay = new FS::cust_pay ( {
3535      'custnum'  => $self->custnum,
3536      'invnum'   => $options{'invnum'},
3537      'paid'     => $amount,
3538      '_date'    => '',
3539      'payby'    => $method2payby{$method},
3540      #'payinfo'  => $payinfo,
3541      'payinfo'  => '4111111111111111',
3542      'paybatch' => $paybatch,
3543      #'paydate'  => $paydate,
3544      'paydate'  => '2012-05-01',
3545   } );
3546   $cust_pay->payunique( $options{payunique} ) if length($options{payunique});
3547
3548   my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3549
3550   if ( $error ) {
3551     $cust_pay->invnum(''); #try again with no specific invnum
3552     my $error2 = $cust_pay->insert( $options{'manual'} ?
3553                                     ( 'manual' => 1 ) : ()
3554                                   );
3555     if ( $error2 ) {
3556       # gah, even with transactions.
3557       my $e = 'WARNING: Card/ACH debited but database not updated - '.
3558               "error inserting (fake!) payment: $error2".
3559               " (previously tried insert with invnum #$options{'invnum'}" .
3560               ": $error )";
3561       warn $e;
3562       return $e;
3563     }
3564   }
3565
3566   if ( $options{'paynum_ref'} ) {
3567     ${ $options{'paynum_ref'} } = $cust_pay->paynum;
3568   }
3569
3570   return ''; #no error
3571
3572 }
3573
3574 =item default_payment_gateway
3575
3576 =cut
3577
3578 sub default_payment_gateway {
3579   my( $self, $method ) = @_;
3580
3581   die "Real-time processing not enabled\n"
3582     unless $conf->exists('business-onlinepayment');
3583
3584   #load up config
3585   my $bop_config = 'business-onlinepayment';
3586   $bop_config .= '-ach'
3587     if $method =~ /^(ECHECK|CHEK)$/ && $conf->exists($bop_config. '-ach');
3588   my ( $processor, $login, $password, $action, @bop_options ) =
3589     $conf->config($bop_config);
3590   $action ||= 'normal authorization';
3591   pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
3592   die "No real-time processor is enabled - ".
3593       "did you set the business-onlinepayment configuration value?\n"
3594     unless $processor;
3595
3596   ( $processor, $login, $password, $action, @bop_options )
3597 }
3598
3599 =item remove_cvv
3600
3601 Removes the I<paycvv> field from the database directly.
3602
3603 If there is an error, returns the error, otherwise returns false.
3604
3605 =cut
3606
3607 sub remove_cvv {
3608   my $self = shift;
3609   my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
3610     or return dbh->errstr;
3611   $sth->execute($self->custnum)
3612     or return $sth->errstr;
3613   $self->paycvv('');
3614   '';
3615 }
3616
3617 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
3618
3619 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
3620 via a Business::OnlinePayment realtime gateway.  See
3621 L<http://420.am/business-onlinepayment> for supported gateways.
3622
3623 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3624
3625 Available options are: I<amount>, I<reason>, I<paynum>, I<paydate>
3626
3627 Most gateways require a reference to an original payment transaction to refund,
3628 so you probably need to specify a I<paynum>.
3629
3630 I<amount> defaults to the original amount of the payment if not specified.
3631
3632 I<reason> specifies a reason for the refund.
3633
3634 I<paydate> specifies the expiration date for a credit card overriding the
3635 value from the customer record or the payment record. Specified as yyyy-mm-dd
3636
3637 Implementation note: If I<amount> is unspecified or equal to the amount of the
3638 orignal payment, first an attempt is made to "void" the transaction via
3639 the gateway (to cancel a not-yet settled transaction) and then if that fails,
3640 the normal attempt is made to "refund" ("credit") the transaction via the
3641 gateway is attempted.
3642
3643 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3644 #I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
3645 #if set, will override the value from the customer record.
3646
3647 #If an I<invnum> is specified, this payment (if successful) is applied to the
3648 #specified invoice.  If you don't specify an I<invnum> you might want to
3649 #call the B<apply_payments> method.
3650
3651 =cut
3652
3653 #some false laziness w/realtime_bop, not enough to make it worth merging
3654 #but some useful small subs should be pulled out
3655 sub realtime_refund_bop {
3656   my( $self, $method, %options ) = @_;
3657   if ( $DEBUG ) {
3658     warn "$me realtime_refund_bop: $method refund\n";
3659     warn "  $_ => $options{$_}\n" foreach keys %options;
3660   }
3661
3662   eval "use Business::OnlinePayment";
3663   die $@ if $@;
3664
3665   ###
3666   # look up the original payment and optionally a gateway for that payment
3667   ###
3668
3669   my $cust_pay = '';
3670   my $amount = $options{'amount'};
3671
3672   my( $processor, $login, $password, @bop_options ) ;
3673   my( $auth, $order_number ) = ( '', '', '' );
3674
3675   if ( $options{'paynum'} ) {
3676
3677     warn "  paynum: $options{paynum}\n" if $DEBUG > 1;
3678     $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
3679       or return "Unknown paynum $options{'paynum'}";
3680     $amount ||= $cust_pay->paid;
3681
3682     $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-\/ ]*)(:([\w\-]+))?$/
3683       or return "Can't parse paybatch for paynum $options{'paynum'}: ".
3684                 $cust_pay->paybatch;
3685     my $gatewaynum = '';
3686     ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
3687
3688     if ( $gatewaynum ) { #gateway for the payment to be refunded
3689
3690       my $payment_gateway =
3691         qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
3692       die "payment gateway $gatewaynum not found"
3693         unless $payment_gateway;
3694
3695       $processor   = $payment_gateway->gateway_module;
3696       $login       = $payment_gateway->gateway_username;
3697       $password    = $payment_gateway->gateway_password;
3698       @bop_options = $payment_gateway->options;
3699
3700     } else { #try the default gateway
3701
3702       my( $conf_processor, $unused_action );
3703       ( $conf_processor, $login, $password, $unused_action, @bop_options ) =
3704         $self->default_payment_gateway($method);
3705
3706       return "processor of payment $options{'paynum'} $processor does not".
3707              " match default processor $conf_processor"
3708         unless $processor eq $conf_processor;
3709
3710     }
3711
3712
3713   } else { # didn't specify a paynum, so look for agent gateway overrides
3714            # like a normal transaction
3715
3716     my $cardtype;
3717     if ( $method eq 'CC' ) {
3718       $cardtype = cardtype($self->payinfo);
3719     } elsif ( $method eq 'ECHECK' ) {
3720       $cardtype = 'ACH';
3721     } else {
3722       $cardtype = $method;
3723     }
3724     my $override =
3725            qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3726                                                cardtype => $cardtype,
3727                                                taxclass => '',              } )
3728         || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3729                                                cardtype => '',
3730                                                taxclass => '',              } );
3731
3732     if ( $override ) { #use a payment gateway override
3733
3734       my $payment_gateway = $override->payment_gateway;
3735
3736       $processor   = $payment_gateway->gateway_module;
3737       $login       = $payment_gateway->gateway_username;
3738       $password    = $payment_gateway->gateway_password;
3739       #$action      = $payment_gateway->gateway_action;
3740       @bop_options = $payment_gateway->options;
3741
3742     } else { #use the standard settings from the config
3743
3744       my $unused_action;
3745       ( $processor, $login, $password, $unused_action, @bop_options ) =
3746         $self->default_payment_gateway($method);
3747
3748     }
3749
3750   }
3751   return "neither amount nor paynum specified" unless $amount;
3752
3753   my %content = (
3754     'type'           => $method,
3755     'login'          => $login,
3756     'password'       => $password,
3757     'order_number'   => $order_number,
3758     'amount'         => $amount,
3759     'referer'        => 'http://cleanwhisker.420.am/',
3760   );
3761   $content{authorization} = $auth
3762     if length($auth); #echeck/ACH transactions have an order # but no auth
3763                       #(at least with authorize.net)
3764
3765   my $disable_void_after;
3766   if ($conf->exists('disable_void_after')
3767       && $conf->config('disable_void_after') =~ /^(\d+)$/) {
3768     $disable_void_after = $1;
3769   }
3770
3771   #first try void if applicable
3772   if ( $cust_pay && $cust_pay->paid == $amount
3773     && (
3774       ( not defined($disable_void_after) )
3775       || ( time < ($cust_pay->_date + $disable_void_after ) )
3776     )
3777   ) {
3778     warn "  attempting void\n" if $DEBUG > 1;
3779     my $void = new Business::OnlinePayment( $processor, @bop_options );
3780     $void->content( 'action' => 'void', %content );
3781     $void->submit();
3782     if ( $void->is_success ) {
3783       my $error = $cust_pay->void($options{'reason'});
3784       if ( $error ) {
3785         # gah, even with transactions.
3786         my $e = 'WARNING: Card/ACH voided but database not updated - '.
3787                 "error voiding payment: $error";
3788         warn $e;
3789         return $e;
3790       }
3791       warn "  void successful\n" if $DEBUG > 1;
3792       return '';
3793     }
3794   }
3795
3796   warn "  void unsuccessful, trying refund\n"
3797     if $DEBUG > 1;
3798
3799   #massage data
3800   my $address = $self->address1;
3801   $address .= ", ". $self->address2 if $self->address2;
3802
3803   my($payname, $payfirst, $paylast);
3804   if ( $self->payname && $method ne 'ECHECK' ) {
3805     $payname = $self->payname;
3806     $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3807       or return "Illegal payname $payname";
3808     ($payfirst, $paylast) = ($1, $2);
3809   } else {
3810     $payfirst = $self->getfield('first');
3811     $paylast = $self->getfield('last');
3812     $payname =  "$payfirst $paylast";
3813   }
3814
3815   my @invoicing_list = $self->invoicing_list_emailonly;
3816   if ( $conf->exists('emailinvoiceautoalways')
3817        || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3818        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3819     push @invoicing_list, $self->all_emails;
3820   }
3821
3822   my $email = ($conf->exists('business-onlinepayment-email-override'))
3823               ? $conf->config('business-onlinepayment-email-override')
3824               : $invoicing_list[0];
3825
3826   my $payip = exists($options{'payip'})
3827                 ? $options{'payip'}
3828                 : $self->payip;
3829   $content{customer_ip} = $payip
3830     if length($payip);
3831
3832   my $payinfo = '';
3833   if ( $method eq 'CC' ) {
3834
3835     if ( $cust_pay ) {
3836       $content{card_number} = $payinfo = $cust_pay->payinfo;
3837       (exists($options{'paydate'}) ? $options{'paydate'} : $cust_pay->paydate)
3838         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/ &&
3839         ($content{expiration} = "$2/$1");  # where available
3840     } else {
3841       $content{card_number} = $payinfo = $self->payinfo;
3842       (exists($options{'paydate'}) ? $options{'paydate'} : $self->paydate)
3843         =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3844       $content{expiration} = "$2/$1";
3845     }
3846
3847   } elsif ( $method eq 'ECHECK' ) {
3848
3849     if ( $cust_pay ) {
3850       $payinfo = $cust_pay->payinfo;
3851     } else {
3852       $payinfo = $self->payinfo;
3853     }
3854     ( $content{account_number}, $content{routing_code} )= split('@', $payinfo );
3855     $content{bank_name} = $self->payname;
3856     $content{account_type} = 'CHECKING';
3857     $content{account_name} = $payname;
3858     $content{customer_org} = $self->company ? 'B' : 'I';
3859     $content{customer_ssn} = $self->ss;
3860   } elsif ( $method eq 'LEC' ) {
3861     $content{phone} = $payinfo = $self->payinfo;
3862   }
3863
3864   #then try refund
3865   my $refund = new Business::OnlinePayment( $processor, @bop_options );
3866   my %sub_content = $refund->content(
3867     'action'         => 'credit',
3868     'customer_id'    => $self->custnum,
3869     'last_name'      => $paylast,
3870     'first_name'     => $payfirst,
3871     'name'           => $payname,
3872     'address'        => $address,
3873     'city'           => $self->city,
3874     'state'          => $self->state,
3875     'zip'            => $self->zip,
3876     'country'        => $self->country,
3877     'email'          => $email,
3878     'phone'          => $self->daytime || $self->night,
3879     %content, #after
3880   );
3881   warn join('', map { "  $_ => $sub_content{$_}\n" } keys %sub_content )
3882     if $DEBUG > 1;
3883   $refund->submit();
3884
3885   return "$processor error: ". $refund->error_message
3886     unless $refund->is_success();
3887
3888   my %method2payby = (
3889     'CC'     => 'CARD',
3890     'ECHECK' => 'CHEK',
3891     'LEC'    => 'LECB',
3892   );
3893
3894   my $paybatch = "$processor:". $refund->authorization;
3895   $paybatch .= ':'. $refund->order_number
3896     if $refund->can('order_number') && $refund->order_number;
3897
3898   while ( $cust_pay && $cust_pay->unapplied < $amount ) {
3899     my @cust_bill_pay = $cust_pay->cust_bill_pay;
3900     last unless @cust_bill_pay;
3901     my $cust_bill_pay = pop @cust_bill_pay;
3902     my $error = $cust_bill_pay->delete;
3903     last if $error;
3904   }
3905
3906   my $cust_refund = new FS::cust_refund ( {
3907     'custnum'  => $self->custnum,
3908     'paynum'   => $options{'paynum'},
3909     'refund'   => $amount,
3910     '_date'    => '',
3911     'payby'    => $method2payby{$method},
3912     'payinfo'  => $payinfo,
3913     'paybatch' => $paybatch,
3914     'reason'   => $options{'reason'} || 'card or ACH refund',
3915   } );
3916   my $error = $cust_refund->insert;
3917   if ( $error ) {
3918     $cust_refund->paynum(''); #try again with no specific paynum
3919     my $error2 = $cust_refund->insert;
3920     if ( $error2 ) {
3921       # gah, even with transactions.
3922       my $e = 'WARNING: Card/ACH refunded but database not updated - '.
3923               "error inserting refund ($processor): $error2".
3924               " (previously tried insert with paynum #$options{'paynum'}" .
3925               ": $error )";
3926       warn $e;
3927       return $e;
3928     }
3929   }
3930
3931   ''; #no error
3932
3933 }
3934
3935 =item batch_card OPTION => VALUE...
3936
3937 Adds a payment for this invoice to the pending credit card batch (see
3938 L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value,
3939 runs the payment using a realtime gateway.
3940
3941 =cut
3942
3943 sub batch_card {
3944   my ($self, %options) = @_;
3945
3946   my $amount;
3947   if (exists($options{amount})) {
3948     $amount = $options{amount};
3949   }else{
3950     $amount = sprintf("%.2f", $self->balance - $self->in_transit_payments);
3951   }
3952   return '' unless $amount > 0;
3953
3954   my $invnum = delete $options{invnum};
3955   my $payby = $options{invnum} || $self->payby;  #dubious
3956
3957   if ($options{'realtime'}) {
3958     return $self->realtime_bop( FS::payby->payby2bop($self->payby),
3959                                 $amount,
3960                                 %options,
3961                               );
3962   }
3963
3964   my $oldAutoCommit = $FS::UID::AutoCommit;
3965   local $FS::UID::AutoCommit = 0;
3966   my $dbh = dbh;
3967
3968   #this needs to handle mysql as well as Pg, like svc_acct.pm
3969   #(make it into a common function if folks need to do batching with mysql)
3970   $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE")
3971     or return "Cannot lock pay_batch: " . $dbh->errstr;
3972
3973   my %pay_batch = (
3974     'status' => 'O',
3975     'payby'  => FS::payby->payby2payment($payby),
3976   );
3977
3978   my $pay_batch = qsearchs( 'pay_batch', \%pay_batch );
3979
3980   unless ( $pay_batch ) {
3981     $pay_batch = new FS::pay_batch \%pay_batch;
3982     my $error = $pay_batch->insert;
3983     if ( $error ) {
3984       $dbh->rollback if $oldAutoCommit;
3985       die "error creating new batch: $error\n";
3986     }
3987   }
3988
3989   my $old_cust_pay_batch = qsearchs('cust_pay_batch', {
3990       'batchnum' => $pay_batch->batchnum,
3991       'custnum'  => $self->custnum,
3992   } );
3993
3994   foreach (qw( address1 address2 city state zip country payby payinfo paydate
3995                payname )) {
3996     $options{$_} = '' unless exists($options{$_});
3997   }
3998
3999   my $cust_pay_batch = new FS::cust_pay_batch ( {
4000     'batchnum' => $pay_batch->batchnum,
4001     'invnum'   => $invnum || 0,                    # is there a better value?
4002                                                    # this field should be
4003                                                    # removed...
4004                                                    # cust_bill_pay_batch now
4005     'custnum'  => $self->custnum,
4006     'last'     => $self->getfield('last'),
4007     'first'    => $self->getfield('first'),
4008     'address1' => $options{address1} || $self->address1,
4009     'address2' => $options{address2} || $self->address2,
4010     'city'     => $options{city}     || $self->city,
4011     'state'    => $options{state}    || $self->state,
4012     'zip'      => $options{zip}      || $self->zip,
4013     'country'  => $options{country}  || $self->country,
4014     'payby'    => $options{payby}    || $self->payby,
4015     'payinfo'  => $options{payinfo}  || $self->payinfo,
4016     'exp'      => $options{paydate}  || $self->paydate,
4017     'payname'  => $options{payname}  || $self->payname,
4018     'amount'   => $amount,                         # consolidating
4019   } );
4020
4021   $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum)
4022     if $old_cust_pay_batch;
4023
4024   my $error;
4025   if ($old_cust_pay_batch) {
4026     $error = $cust_pay_batch->replace($old_cust_pay_batch)
4027   } else {
4028     $error = $cust_pay_batch->insert;
4029   }
4030
4031   if ( $error ) {
4032     $dbh->rollback if $oldAutoCommit;
4033     die $error;
4034   }
4035
4036   my $unapplied = $self->total_credited + $self->total_unapplied_payments + $self->in_transit_payments;
4037   foreach my $cust_bill ($self->open_cust_bill) {
4038     #$dbh->commit or die $dbh->errstr if $oldAutoCommit;
4039     my $cust_bill_pay_batch = new FS::cust_bill_pay_batch {
4040       'invnum' => $cust_bill->invnum,
4041       'paybatchnum' => $cust_pay_batch->paybatchnum,
4042       'amount' => $cust_bill->owed,
4043       '_date' => time,
4044     };
4045     if ($unapplied >= $cust_bill_pay_batch->amount){
4046       $unapplied -= $cust_bill_pay_batch->amount;
4047       next;
4048     }else{
4049       $cust_bill_pay_batch->amount(sprintf ( "%.2f",
4050                                    $cust_bill_pay_batch->amount - $unapplied ));      $unapplied = 0;
4051     }
4052     $error = $cust_bill_pay_batch->insert;
4053     if ( $error ) {
4054       $dbh->rollback if $oldAutoCommit;
4055       die $error;
4056     }
4057   }
4058
4059   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4060   '';
4061 }
4062
4063 =item total_owed
4064
4065 Returns the total owed for this customer on all invoices
4066 (see L<FS::cust_bill/owed>).
4067
4068 =cut
4069
4070 sub total_owed {
4071   my $self = shift;
4072   $self->total_owed_date(2145859200); #12/31/2037
4073 }
4074
4075 =item total_owed_date TIME
4076
4077 Returns the total owed for this customer on all invoices with date earlier than
4078 TIME.  TIME is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also
4079 see L<Time::Local> and L<Date::Parse> for conversion functions.
4080
4081 =cut
4082
4083 sub total_owed_date {
4084   my $self = shift;
4085   my $time = shift;
4086   my $total_bill = 0;
4087   foreach my $cust_bill (
4088     grep { $_->_date <= $time }
4089       qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4090   ) {
4091     $total_bill += $cust_bill->owed;
4092   }
4093   sprintf( "%.2f", $total_bill );
4094 }
4095
4096 =item apply_payments_and_credits
4097
4098 Applies unapplied payments and credits.
4099
4100 In most cases, this new method should be used in place of sequential
4101 apply_payments and apply_credits methods.
4102
4103 If there is an error, returns the error, otherwise returns false.
4104
4105 =cut
4106
4107 sub apply_payments_and_credits {
4108   my $self = shift;
4109
4110   local $SIG{HUP} = 'IGNORE';
4111   local $SIG{INT} = 'IGNORE';
4112   local $SIG{QUIT} = 'IGNORE';
4113   local $SIG{TERM} = 'IGNORE';
4114   local $SIG{TSTP} = 'IGNORE';
4115   local $SIG{PIPE} = 'IGNORE';
4116
4117   my $oldAutoCommit = $FS::UID::AutoCommit;
4118   local $FS::UID::AutoCommit = 0;
4119   my $dbh = dbh;
4120
4121   $self->select_for_update; #mutex
4122
4123   foreach my $cust_bill ( $self->open_cust_bill ) {
4124     my $error = $cust_bill->apply_payments_and_credits;
4125     if ( $error ) {
4126       $dbh->rollback if $oldAutoCommit;
4127       return "Error applying: $error";
4128     }
4129   }
4130
4131   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4132   ''; #no error
4133
4134 }
4135
4136 =item apply_credits OPTION => VALUE ...
4137
4138 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
4139 to outstanding invoice balances in chronological order (or reverse
4140 chronological order if the I<order> option is set to B<newest>) and returns the
4141 value of any remaining unapplied credits available for refund (see
4142 L<FS::cust_refund>).
4143
4144 Dies if there is an error.
4145
4146 =cut
4147
4148 sub apply_credits {
4149   my $self = shift;
4150   my %opt = @_;
4151
4152   local $SIG{HUP} = 'IGNORE';
4153   local $SIG{INT} = 'IGNORE';
4154   local $SIG{QUIT} = 'IGNORE';
4155   local $SIG{TERM} = 'IGNORE';
4156   local $SIG{TSTP} = 'IGNORE';
4157   local $SIG{PIPE} = 'IGNORE';
4158
4159   my $oldAutoCommit = $FS::UID::AutoCommit;
4160   local $FS::UID::AutoCommit = 0;
4161   my $dbh = dbh;
4162
4163   $self->select_for_update; #mutex
4164
4165   unless ( $self->total_credited ) {
4166     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4167     return 0;
4168   }
4169
4170   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
4171       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
4172
4173   my @invoices = $self->open_cust_bill;
4174   @invoices = sort { $b->_date <=> $a->_date } @invoices
4175     if defined($opt{'order'}) && $opt{'order'} eq 'newest';
4176
4177   my $credit;
4178   foreach my $cust_bill ( @invoices ) {
4179     my $amount;
4180
4181     if ( !defined($credit) || $credit->credited == 0) {
4182       $credit = pop @credits or last;
4183     }
4184
4185     if ($cust_bill->owed >= $credit->credited) {
4186       $amount=$credit->credited;
4187     }else{
4188       $amount=$cust_bill->owed;
4189     }
4190
4191     my $cust_credit_bill = new FS::cust_credit_bill ( {
4192       'crednum' => $credit->crednum,
4193       'invnum'  => $cust_bill->invnum,
4194       'amount'  => $amount,
4195     } );
4196     my $error = $cust_credit_bill->insert;
4197     if ( $error ) {
4198       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4199       die $error;
4200     }
4201
4202     redo if ($cust_bill->owed > 0);
4203
4204   }
4205
4206   my $total_credited = $self->total_credited;
4207
4208   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4209
4210   return $total_credited;
4211 }
4212
4213 =item apply_payments
4214
4215 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
4216 to outstanding invoice balances in chronological order.
4217
4218  #and returns the value of any remaining unapplied payments.
4219
4220 Dies if there is an error.
4221
4222 =cut
4223
4224 sub apply_payments {
4225   my $self = shift;
4226
4227   local $SIG{HUP} = 'IGNORE';
4228   local $SIG{INT} = 'IGNORE';
4229   local $SIG{QUIT} = 'IGNORE';
4230   local $SIG{TERM} = 'IGNORE';
4231   local $SIG{TSTP} = 'IGNORE';
4232   local $SIG{PIPE} = 'IGNORE';
4233
4234   my $oldAutoCommit = $FS::UID::AutoCommit;
4235   local $FS::UID::AutoCommit = 0;
4236   my $dbh = dbh;
4237
4238   $self->select_for_update; #mutex
4239
4240   #return 0 unless
4241
4242   my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
4243       qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
4244
4245   my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
4246       qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
4247
4248   my $payment;
4249
4250   foreach my $cust_bill ( @invoices ) {
4251     my $amount;
4252
4253     if ( !defined($payment) || $payment->unapplied == 0 ) {
4254       $payment = pop @payments or last;
4255     }
4256
4257     if ( $cust_bill->owed >= $payment->unapplied ) {
4258       $amount = $payment->unapplied;
4259     } else {
4260       $amount = $cust_bill->owed;
4261     }
4262
4263     my $cust_bill_pay = new FS::cust_bill_pay ( {
4264       'paynum' => $payment->paynum,
4265       'invnum' => $cust_bill->invnum,
4266       'amount' => $amount,
4267     } );
4268     my $error = $cust_bill_pay->insert;
4269     if ( $error ) {
4270       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4271       die $error;
4272     }
4273
4274     redo if ( $cust_bill->owed > 0);
4275
4276   }
4277
4278   my $total_unapplied_payments = $self->total_unapplied_payments;
4279
4280   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4281
4282   return $total_unapplied_payments;
4283 }
4284
4285 =item total_credited
4286
4287 Returns the total outstanding credit (see L<FS::cust_credit>) for this
4288 customer.  See L<FS::cust_credit/credited>.
4289
4290 =cut
4291
4292 sub total_credited {
4293   my $self = shift;
4294   my $total_credit = 0;
4295   foreach my $cust_credit ( qsearch('cust_credit', {
4296     'custnum' => $self->custnum,
4297   } ) ) {
4298     $total_credit += $cust_credit->credited;
4299   }
4300   sprintf( "%.2f", $total_credit );
4301 }
4302
4303 =item total_unapplied_payments
4304
4305 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
4306 See L<FS::cust_pay/unapplied>.
4307
4308 =cut
4309
4310 sub total_unapplied_payments {
4311   my $self = shift;
4312   my $total_unapplied = 0;
4313   foreach my $cust_pay ( qsearch('cust_pay', {
4314     'custnum' => $self->custnum,
4315   } ) ) {
4316     $total_unapplied += $cust_pay->unapplied;
4317   }
4318   sprintf( "%.2f", $total_unapplied );
4319 }
4320
4321 =item total_unapplied_refunds
4322
4323 Returns the total unrefunded refunds (see L<FS::cust_refund>) for this
4324 customer.  See L<FS::cust_refund/unapplied>.
4325
4326 =cut
4327
4328 sub total_unapplied_refunds {
4329   my $self = shift;
4330   my $total_unapplied = 0;
4331   foreach my $cust_refund ( qsearch('cust_refund', {
4332     'custnum' => $self->custnum,
4333   } ) ) {
4334     $total_unapplied += $cust_refund->unapplied;
4335   }
4336   sprintf( "%.2f", $total_unapplied );
4337 }
4338
4339 =item balance
4340
4341 Returns the balance for this customer (total_owed plus total_unrefunded, minus
4342 total_credited minus total_unapplied_payments).
4343
4344 =cut
4345
4346 sub balance {
4347   my $self = shift;
4348   sprintf( "%.2f",
4349       $self->total_owed
4350     + $self->total_unapplied_refunds
4351     - $self->total_credited
4352     - $self->total_unapplied_payments
4353   );
4354 }
4355
4356 =item balance_date TIME
4357
4358 Returns the balance for this customer, only considering invoices with date
4359 earlier than TIME (total_owed_date minus total_credited minus
4360 total_unapplied_payments).  TIME is specified as a UNIX timestamp; see
4361 L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion
4362 functions.
4363
4364 =cut
4365
4366 sub balance_date {
4367   my $self = shift;
4368   my $time = shift;
4369   sprintf( "%.2f",
4370         $self->total_owed_date($time)
4371       + $self->total_unapplied_refunds
4372       - $self->total_credited
4373       - $self->total_unapplied_payments
4374   );
4375 }
4376
4377 =item in_transit_payments
4378
4379 Returns the total of requests for payments for this customer pending in
4380 batches in transit to the bank.  See L<FS::pay_batch> and L<FS::cust_pay_batch>
4381
4382 =cut
4383
4384 sub in_transit_payments {
4385   my $self = shift;
4386   my $in_transit_payments = 0;
4387   foreach my $pay_batch ( qsearch('pay_batch', {
4388     'status' => 'I',
4389   } ) ) {
4390     foreach my $cust_pay_batch ( qsearch('cust_pay_batch', {
4391       'batchnum' => $pay_batch->batchnum,
4392       'custnum' => $self->custnum,
4393     } ) ) {
4394       $in_transit_payments += $cust_pay_batch->amount;
4395     }
4396   }
4397   sprintf( "%.2f", $in_transit_payments );
4398 }
4399
4400 =item paydate_monthyear
4401
4402 Returns a two-element list consisting of the month and year of this customer's
4403 paydate (credit card expiration date for CARD customers)
4404
4405 =cut
4406
4407 sub paydate_monthyear {
4408   my $self = shift;
4409   if ( $self->paydate  =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
4410     ( $2, $1 );
4411   } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
4412     ( $1, $3 );
4413   } else {
4414     ('', '');
4415   }
4416 }
4417
4418 =item invoicing_list [ ARRAYREF ]
4419
4420 If an arguement is given, sets these email addresses as invoice recipients
4421 (see L<FS::cust_main_invoice>).  Errors are not fatal and are not reported
4422 (except as warnings), so use check_invoicing_list first.
4423
4424 Returns a list of email addresses (with svcnum entries expanded).
4425
4426 Note: You can clear the invoicing list by passing an empty ARRAYREF.  You can
4427 check it without disturbing anything by passing nothing.
4428
4429 This interface may change in the future.
4430
4431 =cut
4432
4433 sub invoicing_list {
4434   my( $self, $arrayref ) = @_;
4435
4436   if ( $arrayref ) {
4437     my @cust_main_invoice;
4438     if ( $self->custnum ) {
4439       @cust_main_invoice =
4440         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4441     } else {
4442       @cust_main_invoice = ();
4443     }
4444     foreach my $cust_main_invoice ( @cust_main_invoice ) {
4445       #warn $cust_main_invoice->destnum;
4446       unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
4447         #warn $cust_main_invoice->destnum;
4448         my $error = $cust_main_invoice->delete;
4449         warn $error if $error;
4450       }
4451     }
4452     if ( $self->custnum ) {
4453       @cust_main_invoice =
4454         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4455     } else {
4456       @cust_main_invoice = ();
4457     }
4458     my %seen = map { $_->address => 1 } @cust_main_invoice;
4459     foreach my $address ( @{$arrayref} ) {
4460       next if exists $seen{$address} && $seen{$address};
4461       $seen{$address} = 1;
4462       my $cust_main_invoice = new FS::cust_main_invoice ( {
4463         'custnum' => $self->custnum,
4464         'dest'    => $address,
4465       } );
4466       my $error = $cust_main_invoice->insert;
4467       warn $error if $error;
4468     }
4469   }
4470
4471   if ( $self->custnum ) {
4472     map { $_->address }
4473       qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4474   } else {
4475     ();
4476   }
4477
4478 }
4479
4480 =item check_invoicing_list ARRAYREF
4481
4482 Checks these arguements as valid input for the invoicing_list method.  If there
4483 is an error, returns the error, otherwise returns false.
4484
4485 =cut
4486
4487 sub check_invoicing_list {
4488   my( $self, $arrayref ) = @_;
4489
4490   foreach my $address ( @$arrayref ) {
4491
4492     if ($address eq 'FAX' and $self->getfield('fax') eq '') {
4493       return 'Can\'t add FAX invoice destination with a blank FAX number.';
4494     }
4495
4496     my $cust_main_invoice = new FS::cust_main_invoice ( {
4497       'custnum' => $self->custnum,
4498       'dest'    => $address,
4499     } );
4500     my $error = $self->custnum
4501                 ? $cust_main_invoice->check
4502                 : $cust_main_invoice->checkdest
4503     ;
4504     return $error if $error;
4505
4506   }
4507
4508   return "Email address required"
4509     if $conf->exists('cust_main-require_invoicing_list_email')
4510     && ! grep { $_ !~ /^([A-Z]+)$/ } @$arrayref;
4511
4512   '';
4513 }
4514
4515 =item set_default_invoicing_list
4516
4517 Sets the invoicing list to all accounts associated with this customer,
4518 overwriting any previous invoicing list.
4519
4520 =cut
4521
4522 sub set_default_invoicing_list {
4523   my $self = shift;
4524   $self->invoicing_list($self->all_emails);
4525 }
4526
4527 =item all_emails
4528
4529 Returns the email addresses of all accounts provisioned for this customer.
4530
4531 =cut
4532
4533 sub all_emails {
4534   my $self = shift;
4535   my %list;
4536   foreach my $cust_pkg ( $self->all_pkgs ) {
4537     my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
4538     my @svc_acct =
4539       map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4540         grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4541           @cust_svc;
4542     $list{$_}=1 foreach map { $_->email } @svc_acct;
4543   }
4544   keys %list;
4545 }
4546
4547 =item invoicing_list_addpost
4548
4549 Adds postal invoicing to this customer.  If this customer is already configured
4550 to receive postal invoices, does nothing.
4551
4552 =cut
4553
4554 sub invoicing_list_addpost {
4555   my $self = shift;
4556   return if grep { $_ eq 'POST' } $self->invoicing_list;
4557   my @invoicing_list = $self->invoicing_list;
4558   push @invoicing_list, 'POST';
4559   $self->invoicing_list(\@invoicing_list);
4560 }
4561
4562 =item invoicing_list_emailonly
4563
4564 Returns the list of email invoice recipients (invoicing_list without non-email
4565 destinations such as POST and FAX).
4566
4567 =cut
4568
4569 sub invoicing_list_emailonly {
4570   my $self = shift;
4571   warn "$me invoicing_list_emailonly called"
4572     if $DEBUG;
4573   grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list;
4574 }
4575
4576 =item invoicing_list_emailonly_scalar
4577
4578 Returns the list of email invoice recipients (invoicing_list without non-email
4579 destinations such as POST and FAX) as a comma-separated scalar.
4580
4581 =cut
4582
4583 sub invoicing_list_emailonly_scalar {
4584   my $self = shift;
4585   warn "$me invoicing_list_emailonly_scalar called"
4586     if $DEBUG;
4587   join(', ', $self->invoicing_list_emailonly);
4588 }
4589
4590 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
4591
4592 Returns an array of customers referred by this customer (referral_custnum set
4593 to this custnum).  If DEPTH is given, recurses up to the given depth, returning
4594 customers referred by customers referred by this customer and so on, inclusive.
4595 The default behavior is DEPTH 1 (no recursion).
4596
4597 =cut
4598
4599 sub referral_cust_main {
4600   my $self = shift;
4601   my $depth = @_ ? shift : 1;
4602   my $exclude = @_ ? shift : {};
4603
4604   my @cust_main =
4605     map { $exclude->{$_->custnum}++; $_; }
4606       grep { ! $exclude->{ $_->custnum } }
4607         qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
4608
4609   if ( $depth > 1 ) {
4610     push @cust_main,
4611       map { $_->referral_cust_main($depth-1, $exclude) }
4612         @cust_main;
4613   }
4614
4615   @cust_main;
4616 }
4617
4618 =item referral_cust_main_ncancelled
4619
4620 Same as referral_cust_main, except only returns customers with uncancelled
4621 packages.
4622
4623 =cut
4624
4625 sub referral_cust_main_ncancelled {
4626   my $self = shift;
4627   grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
4628 }
4629
4630 =item referral_cust_pkg [ DEPTH ]
4631
4632 Like referral_cust_main, except returns a flat list of all unsuspended (and
4633 uncancelled) packages for each customer.  The number of items in this list may
4634 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
4635
4636 =cut
4637
4638 sub referral_cust_pkg {
4639   my $self = shift;
4640   my $depth = @_ ? shift : 1;
4641
4642   map { $_->unsuspended_pkgs }
4643     grep { $_->unsuspended_pkgs }
4644       $self->referral_cust_main($depth);
4645 }
4646
4647 =item referring_cust_main
4648
4649 Returns the single cust_main record for the customer who referred this customer
4650 (referral_custnum), or false.
4651
4652 =cut
4653
4654 sub referring_cust_main {
4655   my $self = shift;
4656   return '' unless $self->referral_custnum;
4657   qsearchs('cust_main', { 'custnum' => $self->referral_custnum } );
4658 }
4659
4660 =item credit AMOUNT, REASON
4661
4662 Applies a credit to this customer.  If there is an error, returns the error,
4663 otherwise returns false.
4664
4665 =cut
4666
4667 sub credit {
4668   my( $self, $amount, $reason, %options ) = @_;
4669   my $cust_credit = new FS::cust_credit {
4670     'custnum' => $self->custnum,
4671     'amount'  => $amount,
4672     'reason'  => $reason,
4673   };
4674   $cust_credit->insert(%options);
4675 }
4676
4677 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
4678
4679 Creates a one-time charge for this customer.  If there is an error, returns
4680 the error, otherwise returns false.
4681
4682 =cut
4683
4684 sub charge {
4685   my $self = shift;
4686   my ( $amount, $quantity, $pkg, $comment, $taxclass, $additional, $classnum );
4687   if ( ref( $_[0] ) ) {
4688     $amount     = $_[0]->{amount};
4689     $quantity   = exists($_[0]->{quantity}) ? $_[0]->{quantity} : 1;
4690     $pkg        = exists($_[0]->{pkg}) ? $_[0]->{pkg} : 'One-time charge';
4691     $comment    = exists($_[0]->{comment}) ? $_[0]->{comment}
4692                                            : '$'. sprintf("%.2f",$amount);
4693     $taxclass   = exists($_[0]->{taxclass}) ? $_[0]->{taxclass} : '';
4694     $classnum   = exists($_[0]->{classnum}) ? $_[0]->{classnum} : '';
4695     $additional = $_[0]->{additional};
4696   }else{
4697     $amount     = shift;
4698     $quantity   = 1;
4699     $pkg        = @_ ? shift : 'One-time charge';
4700     $comment    = @_ ? shift : '$'. sprintf("%.2f",$amount);
4701     $taxclass   = @_ ? shift : '';
4702     $additional = [];
4703   }
4704
4705   local $SIG{HUP} = 'IGNORE';
4706   local $SIG{INT} = 'IGNORE';
4707   local $SIG{QUIT} = 'IGNORE';
4708   local $SIG{TERM} = 'IGNORE';
4709   local $SIG{TSTP} = 'IGNORE';
4710   local $SIG{PIPE} = 'IGNORE';
4711
4712   my $oldAutoCommit = $FS::UID::AutoCommit;
4713   local $FS::UID::AutoCommit = 0;
4714   my $dbh = dbh;
4715
4716   my $part_pkg = new FS::part_pkg ( {
4717     'pkg'      => $pkg,
4718     'comment'  => $comment,
4719     'plan'     => 'flat',
4720     'freq'     => 0,
4721     'disabled' => 'Y',
4722     'classnum' => $classnum ? $classnum : '',
4723     'taxclass' => $taxclass,
4724   } );
4725
4726   my %options = ( ( map { ("additional_info$_" => $additional->[$_] ) }
4727                         ( 0 .. @$additional - 1 )
4728                   ),
4729                   'additional_count' => scalar(@$additional),
4730                   'setup_fee' => $amount,
4731                 );
4732
4733   my $error = $part_pkg->insert( options => \%options );
4734   if ( $error ) {
4735     $dbh->rollback if $oldAutoCommit;
4736     return $error;
4737   }
4738
4739   my $pkgpart = $part_pkg->pkgpart;
4740   my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
4741   unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
4742     my $type_pkgs = new FS::type_pkgs \%type_pkgs;
4743     $error = $type_pkgs->insert;
4744     if ( $error ) {
4745       $dbh->rollback if $oldAutoCommit;
4746       return $error;
4747     }
4748   }
4749
4750   my $cust_pkg = new FS::cust_pkg ( {
4751     'custnum'  => $self->custnum,
4752     'pkgpart'  => $pkgpart,
4753     'quantity' => $quantity,
4754   } );
4755
4756   $error = $cust_pkg->insert;
4757   if ( $error ) {
4758     $dbh->rollback if $oldAutoCommit;
4759     return $error;
4760   }
4761
4762   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4763   '';
4764
4765 }
4766
4767 =item cust_bill
4768
4769 Returns all the invoices (see L<FS::cust_bill>) for this customer.
4770
4771 =cut
4772
4773 sub cust_bill {
4774   my $self = shift;
4775   sort { $a->_date <=> $b->_date }
4776     qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4777 }
4778
4779 =item open_cust_bill
4780
4781 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
4782 customer.
4783
4784 =cut
4785
4786 sub open_cust_bill {
4787   my $self = shift;
4788   grep { $_->owed > 0 } $self->cust_bill;
4789 }
4790
4791 =item cust_credit
4792
4793 Returns all the credits (see L<FS::cust_credit>) for this customer.
4794
4795 =cut
4796
4797 sub cust_credit {
4798   my $self = shift;
4799   sort { $a->_date <=> $b->_date }
4800     qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
4801 }
4802
4803 =item cust_pay
4804
4805 Returns all the payments (see L<FS::cust_pay>) for this customer.
4806
4807 =cut
4808
4809 sub cust_pay {
4810   my $self = shift;
4811   sort { $a->_date <=> $b->_date }
4812     qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
4813 }
4814
4815 =item cust_pay_void
4816
4817 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
4818
4819 =cut
4820
4821 sub cust_pay_void {
4822   my $self = shift;
4823   sort { $a->_date <=> $b->_date }
4824     qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
4825 }
4826
4827 =item cust_pay_batch
4828
4829 Returns all batched payments (see L<FS::cust_pay_void>) for this customer.
4830
4831 =cut
4832
4833 sub cust_pay_batch {
4834   my $self = shift;
4835   sort { $a->_date <=> $b->_date }
4836     qsearch( 'cust_pay_batch', { 'custnum' => $self->custnum } )
4837 }
4838
4839 =item cust_refund
4840
4841 Returns all the refunds (see L<FS::cust_refund>) for this customer.
4842
4843 =cut
4844
4845 sub cust_refund {
4846   my $self = shift;
4847   sort { $a->_date <=> $b->_date }
4848     qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
4849 }
4850
4851 =item name
4852
4853 Returns a name string for this customer, either "Company (Last, First)" or
4854 "Last, First".
4855
4856 =cut
4857
4858 sub name {
4859   my $self = shift;
4860   my $name = $self->contact;
4861   $name = $self->company. " ($name)" if $self->company;
4862   $name;
4863 }
4864
4865 =item ship_name
4866
4867 Returns a name string for this (service/shipping) contact, either
4868 "Company (Last, First)" or "Last, First".
4869
4870 =cut
4871
4872 sub ship_name {
4873   my $self = shift;
4874   if ( $self->get('ship_last') ) {
4875     my $name = $self->ship_contact;
4876     $name = $self->ship_company. " ($name)" if $self->ship_company;
4877     $name;
4878   } else {
4879     $self->name;
4880   }
4881 }
4882
4883 =item contact
4884
4885 Returns this customer's full (billing) contact name only, "Last, First"
4886
4887 =cut
4888
4889 sub contact {
4890   my $self = shift;
4891   $self->get('last'). ', '. $self->first;
4892 }
4893
4894 =item ship_contact
4895
4896 Returns this customer's full (shipping) contact name only, "Last, First"
4897
4898 =cut
4899
4900 sub ship_contact {
4901   my $self = shift;
4902   $self->get('ship_last')
4903     ? $self->get('ship_last'). ', '. $self->ship_first
4904     : $self->contact;
4905 }
4906
4907 =item country_full
4908
4909 Returns this customer's full country name
4910
4911 =cut
4912
4913 sub country_full {
4914   my $self = shift;
4915   code2country($self->country);
4916 }
4917
4918 =item geocode DATA_VENDOR
4919
4920 Returns a value for the customer location as encoded by DATA_VENDOR.
4921 Currently this only makes sense for "CCH" as DATA_VENDOR.
4922
4923 =cut
4924
4925 sub geocode {
4926   my ($self, $data_vendor) = (shift, shift);  #always cch for now
4927
4928   my $prefix = ( $conf->exists('tax-ship_address') && length($self->ship_last) )
4929                ? 'ship_'
4930                : '';
4931
4932   my ($zip,$plus4) = split /-/, $self->get("${prefix}zip")
4933     if $self->country eq 'US';
4934
4935   #CCH specific location stuff
4936   my $extra_sql = "AND plus4lo <= '$plus4' AND plus4hi >= '$plus4'";
4937
4938   my $geocode = '';
4939   my $cust_tax_location =
4940     qsearchs( {
4941                 'table'     => 'cust_tax_location',
4942                 'hashref'   => { 'zip' => $zip, 'data_vendor' => $data_vendor },
4943                 'extra_sql' => $extra_sql,
4944               }
4945             );
4946   $geocode = $cust_tax_location->geocode
4947     if $cust_tax_location;
4948
4949   $geocode;
4950 }
4951
4952 =item cust_status
4953
4954 =item status
4955
4956 Returns a status string for this customer, currently:
4957
4958 =over 4
4959
4960 =item prospect - No packages have ever been ordered
4961
4962 =item active - One or more recurring packages is active
4963
4964 =item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled)
4965
4966 =item suspended - All non-cancelled recurring packages are suspended
4967
4968 =item cancelled - All recurring packages are cancelled
4969
4970 =back
4971
4972 =cut
4973
4974 sub status { shift->cust_status(@_); }
4975
4976 sub cust_status {
4977   my $self = shift;
4978   for my $status (qw( prospect active inactive suspended cancelled )) {
4979     my $method = $status.'_sql';
4980     my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
4981     my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
4982     $sth->execute( ($self->custnum) x $numnum )
4983       or die "Error executing 'SELECT $sql': ". $sth->errstr;
4984     return $status if $sth->fetchrow_arrayref->[0];
4985   }
4986 }
4987
4988 =item ucfirst_cust_status
4989
4990 =item ucfirst_status
4991
4992 Returns the status with the first character capitalized.
4993
4994 =cut
4995
4996 sub ucfirst_status { shift->ucfirst_cust_status(@_); }
4997
4998 sub ucfirst_cust_status {
4999   my $self = shift;
5000   ucfirst($self->cust_status);
5001 }
5002
5003 =item statuscolor
5004
5005 Returns a hex triplet color string for this customer's status.
5006
5007 =cut
5008
5009 use vars qw(%statuscolor);
5010 tie my %statuscolor, 'Tie::IxHash',
5011   'prospect'  => '7e0079', #'000000', #black?  naw, purple
5012   'active'    => '00CC00', #green
5013   'inactive'  => '0000CC', #blue
5014   'suspended' => 'FF9900', #yellow
5015   'cancelled' => 'FF0000', #red
5016 ;
5017
5018 sub statuscolor { shift->cust_statuscolor(@_); }
5019
5020 sub cust_statuscolor {
5021   my $self = shift;
5022   $statuscolor{$self->cust_status};
5023 }
5024
5025 =item tickets
5026
5027 Returns an array of hashes representing the customer's RT tickets.
5028
5029 =cut
5030
5031 sub tickets {
5032   my $self = shift;
5033
5034   my $num = $conf->config('cust_main-max_tickets') || 10;
5035   my @tickets = ();
5036
5037   unless ( $conf->config('ticket_system-custom_priority_field') ) {
5038
5039     @tickets = @{ FS::TicketSystem->customer_tickets($self->custnum, $num) };
5040
5041   } else {
5042
5043     foreach my $priority (
5044       $conf->config('ticket_system-custom_priority_field-values'), ''
5045     ) {
5046       last if scalar(@tickets) >= $num;
5047       push @tickets,
5048         @{ FS::TicketSystem->customer_tickets( $self->custnum,
5049                                                $num - scalar(@tickets),
5050                                                $priority,
5051                                              )
5052          };
5053     }
5054   }
5055   (@tickets);
5056 }
5057
5058 # Return services representing svc_accts in customer support packages
5059 sub support_services {
5060   my $self = shift;
5061   my %packages = map { $_ => 1 } $conf->config('support_packages');
5062
5063   grep { $_->pkg_svc && $_->pkg_svc->primary_svc eq 'Y' }
5064     grep { $_->part_svc->svcdb eq 'svc_acct' }
5065     map { $_->cust_svc }
5066     grep { exists $packages{ $_->pkgpart } }
5067     $self->ncancelled_pkgs;
5068
5069 }
5070
5071 =back
5072
5073 =head1 CLASS METHODS
5074
5075 =over 4
5076
5077 =item statuses
5078
5079 Class method that returns the list of possible status strings for customers
5080 (see L<the status method|/status>).  For example:
5081
5082   @statuses = FS::cust_main->statuses();
5083
5084 =cut
5085
5086 sub statuses {
5087   #my $self = shift; #could be class...
5088   keys %statuscolor;
5089 }
5090
5091 =item prospect_sql
5092
5093 Returns an SQL expression identifying prospective cust_main records (customers
5094 with no packages ever ordered)
5095
5096 =cut
5097
5098 use vars qw($select_count_pkgs);
5099 $select_count_pkgs =
5100   "SELECT COUNT(*) FROM cust_pkg
5101     WHERE cust_pkg.custnum = cust_main.custnum";
5102
5103 sub select_count_pkgs_sql {
5104   $select_count_pkgs;
5105 }
5106
5107 sub prospect_sql { "
5108   0 = ( $select_count_pkgs )
5109 "; }
5110
5111 =item active_sql
5112
5113 Returns an SQL expression identifying active cust_main records (customers with
5114 active recurring packages).
5115
5116 =cut
5117
5118 sub active_sql { "
5119   0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. "
5120       )
5121 "; }
5122
5123 =item inactive_sql
5124
5125 Returns an SQL expression identifying inactive cust_main records (customers with
5126 no active recurring packages, but otherwise unsuspended/uncancelled).
5127
5128 =cut
5129
5130 sub inactive_sql { "
5131   0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5132   AND
5133   0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
5134 "; }
5135
5136 =item susp_sql
5137 =item suspended_sql
5138
5139 Returns an SQL expression identifying suspended cust_main records.
5140
5141 =cut
5142
5143
5144 sub suspended_sql { susp_sql(@_); }
5145 sub susp_sql { "
5146     0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " )
5147     AND
5148     0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5149 "; }
5150
5151 =item cancel_sql
5152 =item cancelled_sql
5153
5154 Returns an SQL expression identifying cancelled cust_main records.
5155
5156 =cut
5157
5158 sub cancelled_sql { cancel_sql(@_); }
5159 sub cancel_sql {
5160
5161   my $recurring_sql = FS::cust_pkg->recurring_sql;
5162   my $cancelled_sql = FS::cust_pkg->cancelled_sql;
5163
5164   "
5165         0 < ( $select_count_pkgs )
5166     AND 0 < ( $select_count_pkgs AND $recurring_sql AND $cancelled_sql   )
5167     AND 0 = ( $select_count_pkgs AND $recurring_sql
5168                   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5169             )
5170   ";
5171
5172 }
5173
5174 =item uncancel_sql
5175 =item uncancelled_sql
5176
5177 Returns an SQL expression identifying un-cancelled cust_main records.
5178
5179 =cut
5180
5181 sub uncancelled_sql { uncancel_sql(@_); }
5182 sub uncancel_sql { "
5183   ( 0 < ( $select_count_pkgs
5184                    AND ( cust_pkg.cancel IS NULL
5185                          OR cust_pkg.cancel = 0
5186                        )
5187         )
5188     OR 0 = ( $select_count_pkgs )
5189   )
5190 "; }
5191
5192 =item balance_sql
5193
5194 Returns an SQL fragment to retreive the balance.
5195
5196 =cut
5197
5198 sub balance_sql { "
5199     ( SELECT COALESCE( SUM(charged), 0 ) FROM cust_bill
5200         WHERE cust_bill.custnum   = cust_main.custnum     )
5201   - ( SELECT COALESCE( SUM(paid),    0 ) FROM cust_pay
5202         WHERE cust_pay.custnum    = cust_main.custnum     )
5203   - ( SELECT COALESCE( SUM(amount),  0 ) FROM cust_credit
5204         WHERE cust_credit.custnum = cust_main.custnum     )
5205   + ( SELECT COALESCE( SUM(refund),  0 ) FROM cust_refund
5206         WHERE cust_refund.custnum = cust_main.custnum     )
5207 "; }
5208
5209 =item balance_date_sql START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5210
5211 Returns an SQL fragment to retreive the balance for this customer, only
5212 considering invoices with date earlier than START_TIME, and optionally not
5213 later than END_TIME (total_owed_date minus total_credited minus
5214 total_unapplied_payments).
5215
5216 Times are specified as SQL fragments or numeric
5217 UNIX timestamps; see L<perlfunc/"time">).  Also see L<Time::Local> and
5218 L<Date::Parse> for conversion functions.  The empty string can be passed
5219 to disable that time constraint completely.
5220
5221 Available options are:
5222
5223 =over 4
5224
5225 =item unapplied_date - set to true to disregard unapplied credits, payments and refunds outside the specified time period - by default the time period restriction only applies to invoices (useful for reporting, probably a bad idea for event triggering)
5226
5227 =item total - set to true to remove all customer comparison clauses, for totals
5228
5229 =item where - WHERE clause hashref (elements "AND"ed together) (typically used with the total option)
5230
5231 =item join - JOIN clause (typically used with the total option)
5232
5233 =item
5234
5235 =back
5236
5237 =cut
5238
5239 sub balance_date_sql {
5240   my( $class, $start, $end, %opt ) = @_;
5241
5242   my $owed         = FS::cust_bill->owed_sql;
5243   my $unapp_refund = FS::cust_refund->unapplied_sql;
5244   my $unapp_credit = FS::cust_credit->unapplied_sql;
5245   my $unapp_pay    = FS::cust_pay->unapplied_sql;
5246
5247   my $j = $opt{'join'} || '';
5248
5249   my $owed_wh   = $class->_money_table_where( 'cust_bill',   $start,$end,%opt );
5250   my $refund_wh = $class->_money_table_where( 'cust_refund', $start,$end,%opt );
5251   my $credit_wh = $class->_money_table_where( 'cust_credit', $start,$end,%opt );
5252   my $pay_wh    = $class->_money_table_where( 'cust_pay',    $start,$end,%opt );
5253
5254   "   ( SELECT COALESCE(SUM($owed),         0) FROM cust_bill   $j $owed_wh   )
5255     + ( SELECT COALESCE(SUM($unapp_refund), 0) FROM cust_refund $j $refund_wh )
5256     - ( SELECT COALESCE(SUM($unapp_credit), 0) FROM cust_credit $j $credit_wh )
5257     - ( SELECT COALESCE(SUM($unapp_pay),    0) FROM cust_pay    $j $pay_wh    )
5258   ";
5259
5260 }
5261
5262 =item _money_table_where TABLE START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5263
5264 Helper method for balance_date_sql; name (and usage) subject to change
5265 (suggestions welcome).
5266
5267 Returns a WHERE clause for the specified monetary TABLE (cust_bill,
5268 cust_refund, cust_credit or cust_pay).
5269
5270 If TABLE is "cust_bill" or the unapplied_date option is true, only
5271 considers records with date earlier than START_TIME, and optionally not
5272 later than END_TIME .
5273
5274 =cut
5275
5276 sub _money_table_where {
5277   my( $class, $table, $start, $end, %opt ) = @_;
5278
5279   my @where = ();
5280   push @where, "cust_main.custnum = $table.custnum" unless $opt{'total'};
5281   if ( $table eq 'cust_bill' || $opt{'unapplied_date'} ) {
5282     push @where, "$table._date <= $start" if defined($start) && length($start);
5283     push @where, "$table._date >  $end"   if defined($end)   && length($end);
5284   }
5285   push @where, @{$opt{'where'}} if $opt{'where'};
5286   my $where = scalar(@where) ? 'WHERE '. join(' AND ', @where ) : '';
5287
5288   $where;
5289
5290 }
5291
5292 =item search_sql HASHREF
5293
5294 (Class method)
5295
5296 Returns a qsearch hash expression to search for parameters specified in HREF.
5297 Valid parameters are
5298
5299 =over 4
5300
5301 =item agentnum
5302
5303 =item status
5304
5305 =item cancelled_pkgs
5306
5307 bool
5308
5309 =item signupdate
5310
5311 listref of start date, end date
5312
5313 =item payby
5314
5315 listref
5316
5317 =item current_balance
5318
5319 listref (list returned by FS::UI::Web::parse_lt_gt($cgi, 'current_balance'))
5320
5321 =item cust_fields
5322
5323 =item flattened_pkgs
5324
5325 bool
5326
5327 =back
5328
5329 =cut
5330
5331 sub search_sql {
5332   my ($class, $params) = @_;
5333
5334   my $dbh = dbh;
5335
5336   my @where = ();
5337   my $orderby;
5338
5339   ##
5340   # parse agent
5341   ##
5342
5343   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
5344     push @where,
5345       "cust_main.agentnum = $1";
5346   }
5347
5348   ##
5349   # parse status
5350   ##
5351
5352   #prospect active inactive suspended cancelled
5353   if ( grep { $params->{'status'} eq $_ } FS::cust_main->statuses() ) {
5354     my $method = $params->{'status'}. '_sql';
5355     #push @where, $class->$method();
5356     push @where, FS::cust_main->$method();
5357   }
5358
5359   ##
5360   # parse cancelled package checkbox
5361   ##
5362
5363   my $pkgwhere = "";
5364
5365   $pkgwhere .= "AND (cancel = 0 or cancel is null)"
5366     unless $params->{'cancelled_pkgs'};
5367
5368   ##
5369   # dates
5370   ##
5371
5372   foreach my $field (qw( signupdate )) {
5373
5374     next unless exists($params->{$field});
5375
5376     my($beginning, $ending) = @{$params->{$field}};
5377
5378     push @where,
5379       "cust_main.$field IS NOT NULL",
5380       "cust_main.$field >= $beginning",
5381       "cust_main.$field <= $ending";
5382
5383     $orderby ||= "ORDER BY cust_main.$field";
5384
5385   }
5386
5387   ###
5388   # payby
5389   ###
5390
5391   my @payby = grep /^([A-Z]{4})$/, @{ $params->{'payby'} };
5392   if ( @payby ) {
5393     push @where, '( '. join(' OR ', map "cust_main.payby = '$_'", @payby). ' )';
5394   }
5395
5396   ##
5397   # amounts
5398   ##
5399
5400   #my $balance_sql = $class->balance_sql();
5401   my $balance_sql = FS::cust_main->balance_sql();
5402
5403   push @where, map { s/current_balance/$balance_sql/; $_ }
5404                    @{ $params->{'current_balance'} };
5405
5406   ##
5407   # setup queries, subs, etc. for the search
5408   ##
5409
5410   $orderby ||= 'ORDER BY custnum';
5411
5412   # here is the agent virtualization
5413   push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
5414
5415   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
5416
5417   my $addl_from = 'LEFT JOIN cust_pkg USING ( custnum  ) ';
5418
5419   my $count_query = "SELECT COUNT(*) FROM cust_main $extra_sql";
5420
5421   my $select = join(', ',
5422                  'cust_main.custnum',
5423                  FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
5424                );
5425
5426   my(@extra_headers) = ();
5427   my(@extra_fields)  = ();
5428
5429   if ($params->{'flattened_pkgs'}) {
5430
5431     if ($dbh->{Driver}->{Name} eq 'Pg') {
5432
5433       $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";
5434
5435     }elsif ($dbh->{Driver}->{Name} =~ /^mysql/i) {
5436       $select .= ", GROUP_CONCAT(pkg SEPARATOR '|') as magic";
5437       $addl_from .= " LEFT JOIN part_pkg using ( pkgpart )";
5438     }else{
5439       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
5440            "omitting packing information from report.";
5441     }
5442
5443     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";
5444
5445     my $sth = dbh->prepare($header_query) or die dbh->errstr;
5446     $sth->execute() or die $sth->errstr;
5447     my $headerrow = $sth->fetchrow_arrayref;
5448     my $headercount = $headerrow ? $headerrow->[0] : 0;
5449     while($headercount) {
5450       unshift @extra_headers, "Package ". $headercount;
5451       unshift @extra_fields, eval q!sub {my $c = shift;
5452                                          my @a = split '\|', $c->magic;
5453                                          my $p = $a[!.--$headercount. q!];
5454                                          $p;
5455                                         };!;
5456     }
5457
5458   }
5459
5460   my $sql_query = {
5461     'table'         => 'cust_main',
5462     'select'        => $select,
5463     'hashref'       => {},
5464     'extra_sql'     => $extra_sql,
5465     'order_by'      => $orderby,
5466     'count_query'   => $count_query,
5467     'extra_headers' => \@extra_headers,
5468     'extra_fields'  => \@extra_fields,
5469   };
5470
5471 }
5472
5473 =item email_search_sql HASHREF
5474
5475 (Class method)
5476
5477 Emails a notice to the specified customers.
5478
5479 Valid parameters are those of the L<search_sql> method, plus the following:
5480
5481 =over 4
5482
5483 =item from
5484
5485 From: address
5486
5487 =item subject
5488
5489 Email Subject:
5490
5491 =item html_body
5492
5493 HTML body
5494
5495 =item text_body
5496
5497 Text body
5498
5499 =item job
5500
5501 Optional job queue job for status updates.
5502
5503 =back
5504
5505 Returns an error message, or false for success.
5506
5507 If an error occurs during any email, stops the enture send and returns that
5508 error.  Presumably if you're getting SMTP errors aborting is better than
5509 retrying everything.
5510
5511 =cut
5512
5513 sub email_search_sql {
5514   my($class, $params) = @_;
5515
5516   my $from = delete $params->{from};
5517   my $subject = delete $params->{subject};
5518   my $html_body = delete $params->{html_body};
5519   my $text_body = delete $params->{text_body};
5520
5521   my $job = delete $params->{'job'};
5522
5523   my $sql_query = $class->search_sql($params);
5524
5525   my $count_query   = delete($sql_query->{'count_query'});
5526   my $count_sth = dbh->prepare($count_query)
5527     or die "Error preparing $count_query: ". dbh->errstr;
5528   $count_sth->execute
5529     or die "Error executing $count_query: ". $count_sth->errstr;
5530   my $count_arrayref = $count_sth->fetchrow_arrayref;
5531   my $num_cust = $count_arrayref->[0];
5532
5533   #my @extra_headers = @{ delete($sql_query->{'extra_headers'}) };
5534   #my @extra_fields  = @{ delete($sql_query->{'extra_fields'})  };
5535
5536
5537   my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
5538
5539   #eventually order+limit magic to reduce memory use?
5540   foreach my $cust_main ( qsearch($sql_query) ) {
5541
5542     my $to = $cust_main->invoicing_list_emailonly_scalar;
5543     next unless $to;
5544
5545     my $error = send_email(
5546       generate_email(
5547         'from'      => $from,
5548         'to'        => $to,
5549         'subject'   => $subject,
5550         'html_body' => $html_body,
5551         'text_body' => $text_body,
5552       )
5553     );
5554     return $error if $error;
5555
5556     if ( $job ) { #progressbar foo
5557       $num++;
5558       if ( time - $min_sec > $last ) {
5559         my $error = $job->update_statustext(
5560           int( 100 * $num / $num_cust )
5561         );
5562         die $error if $error;
5563         $last = time;
5564       }
5565     }
5566
5567   }
5568
5569   return '';
5570 }
5571
5572 use Storable qw(thaw);
5573 use Data::Dumper;
5574 use MIME::Base64;
5575 sub process_email_search_sql {
5576   my $job = shift;
5577   #warn "$me process_re_X $method for job $job\n" if $DEBUG;
5578
5579   my $param = thaw(decode_base64(shift));
5580   warn Dumper($param) if $DEBUG;
5581
5582   $param->{'job'} = $job;
5583
5584   my $error = FS::cust_main->email_search_sql( $param );
5585   die $error if $error;
5586
5587 }
5588
5589 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
5590
5591 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
5592 records.  Currently, I<first>, I<last> and/or I<company> may be specified (the
5593 appropriate ship_ field is also searched).
5594
5595 Additional options are the same as FS::Record::qsearch
5596
5597 =cut
5598
5599 sub fuzzy_search {
5600   my( $self, $fuzzy, $hash, @opt) = @_;
5601   #$self
5602   $hash ||= {};
5603   my @cust_main = ();
5604
5605   check_and_rebuild_fuzzyfiles();
5606   foreach my $field ( keys %$fuzzy ) {
5607
5608     my $all = $self->all_X($field);
5609     next unless scalar(@$all);
5610
5611     my %match = ();
5612     $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) );
5613
5614     my @fcust = ();
5615     foreach ( keys %match ) {
5616       push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
5617       push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
5618     }
5619     my %fsaw = ();
5620     push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
5621   }
5622
5623   # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
5624   my %saw = ();
5625   @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
5626
5627   @cust_main;
5628
5629 }
5630
5631 =item masked FIELD
5632
5633 Returns a masked version of the named field
5634
5635 =cut
5636
5637 sub masked {
5638 my ($self,$field) = @_;
5639
5640 # Show last four
5641
5642 'x'x(length($self->getfield($field))-4).
5643   substr($self->getfield($field), (length($self->getfield($field))-4));
5644
5645 }
5646
5647 =back
5648
5649 =head1 SUBROUTINES
5650
5651 =over 4
5652
5653 =item smart_search OPTION => VALUE ...
5654
5655 Accepts the following options: I<search>, the string to search for.  The string
5656 will be searched for as a customer number, phone number, name or company name,
5657 as an exact, or, in some cases, a substring or fuzzy match (see the source code
5658 for the exact heuristics used); I<no_fuzzy_on_exact>, causes smart_search to
5659 skip fuzzy matching when an exact match is found.
5660
5661 Any additional options are treated as an additional qualifier on the search
5662 (i.e. I<agentnum>).
5663
5664 Returns a (possibly empty) array of FS::cust_main objects.
5665
5666 =cut
5667
5668 sub smart_search {
5669   my %options = @_;
5670
5671   #here is the agent virtualization
5672   my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
5673
5674   my @cust_main = ();
5675
5676   my $skip_fuzzy = delete $options{'no_fuzzy_on_exact'};
5677   my $search = delete $options{'search'};
5678   ( my $alphanum_search = $search ) =~ s/\W//g;
5679
5680   if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
5681
5682     #false laziness w/Record::ut_phone
5683     my $phonen = "$1-$2-$3";
5684     $phonen .= " x$4" if $4;
5685
5686     push @cust_main, qsearch( {
5687       'table'   => 'cust_main',
5688       'hashref' => { %options },
5689       'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
5690                      ' ( '.
5691                          join(' OR ', map "$_ = '$phonen'",
5692                                           qw( daytime night fax
5693                                               ship_daytime ship_night ship_fax )
5694                              ).
5695                      ' ) '.
5696                      " AND $agentnums_sql", #agent virtualization
5697     } );
5698
5699     unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
5700       #try looking for matches with extensions unless one was specified
5701
5702       push @cust_main, qsearch( {
5703         'table'   => 'cust_main',
5704         'hashref' => { %options },
5705         'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
5706                        ' ( '.
5707                            join(' OR ', map "$_ LIKE '$phonen\%'",
5708                                             qw( daytime night
5709                                                 ship_daytime ship_night )
5710                                ).
5711                        ' ) '.
5712                        " AND $agentnums_sql", #agent virtualization
5713       } );
5714
5715     }
5716
5717   # custnum search (also try agent_custid), with some tweaking options if your
5718   # legacy cust "numbers" have letters
5719   } elsif ( $search =~ /^\s*(\d+)\s*$/
5720             || ( $conf->config('cust_main-agent_custid-format') eq 'ww?d+'
5721                  && $search =~ /^\s*(\w\w?\d+)\s*$/
5722                )
5723           )
5724   {
5725
5726     push @cust_main, qsearch( {
5727       'table'     => 'cust_main',
5728       'hashref'   => { 'custnum' => $1, %options },
5729       'extra_sql' => " AND $agentnums_sql", #agent virtualization
5730     } );
5731
5732     push @cust_main, qsearch( {
5733       'table'     => 'cust_main',
5734       'hashref'   => { 'agent_custid' => $1, %options },
5735       'extra_sql' => " AND $agentnums_sql", #agent virtualization
5736     } );
5737
5738   } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
5739
5740     my($company, $last, $first) = ( $1, $2, $3 );
5741
5742     # "Company (Last, First)"
5743     #this is probably something a browser remembered,
5744     #so just do an exact search
5745
5746     foreach my $prefix ( '', 'ship_' ) {
5747       push @cust_main, qsearch( {
5748         'table'     => 'cust_main',
5749         'hashref'   => { $prefix.'first'   => $first,
5750                          $prefix.'last'    => $last,
5751                          $prefix.'company' => $company,
5752                          %options,
5753                        },
5754         'extra_sql' => " AND $agentnums_sql",
5755       } );
5756     }
5757
5758   } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
5759                                               # try (ship_){last,company}
5760
5761     my $value = lc($1);
5762
5763     # # remove "(Last, First)" in "Company (Last, First)", otherwise the
5764     # # full strings the browser remembers won't work
5765     # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
5766
5767     use Lingua::EN::NameParse;
5768     my $NameParse = new Lingua::EN::NameParse(
5769              auto_clean     => 1,
5770              allow_reversed => 1,
5771     );
5772
5773     my($last, $first) = ( '', '' );
5774     #maybe disable this too and just rely on NameParse?
5775     if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
5776
5777       ($last, $first) = ( $1, $2 );
5778
5779     #} elsif  ( $value =~ /^(.+)\s+(.+)$/ ) {
5780     } elsif ( ! $NameParse->parse($value) ) {
5781
5782       my %name = $NameParse->components;
5783       $first = $name{'given_name_1'};
5784       $last  = $name{'surname_1'};
5785
5786     }
5787
5788     if ( $first && $last ) {
5789
5790       my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
5791
5792       #exact
5793       my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5794       $sql .= "
5795         (     ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
5796            OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
5797         )";
5798
5799       push @cust_main, qsearch( {
5800         'table'     => 'cust_main',
5801         'hashref'   => \%options,
5802         'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5803       } );
5804
5805       # or it just be something that was typed in... (try that in a sec)
5806
5807     }
5808
5809     my $q_value = dbh->quote($value);
5810
5811     #exact
5812     my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5813     $sql .= " (    LOWER(last)         = $q_value
5814                 OR LOWER(company)      = $q_value
5815                 OR LOWER(ship_last)    = $q_value
5816                 OR LOWER(ship_company) = $q_value
5817               )";
5818
5819     push @cust_main, qsearch( {
5820       'table'     => 'cust_main',
5821       'hashref'   => \%options,
5822       'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5823     } );
5824
5825     #no exact match, trying substring/fuzzy
5826     #always do substring & fuzzy (unless they're explicity config'ed off)
5827     #getting complaints searches are not returning enough
5828     unless ( @cust_main  && $skip_fuzzy || $conf->exists('disable-fuzzy') ) {
5829
5830       #still some false laziness w/search_sql (was search/cust_main.cgi)
5831
5832       #substring
5833
5834       my @hashrefs = (
5835         { 'company'      => { op=>'ILIKE', value=>"%$value%" }, },
5836         { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
5837       );
5838
5839       if ( $first && $last ) {
5840
5841         push @hashrefs,
5842           { 'first'        => { op=>'ILIKE', value=>"%$first%" },
5843             'last'         => { op=>'ILIKE', value=>"%$last%" },
5844           },
5845           { 'ship_first'   => { op=>'ILIKE', value=>"%$first%" },
5846             'ship_last'    => { op=>'ILIKE', value=>"%$last%" },
5847           },
5848         ;
5849
5850       } else {
5851
5852         push @hashrefs,
5853           { 'last'         => { op=>'ILIKE', value=>"%$value%" }, },
5854           { 'ship_last'    => { op=>'ILIKE', value=>"%$value%" }, },
5855         ;
5856       }
5857
5858       foreach my $hashref ( @hashrefs ) {
5859
5860         push @cust_main, qsearch( {
5861           'table'     => 'cust_main',
5862           'hashref'   => { %$hashref,
5863                            %options,
5864                          },
5865           'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
5866         } );
5867
5868       }
5869
5870       #fuzzy
5871       my @fuzopts = (
5872         \%options,                #hashref
5873         '',                       #select
5874         " AND $agentnums_sql",    #extra_sql  #agent virtualization
5875       );
5876
5877       if ( $first && $last ) {
5878         push @cust_main, FS::cust_main->fuzzy_search(
5879           { 'last'   => $last,    #fuzzy hashref
5880             'first'  => $first }, #
5881           @fuzopts
5882         );
5883       }
5884       foreach my $field ( 'last', 'company' ) {
5885         push @cust_main,
5886           FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
5887       }
5888
5889     }
5890
5891     #eliminate duplicates
5892     my %saw = ();
5893     @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
5894
5895   }
5896
5897   @cust_main;
5898
5899 }
5900
5901 =item email_search
5902
5903 Accepts the following options: I<email>, the email address to search for.  The
5904 email address will be searched for as an email invoice destination and as an
5905 svc_acct account.
5906
5907 #Any additional options are treated as an additional qualifier on the search
5908 #(i.e. I<agentnum>).
5909
5910 Returns a (possibly empty) array of FS::cust_main objects (but usually just
5911 none or one).
5912
5913 =cut
5914
5915 sub email_search {
5916   my %options = @_;
5917
5918   local($DEBUG) = 1;
5919
5920   my $email = delete $options{'email'};
5921
5922   #we're only being used by RT at the moment... no agent virtualization yet
5923   #my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
5924
5925   my @cust_main = ();
5926
5927   if ( $email =~ /([^@]+)\@([^@]+)/ ) {
5928
5929     my ( $user, $domain ) = ( $1, $2 );
5930
5931     warn "$me smart_search: searching for $user in domain $domain"
5932       if $DEBUG;
5933
5934     push @cust_main,
5935       map $_->cust_main,
5936           qsearch( {
5937                      'table'     => 'cust_main_invoice',
5938                      'hashref'   => { 'dest' => $email },
5939                    }
5940                  );
5941
5942     push @cust_main,
5943       map  $_->cust_main,
5944       grep $_,
5945       map  $_->cust_svc->cust_pkg,
5946           qsearch( {
5947                      'table'     => 'svc_acct',
5948                      'hashref'   => { 'username' => $user, },
5949                      'extra_sql' =>
5950                        'AND ( SELECT domain FROM svc_domain
5951                                 WHERE svc_acct.domsvc = svc_domain.svcnum
5952                             ) = '. dbh->quote($domain),
5953                    }
5954                  );
5955   }
5956
5957   my %saw = ();
5958   @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
5959
5960   warn "$me smart_search: found ". scalar(@cust_main). " unique customers"
5961     if $DEBUG;
5962
5963   @cust_main;
5964
5965 }
5966
5967 =item check_and_rebuild_fuzzyfiles
5968
5969 =cut
5970
5971 use vars qw(@fuzzyfields);
5972 @fuzzyfields = ( 'last', 'first', 'company' );
5973
5974 sub check_and_rebuild_fuzzyfiles {
5975   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
5976   rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
5977 }
5978
5979 =item rebuild_fuzzyfiles
5980
5981 =cut
5982
5983 sub rebuild_fuzzyfiles {
5984
5985   use Fcntl qw(:flock);
5986
5987   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
5988   mkdir $dir, 0700 unless -d $dir;
5989
5990   foreach my $fuzzy ( @fuzzyfields ) {
5991
5992     open(LOCK,">>$dir/cust_main.$fuzzy")
5993       or die "can't open $dir/cust_main.$fuzzy: $!";
5994     flock(LOCK,LOCK_EX)
5995       or die "can't lock $dir/cust_main.$fuzzy: $!";
5996
5997     open (CACHE,">$dir/cust_main.$fuzzy.tmp")
5998       or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
5999
6000     foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
6001       my $sth = dbh->prepare("SELECT $field FROM cust_main".
6002                              " WHERE $field != '' AND $field IS NOT NULL");
6003       $sth->execute or die $sth->errstr;
6004
6005       while ( my $row = $sth->fetchrow_arrayref ) {
6006         print CACHE $row->[0]. "\n";
6007       }
6008
6009     }
6010
6011     close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
6012
6013     rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
6014     close LOCK;
6015   }
6016
6017 }
6018
6019 =item all_X
6020
6021 =cut
6022
6023 sub all_X {
6024   my( $self, $field ) = @_;
6025   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6026   open(CACHE,"<$dir/cust_main.$field")
6027     or die "can't open $dir/cust_main.$field: $!";
6028   my @array = map { chomp; $_; } <CACHE>;
6029   close CACHE;
6030   \@array;
6031 }
6032
6033 =item append_fuzzyfiles LASTNAME COMPANY
6034
6035 =cut
6036
6037 sub append_fuzzyfiles {
6038   #my( $first, $last, $company ) = @_;
6039
6040   &check_and_rebuild_fuzzyfiles;
6041
6042   use Fcntl qw(:flock);
6043
6044   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6045
6046   foreach my $field (qw( first last company )) {
6047     my $value = shift;
6048
6049     if ( $value ) {
6050
6051       open(CACHE,">>$dir/cust_main.$field")
6052         or die "can't open $dir/cust_main.$field: $!";
6053       flock(CACHE,LOCK_EX)
6054         or die "can't lock $dir/cust_main.$field: $!";
6055
6056       print CACHE "$value\n";
6057
6058       flock(CACHE,LOCK_UN)
6059         or die "can't unlock $dir/cust_main.$field: $!";
6060       close CACHE;
6061     }
6062
6063   }
6064
6065   1;
6066 }
6067
6068 =item batch_import
6069
6070 =cut
6071
6072 sub batch_import {
6073   my $param = shift;
6074   #warn join('-',keys %$param);
6075   my $fh = $param->{filehandle};
6076   my $agentnum = $param->{agentnum};
6077
6078   my $refnum = $param->{refnum};
6079   my $pkgpart = $param->{pkgpart};
6080
6081   #my @fields = @{$param->{fields}};
6082   my $format = $param->{'format'};
6083   my @fields;
6084   my $payby;
6085   if ( $format eq 'simple' ) {
6086     @fields = qw( cust_pkg.setup dayphone first last
6087                   address1 address2 city state zip comments );
6088     $payby = 'BILL';
6089   } elsif ( $format eq 'extended' ) {
6090     @fields = qw( agent_custid refnum
6091                   last first address1 address2 city state zip country
6092                   daytime night
6093                   ship_last ship_first ship_address1 ship_address2
6094                   ship_city ship_state ship_zip ship_country
6095                   payinfo paycvv paydate
6096                   invoicing_list
6097                   cust_pkg.pkgpart
6098                   svc_acct.username svc_acct._password
6099                 );
6100     $payby = 'BILL';
6101  } elsif ( $format eq 'extended-plus_company' ) {
6102     @fields = qw( agent_custid refnum
6103                   last first company address1 address2 city state zip country
6104                   daytime night
6105                   ship_last ship_first ship_company ship_address1 ship_address2
6106                   ship_city ship_state ship_zip ship_country
6107                   payinfo paycvv paydate
6108                   invoicing_list
6109                   cust_pkg.pkgpart
6110                   svc_acct.username svc_acct._password
6111                 );
6112     $payby = 'BILL';
6113   } else {
6114     die "unknown format $format";
6115   }
6116
6117   eval "use Text::CSV_XS;";
6118   die $@ if $@;
6119
6120   my $csv = new Text::CSV_XS;
6121   #warn $csv;
6122   #warn $fh;
6123
6124   my $imported = 0;
6125   #my $columns;
6126
6127   local $SIG{HUP} = 'IGNORE';
6128   local $SIG{INT} = 'IGNORE';
6129   local $SIG{QUIT} = 'IGNORE';
6130   local $SIG{TERM} = 'IGNORE';
6131   local $SIG{TSTP} = 'IGNORE';
6132   local $SIG{PIPE} = 'IGNORE';
6133
6134   my $oldAutoCommit = $FS::UID::AutoCommit;
6135   local $FS::UID::AutoCommit = 0;
6136   my $dbh = dbh;
6137
6138   #while ( $columns = $csv->getline($fh) ) {
6139   my $line;
6140   while ( defined($line=<$fh>) ) {
6141
6142     $csv->parse($line) or do {
6143       $dbh->rollback if $oldAutoCommit;
6144       return "can't parse: ". $csv->error_input();
6145     };
6146
6147     my @columns = $csv->fields();
6148     #warn join('-',@columns);
6149
6150     my %cust_main = (
6151       agentnum => $agentnum,
6152       refnum   => $refnum,
6153       country  => $conf->config('countrydefault') || 'US',
6154       payby    => $payby, #default
6155       paydate  => '12/2037', #default
6156     );
6157     my $billtime = time;
6158     my %cust_pkg = ( pkgpart => $pkgpart );
6159     my %svc_acct = ();
6160     foreach my $field ( @fields ) {
6161
6162       if ( $field =~ /^cust_pkg\.(pkgpart|setup|bill|susp|adjourn|expire|cancel)$/ ) {
6163
6164         #$cust_pkg{$1} = str2time( shift @$columns );
6165         if ( $1 eq 'pkgpart' ) {
6166           $cust_pkg{$1} = shift @columns;
6167         } elsif ( $1 eq 'setup' ) {
6168           $billtime = str2time(shift @columns);
6169         } else {
6170           $cust_pkg{$1} = str2time( shift @columns );
6171         }
6172
6173       } elsif ( $field =~ /^svc_acct\.(username|_password)$/ ) {
6174
6175         $svc_acct{$1} = shift @columns;
6176
6177       } else {
6178
6179         #refnum interception
6180         if ( $field eq 'refnum' && $columns[0] !~ /^\s*(\d+)\s*$/ ) {
6181
6182           my $referral = $columns[0];
6183           my %hash = ( 'referral' => $referral,
6184                        'agentnum' => $agentnum,
6185                        'disabled' => '',
6186                      );
6187
6188           my $part_referral = qsearchs('part_referral', \%hash )
6189                               || new FS::part_referral \%hash;
6190
6191           unless ( $part_referral->refnum ) {
6192             my $error = $part_referral->insert;
6193             if ( $error ) {
6194               $dbh->rollback if $oldAutoCommit;
6195               return "can't auto-insert advertising source: $referral: $error";
6196             }
6197           }
6198
6199           $columns[0] = $part_referral->refnum;
6200         }
6201
6202         #$cust_main{$field} = shift @$columns;
6203         $cust_main{$field} = shift @columns;
6204       }
6205     }
6206
6207     $cust_main{'payby'} = 'CARD' if length($cust_main{'payinfo'});
6208
6209     my $invoicing_list = $cust_main{'invoicing_list'}
6210                            ? [ delete $cust_main{'invoicing_list'} ]
6211                            : [];
6212
6213     my $cust_main = new FS::cust_main ( \%cust_main );
6214
6215     use Tie::RefHash;
6216     tie my %hash, 'Tie::RefHash'; #this part is important
6217
6218     if ( $cust_pkg{'pkgpart'} ) {
6219       my $cust_pkg = new FS::cust_pkg ( \%cust_pkg );
6220
6221       my @svc_acct = ();
6222       if ( $svc_acct{'username'} ) {
6223         my $part_pkg = $cust_pkg->part_pkg;
6224         unless ( $part_pkg ) {
6225           $dbh->rollback if $oldAutoCommit;
6226           return "unknown pkgpart: ". $cust_pkg{'pkgpart'};
6227         }
6228         $svc_acct{svcpart} = $part_pkg->svcpart( 'svc_acct' );
6229         push @svc_acct, new FS::svc_acct ( \%svc_acct )
6230       }
6231
6232       $hash{$cust_pkg} = \@svc_acct;
6233     }
6234
6235     my $error = $cust_main->insert( \%hash, $invoicing_list );
6236
6237     if ( $error ) {
6238       $dbh->rollback if $oldAutoCommit;
6239       return "can't insert customer for $line: $error";
6240     }
6241
6242     if ( $format eq 'simple' ) {
6243
6244       #false laziness w/bill.cgi
6245       $error = $cust_main->bill( 'time' => $billtime );
6246       if ( $error ) {
6247         $dbh->rollback if $oldAutoCommit;
6248         return "can't bill customer for $line: $error";
6249       }
6250
6251       $error = $cust_main->apply_payments_and_credits;
6252       if ( $error ) {
6253         $dbh->rollback if $oldAutoCommit;
6254         return "can't bill customer for $line: $error";
6255       }
6256
6257       $error = $cust_main->collect();
6258       if ( $error ) {
6259         $dbh->rollback if $oldAutoCommit;
6260         return "can't collect customer for $line: $error";
6261       }
6262
6263     }
6264
6265     $imported++;
6266   }
6267
6268   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6269
6270   return "Empty file!" unless $imported;
6271
6272   ''; #no error
6273
6274 }
6275
6276 =item batch_charge
6277
6278 =cut
6279
6280 sub batch_charge {
6281   my $param = shift;
6282   #warn join('-',keys %$param);
6283   my $fh = $param->{filehandle};
6284   my @fields = @{$param->{fields}};
6285
6286   eval "use Text::CSV_XS;";
6287   die $@ if $@;
6288
6289   my $csv = new Text::CSV_XS;
6290   #warn $csv;
6291   #warn $fh;
6292
6293   my $imported = 0;
6294   #my $columns;
6295
6296   local $SIG{HUP} = 'IGNORE';
6297   local $SIG{INT} = 'IGNORE';
6298   local $SIG{QUIT} = 'IGNORE';
6299   local $SIG{TERM} = 'IGNORE';
6300   local $SIG{TSTP} = 'IGNORE';
6301   local $SIG{PIPE} = 'IGNORE';
6302
6303   my $oldAutoCommit = $FS::UID::AutoCommit;
6304   local $FS::UID::AutoCommit = 0;
6305   my $dbh = dbh;
6306
6307   #while ( $columns = $csv->getline($fh) ) {
6308   my $line;
6309   while ( defined($line=<$fh>) ) {
6310
6311     $csv->parse($line) or do {
6312       $dbh->rollback if $oldAutoCommit;
6313       return "can't parse: ". $csv->error_input();
6314     };
6315
6316     my @columns = $csv->fields();
6317     #warn join('-',@columns);
6318
6319     my %row = ();
6320     foreach my $field ( @fields ) {
6321       $row{$field} = shift @columns;
6322     }
6323
6324     my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
6325     unless ( $cust_main ) {
6326       $dbh->rollback if $oldAutoCommit;
6327       return "unknown custnum $row{'custnum'}";
6328     }
6329
6330     if ( $row{'amount'} > 0 ) {
6331       my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
6332       if ( $error ) {
6333         $dbh->rollback if $oldAutoCommit;
6334         return $error;
6335       }
6336       $imported++;
6337     } elsif ( $row{'amount'} < 0 ) {
6338       my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
6339                                       $row{'pkg'}                         );
6340       if ( $error ) {
6341         $dbh->rollback if $oldAutoCommit;
6342         return $error;
6343       }
6344       $imported++;
6345     } else {
6346       #hmm?
6347     }
6348
6349   }
6350
6351   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6352
6353   return "Empty file!" unless $imported;
6354
6355   ''; #no error
6356
6357 }
6358
6359 =item notify CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6360
6361 Sends a templated email notification to the customer (see L<Text::Template>).
6362
6363 OPTIONS is a hash and may include
6364
6365 I<from> - the email sender (default is invoice_from)
6366
6367 I<to> - comma-separated scalar or arrayref of recipients
6368    (default is invoicing_list)
6369
6370 I<subject> - The subject line of the sent email notification
6371    (default is "Notice from company_name")
6372
6373 I<extra_fields> - a hashref of name/value pairs which will be substituted
6374    into the template
6375
6376 The following variables are vavailable in the template.
6377
6378 I<$first> - the customer first name
6379 I<$last> - the customer last name
6380 I<$company> - the customer company
6381 I<$payby> - a description of the method of payment for the customer
6382             # would be nice to use FS::payby::shortname
6383 I<$payinfo> - the account information used to collect for this customer
6384 I<$expdate> - the expiration of the customer payment in seconds from epoch
6385
6386 =cut
6387
6388 sub notify {
6389   my ($customer, $template, %options) = @_;
6390
6391   return unless $conf->exists($template);
6392
6393   my $from = $conf->config('invoice_from') if $conf->exists('invoice_from');
6394   $from = $options{from} if exists($options{from});
6395
6396   my $to = join(',', $customer->invoicing_list_emailonly);
6397   $to = $options{to} if exists($options{to});
6398
6399   my $subject = "Notice from " . $conf->config('company_name')
6400     if $conf->exists('company_name');
6401   $subject = $options{subject} if exists($options{subject});
6402
6403   my $notify_template = new Text::Template (TYPE => 'ARRAY',
6404                                             SOURCE => [ map "$_\n",
6405                                               $conf->config($template)]
6406                                            )
6407     or die "can't create new Text::Template object: Text::Template::ERROR";
6408   $notify_template->compile()
6409     or die "can't compile template: Text::Template::ERROR";
6410
6411   $FS::notify_template::_template::company_name = $conf->config('company_name');
6412   $FS::notify_template::_template::company_address =
6413     join("\n", $conf->config('company_address') ). "\n";
6414
6415   my $paydate = $customer->paydate || '2037-12-31';
6416   $FS::notify_template::_template::first = $customer->first;
6417   $FS::notify_template::_template::last = $customer->last;
6418   $FS::notify_template::_template::company = $customer->company;
6419   $FS::notify_template::_template::payinfo = $customer->mask_payinfo;
6420   my $payby = $customer->payby;
6421   my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6422   my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6423
6424   #credit cards expire at the end of the month/year of their exp date
6425   if ($payby eq 'CARD' || $payby eq 'DCRD') {
6426     $FS::notify_template::_template::payby = 'credit card';
6427     ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6428     $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6429     $expire_time--;
6430   }elsif ($payby eq 'COMP') {
6431     $FS::notify_template::_template::payby = 'complimentary account';
6432   }else{
6433     $FS::notify_template::_template::payby = 'current method';
6434   }
6435   $FS::notify_template::_template::expdate = $expire_time;
6436
6437   for (keys %{$options{extra_fields}}){
6438     no strict "refs";
6439     ${"FS::notify_template::_template::$_"} = $options{extra_fields}->{$_};
6440   }
6441
6442   send_email(from => $from,
6443              to => $to,
6444              subject => $subject,
6445              body => $notify_template->fill_in( PACKAGE =>
6446                                                 'FS::notify_template::_template'                                              ),
6447             );
6448
6449 }
6450
6451 =item generate_letter CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6452
6453 Generates a templated notification to the customer (see L<Text::Template>).
6454
6455 OPTIONS is a hash and may include
6456
6457 I<extra_fields> - a hashref of name/value pairs which will be substituted
6458    into the template.  These values may override values mentioned below
6459    and those from the customer record.
6460
6461 The following variables are available in the template instead of or in addition
6462 to the fields of the customer record.
6463
6464 I<$payby> - a description of the method of payment for the customer
6465             # would be nice to use FS::payby::shortname
6466 I<$payinfo> - the masked account information used to collect for this customer
6467 I<$expdate> - the expiration of the customer payment method in seconds from epoch
6468 I<$returnaddress> - the return address defaults to invoice_latexreturnaddress or company_address
6469
6470 =cut
6471
6472 sub generate_letter {
6473   my ($self, $template, %options) = @_;
6474
6475   return unless $conf->exists($template);
6476
6477   my $letter_template = new Text::Template
6478                         ( TYPE       => 'ARRAY',
6479                           SOURCE     => [ map "$_\n", $conf->config($template)],
6480                           DELIMITERS => [ '[@--', '--@]' ],
6481                         )
6482     or die "can't create new Text::Template object: Text::Template::ERROR";
6483
6484   $letter_template->compile()
6485     or die "can't compile template: Text::Template::ERROR";
6486
6487   my %letter_data = map { $_ => $self->$_ } $self->fields;
6488   $letter_data{payinfo} = $self->mask_payinfo;
6489
6490   #my $paydate = $self->paydate || '2037-12-31';
6491   my $paydate = $self->paydate =~ /^\S+$/ ? $self->paydate : '2037-12-31';
6492
6493   my $payby = $self->payby;
6494   my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6495   my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6496
6497   #credit cards expire at the end of the month/year of their exp date
6498   if ($payby eq 'CARD' || $payby eq 'DCRD') {
6499     $letter_data{payby} = 'credit card';
6500     ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6501     $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6502     $expire_time--;
6503   }elsif ($payby eq 'COMP') {
6504     $letter_data{payby} = 'complimentary account';
6505   }else{
6506     $letter_data{payby} = 'current method';
6507   }
6508   $letter_data{expdate} = $expire_time;
6509
6510   for (keys %{$options{extra_fields}}){
6511     $letter_data{$_} = $options{extra_fields}->{$_};
6512   }
6513
6514   unless(exists($letter_data{returnaddress})){
6515     my $retadd = join("\n", $conf->config_orbase( 'invoice_latexreturnaddress',
6516                                                   $self->agent_template)
6517                      );
6518     if ( length($retadd) ) {
6519       $letter_data{returnaddress} = $retadd;
6520     } elsif ( grep /\S/, $conf->config('company_address') ) {
6521       $letter_data{returnaddress} =
6522         join( '\\*'."\n", map s/( {2,})/'~' x length($1)/eg,
6523                           $conf->config('company_address')
6524         );
6525     } else {
6526       $letter_data{returnaddress} = '~';
6527     }
6528   }
6529
6530   $letter_data{conf_dir} = "$FS::UID::conf_dir/conf.$FS::UID::datasrc";
6531
6532   $letter_data{company_name} = $conf->config('company_name');
6533
6534   my $dir = $FS::UID::conf_dir."cache.". $FS::UID::datasrc;
6535   my $fh = new File::Temp( TEMPLATE => 'letter.'. $self->custnum. '.XXXXXXXX',
6536                            DIR      => $dir,
6537                            SUFFIX   => '.tex',
6538                            UNLINK   => 0,
6539                          ) or die "can't open temp file: $!\n";
6540
6541   $letter_template->fill_in( OUTPUT => $fh, HASH => \%letter_data );
6542   close $fh;
6543   $fh->filename =~ /^(.*).tex$/ or die "unparsable filename: ". $fh->filename;
6544   return $1;
6545 }
6546
6547 =item print_ps TEMPLATE
6548
6549 Returns an postscript letter filled in from TEMPLATE, as a scalar.
6550
6551 =cut
6552
6553 sub print_ps {
6554   my $self = shift;
6555   my $file = $self->generate_letter(@_);
6556   FS::Misc::generate_ps($file);
6557 }
6558
6559 =item print TEMPLATE
6560
6561 Prints the filled in template.
6562
6563 TEMPLATE is the name of a L<Text::Template> to fill in and print.
6564
6565 =cut
6566
6567 sub queueable_print {
6568   my %opt = @_;
6569
6570   my $self = qsearchs('cust_main', { 'custnum' => $opt{custnum} } )
6571     or die "invalid customer number: " . $opt{custvnum};
6572
6573   my $error = $self->print( $opt{template} );
6574   die $error if $error;
6575 }
6576
6577 sub print {
6578   my ($self, $template) = (shift, shift);
6579   do_print [ $self->print_ps($template) ];
6580 }
6581
6582 sub agent_template {
6583   my $self = shift;
6584   $self->_agent_plandata('agent_templatename');
6585 }
6586
6587 sub agent_invoice_from {
6588   my $self = shift;
6589   $self->_agent_plandata('agent_invoice_from');
6590 }
6591
6592 sub _agent_plandata {
6593   my( $self, $option ) = @_;
6594
6595   #yuck.  this whole thing needs to be reconciled better with 1.9's idea of
6596   #agent-specific Conf
6597
6598   use FS::part_event::Condition;
6599
6600   my $agentnum = $self->agentnum;
6601
6602   my $regexp = '';
6603   if ( driver_name =~ /^Pg/i ) {
6604     $regexp = '~';
6605   } elsif ( driver_name =~ /^mysql/i ) {
6606     $regexp = 'REGEXP';
6607   } else {
6608     die "don't know how to use regular expressions in ". driver_name. " databases";
6609   }
6610
6611   my $part_event_option =
6612     qsearchs({
6613       'select'    => 'part_event_option.*',
6614       'table'     => 'part_event_option',
6615       'addl_from' => q{
6616         LEFT JOIN part_event USING ( eventpart )
6617         LEFT JOIN part_event_option AS peo_agentnum
6618           ON ( part_event.eventpart = peo_agentnum.eventpart
6619                AND peo_agentnum.optionname = 'agentnum'
6620                AND peo_agentnum.optionvalue }. $regexp. q{ '(^|,)}. $agentnum. q{(,|$)'
6621              )
6622         LEFT JOIN part_event_option AS peo_cust_bill_age
6623           ON ( part_event.eventpart = peo_cust_bill_age.eventpart
6624                AND peo_cust_bill_age.optionname = 'cust_bill_age'
6625              )
6626       },
6627       #'hashref'   => { 'optionname' => $option },
6628       #'hashref'   => { 'part_event_option.optionname' => $option },
6629       'extra_sql' =>
6630         " WHERE part_event_option.optionname = ". dbh->quote($option).
6631         " AND action = 'cust_bill_send_agent' ".
6632         " AND ( disabled IS NULL OR disabled != 'Y' ) ".
6633         " AND peo_agentnum.optionname = 'agentnum' ".
6634         " AND agentnum IS NULL OR agentnum = $agentnum ".
6635         " ORDER BY
6636            CASE WHEN peo_cust_bill_age.optionname != 'cust_bill_age'
6637            THEN -1
6638            ELSE ". FS::part_event::Condition->age2seconds_sql('peo_cust_bill_age.optionvalue').
6639         " END
6640           , part_event.weight".
6641         " LIMIT 1"
6642     });
6643
6644   unless ( $part_event_option ) {
6645     return $self->agent->invoice_template || ''
6646       if $option eq 'agent_templatename';
6647     return '';
6648   }
6649
6650   $part_event_option->optionvalue;
6651
6652 }
6653
6654 sub queued_bill {
6655   ## actual sub, not a method, designed to be called from the queue.
6656   ## sets up the customer, and calls the bill_and_collect
6657   my (%args) = @_; #, ($time, $invoice_time, $check_freq, $resetup) = @_;
6658   my $cust_main = qsearchs( 'cust_main', { custnum => $args{'custnum'} } );
6659       $cust_main->bill_and_collect(
6660         %args,
6661       );
6662 }
6663
6664 =back
6665
6666 =head1 BUGS
6667
6668 The delete method.
6669
6670 The delete method should possibly take an FS::cust_main object reference
6671 instead of a scalar customer number.
6672
6673 Bill and collect options should probably be passed as references instead of a
6674 list.
6675
6676 There should probably be a configuration file with a list of allowed credit
6677 card types.
6678
6679 No multiple currency support (probably a larger project than just this module).
6680
6681 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
6682
6683 Birthdates rely on negative epoch values.
6684
6685 The payby for card/check batches is broken.  With mixed batching, bad
6686 things will happen.
6687
6688 B<collect> I<invoice_time> should be renamed I<time>, like B<bill>.
6689
6690 =head1 SEE ALSO
6691
6692 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
6693 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
6694 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.
6695
6696 =cut
6697
6698 1;
6699