1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
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;
use FS::reason_type;
our $DEBUG = 0;
our $me = '[FS::reason_Mixin]';
=item reason
Returns the text of the associated reason (see L<FS::reason>) for this credit /
voided payment / voided invoice. This can no longer be used to set the
(deprecated) free-text "reason" field; see L<FS::reason/new_or_existing>.
=cut
sub reason {
my $self = shift;
my $reason_text = $self->reason_only;
if ( $self->get('addlinfo') ) {
$reason_text .= ' ' . $self->get('addlinfo');
}
return $reason_text;
}
=item reason_only
Returns only the text of the associated reason,
absent any addlinfo that is included by L</reason>.
(Currently only affects credit and credit void reasons.)
=cut
# a bit awkward, but much easier to invoke this in the few reports
# that need separate fields than to update every place
# that displays them together
sub reason_only {
my $self = shift;
if ( $self->reasonnum ) {
my $reason = FS::reason->by_key($self->reasonnum);
return $reason->reason;
} else { # in case one of these somehow still exists
return $self->get('reason');
}
}
# Used by FS::Upgrade to migrate reason text fields to reasonnum.
# Note that any new tables that get reasonnum fields do NOT need to be
# added here unless they have previously had a free-text "reason" field.
sub _upgrade_reasonnum { # class method
my $class = shift;
my $table = $class->table;
my $reason_class;
if ( $table =~ /^cust_bill/ ) { # also includes cust_bill_pkg
$reason_class = 'I';
} elsif ( $table =~ /^cust_pay/ ) {
$reason_class = 'P';
} elsif ( $table eq 'cust_refund' ) {
$reason_class = 'F';
} elsif ( $table =~ /^cust_credit/ ) {
$reason_class = 'R';
} else {
die "don't know the reason class to use for upgrading $table";
}
for my $fieldname (qw(reason void_reason)) {
if ( $table =~ /^cust_credit/ and $fieldname eq 'void_reason' ) {
$reason_class = 'X';
}
if ( defined dbdef->table($table)->column($fieldname)
&& defined dbdef->table($table)->column( $fieldname . 'num' ) )
{
warn "$me Checking for unmigrated reasons\n" if $DEBUG;
my @legacy_reason_records = qsearch(
{
'table' => $table,
'hashref' => {},
'extra_sql' => 'WHERE ' . $fieldname . ' IS NOT NULL',
}
);
if ( @legacy_reason_records ) {
warn "$me Found unmigrated reasons\n" if $DEBUG;
my $reason_type =
$class->_upgrade_get_legacy_reason_type( $reason_class );
# XXX "noreason" does not actually work, because we limited to
# "reason is not null" above. Records where the reason string
# is null will end up with a reasonnum of null also.
my $noreason = $class->_upgrade_get_no_reason( $reason_type );
foreach my $record_to_upgrade (@legacy_reason_records) {
my $reason = $record_to_upgrade->getfield($fieldname);
warn "Contemplating reason $reason\n" if $DEBUG > 1;
if ( $reason =~ /\S/ ) {
my $reason =
$class->_upgrade_get_reason( $reason, $reason_type );
$record_to_upgrade->set( $fieldname . 'num',
$reason->reasonnum );
}
else {
$record_to_upgrade->set( $fieldname . 'num',
$noreason->reasonnum );
}
$record_to_upgrade->setfield( $fieldname, '' );
my $error = $record_to_upgrade->replace;
my $primary_key = $record_to_upgrade->primary_key;
warn "*** WARNING: error replacing $fieldname in $class "
. $record_to_upgrade->get($primary_key)
. ": $error ***\n"
if $error;
}
}
}
}
}
# internal methods for upgrade
# _upgrade_get_legacy_reason_type is class method supposed to be used only
# within the reason_Mixin class which will either find or create a reason_type
sub _upgrade_get_legacy_reason_type {
my $class = shift;
my $reason_class = shift;
my $reason_type_params = { 'class' => $reason_class, 'type' => 'Legacy' };
my $reason_type = qsearchs( 'reason_type', $reason_type_params );
unless ($reason_type) {
$reason_type = new FS::reason_type($reason_type_params);
my $error = $reason_type->insert();
die "$class had error inserting FS::reason_type into database: $error\n"
if $error;
}
return $reason_type;
}
# _upgrade_get_no_reason is class method supposed to be used only within the
# reason_Mixin class which will either find or create a default (no reason)
# reason
sub _upgrade_get_no_reason {
my $class = shift;
my $reason_type = shift;
return $class->_upgrade_get_reason( '(none)', $reason_type );
}
# _upgrade_get_reason is class method supposed to be used only within the
# reason_Mixin class which will either find or create a reason
sub _upgrade_get_reason {
my $class = shift;
my $reason_text = shift;
my $reason_type = shift;
my $reason_params = {
'reason_type' => $reason_type->typenum,
'reason' => $reason_text
};
my $reason = qsearchs( 'reason', $reason_params );
unless ($reason) {
$reason_params->{'disabled'} = 'Y';
$reason = new FS::reason($reason_params);
my $error = $reason->insert();
die "can't insert legacy reason '$reason_text' into database: $error\n"
if $error;
}
return $reason;
}
1;
|
