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