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