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;
  26   if ( $self->reasonnum ) {
  27     my $reason = FS::reason->by_key($self->reasonnum);
  28     $reason_text = $reason->reason;
  29   } else { # in case one of these somehow still exists
  30     $reason_text = $self->get('reason');
  31   }
  32   if ( $self->get('addlinfo') ) {
  33     $reason_text .= ' ' . $self->get('addlinfo');
  34   }
  35
  36   return $reason_text;
  37 }
  38
  39 # Used by FS::Upgrade to migrate reason text fields to reasonnum.
  40 # Note that any new tables that get reasonnum fields do NOT need to be
  41 # added here unless they have previously had a free-text "reason" field.
  42
  43 sub _upgrade_reasonnum {    # class method
  44     my $class = shift;
  45     my $table = $class->table;
  46
  47     my $reason_class;
  48     if ( $table eq 'cust_bill' or $table eq 'cust_bill_pkg' ) {
  49       $reason_class = 'I';
  50     } elsif ( $table eq 'cust_pay' ) {
  51       $reason_class = 'P';
  52     } elsif ( $table eq 'cust_refund' ) {
  53       $reason_class = 'F';
  54     } elsif ( $table eq 'cust_credit' ) {
  55       $reason_class = 'R';
  56     } else {
  57       die "don't know the reason class to use for upgrading $table";
  58     }
  59
  60     for my $fieldname (qw(reason void_reason)) {
  61
  62         if ( $table eq 'cust_credit' and $fieldname eq 'void_reason' ) {
  63             $reason_class = 'X';
  64         }
  65
  66         if (   defined dbdef->table($table)->column($fieldname)
  67             && defined dbdef->table($table)->column( $fieldname . 'num' ) )
  68         {
  69
  70             warn "$me Checking for unmigrated reasons\n" if $DEBUG;
  71
  72             my @legacy_reason_records = qsearch(
  73                 {
  74                     'table'     => $table,
  75                     'hashref'   => {},
  76                     'extra_sql' => 'WHERE ' . $fieldname . ' IS NOT NULL',
  77                 }
  78             );
  79
  80             if (
  81                 scalar(
  82                     grep { $_->getfield($fieldname) =~ /\S/ }
  83                       @legacy_reason_records
  84                 )
  85               )
  86             {
  87                 warn "$me Found unmigrated reasons\n" if $DEBUG;
  88
  89                 my $reason_type =
  90                   _upgrade_get_legacy_reason_type( $class, $table );
  91                 my $noreason = _upgrade_get_no_reason( $class, $reason_type );
  92
  93                 foreach my $record_to_upgrade (@legacy_reason_records) {
  94                     my $reason = $record_to_upgrade->getfield($fieldname);
  95                     warn "Contemplating reason $reason\n" if $DEBUG > 1;
  96                     if ( $reason =~ /\S/ ) {
  97                         my $reason =
  98                           _upgrade_get_reason( $class, $reason, $reason_type );
  99                         $record_to_upgrade->set( $fieldname . 'num',
 100                             $reason->reasonnum );
 101                     }
 102                     else {
 103                         $record_to_upgrade->set( $fieldname . 'num',
 104                             $noreason->reasonnum );
 105                     }
 106
 107                     $record_to_upgrade->setfield( $fieldname, '' );
 108                     my $error = $record_to_upgrade->replace;
 109
 110                     my $primary_key = $record_to_upgrade->primary_key;
 111                     warn "*** WARNING: error replacing $fieldname in $class "
 112                       . $record_to_upgrade->get($primary_key)
 113                       . ": $error ***\n"
 114                       if $error;
 115                 }
 116             }
 117         }
 118     }
 119 }
 120
 121 # _upgrade_get_legacy_reason_type is class method supposed to be used only
 122 # within the reason_Mixin class which will either find or create a reason_type
 123 sub _upgrade_get_legacy_reason_type {
 124
 125     my $class = shift;
 126     my $table = shift;
 127
 128     my $reason_class =
 129       ( $table =~ /void/ ) ? 'X' : 'F';    # see FS::reason_type (%class_name)
 130     my $reason_type_params = { 'class' => $reason_class, 'type' => 'Legacy' };
 131     my $reason_type = qsearchs( 'reason_type', $reason_type_params );
 132     unless ($reason_type) {
 133         $reason_type = new FS::reason_type($reason_type_params);
 134         my $error = $reason_type->insert();
 135         die "$class had error inserting FS::reason_type into database: $error\n"
 136            if $error;
 137     }
 138     return $reason_type;
 139 }
 140
 141 # _upgrade_get_no_reason is class method supposed to be used only within the
 142 # reason_Mixin class which will either find or create a default (no reason)
 143 # reason
 144 sub _upgrade_get_no_reason {
 145
 146     my $class       = shift;
 147     my $reason_type = shift;
 148     return _upgrade_get_reason( $class, '(none)', $reason_type );
 149 }
 150
 151 # _upgrade_get_reason is class method supposed to be used only within the
 152 # reason_Mixin class which will either find or create a reason
 153 sub _upgrade_get_reason {
 154
 155     my $class       = shift;
 156     my $reason_text = shift;
 157     my $reason_type = shift;
 158
 159     my $reason_params = {
 160         'reason_type' => $reason_type->typenum,
 161         'reason'      => $reason_text
 162     };
 163     my $reason = qsearchs( 'reason', $reason_params );
 164     unless ($reason) {
 165         $reason_params->{'disabled'} = 'Y';
 166         $reason = new FS::reason($reason_params);
 167         my $error = $reason->insert();
 168         die "can't insert legacy reason '$reason_text' into database: $error\n"
 169            if $error;
 170      }
 171     return $reason;
 172 }
 173
 174 1;