FS/FS/reason_Mixin.pm

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