Open-ILS/src/perlmods/OpenILS/EX.pm

   1 package OpenILS::EX;
   2 use strict; use warnings;
   3 use Template qw(:template);
   4 use OpenSRF::Utils::SettingsClient;
   5 use OpenILS::Utils::Fieldmapper;
   6
   7 # ----------------------------------------------------------------------------------
   8 # These exceptions are not thrown.  They are returned as request result objects
   9 # ----------------------------------------------------------------------------------
  10
  11 my %ex_types = (
  12         UNKNOWN                         => 1,
  13         SEARCH_TOO_LARGE        => 2,
  14         UNKNOWN_BARCODE => 3,
  15 );
  16
  17 use overload ( '""' => sub { $_[0]->ex()->err_msg(); } );
  18
  19 sub new {
  20
  21         my($class, $type) = @_;
  22         $class = ref($class) || $class;
  23
  24         my $self = {};
  25         bless($self, $class);
  26
  27         $self->{ex} = new Fieldmapper::ex;
  28         $self->{ex}->type($ex_types{$type});
  29         $self->{ex}->err_msg($self->run());
  30         warn "type is $type\n";
  31
  32         return $self;
  33 }
  34
  35
  36 sub ex { return shift()->{ex}; }
  37
  38 sub run {
  39
  40         my $self = shift;
  41
  42         my $result;
  43         my $conf = OpenSRF::Utils::SettingsClient->new;
  44
  45         my $script = $conf->config_value("ex_script");
  46
  47         my $template = Template->new(
  48                 {
  49                         ABSOLUTE                => 1,
  50                         OUTPUT          => \$result,
  51                         PRE_CHOMP       => 1,
  52                         POST_CHOMP      => 1,
  53                 }
  54         );
  55
  56         my $status = $template->process($script,
  57                         { ex_types => \%ex_types, type => $self->{ex}->type });
  58
  59         if(!$status) {
  60                 return "Unable to process exception script.  No meaningful data to return..." .
  61                         " Error is:\n" . $template->error() . "\n";
  62         }
  63
  64         $result =~ s/^\s*//og;
  65         warn " -|-|-|- Exception result [$result]\n";
  66
  67         return $result;
  68 }
  69
  70
  71
  72
  73
  74