FS/FS/cust_credit.pm

   1 package FS::cust_credit;
   2 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::reason_Mixin
   3              FS::Record );
   4
   5 use strict;
   6 use vars qw( $conf $unsuspendauto $me $DEBUG
   7              $otaker_upgrade_kludge $ignore_empty_reasonnum
   8            );
   9 use List::Util qw( min );
  10 use Date::Format;
  11 use FS::UID qw( dbh );
  12 use FS::Record qw( qsearch qsearchs dbdef );
  13 use FS::CurrentUser;
  14 use FS::cust_pkg;
  15 use FS::cust_refund;
  16 use FS::cust_credit_bill;
  17 use FS::part_pkg;
  18 use FS::reason_type;
  19 use FS::reason;
  20 use FS::cust_event;
  21 use FS::agent;
  22 use FS::sales;
  23 use FS::cust_credit_void;
  24 use FS::cust_bill_pkg;
  25 use FS::upgrade_journal;
  26
  27 $me = '[ FS::cust_credit ]';
  28 $DEBUG = 0;
  29
  30 $otaker_upgrade_kludge = 0;
  31 $ignore_empty_reasonnum = 0;
  32
  33 #ask FS::UID to run this stuff for us later
  34 $FS::UID::callback{'FS::cust_credit'} = sub {
  35
  36   $conf = new FS::Conf;
  37   $unsuspendauto = $conf->exists('unsuspendauto');
  38
  39 };
  40
  41 our %reasontype_map = ( 'referral_credit_type' => 'Referral Credit',
  42                         'cancel_credit_type'   => 'Cancellation Credit',
  43                       );
  44
  45 =head1 NAME
  46
  47 FS::cust_credit - Object methods for cust_credit records
  48
  49 =head1 SYNOPSIS
  50
  51   use FS::cust_credit;
  52
  53   $record = new FS::cust_credit \%hash;
  54   $record = new FS::cust_credit { 'column' => 'value' };
  55
  56   $error = $record->insert;
  57
  58   $error = $new_record->replace($old_record);
  59
  60   $error = $record->delete;
  61
  62   $error = $record->check;
  63
  64 =head1 DESCRIPTION
  65
  66 An FS::cust_credit object represents a credit; the equivalent of a negative
  67 B<cust_bill> record (see L<FS::cust_bill>).  FS::cust_credit inherits from
  68 FS::Record.  The following fields are currently supported:
  69
  70 =over 4
  71
  72 =item crednum
  73
  74 Primary key (assigned automatically for new credits)
  75
  76 =item custnum
  77
  78 Customer (see L<FS::cust_main>)
  79
  80 =item amount
  81
  82 Amount of the credit
  83
  84 =item _date
  85
  86 Specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
  87 L<Time::Local> and L<Date::Parse> for conversion functions.
  88
  89 =item usernum
  90
  91 Order taker (see L<FS::access_user>)
  92
  93 =item reason
  94
  95 Text ( deprecated )
  96
  97 =item reasonnum
  98
  99 Reason (see L<FS::reason>)
 100
 101 =item addlinfo
 102
 103 Text
 104
 105 =item closed
 106
 107 Books closed flag, empty or `Y'
 108
 109 =item pkgnum
 110
 111 Desired pkgnum when using experimental package balances.
 112
 113 =back
 114
 115 =head1 METHODS
 116
 117 =over 4
 118
 119 =item new HASHREF
 120
 121 Creates a new credit.  To add the credit to the database, see L<"insert">.
 122
 123 =cut
 124
 125 sub table { 'cust_credit'; }
 126 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
 127 sub cust_unlinked_msg {
 128   my $self = shift;
 129   "WARNING: can't find cust_main.custnum ". $self->custnum.
 130   ' (cust_credit.crednum '. $self->crednum. ')';
 131 }
 132
 133 =item insert [ OPTION => VALUE ... ]
 134
 135 Adds this credit to the database ("Posts" the credit).  If there is an error,
 136 returns the error, otherwise returns false.
 137
 138 Ooptions are passed as a list of keys and values.  Available options:
 139
 140 =over 4
 141
 142 =item reason_type
 143
 144 L<FS::reason_type|Reason> type for newly-inserted reason
 145
 146 =item cust_credit_source_bill_pkg
 147
 148 An arrayref of
 149 L<FS::cust_credit_source_bill_pkg|FS::cust_credit_source_bilL_pkg> objects.
 150 They will have their crednum set and will be inserted along with this credit.
 151
 152 =back
 153
 154 =cut
 155
 156 sub insert {
 157   my ($self, %options) = @_;
 158
 159   local $SIG{HUP} = 'IGNORE';
 160   local $SIG{INT} = 'IGNORE';
 161   local $SIG{QUIT} = 'IGNORE';
 162   local $SIG{TERM} = 'IGNORE';
 163   local $SIG{TSTP} = 'IGNORE';
 164   local $SIG{PIPE} = 'IGNORE';
 165
 166   my $oldAutoCommit = $FS::UID::AutoCommit;
 167   local $FS::UID::AutoCommit = 0;
 168   my $dbh = dbh;
 169
 170   my $cust_main = qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 171   my $old_balance = $cust_main->balance;
 172
 173   if (!$self->reasonnum) {
 174     my $reason_text = $self->get('reason')
 175       or return "reason text or existing reason required";
 176     my $reason_type = $options{'reason_type'}
 177       or return "reason type required";
 178
 179     local $@;
 180     my $reason = FS::reason->new_or_existing(
 181       reason => $reason_text,
 182       type   => $reason_type,
 183       class  => 'R',
 184     );
 185     if ($@) {
 186       $dbh->rollback if $oldAutoCommit;
 187       return "failed to set credit reason: $@";
 188     }
 189     $self->set('reasonnum', $reason->reasonnum);
 190   }
 191
 192   $self->setfield('reason', '');
 193
 194   my $error = $self->SUPER::insert;
 195   if ( $error ) {
 196     $dbh->rollback if $oldAutoCommit;
 197     return "error inserting $self: $error";
 198   }
 199
 200   if ( $options{'cust_credit_source_bill_pkg'} ) {
 201     foreach my $ccsbr ( @{ $options{'cust_credit_source_bill_pkg'} } ) {
 202       $ccsbr->crednum( $self->crednum );
 203       $error = $ccsbr->insert;
 204       if ( $error ) {
 205         $dbh->rollback if $oldAutoCommit;
 206         return "error inserting $ccsbr: $error";
 207       }
 208     }
 209   }
 210
 211   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 212
 213   #false laziness w/ cust_pay::insert
 214   if ( $unsuspendauto && $old_balance && $cust_main->balance <= 0 ) {
 215     my @errors = $cust_main->unsuspend;
 216     #return
 217     # side-fx with nested transactions?  upstack rolls back?
 218     warn "WARNING:Errors unsuspending customer ". $cust_main->custnum. ": ".
 219          join(' / ', @errors)
 220       if @errors;
 221   }
 222   #eslaf
 223
 224   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 225
 226   '';
 227
 228 }
 229
 230 =item delete
 231
 232 Unless the closed flag is set, deletes this credit and all associated
 233 applications (see L<FS::cust_credit_bill>).  In most cases, you want to use
 234 the void method instead to leave a record of the deleted credit.
 235
 236 =cut
 237
 238 # very similar to FS::cust_pay::delete
 239 sub delete {
 240   my $self = shift;
 241   my %opt = @_;
 242
 243   return "Can't delete closed credit" if $self->closed =~ /^Y/i;
 244
 245   local $SIG{HUP} = 'IGNORE';
 246   local $SIG{INT} = 'IGNORE';
 247   local $SIG{QUIT} = 'IGNORE';
 248   local $SIG{TERM} = 'IGNORE';
 249   local $SIG{TSTP} = 'IGNORE';
 250   local $SIG{PIPE} = 'IGNORE';
 251
 252   my $oldAutoCommit = $FS::UID::AutoCommit;
 253   local $FS::UID::AutoCommit = 0;
 254   my $dbh = dbh;
 255
 256   foreach my $cust_credit_bill ( $self->cust_credit_bill ) {
 257     my $error = $cust_credit_bill->delete;
 258     if ( $error ) {
 259       $dbh->rollback if $oldAutoCommit;
 260       return $error;
 261     }
 262   }
 263
 264   foreach my $cust_credit_refund ( $self->cust_credit_refund ) {
 265     my $error = $cust_credit_refund->delete;
 266     if ( $error ) {
 267       $dbh->rollback if $oldAutoCommit;
 268       return $error;
 269     }
 270   }
 271
 272   my $error = $self->SUPER::delete(@_);
 273   if ( $error ) {
 274     $dbh->rollback if $oldAutoCommit;
 275     return $error;
 276   }
 277
 278   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 279
 280   '';
 281
 282 }
 283
 284 =item replace [ OLD_RECORD ]
 285
 286 You can, but probably shouldn't modify credits...
 287
 288 Replaces the OLD_RECORD with this one in the database, or, if OLD_RECORD is not
 289 supplied, replaces this record.  If there is an error, returns the error,
 290 otherwise returns false.
 291
 292 =cut
 293
 294 sub replace {
 295   my $self = shift;
 296   return "Can't modify closed credit" if $self->closed =~ /^Y/i;
 297   $self->SUPER::replace(@_);
 298 }
 299
 300 =item check
 301
 302 Checks all fields to make sure this is a valid credit.  If there is an error,
 303 returns the error, otherwise returns false.  Called by the insert and replace
 304 methods.
 305
 306 =cut
 307
 308 sub check {
 309   my $self = shift;
 310
 311   $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
 312
 313   my $error =
 314     $self->ut_numbern('crednum')
 315     || $self->ut_number('custnum')
 316     || $self->ut_numbern('_date')
 317     || $self->ut_money('amount')
 318     || $self->ut_alphan('otaker')
 319     || $self->ut_textn('reason')
 320     || $self->ut_textn('addlinfo')
 321     || $self->ut_enum('closed', [ '', 'Y' ])
 322     || $self->ut_foreign_keyn('pkgnum', 'cust_pkg', 'pkgnum')
 323     || $self->ut_foreign_keyn('eventnum', 'cust_event', 'eventnum')
 324     || $self->ut_foreign_keyn('commission_agentnum',  'agent', 'agentnum')
 325     || $self->ut_foreign_keyn('commission_salesnum',  'sales', 'salesnum')
 326     || $self->ut_foreign_keyn('commission_pkgnum', 'cust_pkg', 'pkgnum')
 327   ;
 328   return $error if $error;
 329
 330   my $method = $ignore_empty_reasonnum ? 'ut_foreign_keyn' : 'ut_foreign_key';
 331   $error = $self->$method('reasonnum', 'reason', 'reasonnum');
 332   return $error if $error;
 333
 334   return "amount must be > 0 " if $self->amount <= 0;
 335
 336   return "amount must be greater or equal to amount applied"
 337     if $self->unapplied < 0 && ! $otaker_upgrade_kludge;
 338
 339   return "Unknown customer"
 340     unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 341
 342   $self->_date(time) unless $self->_date;
 343
 344   $self->SUPER::check;
 345 }
 346
 347 =item void [ REASON ]
 348
 349 Voids this credit: deletes the credit and all associated applications and
 350 adds a record of the voided credit to the cust_credit_void table.
 351
 352 =cut
 353
 354 sub void {
 355   my $self = shift;
 356   my $reason = shift;
 357
 358   unless (ref($reason) || !$reason) {
 359     $reason = FS::reason->new_or_existing(
 360       'class'  => 'X',
 361       'type'   => 'Void credit',
 362       'reason' => $reason
 363     );
 364   }
 365
 366   local $SIG{HUP} = 'IGNORE';
 367   local $SIG{INT} = 'IGNORE';
 368   local $SIG{QUIT} = 'IGNORE';
 369   local $SIG{TERM} = 'IGNORE';
 370   local $SIG{TSTP} = 'IGNORE';
 371   local $SIG{PIPE} = 'IGNORE';
 372
 373   my $oldAutoCommit = $FS::UID::AutoCommit;
 374   local $FS::UID::AutoCommit = 0;
 375   my $dbh = dbh;
 376
 377   my $cust_credit_void = new FS::cust_credit_void ( {
 378       map { $_ => $self->get($_) } $self->fields
 379     } );
 380   $cust_credit_void->set('void_reasonnum', $reason->reasonnum) if $reason;
 381   my $error = $cust_credit_void->insert;
 382   if ( $error ) {
 383     $dbh->rollback if $oldAutoCommit;
 384     return $error;
 385   }
 386
 387   $error = $self->delete();
 388   if ( $error ) {
 389     $dbh->rollback if $oldAutoCommit;
 390     return $error;
 391   }
 392
 393   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 394
 395   '';
 396
 397 }
 398
 399 =item cust_credit_refund
 400
 401 Returns all refund applications (see L<FS::cust_credit_refund>) for this credit.
 402
 403 =cut
 404
 405 sub cust_credit_refund {
 406   my $self = shift;
 407   map { $_ } #return $self->num_cust_credit_refund unless wantarray;
 408   sort { $a->_date <=> $b->_date }
 409     qsearch( 'cust_credit_refund', { 'crednum' => $self->crednum } )
 410   ;
 411 }
 412
 413 =item cust_credit_bill
 414
 415 Returns all application to invoices (see L<FS::cust_credit_bill>) for this
 416 credit.
 417
 418 =cut
 419
 420 sub cust_credit_bill {
 421   my $self = shift;
 422   map { $_ } #return $self->num_cust_credit_bill unless wantarray;
 423   sort { $a->_date <=> $b->_date }
 424     qsearch( 'cust_credit_bill', { 'crednum' => $self->crednum } )
 425   ;
 426 }
 427
 428 =item unapplied
 429
 430 Returns the amount of this credit that is still unapplied/outstanding;
 431 amount minus all refund applications (see L<FS::cust_credit_refund>) and
 432 applications to invoices (see L<FS::cust_credit_bill>).
 433
 434 =cut
 435
 436 sub unapplied {
 437   my $self = shift;
 438   my $amount = $self->amount;
 439   $amount -= $_->amount foreach ( $self->cust_credit_refund );
 440   $amount -= $_->amount foreach ( $self->cust_credit_bill );
 441   sprintf( "%.2f", $amount );
 442 }
 443
 444 =item credited
 445
 446 Deprecated name for the unapplied method.
 447
 448 =cut
 449
 450 sub credited {
 451   my $self = shift;
 452   #carp "cust_credit->credited deprecated; use ->unapplied";
 453   $self->unapplied(@_);
 454 }
 455
 456 =item cust_main
 457
 458 Returns the customer (see L<FS::cust_main>) for this credit.
 459
 460 =cut
 461
 462 # _upgrade_data
 463 #
 464 # Used by FS::Upgrade to migrate to a new database.
 465
 466 sub _upgrade_data {  # class method
 467   my ($class, %opts) = @_;
 468
 469   warn "$me upgrading $class\n" if $DEBUG;
 470
 471   $class->_upgrade_reasonnum(%opts);
 472
 473   if (defined dbdef->table($class->table)->column('reason')) {
 474
 475     warn "$me Ensuring existance of auto reasons\n" if $DEBUG;
 476
 477     foreach ( keys %reasontype_map ) {
 478       unless ($conf->config($_)) {       # hmmmm
 479 #       warn "$me Found $_ reason type lacking\n" if $DEBUG;
 480 #       my $hashref = { 'class' => 'R', 'type' => $reasontype_map{$_} };
 481         my $hashref = { 'class' => 'R', 'type' => 'Legacy' };
 482         my $reason_type = qsearchs( 'reason_type', $hashref );
 483         unless ($reason_type) {
 484           $reason_type  = new FS::reason_type( $hashref );
 485           my $error   = $reason_type->insert();
 486           die "$class had error inserting FS::reason_type into database: $error\n"
 487             if $error;
 488         }
 489         $conf->set($_, $reason_type->typenum);
 490       }
 491     }
 492
 493     warn "$me Ensuring commission packages have a reason type\n" if $DEBUG;
 494
 495     my $hashref = { 'class' => 'R', 'type' => 'Legacy' };
 496     my $reason_type = qsearchs( 'reason_type', $hashref );
 497     unless ($reason_type) {
 498       $reason_type  = new FS::reason_type( $hashref );
 499       my $error   = $reason_type->insert();
 500       die "$class had error inserting FS::reason_type into database: $error\n"
 501         if $error;
 502     }
 503
 504     my @plans = qw( flat_comission flat_comission_cust flat_comission_pkg );
 505     foreach my $plan ( @plans ) {
 506       foreach my $pkg ( qsearch('part_pkg', { 'plan' => $plan } ) ) {
 507         unless ($pkg->option('reason_type', 1) ) {
 508           my $plandata = $pkg->plandata.
 509                         "reason_type=". $reason_type->typenum. "\n";
 510           $pkg->plandata($plandata);
 511           my $error =
 512             $pkg->replace( undef,
 513                            'pkg_svc' => { map { $_->svcpart => $_->quantity }
 514                                           $pkg->pkg_svc
 515                                         },
 516                            'primary_svc' => $pkg->svcpart,
 517                          );
 518             die "failed setting reason_type option: $error"
 519               if $error;
 520         }
 521       }
 522     }
 523   }
 524
 525   local($otaker_upgrade_kludge) = 1;
 526   local($ignore_empty_reasonnum) = 1;
 527   $class->_upgrade_otaker(%opts);
 528
 529   if ( !FS::upgrade_journal->is_done('cust_credit__tax_link')
 530       and !$conf->config('tax_data_vendor') ) {
 531     # RT#25458: fix credit line item applications that should refer to a
 532     # specific tax allocation
 533     my @cust_credit_bill_pkg = qsearch({
 534         table     => 'cust_credit_bill_pkg',
 535         select    => 'cust_credit_bill_pkg.*',
 536         addl_from => ' LEFT JOIN cust_bill_pkg USING (billpkgnum)',
 537         extra_sql =>
 538           'WHERE cust_credit_bill_pkg.billpkgtaxlocationnum IS NULL '.
 539           'AND cust_bill_pkg.pkgnum = 0', # is a tax
 540     });
 541     my %tax_items;
 542     my %credits;
 543     foreach (@cust_credit_bill_pkg) {
 544       my $billpkgnum = $_->billpkgnum;
 545       $tax_items{$billpkgnum} ||= FS::cust_bill_pkg->by_key($billpkgnum);
 546       $credits{$billpkgnum} ||= [];
 547       push @{ $credits{$billpkgnum} }, $_;
 548     }
 549     TAX_ITEM: foreach my $tax_item (values %tax_items) {
 550       my $billpkgnum = $tax_item->billpkgnum;
 551       # get all pkg/location/taxrate allocations of this tax line item
 552       my @allocations = sort {$b->amount <=> $a->amount}
 553                         qsearch('cust_bill_pkg_tax_location', {
 554                             billpkgnum => $billpkgnum
 555                         });
 556       # and these are all credit applications to it
 557       my @credits = sort {$b->amount <=> $a->amount}
 558                     @{ $credits{$billpkgnum} };
 559       my $c = shift @credits;
 560       my $a = shift @allocations; # we will NOT modify these
 561       while ($c and $a) {
 562         if ( abs($c->amount - $a->amount) < 0.005 ) {
 563           # by far the most common case: the tax line item is for a single
 564           # tax, so we just fill in the billpkgtaxlocationnum
 565           $c->set('billpkgtaxlocationnum', $a->billpkgtaxlocationnum);
 566           my $error = $c->replace;
 567           if ($error) {
 568             warn "error fixing credit application to tax item #$billpkgnum:\n$error\n";
 569             next TAX_ITEM;
 570           }
 571           $c = shift @credits;
 572           $a = shift @allocations;
 573         } elsif ( $c->amount > $a->amount ) {
 574           # fairly common: the tax line contains tax for multiple packages
 575           # (or multiple taxes) but the credit isn't divided up
 576           my $new_link = FS::cust_credit_bill_pkg->new({
 577               creditbillnum         => $c->creditbillnum,
 578               billpkgnum            => $c->billpkgnum,
 579               billpkgtaxlocationnum => $a->billpkgtaxlocationnum,
 580               amount                => $a->amount,
 581               setuprecur            => 'setup',
 582           });
 583           my $error = $new_link->insert;
 584           if ($error) {
 585             warn "error fixing credit application to tax item #$billpkgnum:\n$error\n";
 586             next TAX_ITEM;
 587           }
 588           $c->set(amount => sprintf('%.2f', $c->amount - $a->amount));
 589           $a = shift @allocations;
 590         } elsif ( $c->amount < 0.005 ) {
 591           # also fairly common; we can delete these with no harm
 592           my $error = $c->delete;
 593           warn "error removing zero-amount credit application (probably harmless):\n$error\n" if $error;
 594           $c = shift @credits;
 595         } elsif ( $c->amount < $a->amount ) {
 596           # should never happen, but if it does, handle it gracefully
 597           $c->set('billpkgtaxlocationnum', $a->billpkgtaxlocationnum);
 598           my $error = $c->replace;
 599           if ($error) {
 600             warn "error fixing credit application to tax item #$billpkgnum:\n$error\n";
 601             next TAX_ITEM;
 602           }
 603           $a->set(amount => $a->amount - $c->amount);
 604           $c = shift @credits;
 605         }
 606       } # while $c and $a
 607       if ( $c ) {
 608         if ( $c->amount < 0.005 ) {
 609           my $error = $c->delete;
 610           warn "error removing zero-amount credit application (probably harmless):\n$error\n" if $error;
 611         } elsif ( $c->modified ) {
 612           # then we've allocated part of it, so reduce the nonspecific
 613           # application by that much
 614           my $error = $c->replace;
 615           warn "error fixing credit application to tax item #$billpkgnum:\n$error\n" if $error;
 616         }
 617         # else there are probably no allocations, i.e. this is a pre-3.x
 618         # record that was never migrated over, so leave it alone
 619       } # if $c
 620     } # foreach $tax_item
 621     FS::upgrade_journal->set_done('cust_credit__tax_link');
 622   }
 623 }
 624
 625 =back
 626
 627 =head1 CLASS METHODS
 628
 629 =over 4
 630
 631 =item unapplied_sql
 632
 633 Returns an SQL fragment to retreive the unapplied amount.
 634
 635 =cut
 636
 637 sub unapplied_sql {
 638   my ($class, $start, $end) = @_;
 639
 640   my $bill_start   = $start ? "AND cust_credit_bill._date <= $start"   : '';
 641   my $bill_end     = $end   ? "AND cust_credit_bill._date > $end"     : '';
 642   my $refund_start = $start ? "AND cust_credit_refund._date <= $start" : '';
 643   my $refund_end   = $end   ? "AND cust_credit_refund._date > $end"   : '';
 644
 645   "amount
 646         - COALESCE(
 647                     ( SELECT SUM(amount) FROM cust_credit_refund
 648                         WHERE cust_credit.crednum = cust_credit_refund.crednum
 649                         $refund_start $refund_end )
 650                     ,0
 651                   )
 652         - COALESCE(
 653                     ( SELECT SUM(amount) FROM cust_credit_bill
 654                         WHERE cust_credit.crednum = cust_credit_bill.crednum
 655                         $bill_start $bill_end )
 656                     ,0
 657                   )
 658   ";
 659
 660 }
 661
 662 =item credited_sql
 663
 664 Deprecated name for the unapplied_sql method.
 665
 666 =cut
 667
 668 sub credited_sql {
 669   #my $class = shift;
 670
 671   #carp "cust_credit->credited_sql deprecated; use ->unapplied_sql";
 672
 673   #$class->unapplied_sql(@_);
 674   unapplied_sql();
 675 }
 676
 677 =item calculate_tax_adjustment PARAMS
 678
 679 Calculate the amount of tax that needs to be credited as part of a lineitem
 680 credit.
 681
 682 PARAMS must include:
 683
 684 - billpkgnums: arrayref identifying the line items to credit
 685 - setuprecurs: arrayref of 'setup' or 'recur', indicating which part of
 686   the lineitem charge is being credited
 687 - amounts: arrayref of the amounts to credit on each line item
 688 - custnum: the customer all of these invoices belong to, for error checking
 689
 690 Returns a hash containing:
 691 - subtotal: the total non-tax amount to be credited (the sum of the 'amounts')
 692 - taxtotal: the total tax amount to be credited
 693 - taxlines: an arrayref of hashrefs for each tax line to be credited, each with:
 694   - table: "cust_bill_pkg_tax_location" or "cust_bill_pkg_tax_rate_location"
 695   - num: the key within that table
 696   - credit: the credit amount to apply to that line
 697
 698 =cut
 699
 700 sub calculate_tax_adjustment {
 701   my ($class, %arg) = @_;
 702
 703   my $error;
 704   my @taxlines;
 705   my $subtotal = 0;
 706   my $taxtotal = 0;
 707
 708   my (%cust_bill_pkg, %cust_bill);
 709
 710   for (my $i = 0; ; $i++) {
 711     my $billpkgnum = $arg{billpkgnums}[$i]
 712       or last;
 713     my $setuprecur = $arg{setuprecurs}[$i];
 714     my $amount = $arg{amounts}[$i];
 715     next if $amount == 0;
 716     $subtotal += $amount;
 717     my $cust_bill_pkg = $cust_bill_pkg{$billpkgnum}
 718                     ||= FS::cust_bill_pkg->by_key($billpkgnum)
 719       or die "lineitem #$billpkgnum not found\n";
 720
 721     my $invnum = $cust_bill_pkg->invnum;
 722     $cust_bill{ $invnum } ||= FS::cust_bill->by_key($invnum);
 723     $cust_bill{ $invnum}->custnum == $arg{custnum}
 724       or die "lineitem #$billpkgnum not found\n";
 725
 726     # tax_Xlocation records don't distinguish setup and recur, so calculate
 727     # the fraction of setup+recur (after deducting credits) that's setup. This
 728     # will also be the fraction of tax (after deducting credits) that's tax on
 729     # setup.
 730     my ($setup, $recur);
 731     $setup = $cust_bill_pkg->get('setup') || 0;
 732     if ($setup) {
 733       $setup -= $cust_bill_pkg->credited('', '', setuprecur => 'setup') || 0;
 734     }
 735     $recur = $cust_bill_pkg->get('recur') || 0;
 736     if ($recur) {
 737       $recur -= $cust_bill_pkg->credited('', '', setuprecur => 'recur') || 0;
 738     }
 739     my $setup_ratio = $setup / ($setup + $recur);
 740
 741     # Calculate the fraction of tax to credit: it's the fraction of this charge
 742     # (either setup or recur) that's being credited.
 743     my $charged = ($setuprecur eq 'setup') ? $setup : $recur;
 744     next if $charged == 0; # shouldn't happen, but still...
 745
 746     if ($charged < $amount) {
 747       $error = "invoice #$invnum: tried to credit $amount, but only $charged was charged";
 748       last;
 749     }
 750     my $credit_ratio = $amount / $charged;
 751
 752     # gather taxes that apply to the selected item
 753     foreach my $table (
 754       qw(cust_bill_pkg_tax_location cust_bill_pkg_tax_rate_location)
 755     ) {
 756       foreach my $tax_link (
 757         qsearch($table, { taxable_billpkgnum => $billpkgnum })
 758       ) {
 759         my $tax_amount = $tax_link->amount;
 760         # deduct existing credits applied to the tax, for the same reason as
 761         # above
 762         foreach ($tax_link->cust_credit_bill_pkg) {
 763           $tax_amount -= $_->amount;
 764         }
 765         # split tax amount based on setuprecur
 766         # (this method ensures that, if you credit both setup and recur tax,
 767         # it always equals the entire tax despite any rounding)
 768         my $setup_tax = sprintf('%.2f', $tax_amount * $setup_ratio);
 769         if ( $setuprecur eq 'setup' ) {
 770           $tax_amount = $setup_tax;
 771         } else {
 772           $tax_amount = $tax_amount - $setup_tax;
 773         }
 774         my $tax_credit = sprintf('%.2f', $tax_amount * $credit_ratio);
 775         my $pkey = $tax_link->get($tax_link->primary_key);
 776         push @taxlines, {
 777           table   => $table,
 778           num     => $pkey,
 779           credit  => $tax_credit,
 780         };
 781         $taxtotal += $tax_credit;
 782
 783       } #foreach cust_bill_pkg_tax_(rate_)?location
 784     }
 785   } # foreach $billpkgnum
 786
 787   return (
 788     subtotal => sprintf('%.2f', $subtotal),
 789     taxtotal => sprintf('%.2f', $taxtotal),
 790     taxlines => \@taxlines,
 791   );
 792 }
 793
 794 =item credit_lineitems
 795
 796 Example:
 797
 798   my $error = FS::cust_credit->credit_lineitems(
 799
 800     #the lineitems to credit
 801     'billpkgnums'       => \@billpkgnums,
 802     'setuprecurs'       => \@setuprecurs,
 803     'amounts'           => \@amounts,
 804     'apply'             => 1, #0 leaves the credit unapplied
 805
 806     #the credit
 807     map { $_ => scalar($cgi->param($_)) }
 808       #fields('cust_credit')
 809       qw( custnum _date amount reasonnum addlinfo ), #pkgnum eventnum
 810
 811   );
 812
 813 =cut
 814
 815 #maybe i should just be an insert with extra args instead of a class method
 816 sub credit_lineitems {
 817   my( $class, %arg ) = @_;
 818   my $curuser = $FS::CurrentUser::CurrentUser;
 819
 820   #some false laziness w/misc/xmlhttp-cust_bill_pkg-calculate_taxes.html
 821
 822   my $cust_main = qsearchs({
 823     'table'     => 'cust_main',
 824     'hashref'   => { 'custnum' => $arg{custnum} },
 825     'extra_sql' => ' AND '. $curuser->agentnums_sql,
 826   }) or return 'unknown customer';
 827
 828
 829   local $SIG{HUP} = 'IGNORE';
 830   local $SIG{INT} = 'IGNORE';
 831   local $SIG{QUIT} = 'IGNORE';
 832   local $SIG{TERM} = 'IGNORE';
 833   local $SIG{TSTP} = 'IGNORE';
 834   local $SIG{PIPE} = 'IGNORE';
 835
 836   my $oldAutoCommit = $FS::UID::AutoCommit;
 837   local $FS::UID::AutoCommit = 0;
 838   my $dbh = dbh;
 839
 840   #my @cust_bill_pkg = qsearch({
 841   #  'select'    => 'cust_bill_pkg.*',
 842   #  'table'     => 'cust_bill_pkg',
 843   #  'addl_from' => ' LEFT JOIN cust_bill USING (invnum)  '.
 844   #                 ' LEFT JOIN cust_main USING (custnum) ',
 845   #  'extra_sql' => ' WHERE custnum = $custnum AND billpkgnum IN ('.
 846   #                     join( ',', @{$arg{billpkgnums}} ). ')',
 847   #  'order_by'  => 'ORDER BY invnum ASC, billpkgnum ASC',
 848   #});
 849
 850   my $error = '';
 851
 852   my $cust_credit = new FS::cust_credit ( {
 853     map { $_ => $arg{$_} }
 854       #fields('cust_credit')
 855       qw( custnum _date amount reasonnum addlinfo ), #pkgnum eventnum
 856   } );
 857   $error = $cust_credit->insert;
 858   if ( $error ) {
 859     $dbh->rollback if $oldAutoCommit;
 860     return "Error inserting credit: $error";
 861   }
 862
 863   unless ( $arg{'apply'} ) {
 864     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 865     return '';
 866   }
 867
 868   #my $subtotal = 0;
 869   # keys in all of these are invoice numbers
 870   my %cust_credit_bill = ();
 871   my %cust_bill_pkg = ();
 872   my %cust_credit_bill_pkg = ();
 873   my %unapplied_payments = (); #invoice numbers, and then billpaynums
 874
 875   # determine the tax adjustments
 876   my %tax_adjust = $class->calculate_tax_adjustment(%arg);
 877
 878   foreach my $billpkgnum ( @{$arg{billpkgnums}} ) {
 879     my $setuprecur = shift @{$arg{setuprecurs}};
 880     my $amount = shift @{$arg{amounts}};
 881
 882     my $cust_bill_pkg = qsearchs({
 883       'table'     => 'cust_bill_pkg',
 884       'hashref'   => { 'billpkgnum' => $billpkgnum },
 885       'addl_from' => 'LEFT JOIN cust_bill USING (invnum)',
 886       'extra_sql' => 'AND custnum = '. $cust_main->custnum,
 887     }) or die "unknown billpkgnum $billpkgnum";
 888
 889     my $invnum = $cust_bill_pkg->invnum;
 890
 891     push @{$cust_bill_pkg{$invnum}}, $cust_bill_pkg;
 892
 893     $cust_credit_bill{$invnum} += $amount;
 894     push @{ $cust_credit_bill_pkg{$invnum} },
 895       new FS::cust_credit_bill_pkg {
 896         'billpkgnum' => $billpkgnum,
 897         'amount'     => sprintf('%.2f',$amount),
 898         'setuprecur' => $setuprecur,
 899         'sdate'      => $cust_bill_pkg->sdate,
 900         'edate'      => $cust_bill_pkg->edate,
 901       };
 902     # unapply payments (but not other credits) from this line item
 903     foreach my $cust_bill_pay_pkg (
 904       $cust_bill_pkg->cust_bill_pay_pkg($setuprecur)
 905     ) {
 906       $error = $cust_bill_pay_pkg->delete;
 907       if ( $error ) {
 908         $dbh->rollback if $oldAutoCommit;
 909         return "Error unapplying payment: $error";
 910       }
 911       $unapplied_payments{$invnum}{$cust_bill_pay_pkg->billpaynum}
 912         += $cust_bill_pay_pkg->amount;
 913     }
 914   }
 915
 916   # do the same for taxes
 917   foreach my $tax_credit ( @{ $tax_adjust{taxlines} } ) {
 918     my $table = $tax_credit->{table};
 919     my $tax_link = "FS::$table"->by_key( $tax_credit->{num} )
 920       or die "tried to credit $table #$tax_credit->{num} but it doesn't exist";
 921
 922     my $billpkgnum = $tax_link->billpkgnum;
 923     my $cust_bill_pkg = qsearchs({
 924       'table'     => 'cust_bill_pkg',
 925       'hashref'   => { 'billpkgnum' => $billpkgnum },
 926       'addl_from' => 'LEFT JOIN cust_bill USING (invnum)',
 927       'extra_sql' => 'AND custnum = '. $cust_main->custnum,
 928     }) or die "unknown billpkgnum $billpkgnum";
 929
 930     my $invnum = $cust_bill_pkg->invnum;
 931     push @{$cust_bill_pkg{$invnum}}, $cust_bill_pkg;
 932
 933     my $amount = $tax_credit->{credit};
 934     $cust_credit_bill{$invnum} += $amount;
 935
 936     # create a credit application record to the tax line item, earmarked
 937     # to the specific cust_bill_pkg_Xlocation
 938     push @{ $cust_credit_bill_pkg{$invnum} },
 939       new FS::cust_credit_bill_pkg {
 940         'billpkgnum' => $billpkgnum,
 941         'amount'     => sprintf('%.2f', $amount),
 942         'setuprecur' => 'setup',
 943         $tax_link->primary_key, $tax_credit->{num}
 944       };
 945     # unapply any payments from the tax
 946     foreach my $cust_bill_pay_pkg (
 947       $cust_bill_pkg->cust_bill_pay_pkg('setup')
 948     ) {
 949       $error = $cust_bill_pay_pkg->delete;
 950       if ( $error ) {
 951         $dbh->rollback if $oldAutoCommit;
 952         return "Error unapplying payment: $error";
 953       }
 954       $unapplied_payments{$invnum}{$cust_bill_pay_pkg->billpaynum}
 955         += $cust_bill_pay_pkg->amount;
 956     }
 957   }
 958
 959   ###
 960   # now loop through %cust_credit_bill and insert those
 961   ###
 962
 963   # (hack to prevent cust_credit_bill_pkg insertion)
 964   local($FS::cust_bill_ApplicationCommon::skip_apply_to_lineitems_hack) = 1;
 965
 966   foreach my $invnum ( sort { $a <=> $b } keys %cust_credit_bill ) {
 967
 968     # if we unapplied any payments from line items, also unapply that
 969     # amount from the invoice
 970     foreach my $billpaynum (keys %{$unapplied_payments{$invnum}}) {
 971       my $cust_bill_pay = FS::cust_bill_pay->by_key($billpaynum)
 972         or die "broken payment application $billpaynum";
 973       my @subapps = $cust_bill_pay->lineitem_applications;
 974       $error = $cust_bill_pay->delete; # can't replace
 975
 976       my $new_cust_bill_pay = FS::cust_bill_pay->new({
 977           $cust_bill_pay->hash,
 978           billpaynum => '',
 979           amount => sprintf('%.2f',
 980               $cust_bill_pay->amount
 981               - $unapplied_payments{$invnum}{$billpaynum}),
 982       });
 983
 984       if ( $new_cust_bill_pay->amount > 0 ) {
 985         $error ||= $new_cust_bill_pay->insert;
 986         # Also reapply it to everything it was applied to before.
 987         # Note that we've already deleted cust_bill_pay_pkg records for the
 988         # items we're crediting, so they aren't on this list.
 989         foreach my $cust_bill_pay_pkg (@subapps) {
 990           $cust_bill_pay_pkg->billpaypkgnum('');
 991           $cust_bill_pay_pkg->billpaynum($new_cust_bill_pay->billpaynum);
 992           $error ||= $cust_bill_pay_pkg->insert;
 993         }
 994       }
 995       if ( $error ) {
 996         $dbh->rollback if $oldAutoCommit;
 997         return "Error unapplying payment: $error";
 998       }
 999     }
1000     #insert cust_credit_bill
1001
1002     my $cust_credit_bill = new FS::cust_credit_bill {
1003       'crednum' => $cust_credit->crednum,
1004       'invnum'  => $invnum,
1005       'amount'  => sprintf('%.2f', $cust_credit_bill{$invnum}),
1006     };
1007     $error = $cust_credit_bill->insert;
1008     if ( $error ) {
1009       $dbh->rollback if $oldAutoCommit;
1010       return "Error applying credit of $cust_credit_bill{$invnum} ".
1011              " to invoice $invnum: $error";
1012     }
1013
1014     #and then insert cust_credit_bill_pkg for each cust_bill_pkg
1015     foreach my $cust_credit_bill_pkg ( @{$cust_credit_bill_pkg{$invnum}} ) {
1016       $cust_credit_bill_pkg->creditbillnum( $cust_credit_bill->creditbillnum );
1017       $error = $cust_credit_bill_pkg->insert;
1018       if ( $error ) {
1019         $dbh->rollback if $oldAutoCommit;
1020         return "Error applying credit to line item: $error";
1021       }
1022     }
1023
1024   }
1025
1026   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1027   '';
1028
1029 }
1030
1031 ### refund_to_unapply/unapply_refund false laziness with FS::cust_pay
1032
1033 =item refund_to_unapply
1034
1035 Returns L<FS::cust_credit_refund> objects that will be deleted by L</unapply_refund>
1036 (all currently applied refunds that aren't closed.)
1037 Returns empty list if credit itself is closed.
1038
1039 =cut
1040
1041 sub refund_to_unapply {
1042   my $self = shift;
1043   return () if $self->closed;
1044   qsearch({
1045     'table'   => 'cust_credit_refund',
1046     'hashref' => { 'crednum' => $self->crednum },
1047     'addl_from' => 'LEFT JOIN cust_refund USING (refundnum)',
1048     'extra_sql' => "AND cust_refund.closed IS NULL AND cust_refund.source_paynum IS NULL",
1049   });
1050 }
1051
1052 =item unapply_refund
1053
1054 Deletes all objects returned by L</refund_to_unapply>.
1055
1056 =cut
1057
1058 sub unapply_refund {
1059   my $self = shift;
1060
1061   local $SIG{HUP} = 'IGNORE';
1062   local $SIG{INT} = 'IGNORE';
1063   local $SIG{QUIT} = 'IGNORE';
1064   local $SIG{TERM} = 'IGNORE';
1065   local $SIG{TSTP} = 'IGNORE';
1066   local $SIG{PIPE} = 'IGNORE';
1067
1068   my $oldAutoCommit = $FS::UID::AutoCommit;
1069   local $FS::UID::AutoCommit = 0;
1070
1071   foreach my $cust_credit_refund ($self->refund_to_unapply) {
1072     my $error = $cust_credit_refund->delete;
1073     if ($error) {
1074       dbh->rollback if $oldAutoCommit;
1075       return $error;
1076     }
1077   }
1078
1079   dbh->commit or die dbh->errstr if $oldAutoCommit;
1080   return '';
1081 }
1082
1083 =back
1084
1085 =head1 SUBROUTINES
1086
1087 =over 4
1088
1089 =item process_batch_import
1090
1091 =cut
1092
1093 use List::Util qw( min );
1094 use FS::cust_bill;
1095 use FS::cust_credit_bill;
1096 sub process_batch_import {
1097   my $job = shift;
1098
1099   my $opt = { 'table'   => 'cust_credit',
1100               'params'  => [ '_date', 'credbatch' ],
1101               'formats' => { 'simple' =>
1102                                [ 'custnum', 'amount', 'reasonnum', 'invnum' ],
1103                            },
1104               'default_csv' => 1,
1105               'postinsert_callback' => sub {
1106                 my $cust_credit = shift; #my ($cust_credit, $param ) = @_;
1107
1108                 if ( $cust_credit->invnum ) {
1109
1110                   my $cust_bill = qsearchs('cust_bill', { invnum=>$cust_credit->invnum } );
1111                   my $amount = min( $cust_credit->credited, $cust_bill->owed );
1112
1113                   my $cust_credit_bill = new FS::cust_credit_bill ( {
1114                     'crednum' => $cust_credit->crednum,
1115                     'invnum'  => $cust_bill->invnum,
1116                     'amount'  => $amount,
1117                   } );
1118                   my $error = $cust_credit_bill->insert;
1119                   return '' unless $error;
1120
1121                 }
1122
1123                 #apply_payments_and_credits ?
1124                 $cust_credit->cust_main->apply_credits;
1125
1126                 return '';
1127
1128               },
1129             };
1130
1131   FS::Record::process_batch_import( $job, $opt, @_ );
1132
1133 }
1134
1135 =back
1136
1137 =head1 BUGS
1138
1139 The delete method.  The replace method.
1140
1141 B<credited> and B<credited_sql> are now called B<unapplied> and
1142 B<unapplied_sql>.  The old method names should start to give warnings.
1143
1144 =head1 SEE ALSO
1145
1146 L<FS::Record>, L<FS::cust_credit_refund>, L<FS::cust_refund>,
1147 L<FS::cust_credit_bill> L<FS::cust_bill>, schema.html from the base
1148 documentation.
1149
1150 =cut
1151
1152 1;
1153