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