FS/FS/cust_credit.pm

   1 package FS::cust_credit;
   2
   3 use strict;
   4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::Record );
   5 use vars qw( $conf $unsuspendauto $me $DEBUG );
   6 use Date::Format;
   7 use FS::UID qw( dbh getotaker );
   8 use FS::Misc qw(send_email);
   9 use FS::Record qw( qsearch qsearchs dbdef );
  10 use FS::cust_main;
  11 use FS::cust_pkg;
  12 use FS::cust_refund;
  13 use FS::cust_credit_bill;
  14 use FS::part_pkg;
  15 use FS::reason_type;
  16 use FS::reason;
  17
  18 $me = '[ FS::cust_credit ]';
  19 $DEBUG = 0;
  20
  21 #ask FS::UID to run this stuff for us later
  22 $FS::UID::callback{'FS::cust_credit'} = sub {
  23
  24   $conf = new FS::Conf;
  25   $unsuspendauto = $conf->exists('unsuspendauto');
  26
  27 };
  28
  29 our %reasontype_map = ( 'referral_credit_type' => 'Referral Credit',
  30                         'cancel_credit_type'   => 'Cancellation Credit',
  31                         'signup_credit_type'   => 'Self-Service Credit',
  32                       );
  33
  34 =head1 NAME
  35
  36 FS::cust_credit - Object methods for cust_credit records
  37
  38 =head1 SYNOPSIS
  39
  40   use FS::cust_credit;
  41
  42   $record = new FS::cust_credit \%hash;
  43   $record = new FS::cust_credit { 'column' => 'value' };
  44
  45   $error = $record->insert;
  46
  47   $error = $new_record->replace($old_record);
  48
  49   $error = $record->delete;
  50
  51   $error = $record->check;
  52
  53 =head1 DESCRIPTION
  54
  55 An FS::cust_credit object represents a credit; the equivalent of a negative
  56 B<cust_bill> record (see L<FS::cust_bill>).  FS::cust_credit inherits from
  57 FS::Record.  The following fields are currently supported:
  58
  59 =over 4
  60
  61 =item crednum
  62
  63 Primary key (assigned automatically for new credits)
  64
  65 =item custnum
  66
  67 Customer (see L<FS::cust_main>)
  68
  69 =item amount
  70
  71 Amount of the credit
  72
  73 =item _date
  74
  75 Specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
  76 L<Time::Local> and L<Date::Parse> for conversion functions.
  77
  78 =item usernum
  79
  80 Order taker (see L<FS::access_user>)
  81
  82 =item reason
  83
  84 Text ( deprecated )
  85
  86 =item reasonnum
  87
  88 Reason (see L<FS::reason>)
  89
  90 =item addlinfo
  91
  92 Text
  93
  94 =item closed
  95
  96 Books closed flag, empty or `Y'
  97
  98 =item pkgnum
  99
 100 Desired pkgnum when using experimental package balances.
 101
 102 =back
 103
 104 =head1 METHODS
 105
 106 =over 4
 107
 108 =item new HASHREF
 109
 110 Creates a new credit.  To add the credit to the database, see L<"insert">.
 111
 112 =cut
 113
 114 sub table { 'cust_credit'; }
 115 sub cust_linked { $_[0]->cust_main_custnum; }
 116 sub cust_unlinked_msg {
 117   my $self = shift;
 118   "WARNING: can't find cust_main.custnum ". $self->custnum.
 119   ' (cust_credit.crednum '. $self->crednum. ')';
 120 }
 121
 122 =item insert
 123
 124 Adds this credit to the database ("Posts" the credit).  If there is an error,
 125 returns the error, otherwise returns false.
 126
 127 =cut
 128
 129 sub insert {
 130   my ($self, %options) = @_;
 131
 132   local $SIG{HUP} = 'IGNORE';
 133   local $SIG{INT} = 'IGNORE';
 134   local $SIG{QUIT} = 'IGNORE';
 135   local $SIG{TERM} = 'IGNORE';
 136   local $SIG{TSTP} = 'IGNORE';
 137   local $SIG{PIPE} = 'IGNORE';
 138
 139   my $oldAutoCommit = $FS::UID::AutoCommit;
 140   local $FS::UID::AutoCommit = 0;
 141   my $dbh = dbh;
 142
 143   my $cust_main = qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 144   my $old_balance = $cust_main->balance;
 145
 146   unless ($self->reasonnum) {
 147     my $result = $self->reason( $self->getfield('reason'),
 148                                 exists($options{ 'reason_type' })
 149                                   ? ('reason_type' => $options{ 'reason_type' })
 150                                   : (),
 151                               );
 152     unless($result) {
 153       $dbh->rollback if $oldAutoCommit;
 154       return "failed to set reason for $me"; #: ". $dbh->errstr;
 155     }
 156   }
 157
 158   $self->setfield('reason', '');
 159
 160   my $error = $self->SUPER::insert;
 161   if ( $error ) {
 162     $dbh->rollback if $oldAutoCommit;
 163     return "error inserting $self: $error";
 164   }
 165
 166   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 167
 168   #false laziness w/ cust_credit::insert
 169   if ( $unsuspendauto && $old_balance && $cust_main->balance <= 0 ) {
 170     my @errors = $cust_main->unsuspend;
 171     #return
 172     # side-fx with nested transactions?  upstack rolls back?
 173     warn "WARNING:Errors unsuspending customer ". $cust_main->custnum. ": ".
 174          join(' / ', @errors)
 175       if @errors;
 176   }
 177   #eslaf
 178
 179   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 180
 181   '';
 182
 183 }
 184
 185 =item delete
 186
 187 Unless the closed flag is set, deletes this credit and all associated
 188 applications (see L<FS::cust_credit_bill>).  In most cases, you want to use
 189 the void method instead to leave a record of the deleted credit.
 190
 191 =cut
 192
 193 # very similar to FS::cust_pay::delete
 194 sub delete {
 195   my $self = shift;
 196   return "Can't delete closed credit" if $self->closed =~ /^Y/i;
 197
 198   local $SIG{HUP} = 'IGNORE';
 199   local $SIG{INT} = 'IGNORE';
 200   local $SIG{QUIT} = 'IGNORE';
 201   local $SIG{TERM} = 'IGNORE';
 202   local $SIG{TSTP} = 'IGNORE';
 203   local $SIG{PIPE} = 'IGNORE';
 204
 205   my $oldAutoCommit = $FS::UID::AutoCommit;
 206   local $FS::UID::AutoCommit = 0;
 207   my $dbh = dbh;
 208
 209   foreach my $cust_credit_bill ( $self->cust_credit_bill ) {
 210     my $error = $cust_credit_bill->delete;
 211     if ( $error ) {
 212       $dbh->rollback if $oldAutoCommit;
 213       return $error;
 214     }
 215   }
 216
 217   foreach my $cust_credit_refund ( $self->cust_credit_refund ) {
 218     my $error = $cust_credit_refund->delete;
 219     if ( $error ) {
 220       $dbh->rollback if $oldAutoCommit;
 221       return $error;
 222     }
 223   }
 224
 225   my $error = $self->SUPER::delete(@_);
 226   if ( $error ) {
 227     $dbh->rollback if $oldAutoCommit;
 228     return $error;
 229   }
 230
 231   if ( $conf->config('deletecredits') ne '' ) {
 232
 233     my $cust_main = $self->cust_main;
 234
 235     my $error = send_email(
 236       'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 237                                  #invoice_from??? well as good as any
 238       'to'      => $conf->config('deletecredits'),
 239       'subject' => 'FREESIDE NOTIFICATION: Credit deleted',
 240       'body'    => [
 241         "This is an automatic message from your Freeside installation\n",
 242         "informing you that the following credit has been deleted:\n",
 243         "\n",
 244         'crednum: '. $self->crednum. "\n",
 245         'custnum: '. $self->custnum.
 246           " (". $cust_main->last. ", ". $cust_main->first. ")\n",
 247         'amount: $'. sprintf("%.2f", $self->amount). "\n",
 248         'date: '. time2str("%a %b %e %T %Y", $self->_date). "\n",
 249         'reason: '. $self->reason. "\n",
 250       ],
 251     );
 252
 253     if ( $error ) {
 254       $dbh->rollback if $oldAutoCommit;
 255       return "can't send credit deletion notification: $error";
 256     }
 257
 258   }
 259
 260   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 261
 262   '';
 263
 264 }
 265
 266 =item replace OLD_RECORD
 267
 268 You can, but probably shouldn't modify credits...
 269
 270 =cut
 271
 272 sub replace {
 273   #return "Can't modify credit!"
 274   my $self = shift;
 275   return "Can't modify closed credit" if $self->closed =~ /^Y/i;
 276   $self->SUPER::replace(@_);
 277 }
 278
 279 =item check
 280
 281 Checks all fields to make sure this is a valid credit.  If there is an error,
 282 returns the error, otherwise returns false.  Called by the insert and replace
 283 methods.
 284
 285 =cut
 286
 287 sub check {
 288   my $self = shift;
 289
 290   $self->otaker(getotaker) unless ($self->otaker);
 291
 292   my $error =
 293     $self->ut_numbern('crednum')
 294     || $self->ut_number('custnum')
 295     || $self->ut_numbern('_date')
 296     || $self->ut_money('amount')
 297     || $self->ut_alphan('otaker')
 298     || $self->ut_textn('reason')
 299     || $self->ut_foreign_key('reasonnum', 'reason', 'reasonnum')
 300     || $self->ut_textn('addlinfo')
 301     || $self->ut_enum('closed', [ '', 'Y' ])
 302     || $self->ut_foreign_keyn('pkgnum', 'cust_pkg', 'pkgnum')
 303   ;
 304   return $error if $error;
 305
 306   return "amount must be > 0 " if $self->amount <= 0;
 307
 308   return "amount must be greater or equal to amount applied"
 309     if $self->unapplied < 0;
 310
 311   return "Unknown customer"
 312     unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 313
 314   $self->_date(time) unless $self->_date;
 315
 316   $self->SUPER::check;
 317 }
 318
 319 =item cust_credit_refund
 320
 321 Returns all refund applications (see L<FS::cust_credit_refund>) for this credit.
 322
 323 =cut
 324
 325 sub cust_credit_refund {
 326   my $self = shift;
 327   map { $_ } #return $self->num_cust_credit_refund unless wantarray;
 328   sort { $a->_date <=> $b->_date }
 329     qsearch( 'cust_credit_refund', { 'crednum' => $self->crednum } )
 330   ;
 331 }
 332
 333 =item cust_credit_bill
 334
 335 Returns all application to invoices (see L<FS::cust_credit_bill>) for this
 336 credit.
 337
 338 =cut
 339
 340 sub cust_credit_bill {
 341   my $self = shift;
 342   map { $_ } #return $self->num_cust_credit_bill unless wantarray;
 343   sort { $a->_date <=> $b->_date }
 344     qsearch( 'cust_credit_bill', { 'crednum' => $self->crednum } )
 345   ;
 346 }
 347
 348 =item unapplied
 349
 350 Returns the amount of this credit that is still unapplied/outstanding;
 351 amount minus all refund applications (see L<FS::cust_credit_refund>) and
 352 applications to invoices (see L<FS::cust_credit_bill>).
 353
 354 =cut
 355
 356 sub unapplied {
 357   my $self = shift;
 358   my $amount = $self->amount;
 359   $amount -= $_->amount foreach ( $self->cust_credit_refund );
 360   $amount -= $_->amount foreach ( $self->cust_credit_bill );
 361   sprintf( "%.2f", $amount );
 362 }
 363
 364 =item credited
 365
 366 Deprecated name for the unapplied method.
 367
 368 =cut
 369
 370 sub credited {
 371   my $self = shift;
 372   #carp "cust_credit->credited deprecated; use ->unapplied";
 373   $self->unapplied(@_);
 374 }
 375
 376 =item cust_main
 377
 378 Returns the customer (see L<FS::cust_main>) for this credit.
 379
 380 =cut
 381
 382 sub cust_main {
 383   my $self = shift;
 384   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 385 }
 386
 387
 388 =item reason
 389
 390 Returns the text of the associated reason (see L<FS::reason>) for this credit.
 391
 392 =cut
 393
 394 sub reason {
 395   my ($self, $value, %options) = @_;
 396   my $dbh = dbh;
 397   my $reason;
 398   my $typenum = $options{'reason_type'};
 399
 400   my $oldAutoCommit = $FS::UID::AutoCommit;  # this should already be in
 401   local $FS::UID::AutoCommit = 0;            # a transaction if it matters
 402
 403   if ( defined( $value ) ) {
 404     my $hashref = { 'reason' => $value };
 405     $hashref->{'reason_type'} = $typenum if $typenum;
 406     my $addl_from = "LEFT JOIN reason_type ON ( reason_type = typenum ) ";
 407     my $extra_sql = " AND reason_type.class='R'";
 408
 409     $reason = qsearchs( { 'table'     => 'reason',
 410                           'hashref'   => $hashref,
 411                           'addl_from' => $addl_from,
 412                           'extra_sql' => $extra_sql,
 413                        } );
 414
 415     if (!$reason && $typenum) {
 416       $reason = new FS::reason( { 'reason_type' => $typenum,
 417                                   'reason' => $value,
 418                                   'disabled' => 'Y',
 419                               } );
 420       my $error = $reason->insert;
 421       if ( $error ) {
 422         warn "error inserting reason: $error\n";
 423         $reason = undef;
 424       }
 425     }
 426
 427     $self->reasonnum($reason ? $reason->reasonnum : '') ;
 428     warn "$me reason used in set mode with non-existant reason -- clearing"
 429       unless $reason;
 430   }
 431   $reason = qsearchs( 'reason', { 'reasonnum' => $self->reasonnum } );
 432
 433   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 434
 435   ( $reason ? $reason->reason : '' ).
 436   ( $self->addlinfo ? ' '.$self->addlinfo : '' );
 437 }
 438
 439 # _upgrade_data
 440 #
 441 # Used by FS::Upgrade to migrate to a new database.
 442
 443 sub _upgrade_data {  # class method
 444   my ($class, %opts) = @_;
 445
 446   warn "$me upgrading $class\n" if $DEBUG;
 447
 448   if (defined dbdef->table($class->table)->column('reason')) {
 449
 450     warn "$me Checking for unmigrated reasons\n" if $DEBUG;
 451
 452     my @cust_credits = qsearch({ 'table'     => $class->table,
 453                                  'hashref'   => {},
 454                                  'extra_sql' => 'WHERE reason IS NOT NULL',
 455                               });
 456
 457     if (scalar(grep { $_->getfield('reason') =~ /\S/ } @cust_credits)) {
 458       warn "$me Found unmigrated reasons\n" if $DEBUG;
 459       my $hashref = { 'class' => 'R', 'type' => 'Legacy' };
 460       my $reason_type = qsearchs( 'reason_type', $hashref );
 461       unless ($reason_type) {
 462         $reason_type  = new FS::reason_type( $hashref );
 463         my $error   = $reason_type->insert();
 464         die "$class had error inserting FS::reason_type into database: $error\n"
 465           if $error;
 466       }
 467
 468       $hashref = { 'reason_type' => $reason_type->typenum,
 469                    'reason' => '(none)'
 470                  };
 471       my $noreason = qsearchs( 'reason', $hashref );
 472       unless ($noreason) {
 473         $hashref->{'disabled'} = 'Y';
 474         $noreason = new FS::reason( $hashref );
 475         my $error  = $noreason->insert();
 476         die "can't insert legacy reason '(none)' into database: $error\n"
 477           if $error;
 478       }
 479
 480       foreach my $cust_credit ( @cust_credits ) {
 481         my $reason = $cust_credit->getfield('reason');
 482         warn "Contemplating reason $reason\n" if $DEBUG > 1;
 483         if ($reason =~ /\S/) {
 484           $cust_credit->reason($reason, 'reason_type' => $reason_type->typenum)
 485             or die "can't insert legacy reason $reason into database\n";
 486         }else{
 487           $cust_credit->reasonnum($noreason->reasonnum);
 488         }
 489
 490         $cust_credit->setfield('reason', '');
 491         my $error = $cust_credit->replace;
 492
 493         warn "*** WARNING: error replacing reason in $class ".
 494              $cust_credit->crednum. ": $error ***\n"
 495           if $error;
 496       }
 497     }
 498
 499     warn "$me Ensuring existance of auto reasons\n" if $DEBUG;
 500
 501     foreach ( keys %reasontype_map ) {
 502       unless ($conf->config($_)) {       # hmmmm
 503 #       warn "$me Found $_ reason type lacking\n" if $DEBUG;
 504 #       my $hashref = { 'class' => 'R', 'type' => $reasontype_map{$_} };
 505         my $hashref = { 'class' => 'R', 'type' => 'Legacy' };
 506         my $reason_type = qsearchs( 'reason_type', $hashref );
 507         unless ($reason_type) {
 508           $reason_type  = new FS::reason_type( $hashref );
 509           my $error   = $reason_type->insert();
 510           die "$class had error inserting FS::reason_type into database: $error\n"
 511             if $error;
 512         }
 513         $conf->set($_, $reason_type->typenum);
 514       }
 515     }
 516
 517     warn "$me Ensuring commission packages have a reason type\n" if $DEBUG;
 518
 519     my $hashref = { 'class' => 'R', 'type' => 'Legacy' };
 520     my $reason_type = qsearchs( 'reason_type', $hashref );
 521     unless ($reason_type) {
 522       $reason_type  = new FS::reason_type( $hashref );
 523       my $error   = $reason_type->insert();
 524       die "$class had error inserting FS::reason_type into database: $error\n"
 525         if $error;
 526     }
 527
 528     my @plans = qw( flat_comission flat_comission_cust flat_comission_pkg );
 529     foreach my $plan ( @plans ) {
 530       foreach my $pkg ( qsearch('part_pkg', { 'plan' => $plan } ) ) {
 531         unless ($pkg->option('reason_type', 1) ) {
 532           my $plandata = $pkg->plandata.
 533                         "reason_type=". $reason_type->typenum. "\n";
 534           $pkg->plandata($plandata);
 535           my $error =
 536             $pkg->replace( undef,
 537                            'pkg_svc' => { map { $_->svcpart => $_->quantity }
 538                                           $pkg->pkg_svc
 539                                         },
 540                            'primary_svc' => $pkg->svcpart,
 541                          );
 542             die "failed setting reason_type option: $error"
 543               if $error;
 544         }
 545       }
 546     }
 547   }
 548
 549   $class->_upgrade_otaker(%opts);
 550
 551 }
 552
 553 =back
 554
 555 =head1 CLASS METHODS
 556
 557 =over 4
 558
 559 =item unapplied_sql
 560
 561 Returns an SQL fragment to retreive the unapplied amount.
 562
 563 =cut
 564
 565 sub unapplied_sql {
 566   #my $class = shift;
 567
 568   "amount
 569         - COALESCE(
 570                     ( SELECT SUM(amount) FROM cust_credit_refund
 571                         WHERE cust_credit.crednum = cust_credit_refund.crednum )
 572                     ,0
 573                   )
 574         - COALESCE(
 575                     ( SELECT SUM(amount) FROM cust_credit_bill
 576                         WHERE cust_credit.crednum = cust_credit_bill.crednum )
 577                     ,0
 578                   )
 579   ";
 580
 581 }
 582
 583 =item credited_sql
 584
 585 Deprecated name for the unapplied_sql method.
 586
 587 =cut
 588
 589 sub credited_sql {
 590   #my $class = shift;
 591
 592   #carp "cust_credit->credited_sql deprecated; use ->unapplied_sql";
 593
 594   #$class->unapplied_sql(@_);
 595   unapplied_sql();
 596 }
 597
 598 =back
 599
 600 =head1 BUGS
 601
 602 The delete method.  The replace method.
 603
 604 B<credited> and B<credited_sql> are now called B<unapplied> and
 605 B<unapplied_sql>.  The old method names should start to give warnings.
 606
 607 =head1 SEE ALSO
 608
 609 L<FS::Record>, L<FS::cust_credit_refund>, L<FS::cust_refund>,
 610 L<FS::cust_credit_bill> L<FS::cust_bill>, schema.html from the base
 611 documentation.
 612
 613 =cut
 614
 615 1;
 616