FS/FS/cust_main.pm

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