FS/FS/cust_main.pm

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