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