Open-ILS/src/perlmods/lib/OpenILS/Application/Trigger/Reactor.pm

   1 package OpenILS::Application::Trigger::Reactor;
   2 use strict; use warnings;
   3 use Encode qw/ encode /;
   4 use Template;
   5 use DateTime;
   6 use DateTime::Format::ISO8601;
   7 use Unicode::Normalize;
   8 use XML::LibXML;
   9 use OpenSRF::Utils qw/:datetime/;
  10 use OpenSRF::Utils::Logger qw(:logger);
  11 use OpenILS::Application::AppUtils;
  12 use OpenILS::Utils::CStoreEditor qw/:funcs/;
  13 my $U = 'OpenILS::Application::AppUtils';
  14
  15 sub fourty_two { return 42 }
  16 sub NOOP_True  { return  1 }
  17 sub NOOP_False { return  0 }
  18
  19
  20
  21 # helper functions inserted into the TT environment
  22 my $_TT_helpers = {
  23
  24     # turns a date into something TT can understand
  25     format_date => sub {
  26         my $date = shift;
  27         $date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($date));
  28         return sprintf(
  29             "%0.2d:%0.2d:%0.2d %0.2d-%0.2d-%0.4d",
  30             $date->hour,
  31             $date->minute,
  32             $date->second,
  33             $date->day,
  34             $date->month,
  35             $date->year
  36         );
  37     },
  38
  39     # escapes a string for inclusion in an XML document.  escapes &, <, and > characters
  40     escape_xml => sub {
  41         my $str = shift;
  42         $str =~ s/&/&amp;/sog;
  43         $str =~ s/</&lt;/sog;
  44         $str =~ s/>/&gt;/sog;
  45         return $str;
  46     },
  47
  48     escape_json => sub {
  49         my $str = shift;
  50         $str =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
  51         return $str;
  52     },
  53
  54     # encode email headers in UTF-8, per RFC2231
  55     escape_email_header => sub {
  56         my $str = shift;
  57         $str = encode("MIME-Header", $str);
  58         return $str;
  59     },
  60
  61     # strip non-ASCII characters after splitting base characters and diacritics
  62     # least common denominator for EDIFACT messages using the UNOB character set
  63     force_jedi_unob => sub {
  64         my $str = shift;
  65         $str = NFD($str);
  66         $str =~ s/[\x{0080}-\x{fffd}]//g;
  67         return $str;
  68     },
  69
  70     # returns the calculated user locale
  71     get_user_locale => sub {
  72         my $user_id = shift;
  73         return $U->get_user_locale($user_id);
  74     },
  75
  76     # returns the calculated copy price
  77     get_copy_price => sub {
  78         my $copy_id = shift;
  79         return $U->get_copy_price(new_editor(xact=>1), $copy_id);
  80     },
  81
  82     # given a copy, returns the title and author in a hash
  83     get_copy_bib_basics => sub {
  84         my $copy_id = shift;
  85         my $copy = new_editor(xact=>1)->retrieve_asset_copy([
  86             $copy_id,
  87             {
  88                 flesh => 2,
  89                 flesh_fields => {
  90                     acp => ['call_number'],
  91                     acn => ['record']
  92                 }
  93             }
  94         ]);
  95         if($copy->call_number->id == -1) {
  96             return {
  97                 title  => $copy->dummy_title,
  98                 author => $copy->dummy_author,
  99             };
 100         } else {
 101             my $mvr = $U->record_to_mvr($copy->call_number->record);
 102             return {
 103                 title  => $mvr->title,
 104                 author => $mvr->author
 105             };
 106         }
 107     },
 108
 109     # returns the org unit setting value
 110     get_org_setting => sub {
 111         my($org_id, $setting) = @_;
 112         return $U->ou_ancestor_setting_value($org_id, $setting);
 113     },
 114
 115     # This basically greps/maps out ths isbn string values, but also promotes the first isbn-13 to the
 116     # front of the line (so that the EDI translator takes it as primary) if there is one.
 117     get_li_isbns => sub {
 118         my $attrs = shift;
 119         my @isbns;
 120         my $primary;
 121         foreach (@$attrs) {
 122             $_->attr_name eq 'isbn' or next;
 123             my $val = $_->attr_value;
 124             if (! $primary and length($val) == 13) {
 125                 $primary = $val;
 126             } else {
 127                 push @isbns, $val;
 128             }
 129         }
 130         $primary and unshift @isbns, $primary;
 131         $logger->debug("get_li_isbns returning isbns: " . join(', ', @isbns));
 132         return @isbns;
 133     },
 134
 135     # helpers.get_li_attr('isbn_13', li.attributes)
 136     # returns matching line item attribute, or undef
 137     get_li_attr => sub {
 138         my $name = shift or return;     # the first arg is always the name
 139         my ($type, $attr) = (scalar(@_) == 1) ? (undef, $_[0]) : @_;
 140         # if the next is the last, it's the attributes, otherwise type
 141         # use Data::Dumper; $logger->warn("get_li_attr: " . Dumper($attr));
 142         ($name and @$attr) or return;
 143         my $length;
 144         $name =~ s/^(\D+)_(\d+)$/$1/ and $length = $2;
 145         foreach (@$attr) {
 146             $_->attr_name eq $name or next;
 147             next if $length and $length != length($_->attr_value);
 148             return $_->attr_value if (! $type) or $type eq $_->attr_type;
 149         }
 150         return;
 151     },
 152
 153     get_queued_bib_attr => sub {
 154         my $name = shift or return;     # the first arg is always the name
 155         my ($attr) = @_;
 156         # use Data::Dumper; $logger->warn("get_queued_bib_attr: " . Dumper($attr));
 157         ($name and @$attr) or return;
 158
 159         my $query = {
 160             select => {'vqbrad' => ['id']},
 161             from => 'vqbrad',
 162             where => {code => $name}
 163         };
 164
 165         my $def_ids = new_editor()->json_query($query);
 166         @$def_ids or return;
 167
 168         my $length;
 169         $name =~ s/^(\D+)_(\d+)$/$1/ and $length = $2;
 170         foreach (@$attr) {
 171             $_->field eq @{$def_ids}[0]->{id} or next;
 172             next if $length and $length != length($_->attr_value);
 173             return $_->attr_value;
 174         }
 175         return;
 176     },
 177
 178     get_queued_auth_attr => sub {
 179         my $name = shift or return;     # the first arg is always the name
 180         my ($attr) = @_;
 181         # use Data::Dumper; $logger->warn("get_queued_auth_attr: " . Dumper($attr));
 182         ($name and @$attr) or return;
 183
 184         my $query = {
 185             select => {'vqarad' => ['id']},
 186             from => 'vqarad',
 187             where => {code => $name}
 188         };
 189
 190         my $def_ids = new_editor()->json_query($query);
 191         @$def_ids or return;
 192
 193         my $length;
 194         $name =~ s/^(\D+)_(\d+)$/$1/ and $length = $2;
 195         foreach (@$attr) {
 196             $_->field eq @{$def_ids}[0]->{id} or next;
 197             next if $length and $length != length($_->attr_value);
 198             return $_->attr_value;
 199         }
 200         return;
 201     },
 202
 203     csv_datum => sub {
 204         my ($str) = @_;
 205
 206         if ($str =~ /\,/ || $str =~ /"/) {
 207             $str =~ s/"/""/g;
 208             $str = '"' . $str . '"';
 209         }
 210
 211         return $str;
 212     },
 213
 214     xml_doc => sub {
 215         my ($str) = @_;
 216         return $str ? (new XML::LibXML)->parse_string($str) : undef;
 217     }
 218
 219 };
 220
 221
 222 # processes templates.  Returns template output on success, undef on error
 223 sub run_TT {
 224     my $self = shift;
 225     my $env = shift;
 226     my $nostore = shift;
 227     return undef unless $env->{template};
 228
 229     my $error;
 230     my $output = '';
 231     my $tt = Template->new;
 232     # my $tt = Template->new(ENCODING => 'utf8');   # ??
 233     $env->{helpers} = $_TT_helpers;
 234
 235     unless( $tt->process(\$env->{template}, $env, \$output) ) {
 236         $output = undef;
 237         ($error = $tt->error) =~ s/\n/ /og;
 238         $logger->error("Error processing Trigger template: $error");
 239     }
 240
 241     if ( $error or (!$nostore && $output) ) {
 242         my $t_o = Fieldmapper::action_trigger::event_output->new;
 243         $t_o->data( ($error) ? $error : $output );
 244         $t_o->is_error( ($error) ? 't' : 'f' );
 245         $logger->info("trigger: writing " . length($t_o->data) . " bytes to template output");
 246
 247         $env->{EventProcessor}->editor->xact_begin;
 248         $t_o = $env->{EventProcessor}->editor->create_action_trigger_event_output( $t_o );
 249
 250         my $state = (ref $$env{event} eq 'ARRAY') ? $$env{event}->[0]->state : $env->{event}->state;
 251         my $key = ($error) ? 'error_output' : 'template_output';
 252         $env->{EventProcessor}->update_state( $state, { $key => $t_o->id } );
 253     }
 254
 255     return $output;
 256 }
 257
 258
 259 1;