summaryrefslogtreecommitdiff
path: root/FS
diff options
context:
space:
mode:
Diffstat (limited to 'FS')
-rw-r--r--FS/FS/Schema.pm3
-rw-r--r--FS/FS/access_right.pm1
-rw-r--r--FS/FS/cust_credit.pm124
-rw-r--r--FS/FS/cust_refund.pm91
-rw-r--r--FS/FS/reason.pm26
-rw-r--r--FS/FS/reason_Mixin.pm96
-rw-r--r--FS/FS/reason_type.pm2
7 files changed, 226 insertions, 117 deletions
diff --git a/FS/FS/Schema.pm b/FS/FS/Schema.pm
index e55a8f1b7..0793af457 100644
--- a/FS/FS/Schema.pm
+++ b/FS/FS/Schema.pm
@@ -2134,7 +2134,8 @@ sub tables_hashref {
'refund', @money_type, '', '',
'otaker', 'varchar', 'NULL', 32, '', '',
'usernum', 'int', 'NULL', '', '', '',
- 'reason', 'varchar', '', $char_d, '', '',
+ 'reason', 'varchar', 'NULL', $char_d, '', '',
+ 'reasonnum', 'int', 'NULL', '', '', '',
'payby', 'char', '', 4, '', '', # CARD/BILL/COMP, should
# be index into payby
# table eventually
diff --git a/FS/FS/access_right.pm b/FS/FS/access_right.pm
index 14a60981e..121bd4a40 100644
--- a/FS/FS/access_right.pm
+++ b/FS/FS/access_right.pm
@@ -252,6 +252,7 @@ sub _upgrade_data { # class method
'Unvoid credit' => 'Unvoid credit',
'Add on-the-fly void credit reason' => 'Add on-the-fly void credit reason',
'_ALL' => 'Employee preference telephony integration',
+ 'Add on-the-fly credit reason' => 'Add on-the-fly refund reason',
);
# foreach my $old_acl ( keys %onetime ) {
diff --git a/FS/FS/cust_credit.pm b/FS/FS/cust_credit.pm
index 4e0c4c8da..25bd482c6 100644
--- a/FS/FS/cust_credit.pm
+++ b/FS/FS/cust_credit.pm
@@ -1,7 +1,9 @@
package FS::cust_credit;
use strict;
-use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::Record );
+use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::reason_Mixin
+ FS::Record );
+
use vars qw( $conf $unsuspendauto $me $DEBUG
$otaker_upgrade_kludge $ignore_empty_reasonnum
);
@@ -155,16 +157,23 @@ 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) {
+ if (!$self->reasonnum) {
+ my $reason_text = $self->get('reason')
+ or return "reason text or existing reason required";
+ my $reason_type = $options{'reason_type'}
+ or return "reason type required";
+
+ local $@;
+ my $reason = FS::reason->new_or_existing(
+ reason => $reason_text,
+ type => $reason_type,
+ class => 'R',
+ );
+ if ($@) {
$dbh->rollback if $oldAutoCommit;
- return "failed to set reason for $me"; #: ". $dbh->errstr;
+ return "failed to set credit reason: $@";
}
+ $self->set('reasonnum', $reason->reasonnum);
}
$self->setfield('reason', '');
@@ -460,58 +469,12 @@ sub cust_main {
qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
}
-
=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,
- 'disabled' => 'Y',
- } );
- my $error = $reason->insert;
- if ( $error ) {
- warn "error inserting reason: $error\n";
- $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 : '' ).
- ( $self->addlinfo ? ' '.$self->addlinfo : '' );
-}
-
# _upgrade_data
#
# Used by FS::Upgrade to migrate to a new database.
@@ -521,56 +484,9 @@ sub _upgrade_data { # class method
warn "$me upgrading $class\n" if $DEBUG;
- if (defined dbdef->table($class->table)->column('reason')) {
-
- warn "$me Checking for unmigrated reasons\n" if $DEBUG;
-
- my @cust_credits = qsearch({ 'table' => $class->table,
- 'hashref' => {},
- 'extra_sql' => '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 "$class had error inserting FS::reason_type into database: $error\n"
- if $error;
- }
+ $class->_upgrade_reasonnum(%opts);
- $hashref = { 'reason_type' => $reason_type->typenum,
- 'reason' => '(none)'
- };
- my $noreason = qsearchs( 'reason', $hashref );
- unless ($noreason) {
- $hashref->{'disabled'} = 'Y';
- $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;
-
- warn "*** WARNING: error replacing reason in $class ".
- $cust_credit->crednum. ": $error ***\n"
- if $error;
- }
- }
+ if (defined dbdef->table($class->table)->column('reason')) {
warn "$me Ensuring existance of auto reasons\n" if $DEBUG;
diff --git a/FS/FS/cust_refund.pm b/FS/FS/cust_refund.pm
index 166e53783..15335a421 100644
--- a/FS/FS/cust_refund.pm
+++ b/FS/FS/cust_refund.pm
@@ -2,8 +2,8 @@ package FS::cust_refund;
use strict;
use base qw( FS::otaker_Mixin FS::payinfo_transaction_Mixin FS::cust_main_Mixin
- FS::Record );
-use vars qw( @encrypted_fields );
+ FS::reason_Mixin FS::Record );
+use vars qw( @encrypted_fields $me $DEBUG $ignore_empty_reasonnum );
use Business::CreditCard;
use FS::UID qw(getotaker);
use FS::Record qw( qsearch qsearchs dbh );
@@ -12,6 +12,13 @@ use FS::cust_credit;
use FS::cust_credit_refund;
use FS::cust_pay_refund;
use FS::cust_main;
+use FS::reason_type;
+use FS::reason;
+
+$me = '[ FS::cust_refund ]';
+$DEBUG = 0;
+
+$ignore_empty_reasonnum = 0;
@encrypted_fields = ('payinfo');
sub nohistory_fields { ('payinfo'); }
@@ -57,7 +64,11 @@ Amount of the refund
=item reason
-Reason for the refund
+Text stating the reason for the refund ( deprecated )
+
+=item reasonnum
+
+Reason (see L<FS::reason>)
=item _date
@@ -120,7 +131,7 @@ amount of the refund will be created. In both cases, custnum is optional.
=cut
sub insert {
- my $self = shift;
+ my ($self, %options) = @_;
local $SIG{HUP} = 'IGNORE';
local $SIG{INT} = 'IGNORE';
@@ -133,6 +144,20 @@ sub insert {
local $FS::UID::AutoCommit = 0;
my $dbh = dbh;
+ 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', '');
+
if ( $self->crednum ) {
my $cust_credit = qsearchs('cust_credit', { 'crednum' => $self->crednum } )
or do {
@@ -275,13 +300,17 @@ sub check {
|| $self->ut_numbern('custnum')
|| $self->ut_money('refund')
|| $self->ut_alphan('otaker')
- || $self->ut_text('reason')
+ || $self->ut_textn('reason')
|| $self->ut_numbern('_date')
|| $self->ut_textn('paybatch')
|| $self->ut_enum('closed', [ '', 'Y' ])
;
return $error if $error;
+ my $method = $ignore_empty_reasonnum ? 'ut_foreign_keyn' : 'ut_foreign_key';
+ $error = $self->$method('reasonnum', 'reason', 'reasonnum');
+ return $error if $error;
+
return "refund must be > 0 " if $self->refund <= 0;
$self->_date(time) unless $self->_date;
@@ -428,9 +457,61 @@ sub unapplied_sql {
}
+=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='F'";
+
+ $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,
+ 'disabled' => 'Y',
+ } );
+ my $error = $reason->insert;
+ if ( $error ) {
+ warn "error inserting reason: $error\n";
+ $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 : '' ).
+ ( $self->addlinfo ? ' '.$self->addlinfo : '' );
+}
+
# Used by FS::Upgrade to migrate to a new database.
sub _upgrade_data { # class method
my ($class, %opts) = @_;
+ $class->_upgrade_reasonnum(%opts);
$class->_upgrade_otaker(%opts);
}
diff --git a/FS/FS/reason.pm b/FS/FS/reason.pm
index 1739f9609..f50af7ad3 100644
--- a/FS/FS/reason.pm
+++ b/FS/FS/reason.pm
@@ -231,7 +231,8 @@ sub merge {
Fetches the reason matching these parameters if there is one. If not,
inserts one. Will also insert the reason type if necessary. CLASS must
-be one of 'C' (cancel reasons), 'R' (credit reasons), or 'S' (suspend reasons).
+be one of 'C' (cancel reasons), 'R' (credit reasons), 'S' (suspend reasons),
+or 'F' (refund reasons).
This will die if anything fails.
@@ -242,14 +243,25 @@ sub new_or_existing {
my %opt = @_;
my $error = '';
- my %hash = ('class' => $opt{'class'}, 'type' => $opt{'type'});
- my $reason_type = qsearchs('reason_type', \%hash)
- || FS::reason_type->new(\%hash);
+ my $reason_type;
+ if ( ref $opt{type} eq 'FS::reason_type' ) {
+ $reason_type = $opt{type};
+ } elsif ( $opt{type} =~ /^\d+$/ ) {
+ $reason_type = FS::reason_type->by_key($opt{type});
+ if (!$reason_type) {
+ die "reason_type #$opt{type} not found\n";
+ }
+ } else {
+ my %hash = ('class' => $opt{'class'}, 'type' => $opt{'type'});
+ $reason_type = qsearchs('reason_type', \%hash)
+ || FS::reason_type->new(\%hash);
- $error = $reason_type->insert unless $reason_type->typenum;
- die "error inserting reason type: $error\n" if $error;
+ $error = $reason_type->insert unless $reason_type->typenum;
+ die "error inserting reason type: $error\n" if $error;
+ }
- %hash = ('reason_type' => $reason_type->typenum, 'reason' => $opt{'reason'});
+ my %hash = ('reason_type' => $reason_type->typenum,
+ 'reason' => $opt{'reason'});
my $reason = qsearchs('reason', \%hash)
|| FS::reason->new(\%hash);
diff --git a/FS/FS/reason_Mixin.pm b/FS/FS/reason_Mixin.pm
new file mode 100644
index 000000000..a3975419c
--- /dev/null
+++ b/FS/FS/reason_Mixin.pm
@@ -0,0 +1,96 @@
+package FS::reason_Mixin;
+
+use strict;
+use Carp qw( croak ); #confess );
+use FS::Record qw( qsearch qsearchs dbdef );
+use FS::access_user;
+use FS::UID qw( dbh );
+use FS::reason;
+
+our $DEBUG = 0;
+our $me = '[FS::reason_Mixin]';
+
+=item reason
+
+Returns the text of the associated reason (see L<FS::reason>) for this credit.
+
+=cut
+
+sub reason {
+ my ($self, $value, %options) = @_;
+ my $reason_text;
+ if ( $self->reasonnum ) {
+ my $reason = FS::reason->by_key($self->reasonnum);
+ $reason_text = $reason->reason;
+ } else { # in case one of these somehow still exists
+ $reason_text = $self->get('reason');
+ }
+ if ( $self->get('addlinfo') ) {
+ $reason_text .= ' ' . $self->get('addlinfo');
+ }
+
+ return $reason_text;
+}
+
+# it was a mistake to allow setting the reason this way; use
+# FS::reason->new_or_existing
+
+# Used by FS::Upgrade to migrate reason text fields to reasonnum.
+sub _upgrade_reasonnum { # class method
+ my $class = shift;
+ my $table = $class->table;
+
+ if (defined dbdef->table($table)->column('reason')) {
+
+ warn "$me Checking for unmigrated reasons\n" if $DEBUG;
+
+ my @cust_refunds = qsearch({ 'table' => $table,
+ 'hashref' => {},
+ 'extra_sql' => 'WHERE reason IS NOT NULL',
+ });
+
+ if (scalar(grep { $_->getfield('reason') =~ /\S/ } @cust_refunds)) {
+ warn "$me Found unmigrated reasons\n" if $DEBUG;
+ my $hashref = { 'class' => 'F', '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 "$class 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) {
+ $hashref->{'disabled'} = 'Y';
+ $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_refund ( @cust_refunds ) {
+ my $reason = $cust_refund->getfield('reason');
+ warn "Contemplating reason $reason\n" if $DEBUG > 1;
+ if ($reason =~ /\S/) {
+ $cust_refund->reason($reason, 'reason_type' => $reason_type->typenum)
+ or die "can't insert legacy reason $reason into database\n";
+ }else{
+ $cust_refund->reasonnum($noreason->reasonnum);
+ }
+
+ $cust_refund->setfield('reason', '');
+ my $error = $cust_refund->replace;
+
+ warn "*** WARNING: error replacing reason in $class ".
+ $cust_refund->refundnum. ": $error ***\n"
+ if $error;
+ }
+ }
+ }
+}
+
+1;
diff --git a/FS/FS/reason_type.pm b/FS/FS/reason_type.pm
index 4a8c03632..3e9162c94 100644
--- a/FS/FS/reason_type.pm
+++ b/FS/FS/reason_type.pm
@@ -10,6 +10,7 @@ our %class_name = (
'C' => 'cancel',
'R' => 'credit',
'S' => 'suspend',
+ 'F' => 'refund',
'X' => 'void credit',
);
@@ -18,6 +19,7 @@ our %class_purpose = (
'R' => 'explain why a customer was credited',
'S' => 'explain why a customer package was suspended',
'X' => 'explain why a credit was voided',
+ 'F' => 'explain why a customer was refunded',
);
=head1 NAME
generated by cgit v1.2.1 (git 2.18.0) at 2025-07-22 21:48:13 +0000