FS/FS/discount_plan.pm

   1 package FS::discount_plan;
   2
   3 use strict;
   4 use vars qw( $DEBUG $me );
   5 use FS::Record qw( qsearch );
   6 use FS::cust_bill;
   7 use FS::cust_bill_pkg;
   8 use FS::discount;
   9 use List::Util qw( max );
  10
  11 =head1 NAME
  12
  13 FS::discount_plan - A term discount as applied to an invoice
  14
  15 =head1 DESCRIPTION
  16
  17 An FS::discount_plan object represents a term prepayment discount
  18 available for an invoice (L<FS::cust_bill>).  FS::discount_plan
  19 objects are non-persistent and do not inherit from FS::Record.
  20
  21 =head1 CLASS METHODS
  22
  23 =over 4
  24
  25 =item new OPTIONS
  26
  27 Calculate a discount plan.  OPTIONS must include:
  28
  29 cust_bill - the invoice to calculate discounts for
  30
  31 months - the number of months to be prepaid
  32
  33 If there are no line items on the invoice eligible for the discount
  34 C<new()> will return undef.
  35
  36 =cut
  37
  38 sub new {
  39   my $class = shift;
  40   my %opt = @_;
  41   %opt = %{ $_[0] } if ( ref $_[0] );
  42
  43   my $cust_bill = $opt{cust_bill}
  44     or die "$me new() requires 'cust_bill'\n";
  45   my $months = $opt{months}
  46     or die "$me new() requires 'months'\n";
  47
  48   my ($previous_balance) = $cust_bill->previous;
  49   my $self = {
  50     cust_bill     => $cust_bill,
  51     months        => $months,
  52     pkgnums       => [],
  53     base          => $previous_balance || 0, # sum of charges before discount
  54     discounted    => $previous_balance || 0, # sum of charges after discount
  55     list_pkgnums  => undef, # whether any packages are not discounted
  56   };
  57
  58   foreach my $cust_bill_pkg ( $cust_bill->cust_bill_pkg ) {
  59     my $cust_pkg = $cust_bill_pkg->cust_pkg or next;
  60     my $part_pkg = $cust_pkg->part_pkg or next;
  61     my $freq = $part_pkg->freq;
  62     my $setup = $cust_bill_pkg->setup || 0;
  63     my $recur = $cust_bill_pkg->recur || 0;
  64
  65     if ( $freq eq '1' ) { # monthly recurring package
  66       my $permonth = $part_pkg->base_recur_permonth($cust_pkg) || 0;
  67
  68       my ($discount) = grep { $_->months == $months }
  69       map { $_->discount } $part_pkg->part_pkg_discount;
  70
  71       $self->{base} += $setup + $recur + ($months - 1) * $permonth;
  72
  73       if ( $discount ) {
  74
  75         my $discountable;
  76         if ( $discount->setup ) {
  77           $discountable += $setup;
  78         }
  79         else {
  80           $self->{discounted} += $setup;
  81         }
  82
  83         if ( $discount->percent > 0 ) {
  84           $discountable += $months * $permonth;
  85           $discountable -= ($discountable * $discount->percent / 100);
  86           $discountable -= ($permonth - $recur); # correct for prorate
  87           $self->{discounted} += $discountable;
  88         }
  89         elsif ( $discount->amount > 0 ) {
  90           $discountable += $recur;
  91           $discountable -= $discount->amount * $recur/$permonth;
  92           $discountable += ($months - 1) * max($permonth - $discount->amount,0);
  93           $self->{discounted} += $discountable;
  94         }
  95         else {
  96           warn "discountnum ".$discount->discountnum.
  97             " has no amount or percentage, ignored\n";
  98           $self->{discounted} = $self->{base};
  99         }
 100
 101         push @{ $self->{pkgnums} }, $cust_pkg->pkgnum;
 102       }
 103       else { #no discount
 104         $self->{discounted} += $setup + $recur + ($months - 1) * $permonth;
 105         $self->{list_pkgnums} = 1;
 106       }
 107     } #if $freq eq '1'
 108     else { # all non-monthly packages: include current charges only
 109       $self->{discounted} += $setup + $recur;
 110       $self->{base} += $setup + $recur;
 111       $self->{list_pkgnums} = 1;
 112     }
 113   } #foreach $cust_bill_pkg
 114
 115   # we've considered all line items; exit if none of them are
 116   # discountable
 117   return undef if $self->{base} == $self->{discounted}
 118                or $self->{base} == 0;
 119
 120   return bless $self, $class;
 121
 122 }
 123
 124 =item all CUST_BILL
 125
 126 For an L<FS::cust_bill> object, return a hash of all available
 127 discount plans, with discount term (months) as the key.
 128
 129 =cut
 130
 131 sub all {
 132   my $class = shift;
 133   my $cust_bill = shift;
 134
 135   my %hash;
 136   foreach (qsearch('discount', { 'months' => { op => '>', value => 1 } })) {
 137     my $months = $_->months;
 138     my $discount_plan = $class->new(
 139       cust_bill => $cust_bill,
 140       months => $months
 141     );
 142     $hash{$_->months} = $discount_plan if defined($discount_plan);
 143   }
 144
 145   %hash;
 146 }
 147
 148 =back
 149
 150 =head1 METHODS
 151
 152 =over 4
 153
 154 =item discounted_total
 155
 156 Returns the total price for the term after applying discounts.  This is the
 157 price the customer would have to pay to receive the discount.  Note that
 158 this includes the monthly fees for all packages (including non-discountable
 159 ones) for each month in the term, but only includes fees for other packages
 160 as they appear on the current invoice.
 161
 162 =cut
 163
 164 sub discounted_total {
 165   my $self = shift;
 166   sprintf('%.2f', $self->{discounted});
 167 }
 168
 169 =item base_total
 170
 171 Returns the total price for the term before applying discounts.
 172
 173 =cut
 174
 175 sub base_total {
 176   my $self = shift;
 177   sprintf('%.2f', $self->{base});
 178 }
 179
 180 =item pkgnums
 181
 182 Returns a list of package numbers that are receiving discounts under this
 183 plan.
 184
 185 =cut
 186
 187 sub pkgnums {
 188   my $self = shift;
 189   @{ $self->{pkgnums} };
 190 }
 191
 192 =item list_pkgnums
 193
 194 Returns a true value if any packages listed on the invoice do not
 195 receive a discount, either because there isn't one at the specified
 196 term length or because they're not monthly recurring packages.
 197
 198 =cut
 199
 200 sub list_pkgnums {
 201   my $self = shift;
 202   $self->{list_pkgnums};
 203 }
 204
 205 # any others?  don't think so
 206
 207 1;