Koha/XSLT/Base.pm

   1 package Koha::XSLT::Base;
   2
   3 # Copyright 2014, 2019 Rijksmuseum, Prosentient Systems
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 =head1 NAME
  21
  22 Koha::XSLT::Base - Facilitate use of XSLT transformations
  23
  24 =head1 SYNOPSIS
  25
  26     use Koha::XSLT::Base;
  27     my $xslt_engine = Koha::XSLT::Base->new;
  28     my $output = $xslt_engine->transform($xml, $xsltfilename);
  29     $output = $xslt_engine->transform({ xml => $xml, file => $file });
  30     $output = $xslt_engine->transform({ xml => $xml, code => $code });
  31     my $err= $xslt_engine->err; # error code
  32     $xslt_engine->refresh($xsltfilename);
  33
  34 =head1 DESCRIPTION
  35
  36     A XSLT handler object on top of LibXML and LibXSLT, allowing you to
  37     run XSLT stylesheets repeatedly without loading them again.
  38     Errors occurring during loading, parsing or transforming are reported
  39     via the err attribute.
  40     Reloading XSLT files can be done with the refresh method.
  41
  42     The module refers to a (temporary) helper module Koha::XSLT::HTTPS that
  43     resolves issues in libxml2/libxslt for https references.
  44
  45 =head1 METHODS
  46
  47 =head2 new
  48
  49     Create handler object
  50
  51 =head2 transform
  52
  53     Run transformation for specific string and stylesheet
  54
  55 =head2 refresh
  56
  57     Allow to reload stylesheets when transforming again
  58
  59 =head1 PROPERTIES
  60
  61 =head2 err
  62
  63     Error code (see list of ERROR CODES)
  64
  65 =head2 do_not_return_source
  66
  67     If true, transform returns undef on failure. By default, it returns the
  68     original string passed. Errors are reported as described.
  69
  70 =head2 print_warns
  71
  72     If set, print error messages to STDERR. False by default.
  73
  74 =head1 ERROR CODES
  75
  76 =head2 Error XSLTH_ERR_NO_FILE
  77
  78     No XSLT file passed
  79
  80 =head2 Error XSLTH_ERR_FILE_NOT_FOUND
  81
  82     XSLT file not found
  83
  84 =head2 Error XSLTH_ERR_LOADING
  85
  86     Error while loading stylesheet xml: [optional warnings]
  87
  88 =head2 Error XSLTH_ERR_PARSING_CODE
  89
  90     Error while parsing stylesheet: [optional warnings]
  91
  92 =head2 Error XSLTH_ERR_PARSING_DATA
  93
  94     Error while parsing input: [optional warnings]
  95
  96 =head2 Error XSLTH_ERR_TRANSFORMING
  97
  98     Error while transforming input: [optional warnings]
  99
 100 =head2 Error XSLTH_NO_STRING_PASSED
 101
 102     No string to transform
 103
 104 =head1 INTERNALS
 105
 106     For documentation purposes. You are not encouraged to access them.
 107
 108 =head2 last_xsltfile
 109
 110     Contains the last successfully executed XSLT filename
 111
 112 =head2 xslt_hash
 113
 114     Hash reference to loaded stylesheets
 115
 116 =head1 ADDITIONAL COMMENTS
 117
 118 =cut
 119
 120 use Modern::Perl;
 121 use XML::LibXML;
 122 use XML::LibXSLT;
 123 use Koha::XSLT::HTTPS;
 124 use Koha::XSLT::Security;
 125
 126 use base qw(Class::Accessor);
 127
 128 __PACKAGE__->mk_ro_accessors(qw( err ));
 129 __PACKAGE__->mk_accessors(qw( do_not_return_source print_warns ));
 130
 131 use constant XSLTH_ERR_1    => 'XSLTH_ERR_NO_FILE';
 132 use constant XSLTH_ERR_2    => 'XSLTH_ERR_FILE_NOT_FOUND';
 133 use constant XSLTH_ERR_3    => 'XSLTH_ERR_LOADING';
 134 use constant XSLTH_ERR_4    => 'XSLTH_ERR_PARSING_CODE';
 135 use constant XSLTH_ERR_5    => 'XSLTH_ERR_PARSING_DATA';
 136 use constant XSLTH_ERR_6    => 'XSLTH_ERR_TRANSFORMING';
 137 use constant XSLTH_ERR_7    => 'XSLTH_NO_STRING_PASSED';
 138
 139 =head2 new
 140
 141     my $xslt_engine = Koha::XSLT::Base->new;
 142
 143 =cut
 144
 145 sub new {
 146     my ($class, $params) = @_;
 147     my $self = $class->SUPER::new($params);
 148     $self->{_security} = Koha::XSLT::Security->new;
 149     $self->{_security}->register_callbacks;
 150     return $self;
 151 }
 152
 153 =head2 transform
 154
 155     my $output= $xslt_engine->transform( $xml, $xsltfilename, [$format] );
 156     #Alternatively:
 157     #$output = $xslt_engine->transform({ xml => $xml, file => $file, [parameters => $parameters], [format => ['chars'|'bytes'|'xmldoc']] });
 158     #$output = $xslt_engine->transform({ xml => $xml, code => $code, [parameters => $parameters], [format => ['chars'|'bytes'|'xmldoc']] });
 159     if( $xslt_engine->err ) {
 160         #decide what to do on failure..
 161     }
 162     my $output2= $xslt_engine->transform( $xml2 );
 163
 164     Pass a xml string and a fully qualified path of a XSLT file.
 165     Instead of a filename, you may also pass a URL.
 166     You may also pass the contents of a xsl file as a string like $code above.
 167     If you do not pass a filename, the last file used is assumed.
 168     Normally returns the transformed string; if you pass format => 'xmldoc' in
 169     the hash format, it returns a xml document object.
 170     Check the error number in err to know if something went wrong.
 171     In that case do_not_return_source did determine the return value.
 172
 173 =cut
 174
 175 sub transform {
 176     my $self = shift;
 177
 178     #check parameters
 179     #  old style: $xml, $filename, $format
 180     #  new style: $hashref
 181     my ( $xml, $filename, $xsltcode, $format );
 182     my $parameters = {};
 183     if( ref $_[0] eq 'HASH' ) {
 184         $xml = $_[0]->{xml};
 185         $xsltcode = $_[0]->{code};
 186         $filename = $_[0]->{file} if !$xsltcode; #xsltcode gets priority
 187         $parameters = $_[0]->{parameters} if ref $_[0]->{parameters} eq 'HASH';
 188         $format = $_[0]->{format} || 'chars';
 189     } else {
 190         ( $xml, $filename, $format ) = @_;
 191         $format ||= 'chars';
 192     }
 193
 194     #Initialized yet?
 195     if ( !$self->{xslt_hash} ) {
 196         $self->_init;
 197     }
 198     else {
 199         $self->_set_error;    #clear last error
 200     }
 201     my $retval = $self->{do_not_return_source} ? undef : $xml;
 202
 203     #check if no string passed
 204     if ( !defined $xml ) {
 205         $self->_set_error( XSLTH_ERR_7 );
 206         return;               #always undef
 207     }
 208
 209     #load stylesheet
 210     my $key = $self->_load( $filename, $xsltcode );
 211     my $stsh = $key? $self->{xslt_hash}->{$key}: undef;
 212     return $retval if $self->{err};
 213
 214     #parse input and transform
 215     my $parser = XML::LibXML->new();
 216     $self->{_security}->set_parser_options($parser);
 217     my $source = eval { $parser->parse_string($xml) };
 218     if ($@) {
 219         $self->_set_error( XSLTH_ERR_5, $@ );
 220         return $retval;
 221     }
 222     my $result = eval {
 223         #$parameters is an optional hashref that contains
 224         #key-value pairs to be sent to the XSLT.
 225         #Numbers may be bare but strings must be double quoted
 226         #(e.g. "'string'" or '"string"'). See XML::LibXSLT for
 227         #more details.
 228
 229         #NOTE: Parameters are not cached. They are provided for
 230         #each different transform.
 231         my $transformed = $stsh->transform($source, %$parameters);
 232         $format eq 'bytes'
 233             ? $stsh->output_as_bytes( $transformed )
 234             : $format eq 'xmldoc'
 235             ? $transformed
 236             : $stsh->output_as_chars( $transformed ); # default: chars
 237     };
 238     if ($@) {
 239         $self->_set_error( XSLTH_ERR_6, $@ );
 240         return $retval;
 241     }
 242     $self->{last_xsltfile} = $key;
 243     return $result;
 244 }
 245
 246 =head2 refresh
 247
 248     $xslt_engine->refresh;
 249     $xslt_engine->refresh( $xsltfilename );
 250
 251     Pass a file for an individual refresh or no file to refresh all.
 252     Refresh returns the number of items affected.
 253     What we actually do, is just clear the internal cache for reloading next
 254     time when transform is called.
 255     The return value is mainly theoretical. Since this is supposed to work
 256     always(...), there is no actual need to test it.
 257     Note that refresh does also clear the error information.
 258
 259 =cut
 260
 261 sub refresh {
 262     my ( $self, $file ) = @_;
 263     $self->_set_error;
 264     return if !$self->{xslt_hash};
 265     my $rv;
 266     if ($file) {
 267         $rv = delete $self->{xslt_hash}->{$file} ? 1 : 0;
 268     }
 269     else {
 270         $rv = scalar keys %{ $self->{xslt_hash} };
 271         $self->{xslt_hash} = {};
 272     }
 273     return $rv;
 274 }
 275
 276 # **************  INTERNAL ROUTINES ********************************************
 277
 278 # _init
 279 # Internal routine for initialization.
 280
 281 sub _init {
 282     my $self = shift;
 283
 284     $self->_set_error;
 285     $self->{xslt_hash} = {};
 286     $self->{print_warns} = 1 unless exists $self->{print_warns};
 287     $self->{do_not_return_source} = 0
 288       unless exists $self->{do_not_return_source};
 289
 290     #by default we return source on a failing transformation
 291     #but it could be passed at construction time already
 292     return;
 293 }
 294
 295 # _load
 296 # Internal routine for loading a new stylesheet.
 297
 298 sub _load {
 299     my ( $self, $filename, $code ) = @_;
 300     my ( $digest, $codelen, $salt, $rv );
 301     $salt = 'AZ'; #just a constant actually
 302
 303     #If no file or code passed, use the last file again
 304     if ( !$filename && !$code ) {
 305         my $last = $self->{last_xsltfile};
 306         if ( !$last || !exists $self->{xslt_hash}->{$last} ) {
 307             $self->_set_error( XSLTH_ERR_1 );
 308             return;
 309         }
 310         return $last;
 311     }
 312
 313     #check if it is loaded already
 314     if( $code ) {
 315         $codelen = length( $code );
 316         $digest = eval { crypt($code, $salt) };
 317         if( $digest && exists $self->{xslt_hash}->{$digest.$codelen} ) {
 318             return $digest.$codelen;
 319         }
 320     } elsif( $filename && exists $self->{xslt_hash}->{$filename} ) {
 321           return $filename;
 322     }
 323
 324     #Check file existence (skipping URLs)
 325     if( $filename && $filename !~ /^https?:\/\// && !-e $filename ) {
 326         $self->_set_error( XSLTH_ERR_2 );
 327         return;
 328     }
 329
 330     #load sheet
 331     my $parser = XML::LibXML->new;
 332     $self->{_security}->set_parser_options($parser);
 333     my $style_doc = eval {
 334         $parser->load_xml( $self->_load_xml_args($filename, $code) )
 335     };
 336     if ($@) {
 337         $self->_set_error( XSLTH_ERR_3, $@ );
 338         return;
 339     }
 340
 341     #parse sheet
 342     my $xslt = XML::LibXSLT->new;
 343     $self->{_security}->set_callbacks($xslt);
 344
 345     $rv = $code? $digest.$codelen: $filename;
 346     $self->{xslt_hash}->{$rv} = eval { $xslt->parse_stylesheet($style_doc) };
 347     if ($@) {
 348         $self->_set_error( XSLTH_ERR_4, $@ );
 349         delete $self->{xslt_hash}->{$rv};
 350         return;
 351     }
 352     return $rv;
 353 }
 354
 355 sub _load_xml_args {
 356     my ( $self, $filename, $code ) = @_;
 357     return Koha::XSLT::HTTPS->load($filename) if $filename && $filename =~ /^https/i;
 358         # Workaround for current problems with https location in libxml2/libxslt
 359         # Returns response like { string => SOME_CODE }
 360     return $code ? { string => $code } : { location => $filename };
 361 }
 362
 363 # _set_error
 364 # Internal routine for handling error information.
 365
 366 sub _set_error {
 367     my ( $self, $errcode, $warn ) = @_;
 368
 369     $self->{err} = $errcode; #set or clear error
 370     warn 'XSLT::Base: '. $warn if $warn && $self->{print_warns};
 371 }
 372
 373 =head1 AUTHOR
 374
 375     Marcel de Rooy, Rijksmuseum Netherlands
 376     David Cook, Prosentient Systems
 377
 378 =cut
 379
 380 1;