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