Open-ILS/src/perlmods/lib/OpenILS/WWW/IDL2js.pm

   1 package OpenILS::WWW::IDL2js;
   2 use strict; use warnings;
   3 use XML::LibXML;
   4 use XML::LibXSLT;
   5 use Apache2::Const -compile => qw(OK DECLINED HTTP_INTERNAL_SERVER_ERROR);
   6 use Apache2::RequestRec;
   7 use Apache2::SubRequest;
   8 use Apache2::Filter;
   9 use APR::Brigade;
  10 use APR::Bucket;
  11 use Error qw/:try/;
  12 use OpenSRF::System;
  13 use OpenSRF::Utils::SettingsClient;
  14 use CGI;
  15
  16 my $bs_config;
  17 my $stylesheet;
  18
  19 # load and parse the stylesheet
  20 sub import {
  21     my $self = shift;
  22     $bs_config = shift;
  23 }
  24
  25 # parse the IDL, loaded from the network
  26 my $__initted = 0;
  27 sub child_init {
  28     $__initted = 1;
  29
  30     OpenSRF::System->bootstrap_client(config_file => $bs_config);
  31     my $sclient = OpenSRF::Utils::SettingsClient->new();
  32
  33     my $xsl_file = $sclient->config_value('IDL2js');
  34
  35     unless($xsl_file) {
  36         warn "XSL2js XSL file required for IDL2js Apache module\n";
  37         return;
  38     }
  39
  40     $xsl_file = $sclient->config_value(dirs => 'xsl')."/$xsl_file";
  41     my $idl_file = $sclient->config_value("IDL");
  42
  43     my $xslt = XML::LibXSLT->new();
  44
  45     try {
  46
  47         my $style_doc = XML::LibXML->load_xml(location => $xsl_file, no_cdata=>1);
  48         $stylesheet = $xslt->parse_stylesheet($style_doc);
  49
  50     } catch Error with {
  51         my $e = shift;
  52         warn "Invalid XSL File: $xsl_file: $e\n";
  53     };
  54
  55     return Apache2::Const::OK;
  56 }
  57
  58
  59 my %idl_cache;
  60 sub handler {
  61     my $r = shift;
  62     my $args = $r->args || '';
  63     child_init() unless $__initted;
  64
  65     return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR unless $stylesheet;
  66
  67     # pull the locale from the query string if present
  68     (my $locale = $args) =~ s/.*locale=([a-z]{2}-[A-Z]{2}).*/$1/g;
  69
  70     # remove the locale argument from the query
  71     # string, regardless of whether it was valid
  72     $args =~ s/([&;]?locale=[^&;]*)[&;]?//g;
  73
  74     # if no valid locale is present in the query
  75     # string, pull it from the headers
  76     $locale = $r->headers_in->get('Accept-Language') unless $locale;
  77
  78     if (!$locale or $locale !~ /^[a-z]{2}-[A-Z]{2}$/) {
  79         $r->log->debug("Invalid IDL2js locale '$locale'; using en-US");
  80         $locale = 'en-US';
  81     }
  82
  83     $r->log->debug("IDL2js using locale '$locale'");
  84
  85     my $output = '';
  86     my $stat = load_IDL($r, $locale, $args, \$output);
  87     return $stat unless $stat == Apache2::Const::OK;
  88
  89     $r->content_type('application/x-javascript; encoding=utf8');
  90     $r->print($output);
  91     return Apache2::Const::OK;
  92 }
  93
  94 # loads the IDL for the provided locale.
  95 # when possible, use a cached version of the IDL.
  96 sub load_IDL {
  97     my ($r, $locale, $args, $output_ref) = @_;
  98
  99     # do we already have a cached copy of the IDL for this locale?
 100     if (!$args and $idl_cache{$locale}) {
 101         $$output_ref = $idl_cache{$locale};
 102         return Apache2::Const::OK;
 103     }
 104
 105     # Fetch the locale-aware fm_IDL.xml via Apache subrequest.
 106     my $subr = $r->lookup_uri("/reports/fm_IDL.xml?locale=$locale");
 107
 108     # filter allows us to capture the output of the subrequest locally
 109     # http://www.gossamer-threads.com/lists/modperl/modperl/97649#97649
 110     my $xml = '';
 111     $subr->add_output_filter(sub {
 112         my ($f, $bb) = @_;
 113         while (my $e = $bb->first) {
 114             $e->read(my $buf);
 115             $xml .= $buf;
 116             $e->delete;
 117         }
 118         return Apache2::Const::OK;
 119     });
 120
 121     $subr->run;
 122
 123     if (!$xml) {
 124         $r->log->error("No IDL XML found");
 125         return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
 126     }
 127
 128     $xml =~ s/<!--.*?-->//sg;     # filter out XML comments ...
 129     $xml =~ s/(?:^|\s+)--.*$//mg; # and SQL comments ...
 130     $xml =~ s/^\s+/ /mg;          # and extra leading spaces ...
 131     $xml =~ s/\R*//g;             # and newlines
 132
 133     my $output;
 134     try {
 135         my $idl_doc = XML::LibXML->load_xml(string => $xml);
 136         my $results = $stylesheet->transform($idl_doc, class_list => "'$args'");
 137         $output = $stylesheet->output_as_bytes($results);
 138     } catch Error with {
 139         my $e = shift;
 140         $r->log->error("IDL XSL Error: $e");
 141     };
 142
 143     return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR unless $output;
 144
 145     # only cache full versions of the IDL
 146     $idl_cache{$locale} = $output unless $args;
 147
 148     # pass output back to the caller
 149     $$output_ref = $output;
 150
 151     return Apache2::Const::OK;
 152 }
 153
 154 1;