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