FS/FS/cust_main.pm

   1 package FS::cust_main;
   2
   3 use strict;
   4 use vars qw( @ISA @EXPORT_OK $DEBUG $me $conf @encrypted_fields
   5              $import $skip_fuzzyfiles $ignore_expired_card );
   6 use vars qw( $realtime_bop_decline_quiet ); #ugh
   7 use Safe;
   8 use Carp;
   9 use Exporter;
  10 BEGIN {
  11   eval "use Time::Local;";
  12   die "Time::Local minimum version 1.05 required with Perl versions before 5.6"
  13     if $] < 5.006 && !defined($Time::Local::VERSION);
  14   #eval "use Time::Local qw(timelocal timelocal_nocheck);";
  15   eval "use Time::Local qw(timelocal_nocheck);";
  16 }
  17 use Digest::MD5 qw(md5_base64);
  18 use Date::Format;
  19 use Date::Parse;
  20 #use Date::Manip;
  21 use String::Approx qw(amatch);
  22 use Business::CreditCard 0.28;
  23 use Locale::Country;
  24 use FS::UID qw( getotaker dbh );
  25 use FS::Record qw( qsearchs qsearch dbdef );
  26 use FS::Misc qw( send_email );
  27 use FS::Msgcat qw(gettext);
  28 use FS::cust_pkg;
  29 use FS::cust_svc;
  30 use FS::cust_bill;
  31 use FS::cust_bill_pkg;
  32 use FS::cust_pay;
  33 use FS::cust_pay_void;
  34 use FS::cust_credit;
  35 use FS::cust_refund;
  36 use FS::part_referral;
  37 use FS::cust_main_county;
  38 use FS::agent;
  39 use FS::cust_main_invoice;
  40 use FS::cust_credit_bill;
  41 use FS::cust_bill_pay;
  42 use FS::prepay_credit;
  43 use FS::queue;
  44 use FS::part_pkg;
  45 use FS::part_bill_event qw(due_events);
  46 use FS::cust_bill_event;
  47 use FS::cust_tax_exempt;
  48 use FS::cust_tax_exempt_pkg;
  49 use FS::type_pkgs;
  50 use FS::payment_gateway;
  51 use FS::agent_payment_gateway;
  52 use FS::banned_pay;
  53
  54 @ISA = qw( FS::Record );
  55
  56 @EXPORT_OK = qw( smart_search );
  57
  58 $realtime_bop_decline_quiet = 0;
  59
  60 # 1 is mostly method/subroutine entry and options
  61 # 2 traces progress of some operations
  62 # 3 is even more information including possibly sensitive data
  63 $DEBUG = 0;
  64 $me = '[FS::cust_main]';
  65
  66 $import = 0;
  67 $skip_fuzzyfiles = 0;
  68 $ignore_expired_card = 0;
  69
  70 @encrypted_fields = ('payinfo', 'paycvv');
  71
  72 #ask FS::UID to run this stuff for us later
  73 #$FS::UID::callback{'FS::cust_main'} = sub {
  74 install_callback FS::UID sub {
  75   $conf = new FS::Conf;
  76   #yes, need it for stuff below (prolly should be cached)
  77 };
  78
  79 sub _cache {
  80   my $self = shift;
  81   my ( $hashref, $cache ) = @_;
  82   if ( exists $hashref->{'pkgnum'} ) {
  83     #@{ $self->{'_pkgnum'} } = ();
  84     my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum});
  85     $self->{'_pkgnum'} = $subcache;
  86     #push @{ $self->{'_pkgnum'} },
  87     FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum};
  88   }
  89 }
  90
  91 =head1 NAME
  92
  93 FS::cust_main - Object methods for cust_main records
  94
  95 =head1 SYNOPSIS
  96
  97   use FS::cust_main;
  98
  99   $record = new FS::cust_main \%hash;
 100   $record = new FS::cust_main { 'column' => 'value' };
 101
 102   $error = $record->insert;
 103
 104   $error = $new_record->replace($old_record);
 105
 106   $error = $record->delete;
 107
 108   $error = $record->check;
 109
 110   @cust_pkg = $record->all_pkgs;
 111
 112   @cust_pkg = $record->ncancelled_pkgs;
 113
 114   @cust_pkg = $record->suspended_pkgs;
 115
 116   $error = $record->bill;
 117   $error = $record->bill %options;
 118   $error = $record->bill 'time' => $time;
 119
 120   $error = $record->collect;
 121   $error = $record->collect %options;
 122   $error = $record->collect 'invoice_time'   => $time,
 123                           ;
 124
 125 =head1 DESCRIPTION
 126
 127 An FS::cust_main object represents a customer.  FS::cust_main inherits from
 128 FS::Record.  The following fields are currently supported:
 129
 130 =over 4
 131
 132 =item custnum - primary key (assigned automatically for new customers)
 133
 134 =item agentnum - agent (see L<FS::agent>)
 135
 136 =item refnum - Advertising source (see L<FS::part_referral>)
 137
 138 =item first - name
 139
 140 =item last - name
 141
 142 =item ss - social security number (optional)
 143
 144 =item company - (optional)
 145
 146 =item address1
 147
 148 =item address2 - (optional)
 149
 150 =item city
 151
 152 =item county - (optional, see L<FS::cust_main_county>)
 153
 154 =item state - (see L<FS::cust_main_county>)
 155
 156 =item zip
 157
 158 =item country - (see L<FS::cust_main_county>)
 159
 160 =item daytime - phone (optional)
 161
 162 =item night - phone (optional)
 163
 164 =item fax - phone (optional)
 165
 166 =item ship_first - name
 167
 168 =item ship_last - name
 169
 170 =item ship_company - (optional)
 171
 172 =item ship_address1
 173
 174 =item ship_address2 - (optional)
 175
 176 =item ship_city
 177
 178 =item ship_county - (optional, see L<FS::cust_main_county>)
 179
 180 =item ship_state - (see L<FS::cust_main_county>)
 181
 182 =item ship_zip
 183
 184 =item ship_country - (see L<FS::cust_main_county>)
 185
 186 =item ship_daytime - phone (optional)
 187
 188 =item ship_night - phone (optional)
 189
 190 =item ship_fax - phone (optional)
 191
 192 =item payby
 193
 194 I<CARD> (credit card - automatic), I<DCRD> (credit card - on-demand), I<CHEK> (electronic check - automatic), I<DCHK> (electronic check - on-demand), I<LECB> (Phone bill billing), I<BILL> (billing), I<COMP> (free), or I<PREPAY> (special billing type: applies a credit - see L<FS::prepay_credit> and sets billing type to I<BILL>)
 195
 196 =item payinfo
 197
 198 Card Number, P.O., comp issuer (4-8 lowercase alphanumerics; think username) or prepayment identifier (see L<FS::prepay_credit>)
 199
 200 =cut
 201
 202 sub payinfo {
 203   my($self,$payinfo) = @_;
 204   if ( defined($payinfo) ) {
 205     $self->paymask($payinfo);
 206     $self->setfield('payinfo', $payinfo); # This is okay since we are the 'setter'
 207   } else {
 208     $payinfo = $self->getfield('payinfo'); # This is okay since we are the 'getter'
 209     return $payinfo;
 210   }
 211 }
 212
 213
 214 =item paycvv
 215
 216 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
 217
 218 =cut
 219
 220 =item paymask - Masked payment type
 221
 222 =over 4
 223
 224 =item Credit Cards
 225
 226 Mask all but the last four characters.
 227
 228 =item Checks
 229
 230 Mask all but last 2 of account number and bank routing number.
 231
 232 =item Others
 233
 234 Do nothing, return the unmasked string.
 235
 236 =back
 237
 238 =cut
 239
 240 sub paymask {
 241   my($self,$value)=@_;
 242
 243   # If it doesn't exist then generate it
 244   my $paymask=$self->getfield('paymask');
 245   if (!defined($value) && (!defined($paymask) || $paymask eq '')) {
 246     $value = $self->payinfo;
 247   }
 248
 249   if ( defined($value) && !$self->is_encrypted($value)) {
 250     my $payinfo = $value;
 251     my $payby = $self->payby;
 252     if ($payby eq 'CARD' || $payby eq 'DCRD') { # Credit Cards (Show last four)
 253       $paymask = 'x'x(length($payinfo)-4). substr($payinfo,(length($payinfo)-4));
 254     } elsif ($payby eq 'CHEK' ||
 255              $payby eq 'DCHK' ) { # Checks (Show last 2 @ bank)
 256       my( $account, $aba ) = split('@', $payinfo );
 257       $paymask = 'x'x(length($account)-2). substr($account,(length($account)-2))."@".$aba;
 258     } else { # Tie up loose ends
 259       $paymask = $payinfo;
 260     }
 261     $self->setfield('paymask', $paymask); # This is okay since we are the 'setter'
 262   } elsif (defined($value) && $self->is_encrypted($value)) {
 263     $paymask = 'N/A';
 264   }
 265   return $paymask;
 266 }
 267
 268 =item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy
 269
 270 =item paystart_month - start date month (maestro/solo cards only)
 271
 272 =item paystart_year - start date year (maestro/solo cards only)
 273
 274 =item payissue - issue number (maestro/solo cards only)
 275
 276 =item payname - name on card or billing name
 277
 278 =item payip - IP address from which payment information was received
 279
 280 =item tax - tax exempt, empty or `Y'
 281
 282 =item otaker - order taker (assigned automatically, see L<FS::UID>)
 283
 284 =item comments - comments (optional)
 285
 286 =item referral_custnum - referring customer number
 287
 288 =item spool_cdr - Enable individual CDR spooling, empty or `Y'
 289
 290 =back
 291
 292 =head1 METHODS
 293
 294 =over 4
 295
 296 =item new HASHREF
 297
 298 Creates a new customer.  To add the customer to the database, see L<"insert">.
 299
 300 Note that this stores the hash reference, not a distinct copy of the hash it
 301 points to.  You can ask the object for a copy with the I<hash> method.
 302
 303 =cut
 304
 305 sub table { 'cust_main'; }
 306
 307 =item insert [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
 308
 309 Adds this customer to the database.  If there is an error, returns the error,
 310 otherwise returns false.
 311
 312 CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert
 313 method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records
 314 are inserted atomicly, or the transaction is rolled back.  Passing an empty
 315 hash reference is equivalent to not supplying this parameter.  There should be
 316 a better explanation of this, but until then, here's an example:
 317
 318   use Tie::RefHash;
 319   tie %hash, 'Tie::RefHash'; #this part is important
 320   %hash = (
 321     $cust_pkg => [ $svc_acct ],
 322     ...
 323   );
 324   $cust_main->insert( \%hash );
 325
 326 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
 327 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
 328 expected and rollback the entire transaction; it is not necessary to call
 329 check_invoicing_list first.  The invoicing_list is set after the records in the
 330 CUST_PKG_HASHREF above are inserted, so it is now possible to set an
 331 invoicing_list destination to the newly-created svc_acct.  Here's an example:
 332
 333   $cust_main->insert( {}, [ $email, 'POST' ] );
 334
 335 Currently available options are: I<depend_jobnum> and I<noexport>.
 336
 337 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 338 on the supplied jobnum (they will not run until the specific job completes).
 339 This can be used to defer provisioning until some action completes (such
 340 as running the customer's credit card successfully).
 341
 342 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 343 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 344 the B<reexport> method.)
 345
 346 =cut
 347
 348 sub insert {
 349   my $self = shift;
 350   my $cust_pkgs = @_ ? shift : {};
 351   my $invoicing_list = @_ ? shift : '';
 352   my %options = @_;
 353   warn "$me insert called with options ".
 354        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 355     if $DEBUG;
 356
 357   local $SIG{HUP} = 'IGNORE';
 358   local $SIG{INT} = 'IGNORE';
 359   local $SIG{QUIT} = 'IGNORE';
 360   local $SIG{TERM} = 'IGNORE';
 361   local $SIG{TSTP} = 'IGNORE';
 362   local $SIG{PIPE} = 'IGNORE';
 363
 364   my $oldAutoCommit = $FS::UID::AutoCommit;
 365   local $FS::UID::AutoCommit = 0;
 366   my $dbh = dbh;
 367
 368   my $prepay_identifier = '';
 369   my( $amount, $seconds ) = ( 0, 0 );
 370   my $payby = '';
 371   if ( $self->payby eq 'PREPAY' ) {
 372
 373     $self->payby('BILL');
 374     $prepay_identifier = $self->payinfo;
 375     $self->payinfo('');
 376
 377     warn "  looking up prepaid card $prepay_identifier\n"
 378       if $DEBUG > 1;
 379
 380     my $error = $self->get_prepay($prepay_identifier, \$amount, \$seconds);
 381     if ( $error ) {
 382       $dbh->rollback if $oldAutoCommit;
 383       #return "error applying prepaid card (transaction rolled back): $error";
 384       return $error;
 385     }
 386
 387     $payby = 'PREP' if $amount;
 388
 389   } elsif ( $self->payby =~ /^(CASH|WEST|MCRD)$/ ) {
 390
 391     $payby = $1;
 392     $self->payby('BILL');
 393     $amount = $self->paid;
 394
 395   }
 396
 397   warn "  inserting $self\n"
 398     if $DEBUG > 1;
 399
 400   my $error = $self->SUPER::insert;
 401   if ( $error ) {
 402     $dbh->rollback if $oldAutoCommit;
 403     #return "inserting cust_main record (transaction rolled back): $error";
 404     return $error;
 405   }
 406
 407   warn "  setting invoicing list\n"
 408     if $DEBUG > 1;
 409
 410   if ( $invoicing_list ) {
 411     $error = $self->check_invoicing_list( $invoicing_list );
 412     if ( $error ) {
 413       $dbh->rollback if $oldAutoCommit;
 414       return "checking invoicing_list (transaction rolled back): $error";
 415     }
 416     $self->invoicing_list( $invoicing_list );
 417   }
 418
 419   if (    $conf->config('cust_main-skeleton_tables')
 420        && $conf->config('cust_main-skeleton_custnum') ) {
 421
 422     warn "  inserting skeleton records\n"
 423       if $DEBUG > 1;
 424
 425     my $error = $self->start_copy_skel;
 426     if ( $error ) {
 427       $dbh->rollback if $oldAutoCommit;
 428       return $error;
 429     }
 430
 431   }
 432
 433   warn "  ordering packages\n"
 434     if $DEBUG > 1;
 435
 436   $error = $self->order_pkgs($cust_pkgs, \$seconds, %options);
 437   if ( $error ) {
 438     $dbh->rollback if $oldAutoCommit;
 439     return $error;
 440   }
 441
 442   if ( $seconds ) {
 443     $dbh->rollback if $oldAutoCommit;
 444     return "No svc_acct record to apply pre-paid time";
 445   }
 446
 447   if ( $amount ) {
 448     warn "  inserting initial $payby payment of $amount\n"
 449       if $DEBUG > 1;
 450     $error = $self->insert_cust_pay($payby, $amount, $prepay_identifier);
 451     if ( $error ) {
 452       $dbh->rollback if $oldAutoCommit;
 453       return "inserting payment (transaction rolled back): $error";
 454     }
 455   }
 456
 457   unless ( $import || $skip_fuzzyfiles ) {
 458     warn "  queueing fuzzyfiles update\n"
 459       if $DEBUG > 1;
 460     $error = $self->queue_fuzzyfiles_update;
 461     if ( $error ) {
 462       $dbh->rollback if $oldAutoCommit;
 463       return "updating fuzzy search cache: $error";
 464     }
 465   }
 466
 467   warn "  insert complete; committing transaction\n"
 468     if $DEBUG > 1;
 469
 470   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 471   '';
 472
 473 }
 474
 475 sub start_copy_skel {
 476   my $self = shift;
 477
 478   #'mg_user_preference' => {},
 479   #'mg_user_indicator_profile.user_indicator_profile_id' => { 'mg_profile_indicator.profile_indicator_id' => { 'mg_profile_details.profile_detail_id' }, },
 480   #'mg_watchlist_header.watchlist_header_id' => { 'mg_watchlist_details.watchlist_details_id' },
 481   #'mg_user_grid_header.grid_header_id' => { 'mg_user_grid_details.user_grid_details_id' },
 482   #'mg_portfolio_header.portfolio_header_id' => { 'mg_portfolio_trades.portfolio_trades_id' => { 'mg_portfolio_trades_positions.portfolio_trades_positions_id' } },
 483   my @tables = eval($conf->config_binary('cust_main-skeleton_tables'));
 484   die $@ if $@;
 485
 486   _copy_skel( 'cust_main',                                 #tablename
 487               $conf->config('cust_main-skeleton_custnum'), #sourceid
 488               $self->custnum,                              #destid
 489               @tables,                                     #child tables
 490             );
 491 }
 492
 493 #recursive subroutine, not a method
 494 sub _copy_skel {
 495   my( $table, $sourceid, $destid, %child_tables ) = @_;
 496
 497   my $primary_key;
 498   if ( $table =~ /^(\w+)\.(\w+)$/ ) {
 499     ( $table, $primary_key ) = ( $1, $2 );
 500   } else {
 501     my $dbdef_table = dbdef->table($table);
 502     $primary_key = $dbdef_table->primary_key
 503       or return "$table has no primary key".
 504                 " (or do you need to run dbdef-create?)";
 505   }
 506
 507   warn "  _copy_skel: $table.$primary_key $sourceid to $destid for ".
 508        join (', ', keys %child_tables). "\n"
 509     if $DEBUG > 2;
 510
 511   foreach my $child_table_def ( keys %child_tables ) {
 512
 513     my $child_table;
 514     my $child_pkey = '';
 515     if ( $child_table_def =~ /^(\w+)\.(\w+)$/ ) {
 516       ( $child_table, $child_pkey ) = ( $1, $2 );
 517     } else {
 518       $child_table = $child_table_def;
 519
 520       $child_pkey = dbdef->table($child_table)->primary_key;
 521       #  or return "$table has no primary key".
 522       #            " (or do you need to run dbdef-create?)\n";
 523     }
 524
 525     my $sequence = '';
 526     if ( keys %{ $child_tables{$child_table_def} } ) {
 527
 528       return "$child_table has no primary key".
 529              " (run dbdef-create or try specifying it?)\n"
 530         unless $child_pkey;
 531
 532       #false laziness w/Record::insert and only works on Pg
 533       #refactor the proper last-inserted-id stuff out of Record::insert if this
 534       # ever gets use for anything besides a quick kludge for one customer
 535       my $default = dbdef->table($child_table)->column($child_pkey)->default;
 536       $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i
 537         or return "can't parse $child_table.$child_pkey default value ".
 538                   " for sequence name: $default";
 539       $sequence = $1;
 540
 541     }
 542
 543     my @sel_columns = grep { $_ ne $primary_key }
 544                            dbdef->table($child_table)->columns;
 545     my $sel_columns = join(', ', @sel_columns );
 546
 547     my @ins_columns = grep { $_ ne $child_pkey } @sel_columns;
 548     my $ins_columns = ' ( '. join(', ', $primary_key, @ins_columns ). ' ) ';
 549     my $placeholders = ' ( ?, '. join(', ', map '?', @ins_columns ). ' ) ';
 550
 551     my $sel_st = "SELECT $sel_columns FROM $child_table".
 552                  " WHERE $primary_key = $sourceid";
 553     warn "    $sel_st\n"
 554       if $DEBUG > 2;
 555     my $sel_sth = dbh->prepare( $sel_st )
 556       or return dbh->errstr;
 557
 558     $sel_sth->execute or return $sel_sth->errstr;
 559
 560     while ( my $row = $sel_sth->fetchrow_hashref ) {
 561
 562       warn "    selected row: ".
 563            join(', ', map { "$_=".$row->{$_} } keys %$row ). "\n"
 564         if $DEBUG > 2;
 565
 566       my $statement =
 567         "INSERT INTO $child_table $ins_columns VALUES $placeholders";
 568       my $ins_sth =dbh->prepare($statement)
 569           or return dbh->errstr;
 570       my @param = ( $destid, map $row->{$_}, @ins_columns );
 571       warn "    $statement: [ ". join(', ', @param). " ]\n"
 572         if $DEBUG > 2;
 573       $ins_sth->execute( @param )
 574         or return $ins_sth->errstr;
 575
 576       #next unless keys %{ $child_tables{$child_table} };
 577       next unless $sequence;
 578
 579       #another section of that laziness
 580       my $seq_sql = "SELECT currval('$sequence')";
 581       my $seq_sth = dbh->prepare($seq_sql) or return dbh->errstr;
 582       $seq_sth->execute or return $seq_sth->errstr;
 583       my $insertid = $seq_sth->fetchrow_arrayref->[0];
 584
 585       # don't drink soap!  recurse!  recurse!  okay!
 586       my $error =
 587         _copy_skel( $child_table_def,
 588                     $row->{$child_pkey}, #sourceid
 589                     $insertid, #destid
 590                     %{ $child_tables{$child_table_def} },
 591                   );
 592       return $error if $error;
 593
 594     }
 595
 596   }
 597
 598   return '';
 599
 600 }
 601
 602 =item order_pkgs HASHREF, [ SECONDSREF, [ , OPTION => VALUE ... ] ]
 603
 604 Like the insert method on an existing record, this method orders a package
 605 and included services atomicaly.  Pass a Tie::RefHash data structure to this
 606 method containing FS::cust_pkg and FS::svc_I<tablename> objects.  There should
 607 be a better explanation of this, but until then, here's an example:
 608
 609   use Tie::RefHash;
 610   tie %hash, 'Tie::RefHash'; #this part is important
 611   %hash = (
 612     $cust_pkg => [ $svc_acct ],
 613     ...
 614   );
 615   $cust_main->order_pkgs( \%hash, \'0', 'noexport'=>1 );
 616
 617 Services can be new, in which case they are inserted, or existing unaudited
 618 services, in which case they are linked to the newly-created package.
 619
 620 Currently available options are: I<depend_jobnum> and I<noexport>.
 621
 622 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 623 on the supplied jobnum (they will not run until the specific job completes).
 624 This can be used to defer provisioning until some action completes (such
 625 as running the customer's credit card successfully).
 626
 627 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 628 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 629 the B<reexport> method for each cust_pkg object.  Using the B<reexport> method
 630 on the cust_main object is not recommended, as existing services will also be
 631 reexported.)
 632
 633 =cut
 634
 635 sub order_pkgs {
 636   my $self = shift;
 637   my $cust_pkgs = shift;
 638   my $seconds = shift;
 639   my %options = @_;
 640   my %svc_options = ();
 641   $svc_options{'depend_jobnum'} = $options{'depend_jobnum'}
 642     if exists $options{'depend_jobnum'};
 643   warn "$me order_pkgs called with options ".
 644        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 645     if $DEBUG;
 646
 647   local $SIG{HUP} = 'IGNORE';
 648   local $SIG{INT} = 'IGNORE';
 649   local $SIG{QUIT} = 'IGNORE';
 650   local $SIG{TERM} = 'IGNORE';
 651   local $SIG{TSTP} = 'IGNORE';
 652   local $SIG{PIPE} = 'IGNORE';
 653
 654   my $oldAutoCommit = $FS::UID::AutoCommit;
 655   local $FS::UID::AutoCommit = 0;
 656   my $dbh = dbh;
 657
 658   local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
 659
 660   foreach my $cust_pkg ( keys %$cust_pkgs ) {
 661     $cust_pkg->custnum( $self->custnum );
 662     my $error = $cust_pkg->insert;
 663     if ( $error ) {
 664       $dbh->rollback if $oldAutoCommit;
 665       return "inserting cust_pkg (transaction rolled back): $error";
 666     }
 667     foreach my $svc_something ( @{$cust_pkgs->{$cust_pkg}} ) {
 668       if ( $svc_something->svcnum ) {
 669         my $old_cust_svc = $svc_something->cust_svc;
 670         my $new_cust_svc = new FS::cust_svc { $old_cust_svc->hash };
 671         $new_cust_svc->pkgnum( $cust_pkg->pkgnum);
 672         $error = $new_cust_svc->replace($old_cust_svc);
 673       } else {
 674         $svc_something->pkgnum( $cust_pkg->pkgnum );
 675         if ( $seconds && $$seconds && $svc_something->isa('FS::svc_acct') ) {
 676           $svc_something->seconds( $svc_something->seconds + $$seconds );
 677           $$seconds = 0;
 678         }
 679         $error = $svc_something->insert(%svc_options);
 680       }
 681       if ( $error ) {
 682         $dbh->rollback if $oldAutoCommit;
 683         #return "inserting svc_ (transaction rolled back): $error";
 684         return $error;
 685       }
 686     }
 687   }
 688
 689   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 690   ''; #no error
 691 }
 692
 693 =item recharge_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , AMOUNTREF, SECONDSREF ]
 694
 695 Recharges this (existing) customer with the specified prepaid card (see
 696 L<FS::prepay_credit>), specified either by I<identifier> or as an
 697 FS::prepay_credit object.  If there is an error, returns the error, otherwise
 698 returns false.
 699
 700 Optionally, two scalar references can be passed as well.  They will have their
 701 values filled in with the amount and number of seconds applied by this prepaid
 702 card.
 703
 704 =cut
 705
 706 sub recharge_prepay {
 707   my( $self, $prepay_credit, $amountref, $secondsref ) = @_;
 708
 709   local $SIG{HUP} = 'IGNORE';
 710   local $SIG{INT} = 'IGNORE';
 711   local $SIG{QUIT} = 'IGNORE';
 712   local $SIG{TERM} = 'IGNORE';
 713   local $SIG{TSTP} = 'IGNORE';
 714   local $SIG{PIPE} = 'IGNORE';
 715
 716   my $oldAutoCommit = $FS::UID::AutoCommit;
 717   local $FS::UID::AutoCommit = 0;
 718   my $dbh = dbh;
 719
 720   my( $amount, $seconds ) = ( 0, 0 );
 721
 722   my $error = $self->get_prepay($prepay_credit, \$amount, \$seconds)
 723            || $self->increment_seconds($seconds)
 724            || $self->insert_cust_pay_prepay( $amount,
 725                                              ref($prepay_credit)
 726                                                ? $prepay_credit->identifier
 727                                                : $prepay_credit
 728                                            );
 729
 730   if ( $error ) {
 731     $dbh->rollback if $oldAutoCommit;
 732     return $error;
 733   }
 734
 735   if ( defined($amountref)  ) { $$amountref  = $amount;  }
 736   if ( defined($secondsref) ) { $$secondsref = $seconds; }
 737
 738   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 739   '';
 740
 741 }
 742
 743 =item get_prepay IDENTIFIER | PREPAY_CREDIT_OBJ , AMOUNTREF, SECONDSREF
 744
 745 Looks up and deletes a prepaid card (see L<FS::prepay_credit>),
 746 specified either by I<identifier> or as an FS::prepay_credit object.
 747
 748 References to I<amount> and I<seconds> scalars should be passed as arguments
 749 and will be incremented by the values of the prepaid card.
 750
 751 If the prepaid card specifies an I<agentnum> (see L<FS::agent>), it is used to
 752 check or set this customer's I<agentnum>.
 753
 754 If there is an error, returns the error, otherwise returns false.
 755
 756 =cut
 757
 758
 759 sub get_prepay {
 760   my( $self, $prepay_credit, $amountref, $secondsref ) = @_;
 761
 762   local $SIG{HUP} = 'IGNORE';
 763   local $SIG{INT} = 'IGNORE';
 764   local $SIG{QUIT} = 'IGNORE';
 765   local $SIG{TERM} = 'IGNORE';
 766   local $SIG{TSTP} = 'IGNORE';
 767   local $SIG{PIPE} = 'IGNORE';
 768
 769   my $oldAutoCommit = $FS::UID::AutoCommit;
 770   local $FS::UID::AutoCommit = 0;
 771   my $dbh = dbh;
 772
 773   unless ( ref($prepay_credit) ) {
 774
 775     my $identifier = $prepay_credit;
 776
 777     $prepay_credit = qsearchs(
 778       'prepay_credit',
 779       { 'identifier' => $prepay_credit },
 780       '',
 781       'FOR UPDATE'
 782     );
 783
 784     unless ( $prepay_credit ) {
 785       $dbh->rollback if $oldAutoCommit;
 786       return "Invalid prepaid card: ". $identifier;
 787     }
 788
 789   }
 790
 791   if ( $prepay_credit->agentnum ) {
 792     if ( $self->agentnum && $self->agentnum != $prepay_credit->agentnum ) {
 793       $dbh->rollback if $oldAutoCommit;
 794       return "prepaid card not valid for agent ". $self->agentnum;
 795     }
 796     $self->agentnum($prepay_credit->agentnum);
 797   }
 798
 799   my $error = $prepay_credit->delete;
 800   if ( $error ) {
 801     $dbh->rollback if $oldAutoCommit;
 802     return "removing prepay_credit (transaction rolled back): $error";
 803   }
 804
 805   $$amountref  += $prepay_credit->amount;
 806   $$secondsref += $prepay_credit->seconds;
 807
 808   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 809   '';
 810
 811 }
 812
 813 =item increment_seconds SECONDS
 814
 815 Updates this customer's single or primary account (see L<FS::svc_acct>) by
 816 the specified number of seconds.  If there is an error, returns the error,
 817 otherwise returns false.
 818
 819 =cut
 820
 821 sub increment_seconds {
 822   my( $self, $seconds ) = @_;
 823   warn "$me increment_seconds called: $seconds seconds\n"
 824     if $DEBUG;
 825
 826   my @cust_pkg = grep { $_->part_pkg->svcpart('svc_acct') }
 827                       $self->ncancelled_pkgs;
 828
 829   if ( ! @cust_pkg ) {
 830     return 'No packages with primary or single services found'.
 831            ' to apply pre-paid time';
 832   } elsif ( scalar(@cust_pkg) > 1 ) {
 833     #maybe have a way to specify the package/account?
 834     return 'Multiple packages found to apply pre-paid time';
 835   }
 836
 837   my $cust_pkg = $cust_pkg[0];
 838   warn "  found package pkgnum ". $cust_pkg->pkgnum. "\n"
 839     if $DEBUG > 1;
 840
 841   my @cust_svc =
 842     $cust_pkg->cust_svc( $cust_pkg->part_pkg->svcpart('svc_acct') );
 843
 844   if ( ! @cust_svc ) {
 845     return 'No account found to apply pre-paid time';
 846   } elsif ( scalar(@cust_svc) > 1 ) {
 847     return 'Multiple accounts found to apply pre-paid time';
 848   }
 849
 850   my $svc_acct = $cust_svc[0]->svc_x;
 851   warn "  found service svcnum ". $svc_acct->pkgnum.
 852        ' ('. $svc_acct->email. ")\n"
 853     if $DEBUG > 1;
 854
 855   $svc_acct->increment_seconds($seconds);
 856
 857 }
 858
 859 =item insert_cust_pay_prepay AMOUNT [ PAYINFO ]
 860
 861 Inserts a prepayment in the specified amount for this customer.  An optional
 862 second argument can specify the prepayment identifier for tracking purposes.
 863 If there is an error, returns the error, otherwise returns false.
 864
 865 =cut
 866
 867 sub insert_cust_pay_prepay {
 868   shift->insert_cust_pay('PREP', @_);
 869 }
 870
 871 =item insert_cust_pay_cash AMOUNT [ PAYINFO ]
 872
 873 Inserts a cash payment in the specified amount for this customer.  An optional
 874 second argument can specify the payment identifier for tracking purposes.
 875 If there is an error, returns the error, otherwise returns false.
 876
 877 =cut
 878
 879 sub insert_cust_pay_cash {
 880   shift->insert_cust_pay('CASH', @_);
 881 }
 882
 883 =item insert_cust_pay_west AMOUNT [ PAYINFO ]
 884
 885 Inserts a Western Union payment in the specified amount for this customer.  An
 886 optional second argument can specify the prepayment identifier for tracking
 887 purposes.  If there is an error, returns the error, otherwise returns false.
 888
 889 =cut
 890
 891 sub insert_cust_pay_west {
 892   shift->insert_cust_pay('WEST', @_);
 893 }
 894
 895 sub insert_cust_pay {
 896   my( $self, $payby, $amount ) = splice(@_, 0, 3);
 897   my $payinfo = scalar(@_) ? shift : '';
 898
 899   my $cust_pay = new FS::cust_pay {
 900     'custnum' => $self->custnum,
 901     'paid'    => sprintf('%.2f', $amount),
 902     #'_date'   => #date the prepaid card was purchased???
 903     'payby'   => $payby,
 904     'payinfo' => $payinfo,
 905   };
 906   $cust_pay->insert;
 907
 908 }
 909
 910 =item reexport
 911
 912 This method is deprecated.  See the I<depend_jobnum> option to the insert and
 913 order_pkgs methods for a better way to defer provisioning.
 914
 915 Re-schedules all exports by calling the B<reexport> method of all associated
 916 packages (see L<FS::cust_pkg>).  If there is an error, returns the error;
 917 otherwise returns false.
 918
 919 =cut
 920
 921 sub reexport {
 922   my $self = shift;
 923
 924   carp "WARNING: FS::cust_main::reexport is deprectated; ".
 925        "use the depend_jobnum option to insert or order_pkgs to delay export";
 926
 927   local $SIG{HUP} = 'IGNORE';
 928   local $SIG{INT} = 'IGNORE';
 929   local $SIG{QUIT} = 'IGNORE';
 930   local $SIG{TERM} = 'IGNORE';
 931   local $SIG{TSTP} = 'IGNORE';
 932   local $SIG{PIPE} = 'IGNORE';
 933
 934   my $oldAutoCommit = $FS::UID::AutoCommit;
 935   local $FS::UID::AutoCommit = 0;
 936   my $dbh = dbh;
 937
 938   foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
 939     my $error = $cust_pkg->reexport;
 940     if ( $error ) {
 941       $dbh->rollback if $oldAutoCommit;
 942       return $error;
 943     }
 944   }
 945
 946   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 947   '';
 948
 949 }
 950
 951 =item delete NEW_CUSTNUM
 952
 953 This deletes the customer.  If there is an error, returns the error, otherwise
 954 returns false.
 955
 956 This will completely remove all traces of the customer record.  This is not
 957 what you want when a customer cancels service; for that, cancel all of the
 958 customer's packages (see L</cancel>).
 959
 960 If the customer has any uncancelled packages, you need to pass a new (valid)
 961 customer number for those packages to be transferred to.  Cancelled packages
 962 will be deleted.  Did I mention that this is NOT what you want when a customer
 963 cancels service and that you really should be looking see L<FS::cust_pkg/cancel>?
 964
 965 You can't delete a customer with invoices (see L<FS::cust_bill>),
 966 or credits (see L<FS::cust_credit>), payments (see L<FS::cust_pay>) or
 967 refunds (see L<FS::cust_refund>).
 968
 969 =cut
 970
 971 sub delete {
 972   my $self = shift;
 973
 974   local $SIG{HUP} = 'IGNORE';
 975   local $SIG{INT} = 'IGNORE';
 976   local $SIG{QUIT} = 'IGNORE';
 977   local $SIG{TERM} = 'IGNORE';
 978   local $SIG{TSTP} = 'IGNORE';
 979   local $SIG{PIPE} = 'IGNORE';
 980
 981   my $oldAutoCommit = $FS::UID::AutoCommit;
 982   local $FS::UID::AutoCommit = 0;
 983   my $dbh = dbh;
 984
 985   if ( $self->cust_bill ) {
 986     $dbh->rollback if $oldAutoCommit;
 987     return "Can't delete a customer with invoices";
 988   }
 989   if ( $self->cust_credit ) {
 990     $dbh->rollback if $oldAutoCommit;
 991     return "Can't delete a customer with credits";
 992   }
 993   if ( $self->cust_pay ) {
 994     $dbh->rollback if $oldAutoCommit;
 995     return "Can't delete a customer with payments";
 996   }
 997   if ( $self->cust_refund ) {
 998     $dbh->rollback if $oldAutoCommit;
 999     return "Can't delete a customer with refunds";
1000   }
1001
1002   my @cust_pkg = $self->ncancelled_pkgs;
1003   if ( @cust_pkg ) {
1004     my $new_custnum = shift;
1005     unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) {
1006       $dbh->rollback if $oldAutoCommit;
1007       return "Invalid new customer number: $new_custnum";
1008     }
1009     foreach my $cust_pkg ( @cust_pkg ) {
1010       my %hash = $cust_pkg->hash;
1011       $hash{'custnum'} = $new_custnum;
1012       my $new_cust_pkg = new FS::cust_pkg ( \%hash );
1013       my $error = $new_cust_pkg->replace($cust_pkg);
1014       if ( $error ) {
1015         $dbh->rollback if $oldAutoCommit;
1016         return $error;
1017       }
1018     }
1019   }
1020   my @cancelled_cust_pkg = $self->all_pkgs;
1021   foreach my $cust_pkg ( @cancelled_cust_pkg ) {
1022     my $error = $cust_pkg->delete;
1023     if ( $error ) {
1024       $dbh->rollback if $oldAutoCommit;
1025       return $error;
1026     }
1027   }
1028
1029   foreach my $cust_main_invoice ( #(email invoice destinations, not invoices)
1030     qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } )
1031   ) {
1032     my $error = $cust_main_invoice->delete;
1033     if ( $error ) {
1034       $dbh->rollback if $oldAutoCommit;
1035       return $error;
1036     }
1037   }
1038
1039   my $error = $self->SUPER::delete;
1040   if ( $error ) {
1041     $dbh->rollback if $oldAutoCommit;
1042     return $error;
1043   }
1044
1045   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1046   '';
1047
1048 }
1049
1050 =item replace OLD_RECORD [ INVOICING_LIST_ARYREF ]
1051
1052 Replaces the OLD_RECORD with this one in the database.  If there is an error,
1053 returns the error, otherwise returns false.
1054
1055 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
1056 be set as the invoicing list (see L<"invoicing_list">).  Errors return as
1057 expected and rollback the entire transaction; it is not necessary to call
1058 check_invoicing_list first.  Here's an example:
1059
1060   $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
1061
1062 =cut
1063
1064 sub replace {
1065   my $self = shift;
1066   my $old = shift;
1067   my @param = @_;
1068   warn "$me replace called\n"
1069     if $DEBUG;
1070
1071   local $SIG{HUP} = 'IGNORE';
1072   local $SIG{INT} = 'IGNORE';
1073   local $SIG{QUIT} = 'IGNORE';
1074   local $SIG{TERM} = 'IGNORE';
1075   local $SIG{TSTP} = 'IGNORE';
1076   local $SIG{PIPE} = 'IGNORE';
1077
1078   # If the mask is blank then try to set it - if we can...
1079   if (!defined($self->getfield('paymask')) || $self->getfield('paymask') eq '') {
1080     $self->paymask($self->payinfo);
1081   }
1082
1083   # We absolutely have to have an old vs. new record to make this work.
1084   if (!defined($old)) {
1085     $old = qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1086   }
1087
1088   my $curuser = $FS::CurrentUser::CurrentUser;
1089   if (    $self->payby eq 'COMP'
1090        && $self->payby ne $old->payby
1091        && ! $curuser->access_right('Complimentary customer')
1092      )
1093   {
1094     return "You are not permitted to create complimentary accounts.";
1095   }
1096
1097   local($ignore_expired_card) = 1
1098     if $old->payby  =~ /^(CARD|DCRD)$/
1099     && $self->payby =~ /^(CARD|DCRD)$/
1100     && $old->payinfo eq $self->payinfo;
1101
1102   my $oldAutoCommit = $FS::UID::AutoCommit;
1103   local $FS::UID::AutoCommit = 0;
1104   my $dbh = dbh;
1105
1106   my $error = $self->SUPER::replace($old);
1107
1108   if ( $error ) {
1109     $dbh->rollback if $oldAutoCommit;
1110     return $error;
1111   }
1112
1113   if ( @param ) { # INVOICING_LIST_ARYREF
1114     my $invoicing_list = shift @param;
1115     $error = $self->check_invoicing_list( $invoicing_list );
1116     if ( $error ) {
1117       $dbh->rollback if $oldAutoCommit;
1118       return $error;
1119     }
1120     $self->invoicing_list( $invoicing_list );
1121   }
1122
1123   if ( $self->payby =~ /^(CARD|CHEK|LECB)$/ &&
1124        grep { $self->get($_) ne $old->get($_) } qw(payinfo paydate payname) ) {
1125     # card/check/lec info has changed, want to retry realtime_ invoice events
1126     my $error = $self->retry_realtime;
1127     if ( $error ) {
1128       $dbh->rollback if $oldAutoCommit;
1129       return $error;
1130     }
1131   }
1132
1133   unless ( $import || $skip_fuzzyfiles ) {
1134     $error = $self->queue_fuzzyfiles_update;
1135     if ( $error ) {
1136       $dbh->rollback if $oldAutoCommit;
1137       return "updating fuzzy search cache: $error";
1138     }
1139   }
1140
1141   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1142   '';
1143
1144 }
1145
1146 =item queue_fuzzyfiles_update
1147
1148 Used by insert & replace to update the fuzzy search cache
1149
1150 =cut
1151
1152 sub queue_fuzzyfiles_update {
1153   my $self = shift;
1154
1155   local $SIG{HUP} = 'IGNORE';
1156   local $SIG{INT} = 'IGNORE';
1157   local $SIG{QUIT} = 'IGNORE';
1158   local $SIG{TERM} = 'IGNORE';
1159   local $SIG{TSTP} = 'IGNORE';
1160   local $SIG{PIPE} = 'IGNORE';
1161
1162   my $oldAutoCommit = $FS::UID::AutoCommit;
1163   local $FS::UID::AutoCommit = 0;
1164   my $dbh = dbh;
1165
1166   my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1167   my $error = $queue->insert( map $self->getfield($_),
1168                                   qw(first last company)
1169                             );
1170   if ( $error ) {
1171     $dbh->rollback if $oldAutoCommit;
1172     return "queueing job (transaction rolled back): $error";
1173   }
1174
1175   if ( $self->ship_last ) {
1176     $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1177     $error = $queue->insert( map $self->getfield("ship_$_"),
1178                                  qw(first last company)
1179                            );
1180     if ( $error ) {
1181       $dbh->rollback if $oldAutoCommit;
1182       return "queueing job (transaction rolled back): $error";
1183     }
1184   }
1185
1186   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1187   '';
1188
1189 }
1190
1191 =item check
1192
1193 Checks all fields to make sure this is a valid customer record.  If there is
1194 an error, returns the error, otherwise returns false.  Called by the insert
1195 and replace methods.
1196
1197 =cut
1198
1199 sub check {
1200   my $self = shift;
1201
1202   warn "$me check BEFORE: \n". $self->_dump
1203     if $DEBUG > 2;
1204
1205   my $error =
1206     $self->ut_numbern('custnum')
1207     || $self->ut_number('agentnum')
1208     || $self->ut_textn('agent_custid')
1209     || $self->ut_number('refnum')
1210     || $self->ut_name('last')
1211     || $self->ut_name('first')
1212     || $self->ut_snumbern('birthdate')
1213     || $self->ut_textn('company')
1214     || $self->ut_text('address1')
1215     || $self->ut_textn('address2')
1216     || $self->ut_text('city')
1217     || $self->ut_textn('county')
1218     || $self->ut_textn('state')
1219     || $self->ut_country('country')
1220     || $self->ut_anything('comments')
1221     || $self->ut_numbern('referral_custnum')
1222   ;
1223   #barf.  need message catalogs.  i18n.  etc.
1224   $error .= "Please select an advertising source."
1225     if $error =~ /^Illegal or empty \(numeric\) refnum: /;
1226   return $error if $error;
1227
1228   return "Unknown agent"
1229     unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1230
1231   return "Unknown refnum"
1232     unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } );
1233
1234   return "Unknown referring custnum: ". $self->referral_custnum
1235     unless ! $self->referral_custnum
1236            || qsearchs( 'cust_main', { 'custnum' => $self->referral_custnum } );
1237
1238   if ( $self->ss eq '' ) {
1239     $self->ss('');
1240   } else {
1241     my $ss = $self->ss;
1242     $ss =~ s/\D//g;
1243     $ss =~ /^(\d{3})(\d{2})(\d{4})$/
1244       or return "Illegal social security number: ". $self->ss;
1245     $self->ss("$1-$2-$3");
1246   }
1247
1248
1249 # bad idea to disable, causes billing to fail because of no tax rates later
1250 #  unless ( $import ) {
1251     unless ( qsearch('cust_main_county', {
1252       'country' => $self->country,
1253       'state'   => '',
1254      } ) ) {
1255       return "Unknown state/county/country: ".
1256         $self->state. "/". $self->county. "/". $self->country
1257         unless qsearch('cust_main_county',{
1258           'state'   => $self->state,
1259           'county'  => $self->county,
1260           'country' => $self->country,
1261         } );
1262     }
1263 #  }
1264
1265   $error =
1266     $self->ut_phonen('daytime', $self->country)
1267     || $self->ut_phonen('night', $self->country)
1268     || $self->ut_phonen('fax', $self->country)
1269     || $self->ut_zip('zip', $self->country)
1270   ;
1271   return $error if $error;
1272
1273   my @addfields = qw(
1274     last first company address1 address2 city county state zip
1275     country daytime night fax
1276   );
1277
1278   if ( defined $self->dbdef_table->column('ship_last') ) {
1279     if ( scalar ( grep { $self->getfield($_) ne $self->getfield("ship_$_") }
1280                        @addfields )
1281          && scalar ( grep { $self->getfield("ship_$_") ne '' } @addfields )
1282        )
1283     {
1284       my $error =
1285         $self->ut_name('ship_last')
1286         || $self->ut_name('ship_first')
1287         || $self->ut_textn('ship_company')
1288         || $self->ut_text('ship_address1')
1289         || $self->ut_textn('ship_address2')
1290         || $self->ut_text('ship_city')
1291         || $self->ut_textn('ship_county')
1292         || $self->ut_textn('ship_state')
1293         || $self->ut_country('ship_country')
1294       ;
1295       return $error if $error;
1296
1297       #false laziness with above
1298       unless ( qsearchs('cust_main_county', {
1299         'country' => $self->ship_country,
1300         'state'   => '',
1301        } ) ) {
1302         return "Unknown ship_state/ship_county/ship_country: ".
1303           $self->ship_state. "/". $self->ship_county. "/". $self->ship_country
1304           unless qsearch('cust_main_county',{
1305             'state'   => $self->ship_state,
1306             'county'  => $self->ship_county,
1307             'country' => $self->ship_country,
1308           } );
1309       }
1310       #eofalse
1311
1312       $error =
1313         $self->ut_phonen('ship_daytime', $self->ship_country)
1314         || $self->ut_phonen('ship_night', $self->ship_country)
1315         || $self->ut_phonen('ship_fax', $self->ship_country)
1316         || $self->ut_zip('ship_zip', $self->ship_country)
1317       ;
1318       return $error if $error;
1319
1320     } else { # ship_ info eq billing info, so don't store dup info in database
1321       $self->setfield("ship_$_", '')
1322         foreach qw( last first company address1 address2 city county state zip
1323                     country daytime night fax );
1324     }
1325   }
1326
1327   $self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY|CASH|WEST|MCRD)$/
1328     or return "Illegal payby: ". $self->payby;
1329
1330   $error =    $self->ut_numbern('paystart_month')
1331            || $self->ut_numbern('paystart_year')
1332            || $self->ut_numbern('payissue')
1333   ;
1334   return $error if $error;
1335
1336   if ( $self->payip eq '' ) {
1337     $self->payip('');
1338   } else {
1339     $error = $self->ut_ip('payip');
1340     return $error if $error;
1341   }
1342
1343   # If it is encrypted and the private key is not availaible then we can't
1344   # check the credit card.
1345
1346   my $check_payinfo = 1;
1347
1348   if ($self->is_encrypted($self->payinfo)) {
1349     $check_payinfo = 0;
1350   }
1351
1352   $self->payby($1);
1353
1354   if ( $check_payinfo && $self->payby =~ /^(CARD|DCRD)$/ ) {
1355
1356     my $payinfo = $self->payinfo;
1357     $payinfo =~ s/\D//g;
1358     $payinfo =~ /^(\d{13,16})$/
1359       or return gettext('invalid_card'); # . ": ". $self->payinfo;
1360     $payinfo = $1;
1361     $self->payinfo($payinfo);
1362     validate($payinfo)
1363       or return gettext('invalid_card'); # . ": ". $self->payinfo;
1364
1365     return gettext('unknown_card_type')
1366       if cardtype($self->payinfo) eq "Unknown";
1367
1368     my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1369     if ( $ban ) {
1370       return 'Banned credit card: banned on '.
1371              time2str('%a %h %o at %r', $ban->_date).
1372              ' by '. $ban->otaker.
1373              ' (ban# '. $ban->bannum. ')';
1374     }
1375
1376     if ( defined $self->dbdef_table->column('paycvv') ) {
1377       if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) {
1378         if ( cardtype($self->payinfo) eq 'American Express card' ) {
1379           $self->paycvv =~ /^(\d{4})$/
1380             or return "CVV2 (CID) for American Express cards is four digits.";
1381           $self->paycvv($1);
1382         } else {
1383           $self->paycvv =~ /^(\d{3})$/
1384             or return "CVV2 (CVC2/CID) is three digits.";
1385           $self->paycvv($1);
1386         }
1387       } else {
1388         $self->paycvv('');
1389       }
1390     }
1391
1392     my $cardtype = cardtype($payinfo);
1393     if ( $cardtype =~ /^(Switch|Solo)$/i ) {
1394
1395       return "Start date or issue number is required for $cardtype cards"
1396         unless $self->paystart_month && $self->paystart_year or $self->payissue;
1397
1398       return "Start month must be between 1 and 12"
1399         if $self->paystart_month
1400            and $self->paystart_month < 1 || $self->paystart_month > 12;
1401
1402       return "Start year must be 1990 or later"
1403         if $self->paystart_year
1404            and $self->paystart_year < 1990;
1405
1406       return "Issue number must be beween 1 and 99"
1407         if $self->payissue
1408           and $self->payissue < 1 || $self->payissue > 99;
1409
1410     } else {
1411       $self->paystart_month('');
1412       $self->paystart_year('');
1413       $self->payissue('');
1414     }
1415
1416   } elsif ( $check_payinfo && $self->payby =~ /^(CHEK|DCHK)$/ ) {
1417
1418     my $payinfo = $self->payinfo;
1419     $payinfo =~ s/[^\d\@]//g;
1420     if ( $conf->exists('echeck-nonus') ) {
1421       $payinfo =~ /^(\d+)\@(\d+)$/ or return 'invalid echeck account@aba';
1422       $payinfo = "$1\@$2";
1423     } else {
1424       $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba';
1425       $payinfo = "$1\@$2";
1426     }
1427     $self->payinfo($payinfo);
1428     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1429
1430     my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1431     if ( $ban ) {
1432       return 'Banned ACH account: banned on '.
1433              time2str('%a %h %o at %r', $ban->_date).
1434              ' by '. $ban->otaker.
1435              ' (ban# '. $ban->bannum. ')';
1436     }
1437
1438   } elsif ( $self->payby eq 'LECB' ) {
1439
1440     my $payinfo = $self->payinfo;
1441     $payinfo =~ s/\D//g;
1442     $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number';
1443     $payinfo = $1;
1444     $self->payinfo($payinfo);
1445     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1446
1447   } elsif ( $self->payby eq 'BILL' ) {
1448
1449     $error = $self->ut_textn('payinfo');
1450     return "Illegal P.O. number: ". $self->payinfo if $error;
1451     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1452
1453   } elsif ( $self->payby eq 'COMP' ) {
1454
1455     my $curuser = $FS::CurrentUser::CurrentUser;
1456     if (    ! $self->custnum
1457          && ! $curuser->access_right('Complimentary customer')
1458        )
1459     {
1460       return "You are not permitted to create complimentary accounts."
1461     }
1462
1463     $error = $self->ut_textn('payinfo');
1464     return "Illegal comp account issuer: ". $self->payinfo if $error;
1465     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1466
1467   } elsif ( $self->payby eq 'PREPAY' ) {
1468
1469     my $payinfo = $self->payinfo;
1470     $payinfo =~ s/\W//g; #anything else would just confuse things
1471     $self->payinfo($payinfo);
1472     $error = $self->ut_alpha('payinfo');
1473     return "Illegal prepayment identifier: ". $self->payinfo if $error;
1474     return "Unknown prepayment identifier"
1475       unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } );
1476     $self->paycvv('') if $self->dbdef_table->column('paycvv');
1477
1478   }
1479
1480   if ( $self->paydate eq '' || $self->paydate eq '-' ) {
1481     return "Expiration date required"
1482       unless $self->payby =~ /^(BILL|PREPAY|CHEK|DCHK|LECB|CASH|WEST|MCRD)$/;
1483     $self->paydate('');
1484   } else {
1485     my( $m, $y );
1486     if ( $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) {
1487       ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" );
1488     } elsif ( $self->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) {
1489       ( $m, $y ) = ( $3, "20$2" );
1490     } else {
1491       return "Illegal expiration date: ". $self->paydate;
1492     }
1493     $self->paydate("$y-$m-01");
1494     my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
1495     return gettext('expired_card')
1496       if !$import
1497       && !$ignore_expired_card
1498       && ( $y<$nowy || ( $y==$nowy && $1<$nowm ) );
1499   }
1500
1501   if ( $self->payname eq '' && $self->payby !~ /^(CHEK|DCHK)$/ &&
1502        ( ! $conf->exists('require_cardname')
1503          || $self->payby !~ /^(CARD|DCRD)$/  )
1504   ) {
1505     $self->payname( $self->first. " ". $self->getfield('last') );
1506   } else {
1507     $self->payname =~ /^([\w \,\.\-\'\&]+)$/
1508       or return gettext('illegal_name'). " payname: ". $self->payname;
1509     $self->payname($1);
1510   }
1511
1512   foreach my $flag (qw( tax spool_cdr )) {
1513     $self->$flag() =~ /^(Y?)$/ or return "Illegal $flag: ". $self->$flag();
1514     $self->$flag($1);
1515   }
1516
1517   $self->otaker(getotaker) unless $self->otaker;
1518
1519   warn "$me check AFTER: \n". $self->_dump
1520     if $DEBUG > 2;
1521
1522   $self->SUPER::check;
1523 }
1524
1525 =item all_pkgs
1526
1527 Returns all packages (see L<FS::cust_pkg>) for this customer.
1528
1529 =cut
1530
1531 sub all_pkgs {
1532   my $self = shift;
1533   if ( $self->{'_pkgnum'} ) {
1534     values %{ $self->{'_pkgnum'}->cache };
1535   } else {
1536     qsearch( 'cust_pkg', { 'custnum' => $self->custnum });
1537   }
1538 }
1539
1540 =item ncancelled_pkgs
1541
1542 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
1543
1544 =cut
1545
1546 sub ncancelled_pkgs {
1547   my $self = shift;
1548   if ( $self->{'_pkgnum'} ) {
1549     grep { ! $_->getfield('cancel') } values %{ $self->{'_pkgnum'}->cache };
1550   } else {
1551     @{ [ # force list context
1552       qsearch( 'cust_pkg', {
1553         'custnum' => $self->custnum,
1554         'cancel'  => '',
1555       }),
1556       qsearch( 'cust_pkg', {
1557         'custnum' => $self->custnum,
1558         'cancel'  => 0,
1559       }),
1560     ] };
1561   }
1562 }
1563
1564 =item suspended_pkgs
1565
1566 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
1567
1568 =cut
1569
1570 sub suspended_pkgs {
1571   my $self = shift;
1572   grep { $_->susp } $self->ncancelled_pkgs;
1573 }
1574
1575 =item unflagged_suspended_pkgs
1576
1577 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
1578 customer (thouse packages without the `manual_flag' set).
1579
1580 =cut
1581
1582 sub unflagged_suspended_pkgs {
1583   my $self = shift;
1584   return $self->suspended_pkgs
1585     unless dbdef->table('cust_pkg')->column('manual_flag');
1586   grep { ! $_->manual_flag } $self->suspended_pkgs;
1587 }
1588
1589 =item unsuspended_pkgs
1590
1591 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
1592 this customer.
1593
1594 =cut
1595
1596 sub unsuspended_pkgs {
1597   my $self = shift;
1598   grep { ! $_->susp } $self->ncancelled_pkgs;
1599 }
1600
1601 =item num_cancelled_pkgs
1602
1603 Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
1604 customer.
1605
1606 =cut
1607
1608 sub num_cancelled_pkgs {
1609   my $self = shift;
1610   $self->num_pkgs("cancel IS NOT NULL AND cust_pkg.cancel != 0");
1611 }
1612
1613 sub num_pkgs {
1614   my( $self, $sql ) = @_;
1615   my $sth = dbh->prepare(
1616     "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? AND $sql"
1617   ) or die dbh->errstr;
1618   $sth->execute($self->custnum) or die $sth->errstr;
1619   $sth->fetchrow_arrayref->[0];
1620 }
1621
1622 =item unsuspend
1623
1624 Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
1625 and L<FS::cust_pkg>) for this customer.  Always returns a list: an empty list
1626 on success or a list of errors.
1627
1628 =cut
1629
1630 sub unsuspend {
1631   my $self = shift;
1632   grep { $_->unsuspend } $self->suspended_pkgs;
1633 }
1634
1635 =item suspend
1636
1637 Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
1638
1639 Returns a list: an empty list on success or a list of errors.
1640
1641 =cut
1642
1643 sub suspend {
1644   my $self = shift;
1645   grep { $_->suspend(@_) } $self->unsuspended_pkgs;
1646 }
1647
1648 =item suspend_if_pkgpart PKGPART [ , PKGPART ... ]
1649
1650 Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
1651 PKGPARTs (see L<FS::part_pkg>).
1652
1653 Returns a list: an empty list on success or a list of errors.
1654
1655 =cut
1656
1657 sub suspend_if_pkgpart {
1658   my $self = shift;
1659   my (@pkgparts, %opt);
1660   if (ref($_[0]) eq 'HASH'){
1661     @pkgparts = @{$_[0]{pkgparts}};
1662     %opt      = %{$_[0]};
1663   }else{
1664     @pkgparts = @_;
1665   }
1666   grep { $_->suspend(%opt) }
1667     grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
1668       $self->unsuspended_pkgs;
1669 }
1670
1671 =item suspend_unless_pkgpart PKGPART [ , PKGPART ... ]
1672
1673 Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
1674 listed PKGPARTs (see L<FS::part_pkg>).
1675
1676 Returns a list: an empty list on success or a list of errors.
1677
1678 =cut
1679
1680 sub suspend_unless_pkgpart {
1681   my $self = shift;
1682   my (@pkgparts, %opt);
1683   if (ref($_[0]) eq 'HASH'){
1684     @pkgparts = @{$_[0]{pkgparts}};
1685     %opt      = %{$_[0]};
1686   }else{
1687     @pkgparts = @_;
1688   }
1689   grep { $_->suspend(%opt) }
1690     grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
1691       $self->unsuspended_pkgs;
1692 }
1693
1694 =item cancel [ OPTION => VALUE ... ]
1695
1696 Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
1697
1698 Available options are: I<quiet>, I<reasonnum>, and I<ban>
1699
1700 I<quiet> can be set true to supress email cancellation notices.
1701
1702 # I<reasonnum> can be set to a cancellation reason (see L<FS::cancel_reason>)
1703
1704 I<ban> can be set true to ban this customer's credit card or ACH information,
1705 if present.
1706
1707 Always returns a list: an empty list on success or a list of errors.
1708
1709 =cut
1710
1711 sub cancel {
1712   my $self = shift;
1713   my %opt = @_;
1714
1715   if ( $opt{'ban'} && $self->payby =~ /^(CARD|DCRD|CHEK|DCHK)$/ ) {
1716
1717     #should try decryption (we might have the private key)
1718     # and if not maybe queue a job for the server that does?
1719     return ( "Can't (yet) ban encrypted credit cards" )
1720       if $self->is_encrypted($self->payinfo);
1721
1722     my $ban = new FS::banned_pay $self->_banned_pay_hashref;
1723     my $error = $ban->insert;
1724     return ( $error ) if $error;
1725
1726   }
1727
1728   grep { $_ } map { $_->cancel(@_) } $self->ncancelled_pkgs;
1729 }
1730
1731 sub _banned_pay_hashref {
1732   my $self = shift;
1733
1734   my %payby2ban = (
1735     'CARD' => 'CARD',
1736     'DCRD' => 'CARD',
1737     'CHEK' => 'CHEK',
1738     'DCHK' => 'CHEK'
1739   );
1740
1741   {
1742     'payby'   => $payby2ban{$self->payby},
1743     'payinfo' => md5_base64($self->payinfo),
1744     #'reason'  =>
1745   };
1746 }
1747
1748 =item notes
1749
1750 Returns all notes (see L<FS::cust_main_note>) for this customer.
1751
1752 =cut
1753
1754 sub notes {
1755   my $self = shift;
1756   #order by?
1757   qsearch( 'cust_main_note',
1758            { 'custnum' => $self->custnum },
1759            '',
1760            'ORDER BY _DATE DESC'
1761          );
1762 }
1763
1764 =item agent
1765
1766 Returns the agent (see L<FS::agent>) for this customer.
1767
1768 =cut
1769
1770 sub agent {
1771   my $self = shift;
1772   qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1773 }
1774
1775 =item bill OPTIONS
1776
1777 Generates invoices (see L<FS::cust_bill>) for this customer.  Usually used in
1778 conjunction with the collect method.
1779
1780 Options are passed as name-value pairs.
1781
1782 Currently available options are:
1783
1784 resetup - if set true, re-charges setup fees.
1785
1786 time - bills the customer as if it were that time.  Specified as a UNIX
1787 timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and
1788 L<Date::Parse> for conversion functions.  For example:
1789
1790  use Date::Parse;
1791  ...
1792  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
1793
1794
1795 If there is an error, returns the error, otherwise returns false.
1796
1797 =cut
1798
1799 sub bill {
1800   my( $self, %options ) = @_;
1801   return '' if $self->payby eq 'COMP';
1802   warn "$me bill customer ". $self->custnum. "\n"
1803     if $DEBUG;
1804
1805   my $time = $options{'time'} || time;
1806
1807   my $error;
1808
1809   #put below somehow?
1810   local $SIG{HUP} = 'IGNORE';
1811   local $SIG{INT} = 'IGNORE';
1812   local $SIG{QUIT} = 'IGNORE';
1813   local $SIG{TERM} = 'IGNORE';
1814   local $SIG{TSTP} = 'IGNORE';
1815   local $SIG{PIPE} = 'IGNORE';
1816
1817   my $oldAutoCommit = $FS::UID::AutoCommit;
1818   local $FS::UID::AutoCommit = 0;
1819   my $dbh = dbh;
1820
1821   $self->select_for_update; #mutex
1822
1823   #create a new invoice
1824   #(we'll remove it later if it doesn't actually need to be generated [contains
1825   # no line items] and we're inside a transaciton so nothing else will see it)
1826   my $cust_bill = new FS::cust_bill ( {
1827     'custnum' => $self->custnum,
1828     '_date'   => $time,
1829     #'charged' => $charged,
1830     'charged' => 0,
1831   } );
1832   $error = $cust_bill->insert;
1833   if ( $error ) {
1834     $dbh->rollback if $oldAutoCommit;
1835     return "can't create invoice for customer #". $self->custnum. ": $error";
1836   }
1837   my $invnum = $cust_bill->invnum;
1838
1839   ###
1840   # find the packages which are due for billing, find out how much they are
1841   # & generate invoice database.
1842   ###
1843
1844   my( $total_setup, $total_recur ) = ( 0, 0 );
1845   my %tax;
1846   my @precommit_hooks = ();
1847
1848   foreach my $cust_pkg (
1849     qsearch('cust_pkg', { 'custnum' => $self->custnum } )
1850   ) {
1851
1852     #NO!! next if $cust_pkg->cancel;
1853     next if $cust_pkg->getfield('cancel');
1854
1855     warn "  bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG > 1;
1856
1857     #? to avoid use of uninitialized value errors... ?
1858     $cust_pkg->setfield('bill', '')
1859       unless defined($cust_pkg->bill);
1860
1861     my $part_pkg = $cust_pkg->part_pkg;
1862
1863     my %hash = $cust_pkg->hash;
1864     my $old_cust_pkg = new FS::cust_pkg \%hash;
1865
1866     my @details = ();
1867
1868     ###
1869     # bill setup
1870     ###
1871
1872     my $setup = 0;
1873     if ( !$cust_pkg->setup || $options{'resetup'} ) {
1874
1875       warn "    bill setup\n" if $DEBUG > 1;
1876
1877       $setup = eval { $cust_pkg->calc_setup( $time ) };
1878       if ( $@ ) {
1879         $dbh->rollback if $oldAutoCommit;
1880         return "$@ running calc_setup for $cust_pkg\n";
1881       }
1882
1883       $cust_pkg->setfield('setup', $time) unless $cust_pkg->setup;
1884     }
1885
1886     ###
1887     # bill recurring fee
1888     ###
1889
1890     my $recur = 0;
1891     my $sdate;
1892     if ( $part_pkg->getfield('freq') ne '0' &&
1893          ! $cust_pkg->getfield('susp') &&
1894          ( $cust_pkg->getfield('bill') || 0 ) <= $time
1895     ) {
1896
1897       warn "    bill recur\n" if $DEBUG > 1;
1898
1899       # XXX shared with $recur_prog
1900       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
1901
1902       #over two params!  lets at least switch to a hashref for the rest...
1903       my %param = ( 'precommit_hooks' => \@precommit_hooks, );
1904
1905       $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details, \%param ) };
1906       if ( $@ ) {
1907         $dbh->rollback if $oldAutoCommit;
1908         return "$@ running calc_recur for $cust_pkg\n";
1909       }
1910
1911       #change this bit to use Date::Manip? CAREFUL with timezones (see
1912       # mailing list archive)
1913       my ($sec,$min,$hour,$mday,$mon,$year) =
1914         (localtime($sdate) )[0,1,2,3,4,5];
1915
1916       #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
1917       # only for figuring next bill date, nothing else, so, reset $sdate again
1918       # here
1919       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
1920       $cust_pkg->last_bill($sdate)
1921         if $cust_pkg->dbdef_table->column('last_bill');
1922
1923       if ( $part_pkg->freq =~ /^\d+$/ ) {
1924         $mon += $part_pkg->freq;
1925         until ( $mon < 12 ) { $mon -= 12; $year++; }
1926       } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
1927         my $weeks = $1;
1928         $mday += $weeks * 7;
1929       } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
1930         my $days = $1;
1931         $mday += $days;
1932       } elsif ( $part_pkg->freq =~ /^(\d+)h$/ ) {
1933         my $hours = $1;
1934         $hour += $hours;
1935       } else {
1936         $dbh->rollback if $oldAutoCommit;
1937         return "unparsable frequency: ". $part_pkg->freq;
1938       }
1939       $cust_pkg->setfield('bill',
1940         timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
1941     }
1942
1943     warn "\$setup is undefined" unless defined($setup);
1944     warn "\$recur is undefined" unless defined($recur);
1945     warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
1946
1947     ###
1948     # If $cust_pkg has been modified, update it and create cust_bill_pkg records
1949     ###
1950
1951     if ( $cust_pkg->modified ) {
1952
1953       warn "  package ". $cust_pkg->pkgnum. " modified; updating\n"
1954         if $DEBUG >1;
1955
1956       $error=$cust_pkg->replace($old_cust_pkg);
1957       if ( $error ) { #just in case
1958         $dbh->rollback if $oldAutoCommit;
1959         return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error";
1960       }
1961
1962       $setup = sprintf( "%.2f", $setup );
1963       $recur = sprintf( "%.2f", $recur );
1964       if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
1965         $dbh->rollback if $oldAutoCommit;
1966         return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
1967       }
1968       if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
1969         $dbh->rollback if $oldAutoCommit;
1970         return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
1971       }
1972
1973       if ( $setup != 0 || $recur != 0 ) {
1974
1975         warn "    charges (setup=$setup, recur=$recur); adding line items\n"
1976           if $DEBUG > 1;
1977         my $cust_bill_pkg = new FS::cust_bill_pkg ({
1978           'invnum'  => $invnum,
1979           'pkgnum'  => $cust_pkg->pkgnum,
1980           'setup'   => $setup,
1981           'recur'   => $recur,
1982           'sdate'   => $sdate,
1983           'edate'   => $cust_pkg->bill,
1984           'details' => \@details,
1985         });
1986         $error = $cust_bill_pkg->insert;
1987         if ( $error ) {
1988           $dbh->rollback if $oldAutoCommit;
1989           return "can't create invoice line item for invoice #$invnum: $error";
1990         }
1991         $total_setup += $setup;
1992         $total_recur += $recur;
1993
1994         ###
1995         # handle taxes
1996         ###
1997
1998         unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
1999
2000           my $prefix =
2001             ( $conf->exists('tax-ship_address') && length($self->ship_last) )
2002             ? 'ship_'
2003             : '';
2004           my %taxhash = map { $_ => $self->get("$prefix$_") }
2005                             qw( state county country );
2006
2007           $taxhash{'taxclass'} = $part_pkg->taxclass;
2008
2009           my @taxes = qsearch( 'cust_main_county', \%taxhash );
2010
2011           unless ( @taxes ) {
2012             $taxhash{'taxclass'} = '';
2013             @taxes =  qsearch( 'cust_main_county', \%taxhash );
2014           }
2015
2016           #one more try at a whole-country tax rate
2017           unless ( @taxes ) {
2018             $taxhash{$_} = '' foreach qw( state county );
2019             @taxes =  qsearch( 'cust_main_county', \%taxhash );
2020           }
2021
2022           # maybe eliminate this entirely, along with all the 0% records
2023           unless ( @taxes ) {
2024             $dbh->rollback if $oldAutoCommit;
2025             return
2026               "fatal: can't find tax rate for state/county/country/taxclass ".
2027               join('/', ( map $self->get("$prefix$_"),
2028                               qw(state county country)
2029                         ),
2030                         $part_pkg->taxclass ). "\n";
2031           }
2032
2033           foreach my $tax ( @taxes ) {
2034
2035             my $taxable_charged = 0;
2036             $taxable_charged += $setup
2037               unless $part_pkg->setuptax =~ /^Y$/i
2038                   || $tax->setuptax =~ /^Y$/i;
2039             $taxable_charged += $recur
2040               unless $part_pkg->recurtax =~ /^Y$/i
2041                   || $tax->recurtax =~ /^Y$/i;
2042             next unless $taxable_charged;
2043
2044             if ( $tax->exempt_amount && $tax->exempt_amount > 0 ) {
2045               #my ($mon,$year) = (localtime($sdate) )[4,5];
2046               my ($mon,$year) = (localtime( $sdate || $cust_bill->_date ) )[4,5];
2047               $mon++;
2048               my $freq = $part_pkg->freq || 1;
2049               if ( $freq !~ /(\d+)$/ ) {
2050                 $dbh->rollback if $oldAutoCommit;
2051                 return "daily/weekly package definitions not (yet?)".
2052                        " compatible with monthly tax exemptions";
2053               }
2054               my $taxable_per_month =
2055                 sprintf("%.2f", $taxable_charged / $freq );
2056
2057               #call the whole thing off if this customer has any old
2058               #exemption records...
2059               my @cust_tax_exempt =
2060                 qsearch( 'cust_tax_exempt' => { custnum=> $self->custnum } );
2061               if ( @cust_tax_exempt ) {
2062                 $dbh->rollback if $oldAutoCommit;
2063                 return
2064                   'this customer still has old-style tax exemption records; '.
2065                   'run bin/fs-migrate-cust_tax_exempt?';
2066               }
2067
2068               foreach my $which_month ( 1 .. $freq ) {
2069
2070                 #maintain the new exemption table now
2071                 my $sql = "
2072                   SELECT SUM(amount)
2073                     FROM cust_tax_exempt_pkg
2074                       LEFT JOIN cust_bill_pkg USING ( billpkgnum )
2075                       LEFT JOIN cust_bill     USING ( invnum     )
2076                     WHERE custnum = ?
2077                       AND taxnum  = ?
2078                       AND year    = ?
2079                       AND month   = ?
2080                 ";
2081                 my $sth = dbh->prepare($sql) or do {
2082                   $dbh->rollback if $oldAutoCommit;
2083                   return "fatal: can't lookup exising exemption: ". dbh->errstr;
2084                 };
2085                 $sth->execute(
2086                   $self->custnum,
2087                   $tax->taxnum,
2088                   1900+$year,
2089                   $mon,
2090                 ) or do {
2091                   $dbh->rollback if $oldAutoCommit;
2092                   return "fatal: can't lookup exising exemption: ". dbh->errstr;
2093                 };
2094                 my $existing_exemption = $sth->fetchrow_arrayref->[0] || 0;
2095
2096                 my $remaining_exemption =
2097                   $tax->exempt_amount - $existing_exemption;
2098                 if ( $remaining_exemption > 0 ) {
2099                   my $addl = $remaining_exemption > $taxable_per_month
2100                     ? $taxable_per_month
2101                     : $remaining_exemption;
2102                   $taxable_charged -= $addl;
2103
2104                   my $cust_tax_exempt_pkg = new FS::cust_tax_exempt_pkg ( {
2105                     'billpkgnum' => $cust_bill_pkg->billpkgnum,
2106                     'taxnum'     => $tax->taxnum,
2107                     'year'       => 1900+$year,
2108                     'month'      => $mon,
2109                     'amount'     => sprintf("%.2f", $addl ),
2110                   } );
2111                   $error = $cust_tax_exempt_pkg->insert;
2112                   if ( $error ) {
2113                     $dbh->rollback if $oldAutoCommit;
2114                     return "fatal: can't insert cust_tax_exempt_pkg: $error";
2115                   }
2116                 } # if $remaining_exemption > 0
2117
2118                 #++
2119                 $mon++;
2120                 #until ( $mon < 12 ) { $mon -= 12; $year++; }
2121                 until ( $mon < 13 ) { $mon -= 12; $year++; }
2122
2123               } #foreach $which_month
2124
2125             } #if $tax->exempt_amount
2126
2127             $taxable_charged = sprintf( "%.2f", $taxable_charged);
2128
2129             #$tax += $taxable_charged * $cust_main_county->tax / 100
2130             $tax{ $tax->taxname || 'Tax' } +=
2131               $taxable_charged * $tax->tax / 100
2132
2133           } #foreach my $tax ( @taxes )
2134
2135         } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2136
2137       } #if $setup != 0 || $recur != 0
2138
2139     } #if $cust_pkg->modified
2140
2141   } #foreach my $cust_pkg
2142
2143   unless ( $cust_bill->cust_bill_pkg ) {
2144     $cust_bill->delete; #don't create an invoice w/o line items
2145     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2146     return '';
2147   }
2148
2149   my $charged = sprintf( "%.2f", $total_setup + $total_recur );
2150
2151   foreach my $taxname ( grep { $tax{$_} > 0 } keys %tax ) {
2152     my $tax = sprintf("%.2f", $tax{$taxname} );
2153     $charged = sprintf( "%.2f", $charged+$tax );
2154
2155     my $cust_bill_pkg = new FS::cust_bill_pkg ({
2156       'invnum'   => $invnum,
2157       'pkgnum'   => 0,
2158       'setup'    => $tax,
2159       'recur'    => 0,
2160       'sdate'    => '',
2161       'edate'    => '',
2162       'itemdesc' => $taxname,
2163     });
2164     $error = $cust_bill_pkg->insert;
2165     if ( $error ) {
2166       $dbh->rollback if $oldAutoCommit;
2167       return "can't create invoice line item for invoice #$invnum: $error";
2168     }
2169     $total_setup += $tax;
2170
2171   }
2172
2173   $cust_bill->charged( sprintf( "%.2f", $total_setup + $total_recur ) );
2174   $error = $cust_bill->replace;
2175   if ( $error ) {
2176     $dbh->rollback if $oldAutoCommit;
2177     return "can't update charged for invoice #$invnum: $error";
2178   }
2179
2180   foreach my $hook ( @precommit_hooks ) {
2181     eval {
2182       &{$hook}; #($self) ?
2183     };
2184     if ( $@ ) {
2185       $dbh->rollback if $oldAutoCommit;
2186       return "$@ running precommit hook $hook\n";
2187     }
2188   }
2189
2190   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2191   ''; #no error
2192 }
2193
2194 =item collect OPTIONS
2195
2196 (Attempt to) collect money for this customer's outstanding invoices (see
2197 L<FS::cust_bill>).  Usually used after the bill method.
2198
2199 Depending on the value of `payby', this may print or email an invoice (I<BILL>,
2200 I<DCRD>, or I<DCHK>), charge a credit card (I<CARD>), charge via electronic
2201 check/ACH (I<CHEK>), or just add any necessary (pseudo-)payment (I<COMP>).
2202
2203 Most actions are now triggered by invoice events; see L<FS::part_bill_event>
2204 and the invoice events web interface.
2205
2206 If there is an error, returns the error, otherwise returns false.
2207
2208 Options are passed as name-value pairs.
2209
2210 Currently available options are:
2211
2212 invoice_time - Use this time when deciding when to print invoices and
2213 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>
2214 for conversion functions.
2215
2216 retry - Retry card/echeck/LEC transactions even when not scheduled by invoice
2217 events.
2218
2219 quiet - set true to surpress email card/ACH decline notices.
2220
2221 freq - "1d" for the traditional, daily events (the default), or "1m" for the
2222 new monthly events
2223
2224 payby - allows for one time override of normal customer billing method
2225
2226 =cut
2227
2228 sub collect {
2229   my( $self, %options ) = @_;
2230   my $invoice_time = $options{'invoice_time'} || time;
2231
2232   #put below somehow?
2233   local $SIG{HUP} = 'IGNORE';
2234   local $SIG{INT} = 'IGNORE';
2235   local $SIG{QUIT} = 'IGNORE';
2236   local $SIG{TERM} = 'IGNORE';
2237   local $SIG{TSTP} = 'IGNORE';
2238   local $SIG{PIPE} = 'IGNORE';
2239
2240   my $oldAutoCommit = $FS::UID::AutoCommit;
2241   local $FS::UID::AutoCommit = 0;
2242   my $dbh = dbh;
2243
2244   $self->select_for_update; #mutex
2245
2246   my $balance = $self->balance;
2247   warn "$me collect customer ". $self->custnum. ": balance $balance\n"
2248     if $DEBUG;
2249   unless ( $balance > 0 ) { #redundant?????
2250     $dbh->rollback if $oldAutoCommit; #hmm
2251     return '';
2252   }
2253
2254   if ( exists($options{'retry_card'}) ) {
2255     carp 'retry_card option passed to collect is deprecated; use retry';
2256     $options{'retry'} ||= $options{'retry_card'};
2257   }
2258   if ( exists($options{'retry'}) && $options{'retry'} ) {
2259     my $error = $self->retry_realtime;
2260     if ( $error ) {
2261       $dbh->rollback if $oldAutoCommit;
2262       return $error;
2263     }
2264   }
2265
2266   my $extra_sql = '';
2267   if ( defined $options{'freq'} && $options{'freq'} eq '1m' ) {
2268     $extra_sql = " AND freq = '1m' ";
2269   } else {
2270     $extra_sql = " AND ( freq = '1d' OR freq IS NULL OR freq = '' ) ";
2271   }
2272
2273   foreach my $cust_bill ( $self->open_cust_bill ) {
2274
2275     # don't try to charge for the same invoice if it's already in a batch
2276     #next if qsearchs( 'cust_pay_batch', { 'invnum' => $cust_bill->invnum } );
2277
2278     last if $self->balance <= 0;
2279
2280     warn "  invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ")\n"
2281       if $DEBUG > 1;
2282
2283     foreach my $part_bill_event ( due_events ( $cust_bill,
2284                                                exists($options{'payby'})
2285                                                  ? $options{'payby'}
2286                                                  : $self->payby,
2287                                                $invoice_time,
2288                                                $extra_sql ) ) {
2289
2290       last if $cust_bill->owed <= 0  # don't run subsequent events if owed<=0
2291            || $self->balance   <= 0; # or if balance<=0
2292
2293       {
2294         local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
2295         warn "  do_event " .  $cust_bill . " ". (%options) .  "\n"
2296           if $DEBUG > 1;
2297
2298         if (my $error = $part_bill_event->do_event($cust_bill, %options)) {
2299           # gah, even with transactions.
2300           $dbh->commit if $oldAutoCommit; #well.
2301           return $error;
2302         }
2303       }
2304
2305     }
2306
2307   }
2308
2309   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2310   '';
2311
2312 }
2313
2314 =item retry_realtime
2315
2316 Schedules realtime / batch  credit card / electronic check / LEC billing
2317 events for for retry.  Useful if card information has changed or manual
2318 retry is desired.  The 'collect' method must be called to actually retry
2319 the transaction.
2320
2321 Implementation details: For each of this customer's open invoices, changes
2322 the status of the first "done" (with statustext error) realtime processing
2323 event to "failed".
2324
2325 =cut
2326
2327 sub retry_realtime {
2328   my $self = shift;
2329
2330   local $SIG{HUP} = 'IGNORE';
2331   local $SIG{INT} = 'IGNORE';
2332   local $SIG{QUIT} = 'IGNORE';
2333   local $SIG{TERM} = 'IGNORE';
2334   local $SIG{TSTP} = 'IGNORE';
2335   local $SIG{PIPE} = 'IGNORE';
2336
2337   my $oldAutoCommit = $FS::UID::AutoCommit;
2338   local $FS::UID::AutoCommit = 0;
2339   my $dbh = dbh;
2340
2341   foreach my $cust_bill (
2342     grep { $_->cust_bill_event }
2343       $self->open_cust_bill
2344   ) {
2345     my @cust_bill_event =
2346       sort { $a->part_bill_event->seconds <=> $b->part_bill_event->seconds }
2347         grep {
2348                #$_->part_bill_event->plan eq 'realtime-card'
2349                $_->part_bill_event->eventcode =~
2350                    /\$cust_bill\->(batch|realtime)_(card|ach|lec)/
2351                  && $_->status eq 'done'
2352                  && $_->statustext
2353              }
2354           $cust_bill->cust_bill_event;
2355     next unless @cust_bill_event;
2356     my $error = $cust_bill_event[0]->retry;
2357     if ( $error ) {
2358       $dbh->rollback if $oldAutoCommit;
2359       return "error scheduling invoice event for retry: $error";
2360     }
2361
2362   }
2363
2364   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2365   '';
2366
2367 }
2368
2369 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
2370
2371 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
2372 via a Business::OnlinePayment realtime gateway.  See
2373 L<http://420.am/business-onlinepayment> for supported gateways.
2374
2375 Available methods are: I<CC>, I<ECHECK> and I<LEC>
2376
2377 Available options are: I<description>, I<invnum>, I<quiet>
2378
2379 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
2380 I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
2381 if set, will override the value from the customer record.
2382
2383 I<description> is a free-text field passed to the gateway.  It defaults to
2384 "Internet services".
2385
2386 If an I<invnum> is specified, this payment (if successful) is applied to the
2387 specified invoice.  If you don't specify an I<invnum> you might want to
2388 call the B<apply_payments> method.
2389
2390 I<quiet> can be set true to surpress email decline notices.
2391
2392 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
2393
2394 =cut
2395
2396 sub realtime_bop {
2397   my( $self, $method, $amount, %options ) = @_;
2398   if ( $DEBUG ) {
2399     warn "$me realtime_bop: $method $amount\n";
2400     warn "  $_ => $options{$_}\n" foreach keys %options;
2401   }
2402
2403   $options{'description'} ||= 'Internet services';
2404
2405   eval "use Business::OnlinePayment";
2406   die $@ if $@;
2407
2408   my $payinfo = exists($options{'payinfo'})
2409                   ? $options{'payinfo'}
2410                   : $self->payinfo;
2411
2412   ###
2413   # select a gateway
2414   ###
2415
2416   my $taxclass = '';
2417   if ( $options{'invnum'} ) {
2418     my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
2419     die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
2420     my @taxclasses =
2421       map  { $_->part_pkg->taxclass }
2422       grep { $_ }
2423       map  { $_->cust_pkg }
2424       $cust_bill->cust_bill_pkg;
2425     unless ( grep { $taxclasses[0] ne $_ } @taxclasses ) { #unless there are
2426                                                            #different taxclasses
2427       $taxclass = $taxclasses[0];
2428     }
2429   }
2430
2431   #look for an agent gateway override first
2432   my $cardtype;
2433   if ( $method eq 'CC' ) {
2434     $cardtype = cardtype($payinfo);
2435   } elsif ( $method eq 'ECHECK' ) {
2436     $cardtype = 'ACH';
2437   } else {
2438     $cardtype = $method;
2439   }
2440
2441   my $override =
2442        qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2443                                            cardtype => $cardtype,
2444                                            taxclass => $taxclass,       } )
2445     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2446                                            cardtype => '',
2447                                            taxclass => $taxclass,       } )
2448     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2449                                            cardtype => $cardtype,
2450                                            taxclass => '',              } )
2451     || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2452                                            cardtype => '',
2453                                            taxclass => '',              } );
2454
2455   my $payment_gateway = '';
2456   my( $processor, $login, $password, $action, @bop_options );
2457   if ( $override ) { #use a payment gateway override
2458
2459     $payment_gateway = $override->payment_gateway;
2460
2461     $processor   = $payment_gateway->gateway_module;
2462     $login       = $payment_gateway->gateway_username;
2463     $password    = $payment_gateway->gateway_password;
2464     $action      = $payment_gateway->gateway_action;
2465     @bop_options = $payment_gateway->options;
2466
2467   } else { #use the standard settings from the config
2468
2469     ( $processor, $login, $password, $action, @bop_options ) =
2470       $self->default_payment_gateway($method);
2471
2472   }
2473
2474   ###
2475   # massage data
2476   ###
2477
2478   my $address = exists($options{'address1'})
2479                     ? $options{'address1'}
2480                     : $self->address1;
2481   my $address2 = exists($options{'address2'})
2482                     ? $options{'address2'}
2483                     : $self->address2;
2484   $address .= ", ". $address2 if length($address2);
2485
2486   my $o_payname = exists($options{'payname'})
2487                     ? $options{'payname'}
2488                     : $self->payname;
2489   my($payname, $payfirst, $paylast);
2490   if ( $o_payname && $method ne 'ECHECK' ) {
2491     ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
2492       or return "Illegal payname $payname";
2493     ($payfirst, $paylast) = ($1, $2);
2494   } else {
2495     $payfirst = $self->getfield('first');
2496     $paylast = $self->getfield('last');
2497     $payname =  "$payfirst $paylast";
2498   }
2499
2500   my @invoicing_list = grep { $_ ne 'POST' } $self->invoicing_list;
2501   if ( $conf->exists('emailinvoiceauto')
2502        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
2503     push @invoicing_list, $self->all_emails;
2504   }
2505
2506   my $email = ($conf->exists('business-onlinepayment-email-override'))
2507               ? $conf->config('business-onlinepayment-email-override')
2508               : $invoicing_list[0];
2509
2510   my %content = ();
2511
2512   my $payip = exists($options{'payip'})
2513                 ? $options{'payip'}
2514                 : $self->payip;
2515   $content{customer_ip} = $payip
2516     if length($payip);
2517
2518   if ( $method eq 'CC' ) {
2519
2520     $content{card_number} = $payinfo;
2521     my $paydate = exists($options{'paydate'})
2522                     ? $options{'paydate'}
2523                     : $self->paydate;
2524     $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
2525     $content{expiration} = "$2/$1";
2526
2527     my $paycvv = exists($options{'paycvv'})
2528                    ? $options{'paycvv'}
2529                    : $self->paycvv;
2530     $content{cvv2} = $self->paycvv
2531       if length($paycvv);
2532
2533     my $paystart_month = exists($options{'paystart_month'})
2534                            ? $options{'paystart_month'}
2535                            : $self->paystart_month;
2536
2537     my $paystart_year  = exists($options{'paystart_year'})
2538                            ? $options{'paystart_year'}
2539                            : $self->paystart_year;
2540
2541     $content{card_start} = "$paystart_month/$paystart_year"
2542       if $paystart_month && $paystart_year;
2543
2544     my $payissue       = exists($options{'payissue'})
2545                            ? $options{'payissue'}
2546                            : $self->payissue;
2547     $content{issue_number} = $payissue if $payissue;
2548
2549     $content{recurring_billing} = 'YES'
2550       if qsearch('cust_pay', { 'custnum' => $self->custnum,
2551                                'payby'   => 'CARD',
2552                                'payinfo' => $payinfo,
2553                              } );
2554
2555   } elsif ( $method eq 'ECHECK' ) {
2556     ( $content{account_number}, $content{routing_code} ) =
2557       split('@', $payinfo);
2558     $content{bank_name} = $o_payname;
2559     $content{account_type} = 'CHECKING';
2560     $content{account_name} = $payname;
2561     $content{customer_org} = $self->company ? 'B' : 'I';
2562     $content{customer_ssn} = exists($options{'ss'})
2563                                ? $options{'ss'}
2564                                : $self->ss;
2565   } elsif ( $method eq 'LEC' ) {
2566     $content{phone} = $payinfo;
2567   }
2568
2569   ###
2570   # run transaction(s)
2571   ###
2572
2573   my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
2574
2575   my $transaction = new Business::OnlinePayment( $processor, @bop_options );
2576   $transaction->content(
2577     'type'           => $method,
2578     'login'          => $login,
2579     'password'       => $password,
2580     'action'         => $action1,
2581     'description'    => $options{'description'},
2582     'amount'         => $amount,
2583     'invoice_number' => $options{'invnum'},
2584     'customer_id'    => $self->custnum,
2585     'last_name'      => $paylast,
2586     'first_name'     => $payfirst,
2587     'name'           => $payname,
2588     'address'        => $address,
2589     'city'           => ( exists($options{'city'})
2590                             ? $options{'city'}
2591                             : $self->city          ),
2592     'state'          => ( exists($options{'state'})
2593                             ? $options{'state'}
2594                             : $self->state          ),
2595     'zip'            => ( exists($options{'zip'})
2596                             ? $options{'zip'}
2597                             : $self->zip          ),
2598     'country'        => ( exists($options{'country'})
2599                             ? $options{'country'}
2600                             : $self->country          ),
2601     'referer'        => 'http://cleanwhisker.420.am/',
2602     'email'          => $email,
2603     'phone'          => $self->daytime || $self->night,
2604     %content, #after
2605   );
2606   $transaction->submit();
2607
2608   if ( $transaction->is_success() && $action2 ) {
2609     my $auth = $transaction->authorization;
2610     my $ordernum = $transaction->can('order_number')
2611                    ? $transaction->order_number
2612                    : '';
2613
2614     my $capture =
2615       new Business::OnlinePayment( $processor, @bop_options );
2616
2617     my %capture = (
2618       %content,
2619       type           => $method,
2620       action         => $action2,
2621       login          => $login,
2622       password       => $password,
2623       order_number   => $ordernum,
2624       amount         => $amount,
2625       authorization  => $auth,
2626       description    => $options{'description'},
2627     );
2628
2629     foreach my $field (qw( authorization_source_code returned_ACI                                          transaction_identifier validation_code
2630                            transaction_sequence_num local_transaction_date
2631                            local_transaction_time AVS_result_code          )) {
2632       $capture{$field} = $transaction->$field() if $transaction->can($field);
2633     }
2634
2635     $capture->content( %capture );
2636
2637     $capture->submit();
2638
2639     unless ( $capture->is_success ) {
2640       my $e = "Authorization successful but capture failed, custnum #".
2641               $self->custnum. ': '.  $capture->result_code.
2642               ": ". $capture->error_message;
2643       warn $e;
2644       return $e;
2645     }
2646
2647   }
2648
2649   ###
2650   # remove paycvv after initial transaction
2651   ###
2652
2653   #false laziness w/misc/process/payment.cgi - check both to make sure working
2654   # correctly
2655   if ( defined $self->dbdef_table->column('paycvv')
2656        && length($self->paycvv)
2657        && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
2658   ) {
2659     my $error = $self->remove_cvv;
2660     if ( $error ) {
2661       warn "WARNING: error removing cvv: $error\n";
2662     }
2663   }
2664
2665   ###
2666   # result handling
2667   ###
2668
2669   if ( $transaction->is_success() ) {
2670
2671     my %method2payby = (
2672       'CC'     => 'CARD',
2673       'ECHECK' => 'CHEK',
2674       'LEC'    => 'LECB',
2675     );
2676
2677     my $paybatch = '';
2678     if ( $payment_gateway ) { # agent override
2679       $paybatch = $payment_gateway->gatewaynum. '-';
2680     }
2681
2682     $paybatch .= "$processor:". $transaction->authorization;
2683
2684     $paybatch .= ':'. $transaction->order_number
2685       if $transaction->can('order_number')
2686       && length($transaction->order_number);
2687
2688     my $cust_pay = new FS::cust_pay ( {
2689        'custnum'  => $self->custnum,
2690        'invnum'   => $options{'invnum'},
2691        'paid'     => $amount,
2692        '_date'     => '',
2693        'payby'    => $method2payby{$method},
2694        'payinfo'  => $payinfo,
2695        'paybatch' => $paybatch,
2696     } );
2697     my $error = $cust_pay->insert;
2698     if ( $error ) {
2699       $cust_pay->invnum(''); #try again with no specific invnum
2700       my $error2 = $cust_pay->insert;
2701       if ( $error2 ) {
2702         # gah, even with transactions.
2703         my $e = 'WARNING: Card/ACH debited but database not updated - '.
2704                 "error inserting payment ($processor): $error2".
2705                 " (previously tried insert with invnum #$options{'invnum'}" .
2706                 ": $error )";
2707         warn $e;
2708         return $e;
2709       }
2710     }
2711     return ''; #no error
2712
2713   } else {
2714
2715     my $perror = "$processor error: ". $transaction->error_message;
2716
2717     if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
2718          && $conf->exists('emaildecline')
2719          && grep { $_ ne 'POST' } $self->invoicing_list
2720          && ! grep { $transaction->error_message =~ /$_/ }
2721                    $conf->config('emaildecline-exclude')
2722     ) {
2723       my @templ = $conf->config('declinetemplate');
2724       my $template = new Text::Template (
2725         TYPE   => 'ARRAY',
2726         SOURCE => [ map "$_\n", @templ ],
2727       ) or return "($perror) can't create template: $Text::Template::ERROR";
2728       $template->compile()
2729         or return "($perror) can't compile template: $Text::Template::ERROR";
2730
2731       my $templ_hash = { error => $transaction->error_message };
2732
2733       my $error = send_email(
2734         'from'    => $conf->config('invoice_from'),
2735         'to'      => [ grep { $_ ne 'POST' } $self->invoicing_list ],
2736         'subject' => 'Your payment could not be processed',
2737         'body'    => [ $template->fill_in(HASH => $templ_hash) ],
2738       );
2739
2740       $perror .= " (also received error sending decline notification: $error)"
2741         if $error;
2742
2743     }
2744
2745     return $perror;
2746   }
2747
2748 }
2749
2750 =item default_payment_gateway
2751
2752 =cut
2753
2754 sub default_payment_gateway {
2755   my( $self, $method ) = @_;
2756
2757   die "Real-time processing not enabled\n"
2758     unless $conf->exists('business-onlinepayment');
2759
2760   #load up config
2761   my $bop_config = 'business-onlinepayment';
2762   $bop_config .= '-ach'
2763     if $method eq 'ECHECK' && $conf->exists($bop_config. '-ach');
2764   my ( $processor, $login, $password, $action, @bop_options ) =
2765     $conf->config($bop_config);
2766   $action ||= 'normal authorization';
2767   pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
2768   die "No real-time processor is enabled - ".
2769       "did you set the business-onlinepayment configuration value?\n"
2770     unless $processor;
2771
2772   ( $processor, $login, $password, $action, @bop_options )
2773 }
2774
2775 =item remove_cvv
2776
2777 Removes the I<paycvv> field from the database directly.
2778
2779 If there is an error, returns the error, otherwise returns false.
2780
2781 =cut
2782
2783 sub remove_cvv {
2784   my $self = shift;
2785   my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
2786     or return dbh->errstr;
2787   $sth->execute($self->custnum)
2788     or return $sth->errstr;
2789   $self->paycvv('');
2790   '';
2791 }
2792
2793 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
2794
2795 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
2796 via a Business::OnlinePayment realtime gateway.  See
2797 L<http://420.am/business-onlinepayment> for supported gateways.
2798
2799 Available methods are: I<CC>, I<ECHECK> and I<LEC>
2800
2801 Available options are: I<amount>, I<reason>, I<paynum>
2802
2803 Most gateways require a reference to an original payment transaction to refund,
2804 so you probably need to specify a I<paynum>.
2805
2806 I<amount> defaults to the original amount of the payment if not specified.
2807
2808 I<reason> specifies a reason for the refund.
2809
2810 Implementation note: If I<amount> is unspecified or equal to the amount of the
2811 orignal payment, first an attempt is made to "void" the transaction via
2812 the gateway (to cancel a not-yet settled transaction) and then if that fails,
2813 the normal attempt is made to "refund" ("credit") the transaction via the
2814 gateway is attempted.
2815
2816 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
2817 #I<zip>, I<payinfo> and I<paydate> are also available.  Any of these options,
2818 #if set, will override the value from the customer record.
2819
2820 #If an I<invnum> is specified, this payment (if successful) is applied to the
2821 #specified invoice.  If you don't specify an I<invnum> you might want to
2822 #call the B<apply_payments> method.
2823
2824 =cut
2825
2826 #some false laziness w/realtime_bop, not enough to make it worth merging
2827 #but some useful small subs should be pulled out
2828 sub realtime_refund_bop {
2829   my( $self, $method, %options ) = @_;
2830   if ( $DEBUG ) {
2831     warn "$me realtime_refund_bop: $method refund\n";
2832     warn "  $_ => $options{$_}\n" foreach keys %options;
2833   }
2834
2835   eval "use Business::OnlinePayment";
2836   die $@ if $@;
2837
2838   ###
2839   # look up the original payment and optionally a gateway for that payment
2840   ###
2841
2842   my $cust_pay = '';
2843   my $amount = $options{'amount'};
2844
2845   my( $processor, $login, $password, @bop_options ) ;
2846   my( $auth, $order_number ) = ( '', '', '' );
2847
2848   if ( $options{'paynum'} ) {
2849
2850     warn "  paynum: $options{paynum}\n" if $DEBUG > 1;
2851     $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
2852       or return "Unknown paynum $options{'paynum'}";
2853     $amount ||= $cust_pay->paid;
2854
2855     $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-]*)(:([\w\-]+))?$/
2856       or return "Can't parse paybatch for paynum $options{'paynum'}: ".
2857                 $cust_pay->paybatch;
2858     my $gatewaynum = '';
2859     ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
2860
2861     if ( $gatewaynum ) { #gateway for the payment to be refunded
2862
2863       my $payment_gateway =
2864         qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
2865       die "payment gateway $gatewaynum not found"
2866         unless $payment_gateway;
2867
2868       $processor   = $payment_gateway->gateway_module;
2869       $login       = $payment_gateway->gateway_username;
2870       $password    = $payment_gateway->gateway_password;
2871       @bop_options = $payment_gateway->options;
2872
2873     } else { #try the default gateway
2874
2875       my( $conf_processor, $unused_action );
2876       ( $conf_processor, $login, $password, $unused_action, @bop_options ) =
2877         $self->default_payment_gateway($method);
2878
2879       return "processor of payment $options{'paynum'} $processor does not".
2880              " match default processor $conf_processor"
2881         unless $processor eq $conf_processor;
2882
2883     }
2884
2885
2886   } else { # didn't specify a paynum, so look for agent gateway overrides
2887            # like a normal transaction
2888
2889     my $cardtype;
2890     if ( $method eq 'CC' ) {
2891       $cardtype = cardtype($self->payinfo);
2892     } elsif ( $method eq 'ECHECK' ) {
2893       $cardtype = 'ACH';
2894     } else {
2895       $cardtype = $method;
2896     }
2897     my $override =
2898            qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2899                                                cardtype => $cardtype,
2900                                                taxclass => '',              } )
2901         || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
2902                                                cardtype => '',
2903                                                taxclass => '',              } );
2904
2905     if ( $override ) { #use a payment gateway override
2906
2907       my $payment_gateway = $override->payment_gateway;
2908
2909       $processor   = $payment_gateway->gateway_module;
2910       $login       = $payment_gateway->gateway_username;
2911       $password    = $payment_gateway->gateway_password;
2912       #$action      = $payment_gateway->gateway_action;
2913       @bop_options = $payment_gateway->options;
2914
2915     } else { #use the standard settings from the config
2916
2917       my $unused_action;
2918       ( $processor, $login, $password, $unused_action, @bop_options ) =
2919         $self->default_payment_gateway($method);
2920
2921     }
2922
2923   }
2924   return "neither amount nor paynum specified" unless $amount;
2925
2926   my %content = (
2927     'type'           => $method,
2928     'login'          => $login,
2929     'password'       => $password,
2930     'order_number'   => $order_number,
2931     'amount'         => $amount,
2932     'referer'        => 'http://cleanwhisker.420.am/',
2933   );
2934   $content{authorization} = $auth
2935     if length($auth); #echeck/ACH transactions have an order # but no auth
2936                       #(at least with authorize.net)
2937
2938   #first try void if applicable
2939   if ( $cust_pay && $cust_pay->paid == $amount ) { #and check dates?
2940     warn "  attempting void\n" if $DEBUG > 1;
2941     my $void = new Business::OnlinePayment( $processor, @bop_options );
2942     $void->content( 'action' => 'void', %content );
2943     $void->submit();
2944     if ( $void->is_success ) {
2945       my $error = $cust_pay->void($options{'reason'});
2946       if ( $error ) {
2947         # gah, even with transactions.
2948         my $e = 'WARNING: Card/ACH voided but database not updated - '.
2949                 "error voiding payment: $error";
2950         warn $e;
2951         return $e;
2952       }
2953       warn "  void successful\n" if $DEBUG > 1;
2954       return '';
2955     }
2956   }
2957
2958   warn "  void unsuccessful, trying refund\n"
2959     if $DEBUG > 1;
2960
2961   #massage data
2962   my $address = $self->address1;
2963   $address .= ", ". $self->address2 if $self->address2;
2964
2965   my($payname, $payfirst, $paylast);
2966   if ( $self->payname && $method ne 'ECHECK' ) {
2967     $payname = $self->payname;
2968     $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
2969       or return "Illegal payname $payname";
2970     ($payfirst, $paylast) = ($1, $2);
2971   } else {
2972     $payfirst = $self->getfield('first');
2973     $paylast = $self->getfield('last');
2974     $payname =  "$payfirst $paylast";
2975   }
2976
2977   my @invoicing_list = grep { $_ ne 'POST' } $self->invoicing_list;
2978   if ( $conf->exists('emailinvoiceauto')
2979        || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
2980     push @invoicing_list, $self->all_emails;
2981   }
2982
2983   my $email = ($conf->exists('business-onlinepayment-email-override'))
2984               ? $conf->config('business-onlinepayment-email-override')
2985               : $invoicing_list[0];
2986
2987   my $payip = exists($options{'payip'})
2988                 ? $options{'payip'}
2989                 : $self->payip;
2990   $content{customer_ip} = $payip
2991     if length($payip);
2992
2993   my $payinfo = '';
2994   if ( $method eq 'CC' ) {
2995
2996     if ( $cust_pay ) {
2997       $content{card_number} = $payinfo = $cust_pay->payinfo;
2998       #$self->paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
2999       #$content{expiration} = "$2/$1";
3000     } else {
3001       $content{card_number} = $payinfo = $self->payinfo;
3002       $self->paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3003       $content{expiration} = "$2/$1";
3004     }
3005
3006   } elsif ( $method eq 'ECHECK' ) {
3007     ( $content{account_number}, $content{routing_code} ) =
3008       split('@', $payinfo = $self->payinfo);
3009     $content{bank_name} = $self->payname;
3010     $content{account_type} = 'CHECKING';
3011     $content{account_name} = $payname;
3012     $content{customer_org} = $self->company ? 'B' : 'I';
3013     $content{customer_ssn} = $self->ss;
3014   } elsif ( $method eq 'LEC' ) {
3015     $content{phone} = $payinfo = $self->payinfo;
3016   }
3017
3018   #then try refund
3019   my $refund = new Business::OnlinePayment( $processor, @bop_options );
3020   my %sub_content = $refund->content(
3021     'action'         => 'credit',
3022     'customer_id'    => $self->custnum,
3023     'last_name'      => $paylast,
3024     'first_name'     => $payfirst,
3025     'name'           => $payname,
3026     'address'        => $address,
3027     'city'           => $self->city,
3028     'state'          => $self->state,
3029     'zip'            => $self->zip,
3030     'country'        => $self->country,
3031     'email'          => $email,
3032     'phone'          => $self->daytime || $self->night,
3033     %content, #after
3034   );
3035   warn join('', map { "  $_ => $sub_content{$_}\n" } keys %sub_content )
3036     if $DEBUG > 1;
3037   $refund->submit();
3038
3039   return "$processor error: ". $refund->error_message
3040     unless $refund->is_success();
3041
3042   my %method2payby = (
3043     'CC'     => 'CARD',
3044     'ECHECK' => 'CHEK',
3045     'LEC'    => 'LECB',
3046   );
3047
3048   my $paybatch = "$processor:". $refund->authorization;
3049   $paybatch .= ':'. $refund->order_number
3050     if $refund->can('order_number') && $refund->order_number;
3051
3052   while ( $cust_pay && $cust_pay->unappled < $amount ) {
3053     my @cust_bill_pay = $cust_pay->cust_bill_pay;
3054     last unless @cust_bill_pay;
3055     my $cust_bill_pay = pop @cust_bill_pay;
3056     my $error = $cust_bill_pay->delete;
3057     last if $error;
3058   }
3059
3060   my $cust_refund = new FS::cust_refund ( {
3061     'custnum'  => $self->custnum,
3062     'paynum'   => $options{'paynum'},
3063     'refund'   => $amount,
3064     '_date'    => '',
3065     'payby'    => $method2payby{$method},
3066     'payinfo'  => $payinfo,
3067     'paybatch' => $paybatch,
3068     'reason'   => $options{'reason'} || 'card or ACH refund',
3069   } );
3070   my $error = $cust_refund->insert;
3071   if ( $error ) {
3072     $cust_refund->paynum(''); #try again with no specific paynum
3073     my $error2 = $cust_refund->insert;
3074     if ( $error2 ) {
3075       # gah, even with transactions.
3076       my $e = 'WARNING: Card/ACH refunded but database not updated - '.
3077               "error inserting refund ($processor): $error2".
3078               " (previously tried insert with paynum #$options{'paynum'}" .
3079               ": $error )";
3080       warn $e;
3081       return $e;
3082     }
3083   }
3084
3085   ''; #no error
3086
3087 }
3088
3089 =item total_owed
3090
3091 Returns the total owed for this customer on all invoices
3092 (see L<FS::cust_bill/owed>).
3093
3094 =cut
3095
3096 sub total_owed {
3097   my $self = shift;
3098   $self->total_owed_date(2145859200); #12/31/2037
3099 }
3100
3101 =item total_owed_date TIME
3102
3103 Returns the total owed for this customer on all invoices with date earlier than
3104 TIME.  TIME is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also
3105 see L<Time::Local> and L<Date::Parse> for conversion functions.
3106
3107 =cut
3108
3109 sub total_owed_date {
3110   my $self = shift;
3111   my $time = shift;
3112   my $total_bill = 0;
3113   foreach my $cust_bill (
3114     grep { $_->_date <= $time }
3115       qsearch('cust_bill', { 'custnum' => $self->custnum, } )
3116   ) {
3117     $total_bill += $cust_bill->owed;
3118   }
3119   sprintf( "%.2f", $total_bill );
3120 }
3121
3122 =item apply_credits OPTION => VALUE ...
3123
3124 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
3125 to outstanding invoice balances in chronological order (or reverse
3126 chronological order if the I<order> option is set to B<newest>) and returns the
3127 value of any remaining unapplied credits available for refund (see
3128 L<FS::cust_refund>).
3129
3130 =cut
3131
3132 sub apply_credits {
3133   my $self = shift;
3134   my %opt = @_;
3135
3136   return 0 unless $self->total_credited;
3137
3138   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
3139       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
3140
3141   my @invoices = $self->open_cust_bill;
3142   @invoices = sort { $b->_date <=> $a->_date } @invoices
3143     if defined($opt{'order'}) && $opt{'order'} eq 'newest';
3144
3145   my $credit;
3146   foreach my $cust_bill ( @invoices ) {
3147     my $amount;
3148
3149     if ( !defined($credit) || $credit->credited == 0) {
3150       $credit = pop @credits or last;
3151     }
3152
3153     if ($cust_bill->owed >= $credit->credited) {
3154       $amount=$credit->credited;
3155     }else{
3156       $amount=$cust_bill->owed;
3157     }
3158
3159     my $cust_credit_bill = new FS::cust_credit_bill ( {
3160       'crednum' => $credit->crednum,
3161       'invnum'  => $cust_bill->invnum,
3162       'amount'  => $amount,
3163     } );
3164     my $error = $cust_credit_bill->insert;
3165     die $error if $error;
3166
3167     redo if ($cust_bill->owed > 0);
3168
3169   }
3170
3171   return $self->total_credited;
3172 }
3173
3174 =item apply_payments
3175
3176 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
3177 to outstanding invoice balances in chronological order.
3178
3179  #and returns the value of any remaining unapplied payments.
3180
3181 =cut
3182
3183 sub apply_payments {
3184   my $self = shift;
3185
3186   #return 0 unless
3187
3188   my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
3189       qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
3190
3191   my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
3192       qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
3193
3194   my $payment;
3195
3196   foreach my $cust_bill ( @invoices ) {
3197     my $amount;
3198
3199     if ( !defined($payment) || $payment->unapplied == 0 ) {
3200       $payment = pop @payments or last;
3201     }
3202
3203     if ( $cust_bill->owed >= $payment->unapplied ) {
3204       $amount = $payment->unapplied;
3205     } else {
3206       $amount = $cust_bill->owed;
3207     }
3208
3209     my $cust_bill_pay = new FS::cust_bill_pay ( {
3210       'paynum' => $payment->paynum,
3211       'invnum' => $cust_bill->invnum,
3212       'amount' => $amount,
3213     } );
3214     my $error = $cust_bill_pay->insert;
3215     die $error if $error;
3216
3217     redo if ( $cust_bill->owed > 0);
3218
3219   }
3220
3221   return $self->total_unapplied_payments;
3222 }
3223
3224 =item total_credited
3225
3226 Returns the total outstanding credit (see L<FS::cust_credit>) for this
3227 customer.  See L<FS::cust_credit/credited>.
3228
3229 =cut
3230
3231 sub total_credited {
3232   my $self = shift;
3233   my $total_credit = 0;
3234   foreach my $cust_credit ( qsearch('cust_credit', {
3235     'custnum' => $self->custnum,
3236   } ) ) {
3237     $total_credit += $cust_credit->credited;
3238   }
3239   sprintf( "%.2f", $total_credit );
3240 }
3241
3242 =item total_unapplied_payments
3243
3244 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
3245 See L<FS::cust_pay/unapplied>.
3246
3247 =cut
3248
3249 sub total_unapplied_payments {
3250   my $self = shift;
3251   my $total_unapplied = 0;
3252   foreach my $cust_pay ( qsearch('cust_pay', {
3253     'custnum' => $self->custnum,
3254   } ) ) {
3255     $total_unapplied += $cust_pay->unapplied;
3256   }
3257   sprintf( "%.2f", $total_unapplied );
3258 }
3259
3260 =item balance
3261
3262 Returns the balance for this customer (total_owed minus total_credited
3263 minus total_unapplied_payments).
3264
3265 =cut
3266
3267 sub balance {
3268   my $self = shift;
3269   sprintf( "%.2f",
3270     $self->total_owed - $self->total_credited - $self->total_unapplied_payments
3271   );
3272 }
3273
3274 =item balance_date TIME
3275
3276 Returns the balance for this customer, only considering invoices with date
3277 earlier than TIME (total_owed_date minus total_credited minus
3278 total_unapplied_payments).  TIME is specified as a UNIX timestamp; see
3279 L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion
3280 functions.
3281
3282 =cut
3283
3284 sub balance_date {
3285   my $self = shift;
3286   my $time = shift;
3287   sprintf( "%.2f",
3288     $self->total_owed_date($time)
3289       - $self->total_credited
3290       - $self->total_unapplied_payments
3291   );
3292 }
3293
3294 =item in_transit_payments
3295
3296 Returns the total of requests for payments for this customer pending in
3297 batches in transit to the bank.  See L<FS::pay_batch> and L<FS::cust_pay_batch>
3298
3299 =cut
3300
3301 sub in_transit_payments {
3302   my $self = shift;
3303   my $in_transit_payments = 0;
3304   foreach my $pay_batch ( qsearch('pay_batch', {
3305     'status' => 'I',
3306   } ) ) {
3307     foreach my $cust_pay_batch ( qsearch('cust_pay_batch', {
3308       'batchnum' => $pay_batch->batchnum,
3309       'custnum' => $self->custnum,
3310     } ) ) {
3311       $in_transit_payments += $cust_pay_batch->amount;
3312     }
3313   }
3314   sprintf( "%.2f", $in_transit_payments );
3315 }
3316
3317 =item paydate_monthyear
3318
3319 Returns a two-element list consisting of the month and year of this customer's
3320 paydate (credit card expiration date for CARD customers)
3321
3322 =cut
3323
3324 sub paydate_monthyear {
3325   my $self = shift;
3326   if ( $self->paydate  =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
3327     ( $2, $1 );
3328   } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
3329     ( $1, $3 );
3330   } else {
3331     ('', '');
3332   }
3333 }
3334
3335 =item payinfo_masked
3336
3337 Returns a "masked" payinfo field appropriate to the payment type.  Masked characters are replaced by 'x'es.  Use this to display publicly accessable account Information.
3338
3339 Credit Cards - Mask all but the last four characters.
3340 Checks - Mask all but last 2 of account number and bank routing number.
3341 Others - Do nothing, return the unmasked string.
3342
3343 =cut
3344
3345 sub payinfo_masked {
3346   my $self = shift;
3347   return $self->paymask;
3348 }
3349
3350 =item invoicing_list [ ARRAYREF ]
3351
3352 If an arguement is given, sets these email addresses as invoice recipients
3353 (see L<FS::cust_main_invoice>).  Errors are not fatal and are not reported
3354 (except as warnings), so use check_invoicing_list first.
3355
3356 Returns a list of email addresses (with svcnum entries expanded).
3357
3358 Note: You can clear the invoicing list by passing an empty ARRAYREF.  You can
3359 check it without disturbing anything by passing nothing.
3360
3361 This interface may change in the future.
3362
3363 =cut
3364
3365 sub invoicing_list {
3366   my( $self, $arrayref ) = @_;
3367
3368   if ( $arrayref ) {
3369     my @cust_main_invoice;
3370     if ( $self->custnum ) {
3371       @cust_main_invoice =
3372         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
3373     } else {
3374       @cust_main_invoice = ();
3375     }
3376     foreach my $cust_main_invoice ( @cust_main_invoice ) {
3377       #warn $cust_main_invoice->destnum;
3378       unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
3379         #warn $cust_main_invoice->destnum;
3380         my $error = $cust_main_invoice->delete;
3381         warn $error if $error;
3382       }
3383     }
3384     if ( $self->custnum ) {
3385       @cust_main_invoice =
3386         qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
3387     } else {
3388       @cust_main_invoice = ();
3389     }
3390     my %seen = map { $_->address => 1 } @cust_main_invoice;
3391     foreach my $address ( @{$arrayref} ) {
3392       next if exists $seen{$address} && $seen{$address};
3393       $seen{$address} = 1;
3394       my $cust_main_invoice = new FS::cust_main_invoice ( {
3395         'custnum' => $self->custnum,
3396         'dest'    => $address,
3397       } );
3398       my $error = $cust_main_invoice->insert;
3399       warn $error if $error;
3400     }
3401   }
3402
3403   if ( $self->custnum ) {
3404     map { $_->address }
3405       qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
3406   } else {
3407     ();
3408   }
3409
3410 }
3411
3412 =item check_invoicing_list ARRAYREF
3413
3414 Checks these arguements as valid input for the invoicing_list method.  If there
3415 is an error, returns the error, otherwise returns false.
3416
3417 =cut
3418
3419 sub check_invoicing_list {
3420   my( $self, $arrayref ) = @_;
3421   foreach my $address ( @{$arrayref} ) {
3422
3423     if ($address eq 'FAX' and $self->getfield('fax') eq '') {
3424       return 'Can\'t add FAX invoice destination with a blank FAX number.';
3425     }
3426
3427     my $cust_main_invoice = new FS::cust_main_invoice ( {
3428       'custnum' => $self->custnum,
3429       'dest'    => $address,
3430     } );
3431     my $error = $self->custnum
3432                 ? $cust_main_invoice->check
3433                 : $cust_main_invoice->checkdest
3434     ;
3435     return $error if $error;
3436   }
3437   '';
3438 }
3439
3440 =item set_default_invoicing_list
3441
3442 Sets the invoicing list to all accounts associated with this customer,
3443 overwriting any previous invoicing list.
3444
3445 =cut
3446
3447 sub set_default_invoicing_list {
3448   my $self = shift;
3449   $self->invoicing_list($self->all_emails);
3450 }
3451
3452 =item all_emails
3453
3454 Returns the email addresses of all accounts provisioned for this customer.
3455
3456 =cut
3457
3458 sub all_emails {
3459   my $self = shift;
3460   my %list;
3461   foreach my $cust_pkg ( $self->all_pkgs ) {
3462     my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
3463     my @svc_acct =
3464       map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
3465         grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
3466           @cust_svc;
3467     $list{$_}=1 foreach map { $_->email } @svc_acct;
3468   }
3469   keys %list;
3470 }
3471
3472 =item invoicing_list_addpost
3473
3474 Adds postal invoicing to this customer.  If this customer is already configured
3475 to receive postal invoices, does nothing.
3476
3477 =cut
3478
3479 sub invoicing_list_addpost {
3480   my $self = shift;
3481   return if grep { $_ eq 'POST' } $self->invoicing_list;
3482   my @invoicing_list = $self->invoicing_list;
3483   push @invoicing_list, 'POST';
3484   $self->invoicing_list(\@invoicing_list);
3485 }
3486
3487 =item invoicing_list_emailonly
3488
3489 Returns the list of email invoice recipients (invoicing_list without non-email
3490 destinations such as POST and FAX).
3491
3492 =cut
3493
3494 sub invoicing_list_emailonly {
3495   my $self = shift;
3496   grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list;
3497 }
3498
3499 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
3500
3501 Returns an array of customers referred by this customer (referral_custnum set
3502 to this custnum).  If DEPTH is given, recurses up to the given depth, returning
3503 customers referred by customers referred by this customer and so on, inclusive.
3504 The default behavior is DEPTH 1 (no recursion).
3505
3506 =cut
3507
3508 sub referral_cust_main {
3509   my $self = shift;
3510   my $depth = @_ ? shift : 1;
3511   my $exclude = @_ ? shift : {};
3512
3513   my @cust_main =
3514     map { $exclude->{$_->custnum}++; $_; }
3515       grep { ! $exclude->{ $_->custnum } }
3516         qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
3517
3518   if ( $depth > 1 ) {
3519     push @cust_main,
3520       map { $_->referral_cust_main($depth-1, $exclude) }
3521         @cust_main;
3522   }
3523
3524   @cust_main;
3525 }
3526
3527 =item referral_cust_main_ncancelled
3528
3529 Same as referral_cust_main, except only returns customers with uncancelled
3530 packages.
3531
3532 =cut
3533
3534 sub referral_cust_main_ncancelled {
3535   my $self = shift;
3536   grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
3537 }
3538
3539 =item referral_cust_pkg [ DEPTH ]
3540
3541 Like referral_cust_main, except returns a flat list of all unsuspended (and
3542 uncancelled) packages for each customer.  The number of items in this list may
3543 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
3544
3545 =cut
3546
3547 sub referral_cust_pkg {
3548   my $self = shift;
3549   my $depth = @_ ? shift : 1;
3550
3551   map { $_->unsuspended_pkgs }
3552     grep { $_->unsuspended_pkgs }
3553       $self->referral_cust_main($depth);
3554 }
3555
3556 =item referring_cust_main
3557
3558 Returns the single cust_main record for the customer who referred this customer
3559 (referral_custnum), or false.
3560
3561 =cut
3562
3563 sub referring_cust_main {
3564   my $self = shift;
3565   return '' unless $self->referral_custnum;
3566   qsearchs('cust_main', { 'custnum' => $self->referral_custnum } );
3567 }
3568
3569 =item credit AMOUNT, REASON
3570
3571 Applies a credit to this customer.  If there is an error, returns the error,
3572 otherwise returns false.
3573
3574 =cut
3575
3576 sub credit {
3577   my( $self, $amount, $reason ) = @_;
3578   my $cust_credit = new FS::cust_credit {
3579     'custnum' => $self->custnum,
3580     'amount'  => $amount,
3581     'reason'  => $reason,
3582   };
3583   $cust_credit->insert;
3584 }
3585
3586 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
3587
3588 Creates a one-time charge for this customer.  If there is an error, returns
3589 the error, otherwise returns false.
3590
3591 =cut
3592
3593 sub charge {
3594   my ( $self, $amount ) = ( shift, shift );
3595   my $pkg      = @_ ? shift : 'One-time charge';
3596   my $comment  = @_ ? shift : '$'. sprintf("%.2f",$amount);
3597   my $taxclass = @_ ? shift : '';
3598
3599   local $SIG{HUP} = 'IGNORE';
3600   local $SIG{INT} = 'IGNORE';
3601   local $SIG{QUIT} = 'IGNORE';
3602   local $SIG{TERM} = 'IGNORE';
3603   local $SIG{TSTP} = 'IGNORE';
3604   local $SIG{PIPE} = 'IGNORE';
3605
3606   my $oldAutoCommit = $FS::UID::AutoCommit;
3607   local $FS::UID::AutoCommit = 0;
3608   my $dbh = dbh;
3609
3610   my $part_pkg = new FS::part_pkg ( {
3611     'pkg'      => $pkg,
3612     'comment'  => $comment,
3613     #'setup'    => $amount,
3614     #'recur'    => '0',
3615     'plan'     => 'flat',
3616     'plandata' => "setup_fee=$amount",
3617     'freq'     => 0,
3618     'disabled' => 'Y',
3619     'taxclass' => $taxclass,
3620   } );
3621
3622   my $error = $part_pkg->insert;
3623   if ( $error ) {
3624     $dbh->rollback if $oldAutoCommit;
3625     return $error;
3626   }
3627
3628   my $pkgpart = $part_pkg->pkgpart;
3629   my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
3630   unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
3631     my $type_pkgs = new FS::type_pkgs \%type_pkgs;
3632     $error = $type_pkgs->insert;
3633     if ( $error ) {
3634       $dbh->rollback if $oldAutoCommit;
3635       return $error;
3636     }
3637   }
3638
3639   my $cust_pkg = new FS::cust_pkg ( {
3640     'custnum' => $self->custnum,
3641     'pkgpart' => $pkgpart,
3642   } );
3643
3644   $error = $cust_pkg->insert;
3645   if ( $error ) {
3646     $dbh->rollback if $oldAutoCommit;
3647     return $error;
3648   }
3649
3650   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3651   '';
3652
3653 }
3654
3655 =item cust_bill
3656
3657 Returns all the invoices (see L<FS::cust_bill>) for this customer.
3658
3659 =cut
3660
3661 sub cust_bill {
3662   my $self = shift;
3663   sort { $a->_date <=> $b->_date }
3664     qsearch('cust_bill', { 'custnum' => $self->custnum, } )
3665 }
3666
3667 =item open_cust_bill
3668
3669 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
3670 customer.
3671
3672 =cut
3673
3674 sub open_cust_bill {
3675   my $self = shift;
3676   grep { $_->owed > 0 } $self->cust_bill;
3677 }
3678
3679 =item cust_credit
3680
3681 Returns all the credits (see L<FS::cust_credit>) for this customer.
3682
3683 =cut
3684
3685 sub cust_credit {
3686   my $self = shift;
3687   sort { $a->_date <=> $b->_date }
3688     qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
3689 }
3690
3691 =item cust_pay
3692
3693 Returns all the payments (see L<FS::cust_pay>) for this customer.
3694
3695 =cut
3696
3697 sub cust_pay {
3698   my $self = shift;
3699   sort { $a->_date <=> $b->_date }
3700     qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
3701 }
3702
3703 =item cust_pay_void
3704
3705 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
3706
3707 =cut
3708
3709 sub cust_pay_void {
3710   my $self = shift;
3711   sort { $a->_date <=> $b->_date }
3712     qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
3713 }
3714
3715
3716 =item cust_refund
3717
3718 Returns all the refunds (see L<FS::cust_refund>) for this customer.
3719
3720 =cut
3721
3722 sub cust_refund {
3723   my $self = shift;
3724   sort { $a->_date <=> $b->_date }
3725     qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
3726 }
3727
3728 =item select_for_update
3729
3730 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
3731 a mutex.
3732
3733 =cut
3734
3735 sub select_for_update {
3736   my $self = shift;
3737   qsearch('cust_main', { 'custnum' => $self->custnum }, '*', 'FOR UPDATE' );
3738 }
3739
3740 =item name
3741
3742 Returns a name string for this customer, either "Company (Last, First)" or
3743 "Last, First".
3744
3745 =cut
3746
3747 sub name {
3748   my $self = shift;
3749   my $name = $self->contact;
3750   $name = $self->company. " ($name)" if $self->company;
3751   $name;
3752 }
3753
3754 =item ship_name
3755
3756 Returns a name string for this (service/shipping) contact, either
3757 "Company (Last, First)" or "Last, First".
3758
3759 =cut
3760
3761 sub ship_name {
3762   my $self = shift;
3763   if ( $self->get('ship_last') ) {
3764     my $name = $self->ship_contact;
3765     $name = $self->ship_company. " ($name)" if $self->ship_company;
3766     $name;
3767   } else {
3768     $self->name;
3769   }
3770 }
3771
3772 =item contact
3773
3774 Returns this customer's full (billing) contact name only, "Last, First"
3775
3776 =cut
3777
3778 sub contact {
3779   my $self = shift;
3780   $self->get('last'). ', '. $self->first;
3781 }
3782
3783 =item ship_contact
3784
3785 Returns this customer's full (shipping) contact name only, "Last, First"
3786
3787 =cut
3788
3789 sub ship_contact {
3790   my $self = shift;
3791   $self->get('ship_last')
3792     ? $self->get('ship_last'). ', '. $self->ship_first
3793     : $self->contact;
3794 }
3795
3796 =item country_full
3797
3798 Returns this customer's full country name
3799
3800 =cut
3801
3802 sub country_full {
3803   my $self = shift;
3804   code2country($self->country);
3805 }
3806
3807 =item status
3808
3809 Returns a status string for this customer, currently:
3810
3811 =over 4
3812
3813 =item prospect - No packages have ever been ordered
3814
3815 =item active - One or more recurring packages is active
3816
3817 =item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled)
3818
3819 =item suspended - All non-cancelled recurring packages are suspended
3820
3821 =item cancelled - All recurring packages are cancelled
3822
3823 =back
3824
3825 =cut
3826
3827 sub status {
3828   my $self = shift;
3829   for my $status (qw( prospect active inactive suspended cancelled )) {
3830     my $method = $status.'_sql';
3831     my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
3832     my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
3833     $sth->execute( ($self->custnum) x $numnum ) or die $sth->errstr;
3834     return $status if $sth->fetchrow_arrayref->[0];
3835   }
3836 }
3837
3838 =item statuscolor
3839
3840 Returns a hex triplet color string for this customer's status.
3841
3842 =cut
3843
3844 use vars qw(%statuscolor);
3845 %statuscolor = (
3846   'prospect'  => '7e0079', #'000000', #black?  naw, purple
3847   'active'    => '00CC00', #green
3848   'inactive'  => '0000CC', #blue
3849   'suspended' => 'FF9900', #yellow
3850   'cancelled' => 'FF0000', #red
3851 );
3852
3853 sub statuscolor {
3854   my $self = shift;
3855   $statuscolor{$self->status};
3856 }
3857
3858 =back
3859
3860 =head1 CLASS METHODS
3861
3862 =over 4
3863
3864 =item prospect_sql
3865
3866 Returns an SQL expression identifying prospective cust_main records (customers
3867 with no packages ever ordered)
3868
3869 =cut
3870
3871 use vars qw($select_count_pkgs);
3872 $select_count_pkgs =
3873   "SELECT COUNT(*) FROM cust_pkg
3874     WHERE cust_pkg.custnum = cust_main.custnum";
3875
3876 sub select_count_pkgs_sql {
3877   $select_count_pkgs;
3878 }
3879
3880 sub prospect_sql { "
3881   0 = ( $select_count_pkgs )
3882 "; }
3883
3884 =item active_sql
3885
3886 Returns an SQL expression identifying active cust_main records (customers with
3887 no active recurring packages, but otherwise unsuspended/uncancelled).
3888
3889 =cut
3890
3891 sub active_sql { "
3892   0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. "
3893       )
3894 "; }
3895
3896 =item inactive_sql
3897
3898 Returns an SQL expression identifying inactive cust_main records (customers with
3899 active recurring packages).
3900
3901 =cut
3902
3903 sub inactive_sql { "
3904   0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
3905   AND
3906   0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
3907 "; }
3908
3909 =item susp_sql
3910 =item suspended_sql
3911
3912 Returns an SQL expression identifying suspended cust_main records.
3913
3914 =cut
3915
3916
3917 sub suspended_sql { susp_sql(@_); }
3918 sub susp_sql { "
3919     0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " )
3920     AND
3921     0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
3922 "; }
3923
3924 =item cancel_sql
3925 =item cancelled_sql
3926
3927 Returns an SQL expression identifying cancelled cust_main records.
3928
3929 =cut
3930
3931 sub cancelled_sql { cancel_sql(@_); }
3932 sub cancel_sql {
3933
3934   my $recurring_sql = FS::cust_pkg->recurring_sql;
3935   #my $recurring_sql = "
3936   #  '0' != ( select freq from part_pkg
3937   #             where cust_pkg.pkgpart = part_pkg.pkgpart )
3938   #";
3939
3940   "
3941     0 < ( $select_count_pkgs )
3942     AND 0 = ( $select_count_pkgs AND $recurring_sql
3943                   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3944             )
3945   ";
3946 }
3947
3948 =item uncancel_sql
3949 =item uncancelled_sql
3950
3951 Returns an SQL expression identifying un-cancelled cust_main records.
3952
3953 =cut
3954
3955 sub uncancelled_sql { uncancel_sql(@_); }
3956 sub uncancel_sql { "
3957   ( 0 < ( $select_count_pkgs
3958                    AND ( cust_pkg.cancel IS NULL
3959                          OR cust_pkg.cancel = 0
3960                        )
3961         )
3962     OR 0 = ( $select_count_pkgs )
3963   )
3964 "; }
3965
3966 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
3967
3968 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
3969 records.  Currently, I<first>, I<last> and/or I<company> may be specified (the
3970 appropriate ship_ field is also searched).
3971
3972 Additional options are the same as FS::Record::qsearch
3973
3974 =cut
3975
3976 sub fuzzy_search {
3977   my( $self, $fuzzy, $hash, @opt) = @_;
3978   #$self
3979   $hash ||= {};
3980   my @cust_main = ();
3981
3982   check_and_rebuild_fuzzyfiles();
3983   foreach my $field ( keys %$fuzzy ) {
3984
3985     my $all = $self->all_X($field);
3986     next unless scalar(@$all);
3987
3988     my %match = ();
3989     $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) );
3990
3991     my @fcust = ();
3992     foreach ( keys %match ) {
3993       push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
3994       push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
3995     }
3996     my %fsaw = ();
3997     push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
3998   }
3999
4000   # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
4001   my %saw = ();
4002   @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
4003
4004   @cust_main;
4005
4006 }
4007
4008 =back
4009
4010 =head1 SUBROUTINES
4011
4012 =over 4
4013
4014 =item smart_search OPTION => VALUE ...
4015
4016 Accepts the following options: I<search>, the string to search for.  The string
4017 will be searched for as a customer number, phone number, name or company name,
4018 first searching for an exact match then fuzzy and substring matches (in some
4019 cases - see the source code for the exact heuristics used).
4020
4021 Any additional options treated as an additional qualifier on the search
4022 (i.e. I<agentnum>).
4023
4024 Returns a (possibly empty) array of FS::cust_main objects.
4025
4026 =cut
4027
4028 sub smart_search {
4029   my %options = @_;
4030
4031   #here is the agent virtualization
4032   my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
4033
4034   my @cust_main = ();
4035
4036   my $search = delete $options{'search'};
4037   ( my $alphanum_search = $search ) =~ s/\W//g;
4038
4039   if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
4040
4041     #false laziness w/Record::ut_phone
4042     my $phonen = "$1-$2-$3";
4043     $phonen .= " x$4" if $4;
4044
4045     push @cust_main, qsearch( {
4046       'table'   => 'cust_main',
4047       'hashref' => { %options },
4048       'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
4049                      ' ( '.
4050                          join(' OR ', map "$_ = '$phonen'",
4051                                           qw( daytime night fax
4052                                               ship_daytime ship_night ship_fax )
4053                              ).
4054                      ' ) '.
4055                      " AND $agentnums_sql", #agent virtualization
4056     } );
4057
4058     unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
4059       #try looking for matches with extensions unless one was specified
4060
4061       push @cust_main, qsearch( {
4062         'table'   => 'cust_main',
4063         'hashref' => { %options },
4064         'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
4065                        ' ( '.
4066                            join(' OR ', map "$_ LIKE '$phonen\%'",
4067                                             qw( daytime night
4068                                                 ship_daytime ship_night )
4069                                ).
4070                        ' ) '.
4071                        " AND $agentnums_sql", #agent virtualization
4072       } );
4073
4074     }
4075
4076   } elsif ( $search =~ /^\s*(\d+)\s*$/ ) { # customer # search
4077
4078     push @cust_main, qsearch( {
4079       'table'     => 'cust_main',
4080       'hashref'   => { 'custnum' => $1, %options },
4081       'extra_sql' => " AND $agentnums_sql", #agent virtualization
4082     } );
4083
4084   } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
4085
4086     my($company, $last, $first) = ( $1, $2, $3 );
4087
4088     # "Company (Last, First)"
4089     #this is probably something a browser remembered,
4090     #so just do an exact search
4091
4092     foreach my $prefix ( '', 'ship_' ) {
4093       push @cust_main, qsearch( {
4094         'table'     => 'cust_main',
4095         'hashref'   => { $prefix.'first'   => $first,
4096                          $prefix.'last'    => $last,
4097                          $prefix.'company' => $company,
4098                          %options,
4099                        },
4100         'extra_sql' => " AND $agentnums_sql",
4101       } );
4102     }
4103
4104   } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
4105                                               # try (ship_){last,company}
4106
4107     my $value = lc($1);
4108
4109     # # remove "(Last, First)" in "Company (Last, First)", otherwise the
4110     # # full strings the browser remembers won't work
4111     # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
4112
4113     use Lingua::EN::NameParse;
4114     my $NameParse = new Lingua::EN::NameParse(
4115              auto_clean     => 1,
4116              allow_reversed => 1,
4117     );
4118
4119     my($last, $first) = ( '', '' );
4120     #maybe disable this too and just rely on NameParse?
4121     if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
4122
4123       ($last, $first) = ( $1, $2 );
4124
4125     #} elsif  ( $value =~ /^(.+)\s+(.+)$/ ) {
4126     } elsif ( ! $NameParse->parse($value) ) {
4127
4128       my %name = $NameParse->components;
4129       $first = $name{'given_name_1'};
4130       $last  = $name{'surname_1'};
4131
4132     }
4133
4134     if ( $first && $last ) {
4135
4136       my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
4137
4138       #exact
4139       my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
4140       $sql .= "
4141         (     ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
4142            OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
4143         )";
4144
4145       push @cust_main, qsearch( {
4146         'table'     => 'cust_main',
4147         'hashref'   => \%options,
4148         'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
4149       } );
4150
4151       # or it just be something that was typed in... (try that in a sec)
4152
4153     }
4154
4155     my $q_value = dbh->quote($value);
4156
4157     #exact
4158     my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
4159     $sql .= " (    LOWER(last)         = $q_value
4160                 OR LOWER(company)      = $q_value
4161                 OR LOWER(ship_last)    = $q_value
4162                 OR LOWER(ship_company) = $q_value
4163               )";
4164
4165     push @cust_main, qsearch( {
4166       'table'     => 'cust_main',
4167       'hashref'   => \%options,
4168       'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
4169     } );
4170
4171     unless ( @cust_main ) {  #no exact match, trying substring/fuzzy
4172
4173       #still some false laziness w/ search/cust_main.cgi
4174
4175       #substring
4176
4177       my @hashrefs = (
4178         { 'company'      => { op=>'ILIKE', value=>"%$value%" }, },
4179         { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
4180       );
4181
4182       if ( $first && $last ) {
4183
4184         push @hashrefs,
4185           { 'first'        => { op=>'ILIKE', value=>"%$first%" },
4186             'last'         => { op=>'ILIKE', value=>"%$last%" },
4187           },
4188           { 'ship_first'   => { op=>'ILIKE', value=>"%$first%" },
4189             'ship_last'    => { op=>'ILIKE', value=>"%$last%" },
4190           },
4191         ;
4192
4193       } else {
4194
4195         push @hashrefs,
4196           { 'last'         => { op=>'ILIKE', value=>"%$value%" }, },
4197           { 'ship_last'    => { op=>'ILIKE', value=>"%$value%" }, },
4198         ;
4199       }
4200
4201       foreach my $hashref ( @hashrefs ) {
4202
4203         push @cust_main, qsearch( {
4204           'table'     => 'cust_main',
4205           'hashref'   => { %$hashref,
4206                            %options,
4207                          },
4208           'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
4209         } );
4210
4211       }
4212
4213       #fuzzy
4214       my @fuzopts = (
4215         \%options,                #hashref
4216         '',                       #select
4217         " AND $agentnums_sql",    #extra_sql  #agent virtualization
4218       );
4219
4220       if ( $first && $last ) {
4221         push @cust_main, FS::cust_main->fuzzy_search(
4222           { 'last'   => $last,    #fuzzy hashref
4223             'first'  => $first }, #
4224           @fuzopts
4225         );
4226       }
4227       foreach my $field ( 'last', 'company' ) {
4228         push @cust_main,
4229           FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
4230       }
4231
4232     }
4233
4234     #eliminate duplicates
4235     my %saw = ();
4236     @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
4237
4238   }
4239
4240   @cust_main;
4241
4242 }
4243
4244 =item check_and_rebuild_fuzzyfiles
4245
4246 =cut
4247
4248 use vars qw(@fuzzyfields);
4249 @fuzzyfields = ( 'last', 'first', 'company' );
4250
4251 sub check_and_rebuild_fuzzyfiles {
4252   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
4253   rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
4254 }
4255
4256 =item rebuild_fuzzyfiles
4257
4258 =cut
4259
4260 sub rebuild_fuzzyfiles {
4261
4262   use Fcntl qw(:flock);
4263
4264   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
4265   mkdir $dir, 0700 unless -d $dir;
4266
4267   foreach my $fuzzy ( @fuzzyfields ) {
4268
4269     open(LOCK,">>$dir/cust_main.$fuzzy")
4270       or die "can't open $dir/cust_main.$fuzzy: $!";
4271     flock(LOCK,LOCK_EX)
4272       or die "can't lock $dir/cust_main.$fuzzy: $!";
4273
4274     open (CACHE,">$dir/cust_main.$fuzzy.tmp")
4275       or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
4276
4277     foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
4278       my $sth = dbh->prepare("SELECT $field FROM cust_main".
4279                              " WHERE $field != '' AND $field IS NOT NULL");
4280       $sth->execute or die $sth->errstr;
4281
4282       while ( my $row = $sth->fetchrow_arrayref ) {
4283         print CACHE $row->[0]. "\n";
4284       }
4285
4286     }
4287
4288     close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
4289
4290     rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
4291     close LOCK;
4292   }
4293
4294 }
4295
4296 =item all_X
4297
4298 =cut
4299
4300 sub all_X {
4301   my( $self, $field ) = @_;
4302   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
4303   open(CACHE,"<$dir/cust_main.$field")
4304     or die "can't open $dir/cust_main.$field: $!";
4305   my @array = map { chomp; $_; } <CACHE>;
4306   close CACHE;
4307   \@array;
4308 }
4309
4310 =item append_fuzzyfiles LASTNAME COMPANY
4311
4312 =cut
4313
4314 sub append_fuzzyfiles {
4315   #my( $first, $last, $company ) = @_;
4316
4317   &check_and_rebuild_fuzzyfiles;
4318
4319   use Fcntl qw(:flock);
4320
4321   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
4322
4323   foreach my $field (qw( first last company )) {
4324     my $value = shift;
4325
4326     if ( $value ) {
4327
4328       open(CACHE,">>$dir/cust_main.$field")
4329         or die "can't open $dir/cust_main.$field: $!";
4330       flock(CACHE,LOCK_EX)
4331         or die "can't lock $dir/cust_main.$field: $!";
4332
4333       print CACHE "$value\n";
4334
4335       flock(CACHE,LOCK_UN)
4336         or die "can't unlock $dir/cust_main.$field: $!";
4337       close CACHE;
4338     }
4339
4340   }
4341
4342   1;
4343 }
4344
4345 =item batch_import
4346
4347 =cut
4348
4349 sub batch_import {
4350   my $param = shift;
4351   #warn join('-',keys %$param);
4352   my $fh = $param->{filehandle};
4353   my $agentnum = $param->{agentnum};
4354
4355   my $refnum = $param->{refnum};
4356   my $pkgpart = $param->{pkgpart};
4357
4358   #my @fields = @{$param->{fields}};
4359   my $format = $param->{'format'};
4360   my @fields;
4361   my $payby;
4362   if ( $format eq 'simple' ) {
4363     @fields = qw( cust_pkg.setup dayphone first last
4364                   address1 address2 city state zip comments );
4365     $payby = 'BILL';
4366   } elsif ( $format eq 'extended' ) {
4367     @fields = qw( agent_custid refnum
4368                   last first address1 address2 city state zip country
4369                   daytime night
4370                   ship_last ship_first ship_address1 ship_address2
4371                   ship_city ship_state ship_zip ship_country
4372                   payinfo paycvv paydate
4373                   invoicing_list
4374                   cust_pkg.pkgpart
4375                   svc_acct.username svc_acct._password
4376                 );
4377     $payby = 'BILL';
4378   } else {
4379     die "unknown format $format";
4380   }
4381
4382   eval "use Text::CSV_XS;";
4383   die $@ if $@;
4384
4385   my $csv = new Text::CSV_XS;
4386   #warn $csv;
4387   #warn $fh;
4388
4389   my $imported = 0;
4390   #my $columns;
4391
4392   local $SIG{HUP} = 'IGNORE';
4393   local $SIG{INT} = 'IGNORE';
4394   local $SIG{QUIT} = 'IGNORE';
4395   local $SIG{TERM} = 'IGNORE';
4396   local $SIG{TSTP} = 'IGNORE';
4397   local $SIG{PIPE} = 'IGNORE';
4398
4399   my $oldAutoCommit = $FS::UID::AutoCommit;
4400   local $FS::UID::AutoCommit = 0;
4401   my $dbh = dbh;
4402
4403   #while ( $columns = $csv->getline($fh) ) {
4404   my $line;
4405   while ( defined($line=<$fh>) ) {
4406
4407     $csv->parse($line) or do {
4408       $dbh->rollback if $oldAutoCommit;
4409       return "can't parse: ". $csv->error_input();
4410     };
4411
4412     my @columns = $csv->fields();
4413     #warn join('-',@columns);
4414
4415     my %cust_main = (
4416       agentnum => $agentnum,
4417       refnum   => $refnum,
4418       country  => $conf->config('countrydefault') || 'US',
4419       payby    => $payby, #default
4420       paydate  => '12/2037', #default
4421     );
4422     my $billtime = time;
4423     my %cust_pkg = ( pkgpart => $pkgpart );
4424     my %svc_acct = ();
4425     foreach my $field ( @fields ) {
4426
4427       if ( $field =~ /^cust_pkg\.(pkgpart|setup|bill|susp|expire|cancel)$/ ) {
4428
4429         #$cust_pkg{$1} = str2time( shift @$columns );
4430         if ( $1 eq 'pkgpart' ) {
4431           $cust_pkg{$1} = shift @columns;
4432         } elsif ( $1 eq 'setup' ) {
4433           $billtime = str2time(shift @columns);
4434         } else {
4435           $cust_pkg{$1} = str2time( shift @columns );
4436         }
4437
4438       } elsif ( $field =~ /^svc_acct\.(username|_password)$/ ) {
4439
4440         $svc_acct{$1} = shift @columns;
4441
4442       } else {
4443
4444         #refnum interception
4445         if ( $field eq 'refnum' && $columns[0] !~ /^\s*(\d+)\s*$/ ) {
4446
4447           my $referral = $columns[0];
4448           my %hash = ( 'referral' => $referral,
4449                        'agentnum' => $agentnum,
4450                        'disabled' => '',
4451                      );
4452
4453           my $part_referral = qsearchs('part_referral', \%hash )
4454                               || new FS::part_referral \%hash;
4455
4456           unless ( $part_referral->refnum ) {
4457             my $error = $part_referral->insert;
4458             if ( $error ) {
4459               $dbh->rollback if $oldAutoCommit;
4460               return "can't auto-insert advertising source: $referral: $error";
4461             }
4462           }
4463
4464           $columns[0] = $part_referral->refnum;
4465         }
4466
4467         #$cust_main{$field} = shift @$columns;
4468         $cust_main{$field} = shift @columns;
4469       }
4470     }
4471
4472     $cust_main{'payby'} = 'CARD' if length($cust_main{'payinfo'});
4473
4474     my $invoicing_list = $cust_main{'invoicing_list'}
4475                            ? [ delete $cust_main{'invoicing_list'} ]
4476                            : [];
4477
4478     my $cust_main = new FS::cust_main ( \%cust_main );
4479
4480     use Tie::RefHash;
4481     tie my %hash, 'Tie::RefHash'; #this part is important
4482
4483     if ( $cust_pkg{'pkgpart'} ) {
4484       my $cust_pkg = new FS::cust_pkg ( \%cust_pkg );
4485
4486       my @svc_acct = ();
4487       if ( $svc_acct{'username'} ) {
4488         my $part_pkg = $cust_pkg->part_pkg;
4489         unless ( $part_pkg ) {
4490           $dbh->rollback if $oldAutoCommit;
4491           return "unknown pkgnum ". $cust_pkg{'pkgpart'};
4492         }
4493         $svc_acct{svcpart} = $part_pkg->svcpart( 'svc_acct' );
4494         push @svc_acct, new FS::svc_acct ( \%svc_acct )
4495       }
4496
4497       $hash{$cust_pkg} = \@svc_acct;
4498     }
4499
4500     my $error = $cust_main->insert( \%hash, $invoicing_list );
4501
4502     if ( $error ) {
4503       $dbh->rollback if $oldAutoCommit;
4504       return "can't insert customer for $line: $error";
4505     }
4506
4507     if ( $format eq 'simple' ) {
4508
4509       #false laziness w/bill.cgi
4510       $error = $cust_main->bill( 'time' => $billtime );
4511       if ( $error ) {
4512         $dbh->rollback if $oldAutoCommit;
4513         return "can't bill customer for $line: $error";
4514       }
4515
4516       $cust_main->apply_payments;
4517       $cust_main->apply_credits;
4518
4519       $error = $cust_main->collect();
4520       if ( $error ) {
4521         $dbh->rollback if $oldAutoCommit;
4522         return "can't collect customer for $line: $error";
4523       }
4524
4525     }
4526
4527     $imported++;
4528   }
4529
4530   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4531
4532   return "Empty file!" unless $imported;
4533
4534   ''; #no error
4535
4536 }
4537
4538 =item batch_charge
4539
4540 =cut
4541
4542 sub batch_charge {
4543   my $param = shift;
4544   #warn join('-',keys %$param);
4545   my $fh = $param->{filehandle};
4546   my @fields = @{$param->{fields}};
4547
4548   eval "use Text::CSV_XS;";
4549   die $@ if $@;
4550
4551   my $csv = new Text::CSV_XS;
4552   #warn $csv;
4553   #warn $fh;
4554
4555   my $imported = 0;
4556   #my $columns;
4557
4558   local $SIG{HUP} = 'IGNORE';
4559   local $SIG{INT} = 'IGNORE';
4560   local $SIG{QUIT} = 'IGNORE';
4561   local $SIG{TERM} = 'IGNORE';
4562   local $SIG{TSTP} = 'IGNORE';
4563   local $SIG{PIPE} = 'IGNORE';
4564
4565   my $oldAutoCommit = $FS::UID::AutoCommit;
4566   local $FS::UID::AutoCommit = 0;
4567   my $dbh = dbh;
4568
4569   #while ( $columns = $csv->getline($fh) ) {
4570   my $line;
4571   while ( defined($line=<$fh>) ) {
4572
4573     $csv->parse($line) or do {
4574       $dbh->rollback if $oldAutoCommit;
4575       return "can't parse: ". $csv->error_input();
4576     };
4577
4578     my @columns = $csv->fields();
4579     #warn join('-',@columns);
4580
4581     my %row = ();
4582     foreach my $field ( @fields ) {
4583       $row{$field} = shift @columns;
4584     }
4585
4586     my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
4587     unless ( $cust_main ) {
4588       $dbh->rollback if $oldAutoCommit;
4589       return "unknown custnum $row{'custnum'}";
4590     }
4591
4592     if ( $row{'amount'} > 0 ) {
4593       my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
4594       if ( $error ) {
4595         $dbh->rollback if $oldAutoCommit;
4596         return $error;
4597       }
4598       $imported++;
4599     } elsif ( $row{'amount'} < 0 ) {
4600       my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
4601                                       $row{'pkg'}                         );
4602       if ( $error ) {
4603         $dbh->rollback if $oldAutoCommit;
4604         return $error;
4605       }
4606       $imported++;
4607     } else {
4608       #hmm?
4609     }
4610
4611   }
4612
4613   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4614
4615   return "Empty file!" unless $imported;
4616
4617   ''; #no error
4618
4619 }
4620
4621 =back
4622
4623 =head1 BUGS
4624
4625 The delete method.
4626
4627 The delete method should possibly take an FS::cust_main object reference
4628 instead of a scalar customer number.
4629
4630 Bill and collect options should probably be passed as references instead of a
4631 list.
4632
4633 There should probably be a configuration file with a list of allowed credit
4634 card types.
4635
4636 No multiple currency support (probably a larger project than just this module).
4637
4638 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
4639
4640 Birthdates rely on negative epoch values.
4641
4642 =head1 SEE ALSO
4643
4644 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
4645 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
4646 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.
4647
4648 =cut
4649
4650 1;
4651