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 );
  15
  16 use overload ( '""' => sub { $_[0]->ex()->err_msg(); } );
  17
  18 sub new {
  19
  20         my($class, $type) = @_;
  21         $class = ref($class) || $class;
  22
  23         my $self = {};
  24         bless($self, $class);
  25
  26         $self->{ex} = new Fieldmapper::ex;
  27         $self->{ex}->type($ex_types{$type});
  28         $self->{ex}->err_msg($self->run());
  29         warn "type is $type\n";
  30
  31         return $self;
  32 }
  33
  34
  35 sub ex { return shift()->{ex}; }
  36
  37 sub run {
  38
  39         my $self = shift;
  40
  41         my $result;
  42         my $conf = OpenSRF::Utils::SettingsClient->new;
  43
  44         my $script = $conf->config_value("ex_script");
  45
  46         my $template = Template->new(
  47                 {
  48                         ABSOLUTE                => 1,
  49                         OUTPUT          => \$result,
  50                         PRE_CHOMP       => 1,
  51                         POST_CHOMP      => 1,
  52                 }
  53         );
  54
  55         my $status = $template->process($script,
  56                         { ex_types => \%ex_types, type => $self->{ex}->type });
  57
  58         if(!$status) {
  59                 return "Unable to process exception script.  No meaningful data to return..." .
  60                         " Error is:\n" . $template->error() . "\n";
  61         }
  62
  63         $result =~ s/^\s*//og;
  64         warn " -|-|-|- Exception result [$result]\n";
  65
  66         return $result;
  67 }
  68
  69
  70
  71
  72
  73