diff options
Diffstat (limited to 'FS/FS/cust_credit.pm')
-rw-r--r-- | FS/FS/cust_credit.pm | 195 |
1 files changed, 191 insertions, 4 deletions
diff --git a/FS/FS/cust_credit.pm b/FS/FS/cust_credit.pm index e07461d..4c94e15 100644 --- a/FS/FS/cust_credit.pm +++ b/FS/FS/cust_credit.pm @@ -1,17 +1,22 @@ package FS::cust_credit; use strict; -use vars qw( @ISA $conf $unsuspendauto ); +use vars qw( @ISA $conf $unsuspendauto $me $DEBUG ); use Date::Format; use FS::UID qw( dbh getotaker ); use FS::Misc qw(send_email); -use FS::Record qw( qsearch qsearchs ); +use FS::Record qw( qsearch qsearchs dbdef ); use FS::cust_main_Mixin; use FS::cust_main; use FS::cust_refund; use FS::cust_credit_bill; +use FS::part_pkg; +use FS::reason_type; +use FS::reason; @ISA = qw( FS::cust_main_Mixin FS::Record ); +$me = '[ FS::cust_credit ]'; +$DEBUG = 0; #ask FS::UID to run this stuff for us later $FS::UID::callback{'FS::cust_credit'} = sub { @@ -21,6 +26,11 @@ $FS::UID::callback{'FS::cust_credit'} = sub { }; +our %reasontype_map = ( 'referral_credit_type' => 'Referral Credit', + 'cancel_credit_type' => 'Cancellation Credit', + 'signup_credit_type' => 'Self-Service Credit', + ); + =head1 NAME FS::cust_credit - Object methods for cust_credit records @@ -59,7 +69,9 @@ L<Time::Local> and L<Date::Parse> for conversion functions. =item otaker - order taker (assigned automatically, see L<FS::UID>) -=item reason - text +=item reason - text ( deprecated ) + +=item reasonum - int reason (see L<FS::reason>) =item closed - books closed flag, empty or `Y' @@ -91,7 +103,7 @@ returns the error, otherwise returns false. =cut sub insert { - my $self = shift; + my ($self, %options) = @_; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -107,6 +119,20 @@ sub insert { my $cust_main = qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); my $old_balance = $cust_main->balance; + unless ($self->reasonnum) { + my $result = $self->reason( $self->getfield('reason'), + exists($options{ 'reason_type' }) + ? ('reason_type' => $options{ 'reason_type' }) + : (), + ); + unless($result) { + $dbh->rollback if $oldAutoCommit; + return "failed to set reason for $me: ". $dbh->errstr; + } + } + + $self->setfield('reason', ''); + my $error = $self->SUPER::insert; if ( $error ) { $dbh->rollback if $oldAutoCommit; @@ -242,6 +268,7 @@ sub check { || $self->ut_numbern('_date') || $self->ut_money('amount') || $self->ut_textn('reason') + || $self->ut_foreign_key('reasonnum', 'reason', 'reasonnum') || $self->ut_enum('closed', [ '', 'Y' ]) ; return $error if $error; @@ -331,6 +358,166 @@ sub cust_main { } +=item reason + +Returns the text of the associated reason (see L<FS::reason>) for this credit. + +=cut + +sub reason { + my ($self, $value, %options) = @_; + my $dbh = dbh; + my $reason; + my $typenum = $options{'reason_type'}; + + my $oldAutoCommit = $FS::UID::AutoCommit; # this should already be in + local $FS::UID::AutoCommit = 0; # a transaction if it matters + + if ( defined( $value ) ) { + my $hashref = { 'reason' => $value }; + $hashref->{'reason_type'} = $typenum if $typenum; + my $addl_from = "LEFT JOIN reason_type ON ( reason_type = typenum ) "; + my $extra_sql = " AND reason_type.class='R'"; + + $reason = qsearchs( { 'table' => 'reason', + 'hashref' => $hashref, + 'addl_from' => $addl_from, + 'extra_sql' => $extra_sql, + } ); + + if (!$reason && $typenum) { + $reason = new FS::reason( { 'reason_type' => $typenum, + 'reason' => $value, + } ); + $reason->insert and $reason = undef; + } + + $self->reasonnum($reason ? $reason->reasonnum : '') ; + warn "$me reason used in set mode with non-existant reason -- clearing" + unless $reason; + } + $reason = qsearchs( 'reason', { 'reasonnum' => $self->reasonnum } ); + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + $reason ? $reason->reason : ''; +} + +# _upgrade_data +# +# Used by FS::Upgrade to migrate to a new database. +# +# + +sub _upgrade_data { # class method + my ($self, %opts) = @_; + + warn "$me upgrading $self\n" if $DEBUG; + + if (defined dbdef->table($self->table)->column('reason')) { + + warn "$me Checking for unmigrated reasons\n" if $DEBUG; + + my @cust_credits = qsearch({ 'table' => $self->table, + 'hashref' => {}, + 'extrasql' => 'WHERE reason IS NOT NULL', + }); + + if (scalar(grep { $_->getfield('reason') =~ /\S/ } @cust_credits)) { + warn "$me Found unmigrated reasons\n" if $DEBUG; + my $hashref = { 'class' => 'R', 'type' => 'Legacy' }; + my $reason_type = qsearchs( 'reason_type', $hashref ); + unless ($reason_type) { + $reason_type = new FS::reason_type( $hashref ); + my $error = $reason_type->insert(); + die "$self had error inserting FS::reason_type into database: $error\n" + if $error; + } + + $hashref = { 'reason_type' => $reason_type->typenum, + 'reason' => '(none)' + }; + my $noreason = qsearchs( 'reason', $hashref ); + unless ($noreason) { + $noreason = new FS::reason( $hashref ); + my $error = $noreason->insert(); + die "can't insert legacy reason '(none)' into database: $error\n" + if $error; + } + + foreach my $cust_credit ( @cust_credits ) { + my $reason = $cust_credit->getfield('reason'); + warn "Contemplating reason $reason\n" if $DEBUG > 1; + if ($reason =~ /\S/) { + $cust_credit->reason($reason, 'reason_type' => $reason_type->typenum) + or die "can't insert legacy reason $reason into database\n"; + }else{ + $cust_credit->reasonnum($noreason->reasonnum); + } + + $cust_credit->setfield('reason', ''); + my $error = $cust_credit->replace; + + die "error inserting $self into database: $error\n" + if $error; + } + } + + warn "$me Ensuring existance of auto reasons\n" if $DEBUG; + + foreach ( keys %reasontype_map ) { + unless ($conf->config($_)) { # hmmmm +# warn "$me Found $_ reason type lacking\n" if $DEBUG; +# my $hashref = { 'class' => 'R', 'type' => $reasontype_map{$_} }; + my $hashref = { 'class' => 'R', 'type' => 'Legacy' }; + my $reason_type = qsearchs( 'reason_type', $hashref ); + unless ($reason_type) { + $reason_type = new FS::reason_type( $hashref ); + my $error = $reason_type->insert(); + die "$self had error inserting FS::reason_type into database: $error\n" + if $error; + } + # or clause for 1.7.x + $conf->set($_, $reason_type->typenum) or die "failed setting config"; + } + } + + warn "$me Ensuring commission packages have a reason type\n" if $DEBUG; + + my $hashref = { 'class' => 'R', 'type' => 'Legacy' }; + my $reason_type = qsearchs( 'reason_type', $hashref ); + unless ($reason_type) { + $reason_type = new FS::reason_type( $hashref ); + my $error = $reason_type->insert(); + die "$self had error inserting FS::reason_type into database: $error\n" + if $error; + } + + my @plans = qw( flat_comission flat_comission_cust flat_comission_pkg ); + foreach my $plan ( @plans ) { + foreach my $pkg ( qsearch('part_pkg', { 'plan' => $plan } ) ) { + unless ($pkg->option('reason_type', 1) ) { + my $plandata = $pkg->plandata. + "reason_type=". $reason_type->typenum. "\n"; + $pkg->plandata($plandata); + my $error = + $pkg->replace( undef, + 'pkg_svc' => { map { $_->svcpart => $_->quantity } + $pkg->pkg_svc + }, + 'primary_svc' => $pkg->svcpart, + ); + die "failed setting reason_type option: $error" + if $error; + } + } + } + } + + ''; + +} + =back =head1 CLASS METHODS |