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   if (   defined dbdef->table($table)->column('reason')
  47       && defined dbdef->table($table)->column('reasonnum') )
  48   {
  49
  50     warn "$me Checking for unmigrated reasons\n" if $DEBUG;
  51
  52     my @legacy_reason_records = qsearch(
  53         {
  54             'table'     => $table,
  55             'hashref'   => {},
  56             'extra_sql' => 'WHERE reason IS NOT NULL',
  57         }
  58     );
  59
  60     if (scalar(grep { $_->getfield('reason') =~ /\S/ } @legacy_reason_records)) {
  61       warn "$me Found unmigrated reasons\n" if $DEBUG;
  62
  63       my $reason_type = _upgrade_get_legacy_reason_type($class, $table);
  64       my $noreason = _upgrade_get_no_reason($class, $reason_type);
  65
  66       foreach my $record_to_upgrade (@legacy_reason_records) {
  67           my $reason = $record_to_upgrade->getfield('reason');
  68           warn "Contemplating reason $reason\n" if $DEBUG > 1;
  69           if ( $reason =~ /\S/ ) {
  70               my $reason = _upgrade_get_reason( $class, $reason, $reason_type );
  71               $record_to_upgrade->reasonnum( $reason->reasonnum );
  72           }
  73           else {
  74               $record_to_upgrade->reasonnum( $noreason->reasonnum );
  75           }
  76
  77           $record_to_upgrade->setfield( 'reason', '' );
  78           my $error = $record_to_upgrade->replace;
  79
  80           my $primary_key = $record_to_upgrade->primary_key;
  81           warn "*** WARNING: error replacing reason in $class "
  82             . $record_to_upgrade->get($primary_key)
  83             . ": $error ***\n"
  84             if $error;
  85        }
  86     }
  87   }
  88 }
  89
  90 # _upgrade_get_legacy_reason_type is class method supposed to be used only
  91 # within the reason_Mixin class which will either find or create a reason_type
  92 sub _upgrade_get_legacy_reason_type {
  93
  94     my $class = shift;
  95     my $table = shift;
  96
  97     my $reason_class =
  98       ( $table =~ /void/ ) ? 'X' : 'F';    # see FS::reason_type (%class_name)
  99     my $reason_type_params = { 'class' => $reason_class, 'type' => 'Legacy' };
 100     my $reason_type = qsearchs( 'reason_type', $reason_type_params );
 101     unless ($reason_type) {
 102         $reason_type = new FS::reason_type($reason_type_params);
 103         my $error = $reason_type->insert();
 104         die "$class had error inserting FS::reason_type into database: $error\n"
 105            if $error;
 106     }
 107     return $reason_type;
 108 }
 109
 110 # _upgrade_get_no_reason is class method supposed to be used only within the
 111 # reason_Mixin class which will either find or create a default (no reason)
 112 # reason
 113 sub _upgrade_get_no_reason {
 114
 115     my $class       = shift;
 116     my $reason_type = shift;
 117     return _upgrade_get_reason( $class, '(none)', $reason_type );
 118 }
 119
 120 # _upgrade_get_reason is class method supposed to be used only within the
 121 # reason_Mixin class which will either find or create a reason
 122 sub _upgrade_get_reason {
 123
 124     my $class       = shift;
 125     my $reason_text = shift;
 126     my $reason_type = shift;
 127
 128     my $reason_params = {
 129         'reason_type' => $reason_type->typenum,
 130         'reason'      => $reason_text
 131     };
 132     my $reason = qsearchs( 'reason', $reason_params );
 133     unless ($reason) {
 134         $reason_params->{'disabled'} = 'Y';
 135         $reason = new FS::reason($reason_params);
 136         my $error = $reason->insert();
 137         die "can't insert legacy reason '$reason_text' into database: $error\n"
 138            if $error;
 139      }
 140     return $reason;
 141 }
 142
 143 1;