/[cvs]/nfo/perl/libs/XML/XSLT.pm
ViewVC logotype

Annotation of /nfo/perl/libs/XML/XSLT.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Thu May 1 20:10:36 2003 UTC (21 years, 6 months ago) by joko
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +6 -2 lines
increased version number to 0.41

1 joko 1.1 ##############################################################################
2     #
3     # Perl module: XML::XSLT
4     #
5     # By Geert Josten, gjosten@sci.kun.nl
6     # and Egon Willighagen, egonw@sci.kun.nl
7     #
8 joko 1.3 # $Log$
9     # Revision x.xx 2003/04/30 00:06:55 joko
10     # * sub __evaluate_test__ now detects a variable name in
11     # an lvalue of an expression (e.g. $var=val, {$var}=val)
12     #
13 joko 1.1 # Revision 1.19 2002/02/18 09:05:14 gellyfish
14     # Refactoring
15     #
16     # Revision 1.18 2002/01/16 21:05:27 gellyfish
17     # * Added the manpage as an example
18     # * Started to properly implement omit-xml-declaration
19     #
20     # Revision 1.17 2002/01/13 10:35:00 gellyfish
21     # Updated pod
22     #
23     # Revision 1.16 2002/01/09 09:17:40 gellyfish
24     # * added test for <xsl:text>
25     # * Stylesheet whitespace stripping as per spec and altered tests ...
26     #
27     # Revision 1.15 2002/01/08 10:11:47 gellyfish
28     # * First cut at cdata-section-element
29     # * test for above
30     #
31     # Revision 1.14 2001/12/24 16:00:19 gellyfish
32     # * Version released to CPAN
33     #
34     # Revision 1.13 2001/12/20 09:21:42 gellyfish
35     # More refactoring
36     #
37     # Revision 1.12 2001/12/19 21:06:31 gellyfish
38     # * Some refactoring and style changes
39     #
40     # Revision 1.11 2001/12/19 09:11:14 gellyfish
41     # * Added more accessors for object attributes
42     # * Fixed potentially broken usage of $variables in _evaluate_template
43     #
44     # Revision 1.10 2001/12/18 09:10:10 gellyfish
45     # Implemented attribute-sets
46     #
47     # Revision 1.9 2001/12/17 22:32:12 gellyfish
48     # * Added Test::More to Makefile.PL
49     # * Added _indent and _outdent methods
50     # * Placed __get_attribute_sets in transform()
51     #
52     # Revision 1.8 2001/12/17 11:32:08 gellyfish
53     # * Rolled in various patches
54     # * Added new tests
55     #
56     #
57     ###############################################################################
58    
59     =head1 NAME
60    
61     XML::XSLT - A perl module for processing XSLT
62    
63     =cut
64    
65    
66     ######################################################################
67     package XML::XSLT;
68     ######################################################################
69    
70     use strict;
71    
72     use XML::DOM 1.25;
73     use LWP::Simple qw(get);
74     use URI;
75     use Cwd;
76     use File::Basename qw(dirname);
77     use Carp;
78    
79     # Namespace constants
80    
81     use constant NS_XSLT => 'http://www.w3.org/1999/XSL/Transform';
82     use constant NS_XHTML => 'http://www.w3.org/TR/xhtml1/strict';
83    
84     use vars qw ( $VERSION @ISA @EXPORT_OK $AUTOLOAD );
85    
86 joko 1.3 $VERSION = '0.41';
87 joko 1.1
88     @ISA = qw( Exporter );
89     @EXPORT_OK = qw( &transform &serve );
90    
91    
92    
93     my %deprecation_used;
94    
95    
96     ######################################################################
97     # PUBLIC DEFINITIONS
98    
99     sub new {
100     my $class = shift;
101     my $self = bless {}, $class;
102     my %args = $self->__parse_args(@_);
103    
104     $self->{DEBUG} = defined $args{debug} ? $args{debug} : "";
105     $self->{PARSER} = XML::DOM::Parser->new;
106     $self->{PARSER_ARGS} = defined $args{DOMparser_args}
107     ? $args{DOMparser_args} : {};
108     $self->{VARIABLES} = defined $args{variables}
109     ? $args{variables} : {};
110     $self->{WARNINGS} = defined $args{warnings}
111     ? $args{warnings} : 0;
112     $self->{INDENT} = defined $args{indent}
113     ? $args{indent} : 0;
114     $self->{INDENT_INCR} = defined $args{indent_incr}
115     ? $args{indent_incr} : 1;
116     $self->{XSL_BASE} = defined $args{base}
117     ? $args{base} : 'file://' . cwd . '/';
118     $self->{XML_BASE} = defined $args{base}
119     ? $args{base} : 'file://' . cwd . '/';
120    
121     $self->use_deprecated($args{use_deprecated}) if exists $args{use_deprecated};
122    
123     $self->debug("creating parser object:");
124    
125     $self->_indent();
126     $self->open_xsl(%args);
127     $self->_outdent();
128    
129     return $self;
130     }
131    
132     sub use_deprecated
133     {
134     my ( $self, $use_deprecated ) = @_;
135    
136     if ( defined $use_deprecated )
137     {
138     $self->{USE_DEPRECATED} = $use_deprecated;
139     }
140    
141     return $self->{USE_DEPRECATED} || 0;
142     }
143    
144     sub DESTROY {} # Cuts out random dies on includes
145    
146     sub default_xml_version
147     {
148     my ( $self, $xml_version ) = @_;
149    
150     if ( defined $xml_version )
151     {
152     $self->{DEFAULT_XML_VERSION} = $xml_version;
153     }
154    
155     return $self->{DEFAULT_XML_VERSION} ||= '1.0';
156     }
157    
158     sub serve {
159     my $self = shift;
160     my $class = ref $self || croak "Not a method call";
161     my %args = $self->__parse_args(@_);
162     my $ret;
163    
164     $args{http_headers} = 1 unless defined $args{http_headers};
165     $args{xml_declaration} = 1 unless defined $args{xml_declaration};
166     $args{xml_version} = $self->default_xml_version()
167     unless defined $args{xml_version};
168     $args{doctype} = 'SYSTEM' unless defined $args{doctype};
169     $args{clean} = 0 unless defined $args{clean};
170    
171     $ret = $self->transform($args{Source})->toString;
172    
173     if($args{clean}) {
174     eval {require HTML::Clean};
175    
176     if($@) {
177     CORE::warn("Not passing through HTML::Clean -- install the module");
178     } else {
179     my $hold = HTML::Clean->new(\$ret);
180     $hold->strip;
181     $ret = ${$hold->data};
182     }
183     }
184    
185    
186    
187     if (my $doctype = $self->doctype())
188     {
189     $ret = $doctype . "\n" . $ret;
190     }
191    
192    
193     if($args{xml_declaration})
194     {
195     $ret = $self->xml_declaration() . "\n" . $ret;
196     }
197    
198     if($args{http_headers}) {
199     $ret = "Content-Type: " . $self->media_type . "\n" .
200     "Content-Length: " . length($ret) . "\n\n" . $ret;
201     }
202    
203     return $ret;
204     }
205    
206    
207     sub xml_declaration
208     {
209     my ( $self, $xml_version, $output_encoding ) = @_;
210    
211     $xml_version ||= $self->default_xml_version();
212     $output_encoding ||= $self->output_encoding();
213    
214     return qq{<?xml version="$xml_version" encoding="$output_encoding"?>};
215     }
216    
217    
218    
219     sub output_encoding
220     {
221     my ( $self,$encoding ) = @_;
222    
223     if ( defined $encoding )
224     {
225     $self->{OUTPUT_ENCODING} = $encoding;
226     }
227    
228     return exists $self->{OUTPUT_ENCODING} ? $self->{OUTPUT_ENCODING} : 'UTF-8';
229     }
230    
231     sub doctype_system
232     {
233     my ( $self, $doctype ) = @_;
234    
235     if ( defined $doctype )
236     {
237     $self->{DOCTYPE_SYSTEM} = $doctype;
238     }
239    
240     return $self->{DOCTYPE_SYSTEM};
241     }
242    
243     sub doctype_public
244     {
245     my ( $self, $doctype ) = @_;
246    
247     if ( defined $doctype )
248     {
249     $self->{DOCTYPE_PUBLIC} = $doctype;
250     }
251    
252     return $self->{DOCTYPE_PUBLIC};
253     }
254    
255     sub result_document()
256     {
257     my ( $self, $document ) = @_;
258    
259     if ( defined $document )
260     {
261     $self->{RESULT_DOCUMENT} = $document;
262     }
263    
264     return $self->{RESULT_DOCUMENT};
265     }
266    
267     sub debug {
268     my $self = shift;
269     my $arg = shift || "";
270    
271     print STDERR " "x$self->{INDENT},"$arg\n"
272     if $self->{DEBUG};
273     }
274    
275     sub warn {
276     my $self = shift;
277     my $arg = shift || "";
278    
279     print STDERR " "x$self->{INDENT},"$arg\n"
280     if $self->{DEBUG};
281     print STDERR "$arg\n"
282     if $self->{WARNINGS} && ! $self->{DEBUG};
283     }
284    
285     sub open_xml {
286     my $self = shift;
287     my $class = ref $self || croak "Not a method call";
288     my %args = $self->__parse_args(@_);
289    
290     if(defined $self->xml_document() && not $self->{XML_PASSED_AS_DOM}) {
291     $self->debug("flushing old XML::DOM::Document object...");
292     $self->xml_document()->dispose;
293     }
294    
295     $self->{XML_PASSED_AS_DOM} = 1
296     if ref $args{Source} eq 'XML::DOM::Document';
297    
298     if (defined $self->result_document()) {
299     $self->debug("flushing result...");
300     $self->result_document()->dispose ();
301     }
302    
303     $self->debug("opening xml...");
304    
305     $args{parser_args} ||= {};
306    
307     my $xml_document = $self->__open_document (Source => $args{Source},
308     base => $self->{XML_BASE},
309     parser_args =>
310     {%{$self->{PARSER_ARGS}},
311     %{$args{parser_args}}},
312     );
313    
314     $self->xml_document($xml_document);
315    
316     $self->{XML_BASE} =
317     dirname(URI->new_abs($args{Source}, $self->{XML_BASE})->as_string) . '/';
318     $self->result_document($self->xml_document()->createDocumentFragment);
319     }
320    
321     sub xml_document
322     {
323     my ( $self, $xml_document ) = @_;
324    
325     if ( defined $xml_document )
326     {
327     $self->{XML_DOCUMENT} = $xml_document;
328     }
329    
330     return $self->{XML_DOCUMENT};
331     }
332    
333     sub open_xsl {
334     my $self = shift;
335     my $class = ref $self || croak "Not a method call";
336     my %args = $self->__parse_args(@_);
337    
338     $self->xsl_document()->dispose
339     if not $self->{XSL_PASSED_AS_DOM} and defined $self->xsl_document();
340    
341     $self->{XSL_PASSED_AS_DOM} = 1
342     if ref $args{Source} eq 'XML::DOM::Document';
343    
344     # open new document # open new document
345     $self->debug("opening xsl...");
346    
347     $args{parser_args} ||= {};
348    
349     my $xsl_document = $self->__open_document (Source => $args{Source},
350     base => $self->{XSL_BASE},
351     parser_args =>
352     {%{$self->{PARSER_ARGS}},
353     %{$args{parser_args}}},
354     );
355    
356     $self->xsl_document($xsl_document);
357    
358     $self->{XSL_BASE} =
359     dirname(URI->new_abs($args{Source}, $self->{XSL_BASE})->as_string) . '/';
360    
361     $self->__preprocess_stylesheet;
362     }
363    
364     sub xsl_document
365     {
366     my ( $self, $xsl_document ) = @_;
367    
368     if ( defined $xsl_document )
369     {
370     $self->{XSL_DOCUMENT} = $xsl_document;
371     }
372    
373     return $self->{XSL_DOCUMENT};
374     }
375    
376     # Argument parsing with backwards compatibility.
377     sub __parse_args {
378     my $self = shift;
379     my %args;
380    
381     if(@_ % 2 ) {
382     $args{Source} = shift;
383     %args = (%args, @_);
384     } else {
385     %args = @_;
386     if(not exists $args{Source}) {
387     my $name = [caller(1)]->[3];
388     carp "Argument syntax of call to $name deprecated. See the documentation for $name"
389     unless $self->use_deprecated()
390     or exists $deprecation_used{$name};
391     $deprecation_used{$name} = 1;
392     %args = ();
393     $args{Source} = shift;
394     shift;
395     %args = (%args, @_);
396     }
397     }
398    
399     return %args;
400     }
401    
402     # private auxiliary function #
403     sub __my_tag_compression {
404     my ($tag, $elem) = @_;
405    
406     =begin internal_docs
407    
408     __my_tag_compression__( $tag, $elem )
409    
410     A function for DOM::XML::setTagCompression to determine the style for printing
411     of empty tags and empty container tags.
412    
413     XML::XSLT implements an XHTML-friendly style.
414    
415     Allow tag to be preceded by a namespace: ([\w\.]+\:){0,1}
416    
417     <br> -> <br />
418    
419     or
420    
421     <myns:hr> -> <myns:hr />
422    
423     Empty tag list obtained from:
424    
425     http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd
426    
427     According to "Appendix C. HTML Compatibility Guidelines",
428     C.3 Element Minimization and Empty Element Content
429    
430     Given an empty instance of an element whose content model is not EMPTY
431     (for example, an empty title or paragraph) do not use the minimized form
432     (e.g. use <p> </p> and not <p />).
433    
434     However, the <p> tag is processed like an empty tag here!
435    
436     Tags allowed:
437    
438     base meta link hr br param img area input col
439    
440     Special Case: p (even though it violates C.3)
441    
442     The tags are matched in order of expected common occurence.
443    
444     =end internal_docs
445    
446     =cut
447    
448     $tag = [split ':', $tag]->[1] if index($tag, ':') >= 0;
449     return 2 if $tag =~ m/^(p|br|img|hr|input|meta|base|link|param|area|col)$/i;
450    
451     # Print other empty tags like this: <empty></empty>
452     return 1;
453     }
454    
455    
456     # private auxiliary function #
457     sub __preprocess_stylesheet {
458     my $self = $_[0];
459    
460     $self->debug("preprocessing stylesheet...");
461    
462     $self->__get_first_element;
463     $self->__extract_namespaces;
464     $self->__get_stylesheet;
465    
466     # Why is this here when __get_first_element does, apparently, the same thing?
467     # Because, in __get_stylesheet we warp the document.
468     $self->top_xsl_node($self->xsl_document()->getFirstChild);
469     $self->__expand_xsl_includes;
470     $self->__extract_top_level_variables;
471    
472     $self->__add_default_templates;
473     $self->__cache_templates; # speed optim
474    
475     $self->__set_xsl_output;
476     }
477    
478     sub top_xsl_node
479     {
480     my ( $self, $top_xsl_node) = @_;
481    
482     if ( defined $top_xsl_node )
483     {
484     $self->{TOP_XSL_NODE} = $top_xsl_node;
485     }
486    
487     return $self->{TOP_XSL_NODE};
488     }
489    
490     # private auxiliary function #
491    
492     sub __get_stylesheet {
493     my $self = shift;
494     my $stylesheet;
495     my $xsl_ns = $self->xsl_ns();
496     my $xsl = $self->xsl_document();
497    
498     foreach my $child ($xsl->getElementsByTagName ('*', 0))
499     {
500 joko 1.2 my ($ns, $tag) = split(':', $child->getTagName());
501 joko 1.1 if(not defined $tag)
502     {
503     $tag = $ns;
504     $ns = $self->default_ns();
505     }
506     if ($tag eq 'stylesheet' || $tag eq 'transform')
507     {
508     if ( my $attributes = $child->getAttributes())
509     {
510     my $version = $attributes->getNamedItem('version');
511    
512     $self->xslt_version($version->getNodeValue()) if $version;
513     }
514    
515     $stylesheet = $child;
516     last;
517     }
518     }
519    
520     if (! $stylesheet) {
521     # stylesheet is actually one complete template!
522     # put it in a template-element
523    
524     $stylesheet = $xsl->createElement ("$ {xsl_ns}stylesheet");
525     my $template = $xsl->createElement ("$ {xsl_ns}template");
526     $template->setAttribute ('match', "/");
527    
528     my $template_content = $xsl->getElementsByTagName ('*', 0)->item (0);
529     $xsl->replaceChild ($stylesheet, $template_content);
530     $stylesheet->appendChild ($template);
531     $template->appendChild ($template_content);
532     }
533    
534     $self->xsl_document($stylesheet);
535     }
536    
537     sub xslt_version
538     {
539     my ( $self, $xslt_version ) = @_;
540    
541     if ( defined $xslt_version )
542     {
543     $self->{XSLT_VERSION} = $xslt_version;
544     }
545    
546     return $self->{XSLT_VERSION} ||= '1.0';
547     }
548    
549     # private auxiliary function #
550     sub __get_first_element {
551     my ($self) = @_;
552     my $node = $self->xsl_document()->getFirstChild();
553    
554     $node = $node->getNextSibling
555     until ref $node eq 'XML::DOM::Element';
556     $self->top_xsl_node($node);
557     }
558    
559     # private auxiliary function #
560     sub __extract_namespaces {
561     my ($self) = @_;
562    
563     my $attr = $self->top_xsl_node()->getAttributes;
564     if(defined $attr) {
565     foreach my $attribute ($self->top_xsl_node()->getAttributes->getValues) {
566     my ($pre, $post) = split(":", $attribute->getName, 2);
567     my $value = $attribute->getValue;
568    
569     # Take care of namespaces
570     if ($pre eq 'xmlns' and not defined $post) {
571     $self->default_ns('');
572    
573     $self->{NAMESPACE}->{$self->default_ns()}->{namespace} = $value;
574     $self->xsl_ns('')
575     if $value eq NS_XSLT;
576     $self->debug("Namespace `" . $self->default_ns() . "' = `$value'");
577     } elsif ($pre eq 'xmlns') {
578     $self->{NAMESPACE}->{$post}->{namespace} = $value;
579     $self->xsl_ns("$post:")
580     if $value eq NS_XSLT;
581     $self->debug("Namespace `$post:' = `$value'");
582     } else {
583     $self->default_ns('');
584     }
585    
586     # Take care of versions
587     if ($pre eq "version" and not defined $post) {
588     $self->{NAMESPACE}->{$self->default_ns()}->{version} = $value;
589     $self->debug("Version for namespace `" . $self->default_ns() .
590     "' = `$value'");
591     } elsif ($pre eq "version") {
592     $self->{NAMESPACE}->{$post}->{version} = $value;
593     $self->debug("Version for namespace `$post:' = `$value'");
594     }
595     }
596     }
597     if (not defined $self->default_ns()) {
598     my ($dns) = split(':', $self->top_xsl_node()->getTagName);
599     $self->default_ns($dns);
600     }
601     $self->debug("Default Namespace: `" . $self->default_ns() . "'");
602     $self->xsl_ns($self->default_ns()) unless $self->xsl_ns();
603    
604     $self->debug("XSL Namespace: `" .$self->xsl_ns() ."'");
605     # ** FIXME: is this right?
606     $self->{NAMESPACE}->{$self->default_ns()}->{namespace} ||= NS_XHTML;
607     }
608    
609     sub default_ns
610     {
611     my ( $self, $default_ns ) = @_;
612    
613     if ( defined $default_ns )
614     {
615     $self->{DEFAULT_NS} = $default_ns;
616     }
617     return exists $self->{DEFAULT_NS} ? $self->{DEFAULT_NS} : undef;
618     }
619    
620     sub xsl_ns
621     {
622     my ( $self, $prefix ) = @_;
623    
624     if ( defined $prefix )
625     {
626     $prefix .= ':' unless $prefix =~ /:$/;
627     $self->{XSL_NS} = $prefix;
628     }
629     return $self->{XSL_NS};
630     }
631    
632     # private auxiliary function #
633     sub __expand_xsl_includes {
634     my $self = shift;
635    
636     foreach my $include_node
637     ($self->top_xsl_node()->getElementsByTagName($self->xsl_ns() . "include"))
638     {
639     my $include_file = $include_node->getAttribute('href');
640    
641     die "include tag carries no selection!"
642     unless defined $include_file;
643    
644     my $include_doc;
645     eval {
646     my $tmp_doc =
647     $self->__open_by_filename($include_file, $self->{XSL_BASE});
648     $include_doc = $tmp_doc->getFirstChild->cloneNode(1);
649     $tmp_doc->dispose;
650     };
651     die "parsing of $include_file failed: $@"
652     if $@;
653    
654     $self->debug("inserting `$include_file'");
655     $include_doc->setOwnerDocument($self->xsl_document());
656     $self->top_xsl_node()->replaceChild($include_doc, $include_node);
657     $include_doc->dispose;
658     }
659     }
660    
661     # private auxiliary function #
662     sub __extract_top_level_variables {
663     my $self = $_[0];
664    
665     $self->debug("Extracting variables");
666     foreach my $child ($self->top_xsl_node()->getElementsByTagName ('*',0)) {
667     my ($ns, $tag) = split(':', $child);
668    
669     if(($tag eq '' && $self->xsl_ns() eq '') ||
670     $self->xsl_ns() eq $ns) {
671     $tag = $ns if $tag eq '';
672    
673     if ($tag eq 'variable' || $tag eq 'param') {
674    
675     my $name = $child->getAttribute("name");
676     if ($name) {
677     my $value = $child->getAttribute("select");
678     if (!$value) {
679     my $result = $self->xml_document()->createDocumentFragment;
680     $self->_evaluate_template ($child, $self->xml_document(), '',
681     $result);
682     $value = $self->_string ($result);
683     $result->dispose();
684     }
685     $self->debug("Setting $tag `$name' = `$value'");
686     $self->{VARIABLES}->{$name} = $value;
687     } else {
688     # Required, so we die (http://www.w3.org/TR/xslt#variables)
689     die "$tag tag carries no name!";
690     }
691     }
692     }
693     }
694     }
695    
696     # private auxiliary function #
697     sub __add_default_templates {
698     my $self = $_[0];
699     my $doc = $self->top_xsl_node()->getOwnerDocument;
700    
701     # create template for '*' and '/'
702     my $elem_template =
703     $doc->createElement
704     ($self->xsl_ns() . "template");
705     $elem_template->setAttribute('match','*|/');
706    
707     # <xsl:apply-templates />
708     $elem_template->appendChild
709     ($doc->createElement
710     ($self->xsl_ns() . "apply-templates"));
711    
712     # create template for 'text()' and '@*'
713     my $attr_template =
714     $doc->createElement
715     ($self->xsl_ns() . "template");
716     $attr_template->setAttribute('match','text()|@*');
717    
718     # <xsl:value-of select="." />
719     $attr_template->appendChild
720     ($doc->createElement
721     ($self->xsl_ns() . "value-of"));
722     $attr_template->getFirstChild->setAttribute('select','.');
723    
724     # create template for 'processing-instruction()' and 'comment()'
725     my $pi_template =
726     $doc->createElement($self->xsl_ns() . "template");
727     $pi_template->setAttribute('match','processing-instruction()|comment()');
728    
729     $self->debug("adding default templates to stylesheet");
730     # add them to the stylesheet
731     $self->xsl_document()->insertBefore($pi_template,
732     $self->top_xsl_node);
733     $self->xsl_document()->insertBefore($attr_template,
734     $self->top_xsl_node());
735     $self->xsl_document()->insertBefore($elem_template,
736     $self->top_xsl_node());
737     }
738    
739    
740     sub templates
741     {
742     my ( $self, $templates ) = @_;
743    
744     if ( defined $templates )
745     {
746     $self->{TEMPLATE} = $templates;
747     }
748    
749     unless ( exists $self->{TEMPLATE} )
750     {
751     $self->{TEMPLATE} = [];
752     my $xsld = $self->xsl_document();
753     my $tag = $self->xsl_ns() . 'template';
754    
755     @{$self->{TEMPLATE}} = $xsld->getElementsByTagName($tag);
756     }
757    
758     return wantarray ? @{$self->{TEMPLATE}} : $self->{TEMPLATE};
759     }
760    
761     # private auxiliary function #
762     sub __cache_templates {
763     my $self = $_[0];
764    
765    
766     # pre-cache template names and matches #
767     # reversing the template order is much more efficient #
768    
769     foreach my $template (reverse $self->templates()) {
770     if ($template->getParentNode->getTagName =~
771     /^([\w\.\-]+\:){0,1}(stylesheet|transform|include)/) {
772     my $match = $template->getAttribute ('match');
773     my $name = $template->getAttribute ('name');
774     if ($match && $name) {
775     $self->warn(qq{defining a template with both a "name" and a "match" attribute is not allowed!});
776     push (@{$self->{TEMPLATE_MATCH}}, "");
777     push (@{$self->{TEMPLATE_NAME}}, "");
778     } elsif ($match) {
779     push (@{$self->{TEMPLATE_MATCH}}, $match);
780     push (@{$self->{TEMPLATE_NAME}}, "");
781     } elsif ($name) {
782     push (@{$self->{TEMPLATE_MATCH}}, "");
783     push (@{$self->{TEMPLATE_NAME}}, $name);
784     } else {
785     push (@{$self->{TEMPLATE_MATCH}}, "");
786     push (@{$self->{TEMPLATE_NAME}}, "");
787     }
788     }
789     }
790     }
791    
792     # private auxiliary function #
793     sub __set_xsl_output {
794     my $self = $_[0];
795    
796     # default settings
797     $self->{METHOD} = 'xml';
798     $self->media_type('text/xml');
799    
800     # extraction of top-level xsl:output tag
801     my ($output) =
802     $self->xsl_document()->getElementsByTagName($self->xsl_ns() . "output",0);
803    
804     if (defined $output) {
805     # extraction and processing of the attributes
806     my $attribs = $output->getAttributes;
807     my $media = $attribs->getNamedItem('media-type');
808     my $method = $attribs->getNamedItem('method');
809     $self->media_type($media->getNodeValue) if defined $media;
810     $self->{METHOD} = $method->getNodeValue if defined $method;
811    
812     if (my $omit = $attribs->getNamedItem('omit-xml-declaration'))
813     {
814     if ($omit->getNodeValue() =~ /^(yes|no)$/)
815     {
816     $self->omit_xml_declaration($1);
817     }
818     else
819     {
820    
821     # I would say that this should be fatal
822     # Perhaps there should be a 'strict' option to the constructor
823    
824     my $m = qq{Wrong value for attribute "omit-xml-declaration" in\n\t} .
825     $self->xsl_ns() . qq{output, should be "yes" or "no"};
826     $self->warn($m);
827     }
828     }
829    
830     unless ( $self->omit_xml_declaration())
831     {
832     my $output_ver = $attribs->getNamedItem('version');
833     my $output_enc = $attribs->getNamedItem('encoding');
834     $self->output_version($output_ver->getNodeValue)
835     if defined $output_ver;
836     $self->output_encoding($output_enc->getNodeValue)
837     if defined $output_enc;
838    
839     if (not $self->output_version() || not $self->output_encoding())
840     {
841     $self->warn(qq{Expected attributes "version" and "encoding" in\n\t} .
842     $self->xsl_ns() . "output");
843     }
844     }
845     my $doctype_public = $attribs->getNamedItem('doctype-public');
846     my $doctype_system = $attribs->getNamedItem('doctype-system');
847    
848     my $dp = defined $doctype_public ? $doctype_public->getNodeValue : '';
849    
850     $self->doctype_public($dp);
851    
852     my $ds = defined $doctype_system ? $doctype_system->getNodeValue : '';
853     $self->doctype_system($ds);
854    
855     # cdata-section-elements should only be used if the output type
856     # is XML but as we are not checking that right now ...
857    
858     my $cdata_section = $attribs->getNamedItem('cdata-section-elements');
859    
860     if ( defined $cdata_section )
861     {
862     my $cdata_sections = [];
863     @{$cdata_sections} = split /\s+/, $cdata_section->getNodeValue();
864     $self->cdata_sections($cdata_sections);
865     }
866     } else {
867     $self->debug("Default Output options being used");
868     }
869     }
870    
871     sub omit_xml_declaration
872     {
873     my ( $self, $omit_xml_declaration ) = @_;
874    
875     if ( defined $omit_xml_declaration )
876     {
877     if ( $omit_xml_declaration =~ /^(yes|no)$/ )
878     {
879     $self->{OMIT_XML_DECL} = ($1 eq 'yes');
880     }
881     else
882     {
883     $self->{OMIT_XML_DECL} = $omit_xml_declaration ? 1 : 0;
884     }
885     }
886    
887     return exists $self->{OMIT_XML_DECL} ? $self->{OMIT_XML_DECL} : 0;
888     }
889    
890     sub cdata_sections
891     {
892     my ( $self, $cdata_sections ) = @_;
893    
894     if ( defined $cdata_sections )
895     {
896     $self->{CDATA_SECTIONS} = $cdata_sections;
897     }
898    
899     $self->{CDATA_SECTIONS} = [] unless exists $self->{CDATA_SECTIONS};
900    
901     return wantarray() ? @{$self->{CDATA_SECTIONS}} : $self->{CDATA_SECTIONS};
902     }
903    
904    
905     sub is_cdata_section
906     {
907     my ( $self, $element ) = @_;
908    
909     my %cdata_sections;
910    
911     my @cdata_temp = $self->cdata_sections();
912     @cdata_sections{@cdata_temp} = (1) x @cdata_temp;
913    
914     my $tagname;
915    
916     if ( defined $element and ref($element) and ref($element) eq 'XML::DOM' )
917     {
918     $tagname = $element->getTagName();
919     }
920     else
921     {
922     $tagname = $element;
923     }
924    
925     # Will need to do namespace checking on this really
926    
927     return exists $cdata_sections{$tagname} ? 1 : 0;
928     }
929    
930    
931     sub output_version
932     {
933     my ( $self, $output_version ) = @_;
934    
935     if ( defined $output_version )
936     {
937     $self->{OUTPUT_VERSION} = $output_version;
938     }
939    
940     return exists $self->{OUTPUT_VERSION} ? $self->{OUTPUT_VERSION} :
941     $self->default_xml_version();
942     }
943    
944     sub __get_attribute_sets
945     {
946     my ( $self ) = @_;
947    
948     my $doc = $self->xsl_document();
949     my $nsp = $self->xsl_ns();
950     my $tagname = $nsp . 'attribute-set';
951     foreach my $attribute_set ( $doc->getElementsByTagName($tagname,0))
952     {
953     my $attribs = $attribute_set->getAttributes();
954     next unless defined $attribs;
955     my $name_attr = $attribs->getNamedItem('name');
956     next unless defined $name_attr;
957     my $name = $name_attr->getValue();
958     $self->debug("processing attribute-set $name");
959    
960     my $attr_set = {};
961    
962     my $tagname = $nsp . 'attribute';
963    
964     foreach my $attribute ( $attribute_set->getElementsByTagName($tagname,0))
965     {
966     my $attribs = $attribute->getAttributes();
967     next unless defined $attribs;
968     my $name_attr = $attribs->getNamedItem('name');
969     next unless defined $name_attr;
970     my $attr_name = $name_attr->getValue();
971     $self->debug("Processing attribute $attr_name");
972     if ( $attr_name )
973     {
974     my $result = $self->xml_document()->createDocumentFragment();
975     $self->_evaluate_template($attribute,
976     $self->xml_document(),
977     '/',
978     $result); # might need variables
979     my $value = $self->fix_attribute_value($self->__string__($result));
980     $attr_set->{$attr_name} = $value;
981     $result->dispose();
982     $self->debug("Adding attribute $attr_name with value $value");
983     }
984     }
985    
986     $self->__attribute_set_($name,$attr_set);
987     }
988     }
989    
990     # Accessor for attribute sets
991    
992     sub __attribute_set_
993     {
994     my ($self,$name,$attr_hash) = @_;
995    
996     if ( defined $attr_hash && defined $name)
997     {
998     $self->{ATTRIBUTE_SETS}->{$name} = $attr_hash;
999     }
1000    
1001     return defined $name && exists $self->{ATTRIBUTE_SETS}->{$name} ?
1002     $self->{ATTRIBUTE_SETS}->{$name} : undef;
1003     }
1004    
1005     sub open_project {
1006     my $self = shift;
1007     my $xml = shift;
1008     my $xsl = shift;
1009     my ($xmlflag, $xslflag, %args) = @_;
1010    
1011     carp "open_project is deprecated."
1012     unless $self->use_deprecated()
1013     or exists $deprecation_used{open_project};
1014     $deprecation_used{open_project} = 1;
1015    
1016     $self->debug("opening project:");
1017     $self->_indent();
1018    
1019     $self->open_xml ($xml, %args);
1020     $self->open_xsl ($xsl, %args);
1021    
1022     $self->debug("done...");
1023     $self->_outdent();
1024     }
1025    
1026     sub transform {
1027     my $self = shift;
1028     my %topvariables = $self->__parse_args(@_);
1029    
1030     $self->debug("transforming document:");
1031     $self->_indent();
1032    
1033     $self->open_xml (%topvariables);
1034    
1035    
1036     $self->debug("done...");
1037     $self->_outdent();
1038    
1039     # The _get_attribute_set needs an open XML document
1040    
1041     $self->_indent();
1042     $self->__get_attribute_sets();
1043     $self->_outdent();
1044    
1045     $self->debug("processing project:");
1046     $self->_indent();
1047    
1048     $self->process(%topvariables);
1049    
1050     $self->debug("done!");
1051     $self->_outdent();
1052     $self->result_document()->normalize();
1053     return $self->result_document();
1054     }
1055    
1056     sub process {
1057     my ($self, %topvariables) = @_;
1058    
1059     $self->debug("processing project:");
1060     $self->_indent();
1061    
1062     my $root_template = $self->_match_template ("match", '/', 1, '');
1063    
1064     %topvariables = (%topvariables,
1065     defined $self->{VARIABLES} && ref $self->{VARIABLES} &&
1066     ref $self->{VARIABLES} eq 'ARRAY' ?
1067     @{$self->{VARIABLES}} : ());
1068    
1069     $self->_evaluate_template (
1070     $root_template, # starting template: the root template
1071     $self->xml_document(),
1072     '', # current XML selection path: the root
1073     $self->result_document(), # current result tree node: the root
1074     {()}, # current known variables: none
1075     \%topvariables # previously known variables: top level variables
1076     );
1077    
1078     $self->debug("done!");
1079     $self->_outdent();
1080     }
1081    
1082     # Handles deprecations.
1083     sub AUTOLOAD {
1084     my $self = shift;
1085     my $type = ref($self) || croak "Not a method call";
1086     my $name = $AUTOLOAD;
1087     $name =~ s/.*://;
1088    
1089     my %deprecation = ('output_string' => 'toString',
1090     'result_string' => 'toString',
1091     'output' => 'toString',
1092     'result' => 'toString',
1093     'result_mime_type' => 'media_type',
1094     'output_mime_type' => 'media_type',
1095     'result_tree' => 'to_dom',
1096     'output_tree' => 'to_dom',
1097     'transform_document' => 'transform',
1098     'process_project' => 'process'
1099     );
1100    
1101     if (exists $deprecation{$name}) {
1102     carp "$name is deprecated. Use $deprecation{$name}"
1103     unless $self->use_deprecated()
1104     or exists $deprecation_used{$name};
1105     $deprecation_used{$name} = 1;
1106     eval qq{return \$self->$deprecation{$name}(\@_)};
1107     } else {
1108     croak "$name: No such method name";
1109     }
1110     }
1111    
1112     sub _my_print_text {
1113     my ($self, $FILE) = @_;
1114    
1115     if (UNIVERSAL::isa($self, "XML::DOM::CDATASection")) {
1116     $FILE->print ($self->getData());
1117     } else {
1118     $FILE->print (XML::DOM::encodeText($self->getData(), "<&"));
1119     }
1120     }
1121    
1122     sub toString {
1123     my $self = $_[0];
1124    
1125     local *XML::DOM::Text::print = \&_my_print_text;
1126    
1127     my $string = $self->result_document()->toString();
1128    
1129     return $string;
1130     }
1131    
1132     sub to_dom {
1133     my ($self) = @_;
1134    
1135     return $self->result_document();
1136     }
1137    
1138     sub media_type {
1139     my ( $self, $media_type ) = @_;
1140    
1141     if ( defined $media_type )
1142     {
1143     $self->{MEDIA_TYPE} = $media_type;
1144     }
1145    
1146     return $self->{MEDIA_TYPE};
1147     }
1148    
1149     sub print_output {
1150     my ($self, $file, $mime) = @_;
1151     $file ||= ''; # print to STDOUT by default
1152     $mime = 1 unless defined $mime;
1153    
1154     # print mime-type header etc by default
1155    
1156     # $self->{RESULT_DOCUMENT}->printToFileHandle (\*STDOUT);
1157     # or $self->{RESULT_DOCUMENT}->print (\*STDOUT); ???
1158     # exit;
1159    
1160     carp "print_output is deprecated. Use serve."
1161     unless $self->use_deprecated()
1162     or exists $deprecation_used{print_output};
1163     $deprecation_used{print_output} = 1;
1164    
1165     if ($mime) {
1166     print "Content-type: " . $self->media_type() . "\n\n";
1167    
1168     if ($self->{METHOD} eq 'xml' || $self->{METHOD} eq 'html') {
1169     unless ($self->omit_xml_declaration())
1170     {
1171     print $self->xml_declaration(),"\n";
1172     }
1173     }
1174    
1175     if ( my $doctype = $self->doctype() )
1176     {
1177     print "$doctype\n";
1178     }
1179     }
1180    
1181     if ($file) {
1182     if (ref (\$file) eq 'SCALAR') {
1183     print $file $self->output_string,"\n"
1184     } else {
1185     if (open (FILE, ">$file")) {
1186     print FILE $self->output_string,"\n";
1187     if (! close (FILE)) {
1188     die ("Error writing $file: $!. Nothing written...\n");
1189     }
1190     } else {
1191     die ("Error opening $file: $!. Nothing done...\n");
1192     }
1193     }
1194     } else {
1195     print $self->output_string,"\n";
1196     }
1197     }
1198    
1199     *print_result = *print_output;
1200    
1201     sub doctype
1202     {
1203     my ( $self ) = @_;
1204    
1205     my $doctype = "";
1206    
1207     if ($self->doctype_public() || $self->doctype_system())
1208     {
1209     my $root_name = $self->result_document()
1210     ->getElementsByTagName('*',0)->item(0)->getTagName;
1211    
1212     if ($self->doctype_public())
1213     {
1214     $doctype = qq{<!DOCTYPE $root_name PUBLIC "} .
1215     $self->doctype_public() .
1216     qq{" "} . $self->doctype_system() . qq{">};
1217     }
1218     else
1219     {
1220     $doctype = qq{<!DOCTYPE $root_name SYSTEM "} .
1221     $self->doctype_system()
1222     . qq{">};
1223     }
1224     }
1225    
1226     $self->debug("returning doctype of $doctype");
1227     return $doctype;
1228     }
1229    
1230     sub dispose {
1231     #my $self = $_[0];
1232    
1233     #$_[0]->[PARSER] = undef if (defined $_[0]->[PARSER]);
1234     $_[0]->result_document()->dispose if (defined $_[0]->result_document());
1235    
1236     # only dispose xml and xsl when they were not passed as DOM
1237     if (not defined $_[0]->{XML_PASSED_AS_DOM} && defined $_-[0]->xml_document()) {
1238     $_[0]->xml_document()->dispose;
1239     }
1240     if (not defined $_[0]->{XSL_PASSED_AS_DOM} && defined $_-[0]->xsl_document()) {
1241     $_[0]->xsl_document()->dispose;
1242     }
1243    
1244     $_[0] = undef;
1245     }
1246    
1247    
1248     ######################################################################
1249     # PRIVATE DEFINITIONS
1250    
1251     sub __open_document {
1252     my $self = shift;
1253     my %args = @_;
1254     %args = (%{$self->{PARSER_ARGS}}, %args);
1255     my $doc;
1256    
1257     $self->debug("opening document");
1258    
1259     eval
1260     {
1261     my $ref = ref($args{Source});
1262     if(!$ref && length $args{Source} < 255 &&
1263     (-f $args{Source} ||
1264     lc(substr($args{Source}, 0, 5)) eq 'http:' ||
1265     lc(substr($args{Source}, 0, 6)) eq 'https:' ||
1266     lc(substr($args{Source}, 0, 4)) eq 'ftp:' ||
1267     lc(substr($args{Source}, 0, 5)) eq 'file:')) {
1268     # Filename
1269     $self->debug("Opening URL");
1270     $doc = $self->__open_by_filename($args{Source}, $args{base});
1271     } elsif(!$ref) {
1272     # String
1273     $self->debug("Opening String");
1274     $doc = $self->{PARSER}->parse ($args{Source});
1275     } elsif($ref eq "SCALAR") {
1276     # Stringref
1277     $self->debug("Opening Stringref");
1278     $doc = $self->{PARSER}->parse (${$args{Source}});
1279     } elsif($ref eq "XML::DOM::Document") {
1280     # DOM object
1281     $self->debug("Opening XML::DOM");
1282     $doc = $args{Source};
1283     } elsif ($ref eq "GLOB") { # This is a file glob
1284     $self->debug("Opening GLOB");
1285     my $ioref = *{$args{Source}}{IO};
1286     $doc = $self->{PARSER}->parse($ioref);
1287     } elsif (UNIVERSAL::isa($args{Source}, 'IO::Handle')) { # IO::Handle
1288     $self->debug("Opening IO::Handle");
1289     $doc = $self->{PARSER}->parse($args{Source});
1290     }
1291     else {
1292     $doc = undef;
1293     }
1294     };
1295     die "Error while parsing: $@\n". $args{Source} if $@;
1296     return $doc;
1297     }
1298    
1299     # private auxiliary function #
1300     sub __open_by_filename {
1301     my ($self, $filename, $base) = @_;
1302     my $doc;
1303    
1304     # ** FIXME: currently reads the whole document into memory
1305     # might not be avoidable
1306    
1307     # LWP should be able to deal with files as well as links
1308     $ENV{DOMAIN} ||= "example.com"; # hide complaints from Net::Domain
1309    
1310     my $file = get(URI->new_abs($filename, $base));
1311    
1312     return $self->{PARSER}->parse($file, %{$self->{PARSER_ARGS}});
1313     }
1314    
1315     sub _match_template {
1316     my ($self, $attribute_name, $select_value, $xml_count, $xml_selection_path,
1317     $mode) = @_;
1318     $mode ||= "";
1319    
1320     my $template = "";
1321     my @template_matches = ();
1322    
1323     $self->debug(qq{matching template for "$select_value" with count $xml_count\n\t} .
1324     qq{and path "$xml_selection_path":});
1325    
1326     if ($attribute_name eq "match" && ref $self->{TEMPLATE_MATCH}) {
1327     push @template_matches, @{$self->{TEMPLATE_MATCH}};
1328     } elsif ($attribute_name eq "name" && ref $self->{TEMPLATE_NAME}) {
1329     push @template_matches, @{$self->{TEMPLATE_NAME}};
1330     }
1331    
1332     # note that the order of @template_matches is the reverse of $self->{TEMPLATE}
1333     my $count = @template_matches;
1334     foreach my $original_match (@template_matches) {
1335     # templates with no match or name or with both simultaniuously
1336     # have no $template_match value
1337     if ($original_match) {
1338     my $full_match = $original_match;
1339    
1340     # multipe match? (for example: match="*|/")
1341     while ($full_match =~ s/^(.+?)\|//) {
1342     my $match = $1;
1343     if (&__template_matches__ ($match, $select_value, $xml_count,
1344     $xml_selection_path)) {
1345     $self->debug(qq{ found #$count with "$match" in "$original_match"});
1346    
1347     $template = ($self->templates())[$count-1];
1348     return $template;
1349     # last;
1350     }
1351     }
1352    
1353     # last match?
1354     if (!$template) {
1355     if (&__template_matches__ ($full_match, $select_value, $xml_count,
1356     $xml_selection_path)) {
1357     $self->debug(qq{ found #$count with "$full_match" in "$original_match"});
1358     $template = ($self->templates())[$count-1];
1359     return $template;
1360     # last;
1361     } else {
1362     $self->debug(qq{ #$count "$original_match" did not match});
1363     }
1364     }
1365     }
1366     $count--;
1367     }
1368    
1369     if (! $template) {
1370     $self->warn(qq{No template matching `$xml_selection_path' found !!});
1371     }
1372    
1373     return $template;
1374     }
1375    
1376     # auxiliary function #
1377     sub __template_matches__ {
1378     my ($template, $select, $count, $path) = @_;
1379    
1380     my $nocount_path = $path;
1381     $nocount_path =~ s/\[.*?\]//g;
1382    
1383     if (($template eq $select) || ($template eq $path)
1384     || ($template eq "$select\[$count\]") || ($template eq "$path\[$count\]")) {
1385     # perfect match or path ends with templates match
1386     #print "perfect match","\n";
1387     return "True";
1388     } elsif ( ($template eq substr ($path, - length ($template)))
1389     || ($template eq substr ($nocount_path, - length ($template)))
1390     || ("$template\[$count\]" eq substr ($path, - length ($template)))
1391     || ("$template\[$count\]" eq substr ($nocount_path, - length ($template)))
1392     ) {
1393     # template matches tail of path matches perfectly
1394     #print "perfect tail match","\n";
1395     return "True";
1396     } elsif ($select =~ /\[\s*(\@.*?)\s*=\s*(.*?)\s*\]$/) {
1397     # match attribute test
1398     my $attribute = $1;
1399     my $value = $2;
1400     return ""; # False, no test evaluation yet #
1401     } elsif ($select =~ /\[\s*(.*?)\s*=\s*(.*?)\s*\]$/) {
1402     # match test
1403     my $element = $1;
1404     my $value = $2;
1405     return ""; # False, no test evaluation yet #
1406     } elsif ($select =~ /(\@\*|\@[\w\.\-\:]+)$/) {
1407     # match attribute
1408     my $attribute = $1;
1409     #print "attribute match?\n";
1410     return (($template eq '@*') || ($template eq $attribute)
1411     || ($template eq "\@*\[$count\]") || ($template eq "$attribute\[$count\]"));
1412     } elsif ($select =~ /(\*|[\w\.\-\:]+)$/) {
1413     # match element
1414     my $element = $1;
1415     #print "element match?\n";
1416     return (($template eq "*") || ($template eq $element)
1417     || ($template eq "*\[$count\]") || ($template eq "$element\[$count\]"));
1418     } else {
1419     return ""; # False #
1420     }
1421     }
1422    
1423     sub _evaluate_test {
1424     my ($self, $test, $current_xml_node, $current_xml_selection_path,
1425     $variables) = @_;
1426    
1427     if ($test =~ /^(.+)\/\[(.+)\]$/) {
1428     my $path = $1;
1429     $test = $2;
1430    
1431     $self->debug("evaluating test $test at path $path:");;
1432    
1433     $self->_indent();
1434     my $node = $self->_get_node_set ($path, $self->xml_document(),
1435     $current_xml_selection_path,
1436     $current_xml_node, $variables);
1437     if (@$node) {
1438     $current_xml_node = $$node[0];
1439     } else {
1440     return "";
1441     }
1442     $self->_outdent();
1443     } else {
1444     $self->debug("evaluating path or test $test:");;
1445     my $node = $self->_get_node_set ($test, $self->xml_document(),
1446     $current_xml_selection_path,
1447     $current_xml_node, $variables, "silent");
1448     $self->_indent();
1449     if (@$node) {
1450     $self->debug("path exists!");;
1451     return "true";
1452     } else {
1453     $self->debug("not a valid path, evaluating as test");;
1454     }
1455     $self->_outdent();
1456     }
1457    
1458     $self->_indent();
1459     my $result = &__evaluate_test__ ($self,$test, $current_xml_selection_path,$current_xml_node,$variables);
1460     if ($result) {
1461     $self->debug("test evaluates true..");
1462     } else {
1463     $self->debug("test evaluates false..");
1464     }
1465     $self->_outdent();
1466     return $result;
1467     }
1468    
1469     sub _evaluate_template {
1470     my ($self, $template, $current_xml_node, $current_xml_selection_path,
1471     $current_result_node, $variables, $oldvariables) = @_;
1472    
1473     $self->debug(qq{evaluating template content with current path }
1474     . qq{"$current_xml_selection_path": });
1475     $self->_indent();
1476    
1477     die "No Template"
1478     unless defined $template && ref $template;
1479     $template->normalize;
1480    
1481     foreach my $child ($template->getChildNodes) {
1482     my $ref = ref $child;
1483    
1484     $self->debug("$ref");
1485     $self->_indent();
1486     my $node_type = $child->getNodeType;
1487     if ($node_type == ELEMENT_NODE) {
1488     $self->_evaluate_element ($child, $current_xml_node,
1489     $current_xml_selection_path,
1490     $current_result_node, $variables,
1491     $oldvariables);
1492     } elsif ($node_type == TEXT_NODE) {
1493     my $value = $child->getNodeValue;
1494     if ( length($value) and $value !~ /^[\x20\x09\x0D\x0A]+$/s )
1495     {
1496     $self->_add_node ($child, $current_result_node);
1497     }
1498     } elsif ($node_type == CDATA_SECTION_NODE) {
1499     my $text = $self->xml_document()->createTextNode ($child->getData);
1500     $self->_add_node($text, $current_result_node);
1501     } elsif ($node_type == ENTITY_REFERENCE_NODE) {
1502     $self->_add_node($child, $current_result_node);
1503     } elsif ($node_type == DOCUMENT_TYPE_NODE) {
1504     # skip #
1505     $self->debug("Skipping Document Type node...");
1506     } elsif ($node_type == COMMENT_NODE) {
1507     # skip #
1508     $self->debug("Skipping Comment node...");
1509     } else {
1510     $self->warn("evaluate-template: Dunno what to do with node of type $ref !!!\n\t" .
1511     "($current_xml_selection_path)");
1512     }
1513    
1514     $self->_outdent();
1515     }
1516    
1517     $self->debug("done!");
1518     $self->_outdent();
1519     }
1520    
1521     sub _add_node {
1522     my ($self, $node, $parent, $deep, $owner) = @_;
1523     $owner ||= $self->xml_document();
1524    
1525     my $what = defined $deep ? 'deep' : 'non-deep';
1526    
1527     $self->debug("adding node ($what)..");
1528    
1529     $node = $node->cloneNode($deep);
1530     $node->setOwnerDocument($owner);
1531     if ($node->getNodeType == ATTRIBUTE_NODE) {
1532     $parent->setAttributeNode($node);
1533     } else {
1534     $parent->appendChild($node);
1535     }
1536     }
1537    
1538     sub _apply_templates {
1539     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
1540     $current_result_node, $variables, $oldvariables) = @_;
1541     my $children;
1542     my $params = {};
1543     my $newvariables = defined $variables ? {%$variables}: {};
1544    
1545     my $select = $xsl_node->getAttribute ('select');
1546    
1547     if ($select =~ /\$/ and defined $variables) {
1548     # replacing occurences of variables:
1549     foreach my $varname (keys (%$variables)) {
1550     $select =~ s/[^\\]\$$varname/$$variables{$varname}/g;
1551     }
1552     }
1553    
1554     if ($select) {
1555     $self->debug(qq{applying templates on children $select of "$current_xml_selection_path":});
1556     $children = $self->_get_node_set ($select, $self->xml_document(),
1557     $current_xml_selection_path,
1558     $current_xml_node, $variables);
1559     } else {
1560     $self->debug(qq{applying templates on all children of "$current_xml_selection_path":});
1561     $children = [ $current_xml_node->getChildNodes ];
1562     }
1563    
1564     $self->_process_with_params ($xsl_node, $current_xml_node,
1565     $current_xml_selection_path,
1566     $variables, $params);
1567    
1568     # process xsl:sort here
1569    
1570     $self->_indent();
1571    
1572     my $count = 1;
1573     foreach my $child (@$children) {
1574     my $node_type = $child->getNodeType;
1575    
1576     if ($node_type == DOCUMENT_TYPE_NODE) {
1577     # skip #
1578     $self->debug("Skipping Document Type node...");
1579     } elsif ($node_type == DOCUMENT_FRAGMENT_NODE) {
1580     # skip #
1581     $self->debug("Skipping Document Fragment node...");
1582     } elsif ($node_type == NOTATION_NODE) {
1583     # skip #
1584     $self->debug("Skipping Notation node...");
1585     } else {
1586    
1587     my $newselect = "";
1588     my $newcount = $count;
1589     if (!$select || ($select eq '.')) {
1590     if ($node_type == ELEMENT_NODE) {
1591     $newselect = $child->getTagName;
1592     } elsif ($node_type == ATTRIBUTE_NODE) {
1593     $newselect = "@$child->getName";
1594     } elsif (($node_type == TEXT_NODE) || ($node_type == ENTITY_REFERENCE_NODE)) {
1595     $newselect = "text()";
1596     } elsif ($node_type == PROCESSING_INSTRUCTION_NODE) {
1597     $newselect = "processing-instruction()";
1598     } elsif ($node_type == COMMENT_NODE) {
1599     $newselect = "comment()";
1600     } else {
1601     my $ref = ref $child;
1602     $self->debug("Unknown node encountered: `$ref'");
1603     }
1604     } else {
1605     $newselect = $select;
1606     if ($newselect =~ s/\[(\d+)\]$//) {
1607     $newcount = $1;
1608     }
1609     }
1610    
1611     $self->_select_template ($child, $newselect, $newcount,
1612     $current_xml_node,
1613     $current_xml_selection_path,
1614     $current_result_node, $newvariables, $params);
1615     }
1616     $count++;
1617     }
1618    
1619     $self->_indent();
1620     }
1621    
1622     sub _for_each {
1623     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
1624     $current_result_node, $variables, $oldvariables) = @_;
1625    
1626     my $select = $xsl_node->getAttribute ('select') || die "No `select' attribute in for-each element";
1627    
1628     if ($select =~ /\$/) {
1629     # replacing occurences of variables:
1630     foreach my $varname (keys (%$variables)) {
1631     $select =~ s/[^\\]\$$varname/$$variables{$varname}/g;
1632     }
1633     }
1634    
1635     if (defined $select) {
1636     $self->debug(qq{applying template for each child $select of "$current_xml_selection_path":});
1637     my $children = $self->_get_node_set ($select, $self->xml_document(),
1638     $current_xml_selection_path,
1639     $current_xml_node, $variables);
1640     $self->_indent();
1641     my $count = 1;
1642     foreach my $child (@$children) {
1643     my $node_type = $child->getNodeType;
1644    
1645     if ($node_type == DOCUMENT_TYPE_NODE) {
1646     # skip #
1647     $self->debug("Skipping Document Type node...");;
1648     } elsif ($node_type == DOCUMENT_FRAGMENT_NODE) {
1649     # skip #
1650     $self->debug("Skipping Document Fragment node...");;
1651     } elsif ($node_type == NOTATION_NODE) {
1652     # skip #
1653     $self->debug("Skipping Notation node...");;
1654     } else {
1655    
1656     $self->_evaluate_template ($xsl_node, $child,
1657     "$current_xml_selection_path/$select\[$count\]",
1658     $current_result_node, $variables, $oldvariables);
1659     }
1660     $count++;
1661     }
1662    
1663     $self->_outdent();
1664     } else {
1665     my $ns = $self->xsl_ns();
1666     $self->warn(qq%expected attribute "select" in <${ns}for-each>%);
1667     }
1668    
1669     }
1670    
1671     sub _select_template {
1672     my ($self, $child, $select, $count, $current_xml_node, $current_xml_selection_path,
1673     $current_result_node, $variables, $oldvariables) = @_;
1674    
1675     my $ref = ref $child;
1676     $self->debug(qq{selecting template $select for child type $ref of "$current_xml_selection_path":});
1677    
1678     $self->_indent();
1679    
1680     my $child_xml_selection_path = "$current_xml_selection_path/$select";
1681     my $template = $self->_match_template ("match", $select, $count,
1682     $child_xml_selection_path);
1683    
1684     if ($template) {
1685    
1686     $self->_evaluate_template ($template,
1687     $child,
1688     "$child_xml_selection_path\[$count\]",
1689     $current_result_node, $variables, $oldvariables);
1690     } else {
1691     $self->debug("skipping template selection...");;
1692     }
1693    
1694     $self->_outdent();
1695     }
1696    
1697     sub _evaluate_element {
1698     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
1699     $current_result_node, $variables, $oldvariables) = @_;
1700     my ($ns, $xsl_tag) = split(':', $xsl_node->getTagName);
1701    
1702     if(not defined $xsl_tag) {
1703     $xsl_tag = $ns;
1704     $ns = $self->default_ns();
1705     } else {
1706     $ns .= ':';
1707     }
1708     $self->debug(qq{evaluating element `$xsl_tag' from `$current_xml_selection_path': });
1709     $self->_indent();
1710    
1711     if ($ns eq $self->xsl_ns()) {
1712     my @attributes = $xsl_node->getAttributes->getValues;
1713     $self->debug(qq{This is an xsl tag});
1714     if ($xsl_tag eq 'apply-templates') {
1715     $self->_apply_templates ($xsl_node, $current_xml_node,
1716     $current_xml_selection_path,
1717     $current_result_node, $variables, $oldvariables);
1718    
1719     } elsif ($xsl_tag eq 'attribute') {
1720     $self->_attribute ($xsl_node, $current_xml_node,
1721     $current_xml_selection_path,
1722     $current_result_node, $variables, $oldvariables);
1723    
1724     } elsif ($xsl_tag eq 'call-template') {
1725     $self->_call_template ($xsl_node, $current_xml_node,
1726     $current_xml_selection_path,
1727     $current_result_node, $variables, $oldvariables);
1728    
1729     } elsif ($xsl_tag eq 'choose') {
1730     $self->_choose ($xsl_node, $current_xml_node,
1731     $current_xml_selection_path,
1732     $current_result_node, $variables, $oldvariables);
1733    
1734     } elsif ($xsl_tag eq 'comment') {
1735     $self->_comment ($xsl_node, $current_xml_node,
1736     $current_xml_selection_path,
1737     $current_result_node, $variables, $oldvariables);
1738    
1739     } elsif ($xsl_tag eq 'copy') {
1740     $self->_copy ($xsl_node, $current_xml_node,
1741     $current_xml_selection_path,
1742     $current_result_node, $variables, $oldvariables);
1743    
1744     } elsif ($xsl_tag eq 'copy-of') {
1745     $self->_copy_of ($xsl_node, $current_xml_node,
1746     $current_xml_selection_path,
1747     $current_result_node, $variables);
1748     } elsif ($xsl_tag eq 'element') {
1749     $self->_element ($xsl_node, $current_xml_node,
1750     $current_xml_selection_path,
1751     $current_result_node, $variables, $oldvariables);
1752     } elsif ($xsl_tag eq 'for-each') {
1753     $self->_for_each ($xsl_node, $current_xml_node,
1754     $current_xml_selection_path,
1755     $current_result_node, $variables, $oldvariables);
1756    
1757     } elsif ($xsl_tag eq 'if') {
1758     $self->_if ($xsl_node, $current_xml_node,
1759     $current_xml_selection_path,
1760     $current_result_node, $variables, $oldvariables);
1761    
1762     # } elsif ($xsl_tag eq 'output') {
1763    
1764     } elsif ($xsl_tag eq 'param') {
1765     $self->_variable ($xsl_node, $current_xml_node,
1766     $current_xml_selection_path,
1767     $current_result_node, $variables, $oldvariables, 1);
1768    
1769     } elsif ($xsl_tag eq 'processing-instruction') {
1770     $self->_processing_instruction ($xsl_node, $current_result_node);
1771    
1772     } elsif ($xsl_tag eq 'text') {
1773     $self->_text ($xsl_node, $current_result_node);
1774    
1775     } elsif ($xsl_tag eq 'value-of') {
1776     $self->_value_of ($xsl_node, $current_xml_node,
1777     $current_xml_selection_path,
1778     $current_result_node, $variables);
1779    
1780     } elsif ($xsl_tag eq 'variable') {
1781     $self->_variable ($xsl_node, $current_xml_node,
1782     $current_xml_selection_path,
1783     $current_result_node, $variables, $oldvariables, 0);
1784    
1785     } elsif ( $xsl_tag eq 'sort' ) {
1786     $self->_sort ($xsl_node, $current_xml_node,
1787     $current_xml_selection_path,
1788     $current_result_node, $variables, $oldvariables, 0);
1789     } elsif ( $xsl_tag eq 'fallback' ) {
1790     $self->_fallback ($xsl_node, $current_xml_node,
1791     $current_xml_selection_path,
1792     $current_result_node, $variables, $oldvariables, 0);
1793     } elsif ( $xsl_tag eq 'attribute-set' ) {
1794     $self->_attribute_set ($xsl_node, $current_xml_node,
1795     $current_xml_selection_path,
1796     $current_result_node, $variables,
1797     $oldvariables, 0);
1798     } else {
1799     $self->_add_and_recurse ($xsl_node, $current_xml_node,
1800     $current_xml_selection_path,
1801     $current_result_node, $variables, $oldvariables);
1802     }
1803     } else {
1804     $self->debug($ns ." does not match ". $self->xsl_ns());
1805    
1806     # not entirely sure if this right but the spec is a bit vague
1807    
1808     if ( $self->is_cdata_section($xsl_tag) )
1809     {
1810     $self->debug("This is a CDATA section element");
1811     $self->_add_cdata_section($xsl_node, $current_xml_node,
1812     $current_xml_selection_path,
1813     $current_result_node, $variables,
1814     $oldvariables);
1815     }
1816     else
1817     {
1818     $self->debug("This is a literal element");
1819     $self->_check_attributes_and_recurse ($xsl_node, $current_xml_node,
1820     $current_xml_selection_path,
1821     $current_result_node, $variables,
1822     $oldvariables);
1823     }
1824     }
1825    
1826     $self->_outdent();
1827     }
1828    
1829     sub _add_cdata_section
1830     {
1831     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
1832     $current_result_node, $variables, $oldvariables) = @_;
1833    
1834     my $node = $self->xml_document()->createElement($xsl_node->getTagName);
1835    
1836     my $cdata = '';
1837    
1838     foreach my $child_node ( $xsl_node->getChildNodes() )
1839     {
1840     if ($child_node->can('asString') )
1841     {
1842     $cdata .= $child_node->asString();
1843     }
1844     else
1845     {
1846     $cdata .= $child_node->getNodeValue();
1847     }
1848     }
1849    
1850     $node->addCDATA($cdata);
1851    
1852     $current_result_node->appendChild($node);
1853    
1854     }
1855    
1856     sub _add_and_recurse {
1857     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
1858     $current_result_node, $variables, $oldvariables) = @_;
1859    
1860     # the addition is commented out to prevent unknown xsl: commands to be printed in the result
1861     $self->_add_node ($xsl_node, $current_result_node);
1862     $self->_evaluate_template ($xsl_node, $current_xml_node,
1863     $current_xml_selection_path,
1864     $current_result_node, $variables, $oldvariables); #->getLastChild);
1865     }
1866    
1867     sub _check_attributes_and_recurse {
1868     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
1869     $current_result_node, $variables, $oldvariables) = @_;
1870    
1871     $self->_add_node ($xsl_node, $current_result_node);
1872     $self->_attribute_value_of ($current_result_node->getLastChild,
1873     $current_xml_node,
1874     $current_xml_selection_path, $variables);
1875     $self->_evaluate_template ($xsl_node, $current_xml_node,
1876     $current_xml_selection_path,
1877     $current_result_node->getLastChild,
1878     $variables, $oldvariables);
1879     }
1880    
1881    
1882     sub _element {
1883     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
1884     $current_result_node, $variables, $oldvariables) = @_;
1885    
1886     my $name = $xsl_node->getAttribute ('name');
1887     $self->debug(qq{inserting Element named "$name":});
1888     $self->_indent();
1889    
1890     if (defined $name) {
1891     my $result = $self->xml_document()->createElement($name);
1892    
1893     $self->_evaluate_template ($xsl_node,
1894     $current_xml_node,
1895     $current_xml_selection_path,
1896     $result, $variables, $oldvariables);
1897    
1898     my $attr_set = $xsl_node->getAttribute('use-attribute-sets');
1899    
1900     if ( $attr_set )
1901     {
1902     $self->_indent();
1903     my $set_name = $attr_set;
1904    
1905     if ( my $set = $self->__attribute_set_($set_name) )
1906     {
1907     $self->debug("Adding attribute-set '$set_name'");
1908    
1909     foreach my $attr_name ( keys %{$set} )
1910     {
1911     $self->debug("Adding attribute $attr_name ->" . $set->{$attr_name});
1912     $result->setAttribute($attr_name,$set->{$attr_name});
1913     }
1914     }
1915     $self->_outdent();
1916     }
1917     $current_result_node->appendChild($result);
1918     } else {
1919     $self->warn(q{expected attribute "name" in <} .
1920     $self->xsl_ns() . q{element>});
1921     }
1922     $self->_outdent();
1923     }
1924    
1925     {
1926     ######################################################################
1927     # Auxiliary package for disable-output-escaping
1928     ######################################################################
1929    
1930     package XML::XSLT::DOM::TextDOE;
1931     use vars qw( @ISA );
1932     @ISA = qw( XML::DOM::Text );
1933    
1934     sub print {
1935     my ($self, $FILE) = @_;
1936     $FILE->print ($self->getData);
1937     }
1938     }
1939    
1940    
1941     sub _value_of {
1942     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
1943     $current_result_node, $variables) = @_;
1944    
1945     my $select = $xsl_node->getAttribute('select');
1946    
1947     # Need to determine here whether the value is an XPath expression
1948     # and act accordingly
1949    
1950     my $xml_node;
1951    
1952     if (defined $select) {
1953     $xml_node = $self->_get_node_set ($select, $self->xml_document(),
1954     $current_xml_selection_path,
1955     $current_xml_node, $variables);
1956    
1957     $self->debug("stripping node to text:");
1958    
1959     $self->_indent();
1960     my $text = '';
1961     $text = $self->__string__ ($xml_node->[0]) if @{$xml_node};
1962     $self->_outdent();
1963    
1964     if ($text ne '') {
1965     my $node = $self->xml_document()->createTextNode ($text);
1966     if ($xsl_node->getAttribute ('disable-output-escaping') eq 'yes') {
1967     $self->debug("disabling output escaping");
1968     bless $node,'XML::XSLT::DOM::TextDOE' ;
1969     }
1970     $self->_move_node ($node, $current_result_node);
1971     } else {
1972     $self->debug("nothing left..");
1973     }
1974     } else {
1975     $self->warn(qq{expected attribute "select" in <} .
1976     $self->xsl_ns() . q{value-of>});
1977     }
1978     }
1979    
1980     sub __strip_node_to_text__ {
1981     my ($self, $node) = @_;
1982    
1983     my $result = "";
1984    
1985     my $node_type = $node->getNodeType;
1986     if ($node_type == TEXT_NODE) {
1987     $result = $node->getData;
1988     } elsif (($node_type == ELEMENT_NODE)
1989     || ($node_type == DOCUMENT_FRAGMENT_NODE)) {
1990     $self->_indent();
1991     foreach my $child ($node->getChildNodes) {
1992     $result .= &__strip_node_to_text__ ($self, $child);
1993     }
1994     $self->_outdent();
1995     }
1996     return $result;
1997     }
1998    
1999     sub __string__ {
2000     my ($self, $node,$depth) = @_;
2001    
2002     my $result = "";
2003    
2004     if (defined $node) {
2005     my $ref = (ref ($node) || "not a reference");
2006     $self->debug("stripping child nodes ($ref):");
2007    
2008     $self->_indent();
2009    
2010     if ($ref eq "ARRAY") {
2011     return $self->__string__ ($$node[0], $depth);
2012     } else {
2013     my $node_type = $node->getNodeType;
2014    
2015     if (($node_type == ELEMENT_NODE)
2016     || ($node_type == DOCUMENT_FRAGMENT_NODE)
2017     || ($node_type == DOCUMENT_NODE)) {
2018     foreach my $child ($node->getChildNodes) {
2019     $result .= &__string__ ($self, $child,1);
2020     }
2021     } elsif ($node_type == ATTRIBUTE_NODE) {
2022     $result .= $node->getValue;
2023     } elsif (($node_type == TEXT_NODE)
2024     || ($node_type == CDATA_SECTION_NODE)
2025     || ($node_type == ENTITY_REFERENCE_NODE)) {
2026     $result .= $node->getData;
2027     } elsif (!$depth && ( ($node_type == PROCESSING_INSTRUCTION_NODE)
2028     || ($node_type == COMMENT_NODE) )) {
2029     $result .= $node->getData; # COM,PI - only in 'top-level' call
2030     } else {
2031     # just to be consistent
2032     $self->warn("Can't get string-value for node of type $ref !");
2033     }
2034     }
2035    
2036     $self->debug(qq{ "$result"});
2037     $self->_outdent();
2038     } else {
2039     $self->debug(" no result");
2040     }
2041    
2042     return $result;
2043     }
2044    
2045     sub _move_node {
2046     my ($self, $node, $parent) = @_;
2047    
2048     $self->debug("moving node..");;
2049    
2050     $parent->appendChild($node);
2051     }
2052    
2053     sub _get_node_set {
2054     my ($self, $path, $root_node, $current_path, $current_node, $variables,
2055     $silent) = @_;
2056     $current_path ||= "/";
2057     $current_node ||= $root_node;
2058     $silent ||= 0;
2059    
2060     $self->debug(qq{getting node-set "$path" from "$current_path"});
2061    
2062     $self->_indent();
2063    
2064     # expand abbriviated syntax
2065     $path =~ s/\@/attribute\:\:/g;
2066     $path =~ s/\.\./parent\:\:node\(\)/g;
2067     $path =~ s/\./self\:\:node\(\)/g;
2068     $path =~ s/\/\//\/descendant\-or\-self\:\:node\(\)\//g;
2069     #$path =~ s/\/[^\:\/]*?\//attribute::/g;
2070    
2071     if ($path =~ /^\$([\w\.\-]+)$/) {
2072     my $varname = $1;
2073     my $var = $$variables{$varname};
2074     if (defined $var) {
2075     if (ref ($$variables{$varname}) eq 'ARRAY') {
2076     # node-set array-ref
2077     return $$variables{$varname};
2078     } elsif (ref ($$variables{$varname}) eq 'XML::DOM::NodeList') {
2079     # node-set nodelist
2080     return [@{$$variables{$varname}}];
2081     } elsif (ref ($$variables{$varname}) eq 'XML::DOM::DocumentFragment') {
2082     # node-set documentfragment
2083     return [$$variables{$varname}->getChildNodes];
2084     } else {
2085     # string or number?
2086     return [$self->xml_document()->createTextNode ($$variables{$varname})];
2087     }
2088     } else {
2089     # var does not exist
2090     return [];
2091     }
2092     } elsif ($path eq $current_path || $path eq 'self::node()') {
2093     $self->debug("direct hit!");;
2094     return [$current_node];
2095     } else {
2096     # open external documents first #
2097     if ($path =~ /^\s*document\s*\(["'](.*?)["']\s*(,\s*(.*)\s*){0,1}\)\s*(.*)$/) {
2098     my $filename = $1;
2099     my $sec_arg = $3;
2100     $path = ($4 || "");
2101    
2102     $self->debug(qq{external selection ("$filename")!});
2103    
2104     if ($sec_arg) {
2105     $self->warn("Ignoring second argument of $path");
2106     }
2107    
2108     ($root_node) = $self->__open_by_filename ($filename, $self->{XSL_BASE});
2109     }
2110    
2111     if ($path =~ /^\//) {
2112     # start from the root #
2113     $current_node = $root_node;
2114     } elsif ($path =~ /^self\:\:node\(\)\//) { #'#"#'#"
2115     # remove preceding dot from './etc', which is expanded to 'self::node()'
2116     # at the top of this subroutine #
2117     $path =~ s/^self\:\:node\(\)//;
2118     } else {
2119     # to facilitate parsing, precede path with a '/' #
2120     $path = "/$path";
2121     }
2122    
2123     $self->debug(qq{using "$path":});
2124    
2125     if ($path eq '/') {
2126     $current_node = [$current_node];
2127     } else {
2128     $current_node = &__get_node_set__ ($self, $path, [$current_node], $silent);
2129     }
2130    
2131     $self->_outdent();
2132    
2133     return $current_node;
2134     }
2135     }
2136    
2137    
2138     # auxiliary function #
2139     sub __get_node_set__ {
2140     my ($self, $path, $node, $silent) = @_;
2141    
2142     # a Qname (?) should actually be: [a-Z_][\w\.\-]*\:[a-Z_][\w\.\-]*
2143    
2144     if ($path eq "") {
2145    
2146     $self->debug("node found!");;
2147     return $node;
2148    
2149     } else {
2150     my $list = [];
2151     foreach my $item (@$node) {
2152     my $sublist = &__try_a_step__ ($self, $path, $item, $silent);
2153     push (@$list, @$sublist);
2154     }
2155     return $list;
2156     }
2157     }
2158    
2159     sub __try_a_step__ {
2160     my ($self, $path, $node, $silent) = @_;
2161    
2162     study ($path);
2163     if ($path =~ s/^\/parent\:\:node\(\)//) {
2164     # /.. #
2165     $self->debug(qq{getting parent ("$path")});
2166     return &__parent__ ($self, $path, $node, $silent);
2167    
2168     } elsif ($path =~ s/^\/attribute\:\:(\*|[\w\.\:\-]+)//) {
2169     # /@attr #
2170     $self->debug(qq{getting attribute `$1' ("$path")});
2171     return &__attribute__ ($self, $1, $path, $node, $silent);
2172    
2173     } elsif ($path =~ s/^\/descendant\-or\-self\:\:node\(\)\/(child\:\:|)(\*|[\w\.\:\-]+)\[(\S+?)\]//) {
2174     # //elem[n] #
2175     $self->debug(qq{getting deep indexed element `$1' `$2' ("$path")});
2176     return &__indexed_element__ ($self, $1, $2, $path, $node, $silent, "deep");
2177    
2178     } elsif ($path =~ s/^\/descendant\-or\-self\:\:node\(\)\/(\*|[\w\.\:\-]+)//) {
2179     # //elem #
2180     $self->debug(qq{getting deep element `$1' ("$path")});
2181     return &__element__ ($self, $1, $path, $node, $silent, "deep");
2182    
2183     } elsif ($path =~ s/^\/(child\:\:|)(\*|[\w\.\:\-]+)\[(\S+?)\]//) {
2184     # /elem[n] #
2185     $self->debug(qq{getting indexed element `$2' `$3' ("$path")});
2186     return &__indexed_element__ ($self, $2, $3, $path, $node, $silent);
2187    
2188     } elsif ($path =~ s/^\/(child\:\:|)(\*|[\w\.\:\-]+)//) {
2189     # /elem #
2190     $self->debug(qq{getting element `$2' ("$path")});
2191     return &__element__ ($self, $2, $path, $node, $silent);
2192    
2193     } elsif ($path =~ s/^\/(child\:\:|)text\(\)//) {
2194     # /text() #
2195     $self->debug(qq{getting text ("$path")});
2196     return &__get_nodes__ ($self, TEXT_NODE, $path, $node, $silent);
2197    
2198     } elsif ($path =~ s/^\/(child\:\:|)processing-instruction\(\)//) {
2199     # /processing-instruction() #
2200     $self->debug(qq{getting processing instruction ("$path")});
2201     return &__get_nodes__ ($self, PROCESSING_INSTRUCTION_NODE, $path, $node, $silent);
2202    
2203     } elsif ($path =~ s/^\/(child\:\:|)comment\(\)//) {
2204     # /comment() #
2205     $self->debug(qq{getting comment ("$path")});
2206     return &__get_nodes__ ($self, COMMENT_NODE, $path, $node, $silent);
2207    
2208     } else {
2209     $self->warn("get-node-from-path: Don't know what to do with path $path !!!");
2210     return [];
2211     }
2212     }
2213    
2214     sub __parent__ {
2215     my ($self, $path, $node, $silent) = @_;
2216    
2217     $self->_indent();
2218     if (($node->getNodeType == DOCUMENT_NODE)
2219     || ($node->getNodeType == DOCUMENT_FRAGMENT_NODE)) {
2220     $self->debug("no parent!");;
2221     $node = [];
2222     } else {
2223     $node = $node->getParentNode;
2224    
2225     $node = &__get_node_set__ ($self, $path, [$node], $silent);
2226     }
2227     $self->_outdent();
2228    
2229     return $node;
2230     }
2231    
2232     sub __indexed_element__ {
2233     my ($self, $element, $index, $path, $node, $silent, $deep) = @_;
2234     $index ||= 0;
2235     $deep ||= ""; # False #
2236    
2237     if ($index =~ /^first\s*\(\)/) {
2238     $index = 0;
2239     } elsif ($index =~ /^last\s*\(\)/) {
2240     $index = -1;
2241     } else {
2242     $index--;
2243     }
2244    
2245     my @list = $node->getElementsByTagName($element, $deep);
2246    
2247     if (@list) {
2248     $node = $list[$index];
2249     } else {
2250     $node = "";
2251     }
2252    
2253     $self->_indent();
2254     if ($node) {
2255     $node = &__get_node_set__ ($self, $path, [$node], $silent);
2256     } else {
2257     $self->debug("failed!");;
2258     $node = [];
2259     }
2260     $self->_outdent();
2261    
2262     return $node;
2263     }
2264    
2265     sub __element__ {
2266     my ($self, $element, $path, $node, $silent, $deep) = @_;
2267     $deep ||= ""; # False #
2268    
2269     $node = [$node->getElementsByTagName($element, $deep)];
2270    
2271     $self->_indent();
2272     if (@$node) {
2273     $node = &__get_node_set__($self, $path, $node, $silent);
2274     } else {
2275     $self->debug("failed!");;
2276     }
2277     $self->_outdent();
2278    
2279     return $node;
2280     }
2281    
2282     sub __attribute__ {
2283     my ($self, $attribute, $path, $node, $silent) = @_;
2284     if ($attribute eq '*') {
2285     $node = [$node->getAttributes->getValues];
2286    
2287     $self->_indent();
2288     if ($node) {
2289     $node = &__get_node_set__ ($self, $path, $node, $silent);
2290     } else {
2291     $self->debug("failed!");;
2292     }
2293     $self->_outdent();
2294     } else {
2295     $node = $node->getAttributeNode($attribute);
2296    
2297     $self->_indent();
2298     if ($node) {
2299     $node = &__get_node_set__ ($self, $path, [$node], $silent);
2300     } else {
2301     $self->debug("failed!");;
2302     $node = [];
2303     }
2304     $self->_outdent();
2305     }
2306    
2307     return $node;
2308     }
2309    
2310     sub __get_nodes__ {
2311     my ($self, $node_type, $path, $node, $silent) = @_;
2312    
2313     my $result = [];
2314    
2315     $self->_indent();
2316     foreach my $child ($node->getChildNodes) {
2317     if ($child->getNodeType == $node_type) {
2318     $result = [@$result, &__get_node_set__ ($self, $path, [$child], $silent)];
2319     }
2320     }
2321     $self->_outdent();
2322    
2323     if (! @$result) {
2324     $self->debug("failed!");;
2325     }
2326    
2327     return $result;
2328     }
2329    
2330    
2331     sub _attribute_value_of {
2332     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2333     $variables) = @_;
2334    
2335     foreach my $attribute ($xsl_node->getAttributes->getValues) {
2336     my $value = $attribute->getValue;
2337     study ($value);
2338     #$value =~ s/(\*|\$|\@|\&|\?|\+|\\)/\\$1/g;
2339     $value =~ s/(\*|\?|\+)/\\$1/g;
2340     study ($value);
2341     while ($value =~ /\G[^\\]?\{(.*?[^\\]?)\}/) {
2342     my $node = $self->_get_node_set ($1, $self->xml_document(),
2343     $current_xml_selection_path,
2344     $current_xml_node, $variables);
2345     if (@$node) {
2346     $self->_indent();
2347     my $text = $self->__string__ ($$node[0]);
2348     $self->_outdent();
2349     $value =~ s/(\G[^\\]?)\{(.*?)[^\\]?\}/$1$text/;
2350     } else {
2351     $value =~ s/(\G[^\\]?)\{(.*?)[^\\]?\}/$1/;
2352     }
2353     }
2354     #$value =~ s/\\(\*|\$|\@|\&|\?|\+|\\)/$1/g;
2355     $value =~ s/\\(\*|\?|\+)/$1/g;
2356     $value =~ s/\\(\{|\})/$1/g;
2357     $attribute->setValue ($value);
2358     }
2359     }
2360    
2361     sub _processing_instruction {
2362     my ($self, $xsl_node, $current_result_node, $variables, $oldvariables) = @_;
2363    
2364     my $new_PI_name = $xsl_node->getAttribute('name');
2365    
2366     if ($new_PI_name eq "xml") {
2367     $self->warn("<" . $self->xsl_ns() . "processing-instruction> may not be used to create XML");
2368     $self->warn("declaration. Use <" . $self->xsl_ns() . "output> instead...");
2369     } elsif ($new_PI_name) {
2370     my $text = $self->__string__ ($xsl_node);
2371     my $new_PI = $self->xml_document()->createProcessingInstruction($new_PI_name, $text);
2372    
2373     if ($new_PI) {
2374     $self->_move_node ($new_PI, $current_result_node);
2375     }
2376     } else {
2377     $self->warn(q{Expected attribute "name" in <} .
2378     $self->xsl_ns() . "processing-instruction> !");
2379     }
2380     }
2381    
2382     sub _process_with_params {
2383     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2384     $variables, $params) = @_;
2385    
2386     my @params = $xsl_node->getElementsByTagName($self->xsl_ns() . "with-param");
2387     foreach my $param (@params) {
2388     my $varname = $param->getAttribute('name');
2389    
2390     if ($varname) {
2391     my $value = $param->getAttribute('select');
2392    
2393     if (!$value) {
2394     # process content as template
2395     $value = $self->xml_document()->createDocumentFragment;
2396    
2397     $self->_evaluate_template ($param,
2398     $current_xml_node,
2399     $current_xml_selection_path,
2400     $value, $variables, {} );
2401     $$params{$varname} = $value;
2402    
2403     } else {
2404     # *** FIXME - should evaluate this as an expression!
2405     $$params{$varname} = $value;
2406     }
2407     } else {
2408     $self->warn(q{Expected attribute "name" in <} .
2409     $self->xsl_ns() . q{with-param> !});
2410     }
2411     }
2412    
2413     }
2414    
2415     sub _call_template {
2416     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2417     $current_result_node, $variables, $oldvariables) = @_;
2418    
2419     my $params={};
2420     my $newvariables = defined $variables ? {%$variables} : {} ;
2421     my $name = $xsl_node->getAttribute('name');
2422    
2423     if ($name) {
2424     $self->debug(qq{calling template named "$name"});
2425    
2426     $self->_process_with_params ($xsl_node, $current_xml_node,
2427     $current_xml_selection_path,
2428     $variables, $params);
2429    
2430     $self->_indent();
2431     my $template = $self->_match_template ("name", $name, 0, '');
2432    
2433     if ($template) {
2434     $self->_evaluate_template ($template, $current_xml_node,
2435     $current_xml_selection_path,
2436     $current_result_node, $newvariables, $params);
2437     } else {
2438     $self->warn("no template named $name found!");
2439     }
2440     $self->_outdent();
2441     } else {
2442     $self->warn(q{Expected attribute "name" in <} .
2443     $self->xsl_ns() . q{call-template/>});
2444     }
2445     }
2446    
2447     sub _choose {
2448     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2449     $current_result_node, $variables, $oldvariables) = @_;
2450    
2451     $self->debug("evaluating choose:");;
2452    
2453     $self->_indent();
2454    
2455     my $notdone = "true";
2456     my $testwhen = "active";
2457     foreach my $child ($xsl_node->getElementsByTagName ('*', 0)) {
2458     if ($notdone && $testwhen && ($child->getTagName eq $self->xsl_ns() ."when")) {
2459     my $test = $child->getAttribute ('test');
2460    
2461     if ($test) {
2462     my $test_succeeds = $self->_evaluate_test ($test, $current_xml_node,
2463     $current_xml_selection_path,
2464     $variables);
2465     if ($test_succeeds) {
2466     $self->_evaluate_template ($child, $current_xml_node,
2467     $current_xml_selection_path,
2468     $current_result_node, $variables, $oldvariables);
2469     $testwhen = "";
2470     $notdone = "";
2471     }
2472     } else {
2473     $self->warn(q{expected attribute "test" in <} .
2474     $self->xsl_ns() . q{when>});
2475     }
2476     } elsif ($notdone && ($child->getTagName eq $self->xsl_ns() . "otherwise")) {
2477     $self->_evaluate_template ($child, $current_xml_node,
2478     $current_xml_selection_path,
2479     $current_result_node, $variables, $oldvariables);
2480     $notdone = "";
2481     }
2482     }
2483    
2484     if ($notdone) {
2485     $self->debug("nothing done!");;
2486     }
2487    
2488     $self->_outdent();
2489     }
2490    
2491     sub _if {
2492     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2493     $current_result_node, $variables, $oldvariables) = @_;
2494    
2495     $self->debug("evaluating if:");;
2496    
2497     $self->_indent();
2498    
2499     my $test = $xsl_node->getAttribute ('test');
2500    
2501     if ($test) {
2502     my $test_succeeds = $self->_evaluate_test ($test, $current_xml_node,
2503     $current_xml_selection_path,
2504     $variables);
2505     if ($test_succeeds) {
2506     $self->_evaluate_template ($xsl_node, $current_xml_node,
2507     $current_xml_selection_path,
2508     $current_result_node, $variables, $oldvariables);
2509     }
2510     } else {
2511     $self->warn(q{expected attribute "test" in <} .
2512     $self->xsl_ns() . q{if>});
2513     }
2514    
2515     $self->_outdent();
2516     }
2517    
2518     sub __evaluate_test__ {
2519     my ($self,$test, $path,$node,$variables) = @_;
2520    
2521     my $tagname = eval { $node->getTagName() } || '';
2522    
2523     $self->debug(qq{testing with "$test" and $tagname});
2524    
2525     if ($test =~ /^\s*\@([\w\.\:\-]+)\s*(<=|>=|!=|<|>|=)?\s*['"]?([^'"]*?)['"]?\s*$/) {
2526     my $attr = $node->getAttribute($1);
2527    
2528     my $test = $2 ;
2529     $test =~ s/\s+//g;
2530     my $expval = $3;
2531     my $numeric = ($attr =~ /^\d+$/ && $expval =~ /^\d+$/ ? 1 : 0);
2532    
2533     $self->debug("evaluating $attr $test $expval " );
2534    
2535     if ( $test eq '!=' )
2536     {
2537     $self->debug("$numeric ? $attr != $expval : $attr ne $expval");
2538     return $numeric ? $attr != $expval : $attr ne $expval;
2539     }
2540     elsif ( $test eq '=' )
2541     {
2542     $self->debug("$numeric ? $attr == $expval : $attr eq $expval");
2543     return $numeric ? $attr == $expval : $attr eq $expval;
2544     }
2545     elsif ( $test eq '<' )
2546     {
2547     $self->debug("$numeric ? $attr < $expval : $attr lt $expval");
2548     return $numeric ? $attr < $expval : $attr lt $expval;
2549     }
2550     elsif ( $test eq '>' )
2551     {
2552     $self->debug("$numeric ? $attr > $expval : $attr gt $expval");
2553     return $numeric ? $attr > $expval : $attr gt $expval;
2554     }
2555     elsif ( $test eq '>=' )
2556     {
2557     $self->debug("$numeric ? $attr >= $expval : $attr ge $expval");
2558     return $numeric ? $attr >= $expval : $attr ge $expval;
2559     }
2560     elsif ( $test eq '<=' )
2561     {
2562     $self->debug("$numeric ? $attr <= $expval : $attr le $expval");
2563     return $numeric ? $attr <= $expval : $attr le $expval;
2564     }
2565     else
2566     {
2567     $self->debug("no test matches");
2568     return 0;
2569     }
2570     } elsif ($test =~ /^\s*([\w\.\:\-]+)\s*(<=|>=|!=|=|<|>)\s*['"]?([^'"]*)['"]?\s*$/) {
2571     my $expval = $3;
2572     my $test = $2;
2573     my $nodeset=&_get_node_set($self,$1,$self->xml_document(),$path,$node,$variables);
2574     return ($expval ne '') unless @$nodeset;
2575     my $content = &__string__($self,$$nodeset[0]);
2576     my $numeric = $content =~ /^\d+$/ && $expval =~ /^\d+$/ ? 1 : 0;
2577    
2578     $self->debug("evaluating $content $test $expval");
2579    
2580     if ( $test eq '!=' )
2581     {
2582     return $numeric ? $content != $expval : $content ne $expval;
2583     }
2584     elsif ( $test eq '=' )
2585     {
2586     return $numeric ? $content == $expval : $content eq $expval;
2587     }
2588     elsif ( $test eq '<' )
2589     {
2590     return $numeric ? $content < $expval : $content lt $expval;
2591     }
2592     elsif ( $test eq '>' )
2593     {
2594     return $numeric ? $content > $expval : $content gt $expval;
2595     }
2596     elsif ( $test eq '>=' )
2597     {
2598     return $numeric ? $content >= $expval : $content ge $expval;
2599     }
2600     elsif ( $test eq '<=' )
2601     {
2602     return $numeric ? $content <= $expval : $content le $expval;
2603     }
2604     else
2605     {
2606     $self->debug("no test matches");
2607     return 0;
2608     }
2609 joko 1.2
2610     # tests for variables|parameters
2611     } elsif ($test =~ /^\s*{*\$([\w\.\:\-]+)}*\s*(<=|>=|!=|=|<|>)\s*['"]?([^'"]*)['"]?\s*$/) {
2612     my $expval = $3;
2613     my $test = $2;
2614     =pod
2615     my $nodeset=&_get_node_set($self,$1,$self->xml_document(),$path,$node,$variables);
2616     return ($expval ne '') unless @$nodeset;
2617     my $content = &__string__($self,$$nodeset[0]);
2618     =cut
2619     my $variable_name = $1;
2620     my $content = &__string__($self,$variables->{$variable_name});
2621     my $numeric = $content =~ /^\d+$/ && $expval =~ /^\d+$/ ? 1 : 0;
2622    
2623     $self->debug("evaluating $content $test $expval");
2624    
2625     if ( $test eq '!=' )
2626     {
2627     return $numeric ? $content != $expval : $content ne $expval;
2628     }
2629     elsif ( $test eq '=' )
2630     {
2631     return $numeric ? $content == $expval : $content eq $expval;
2632     }
2633     elsif ( $test eq '<' )
2634     {
2635     return $numeric ? $content < $expval : $content lt $expval;
2636     }
2637     elsif ( $test eq '>' )
2638     {
2639     return $numeric ? $content > $expval : $content gt $expval;
2640     }
2641     elsif ( $test eq '>=' )
2642     {
2643     return $numeric ? $content >= $expval : $content ge $expval;
2644     }
2645     elsif ( $test eq '<=' )
2646     {
2647     return $numeric ? $content <= $expval : $content le $expval;
2648     }
2649     else
2650     {
2651     $self->warn("no test matches while evaluating parameter comparison: $test");
2652     return 0;
2653     }
2654 joko 1.1 } else {
2655 joko 1.2 $self->debug("no match for test");
2656 joko 1.1 return "";
2657     }
2658     }
2659    
2660     sub _copy_of {
2661     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2662     $current_result_node, $variables) = @_;
2663    
2664     my $nodelist;
2665     my $select = $xsl_node->getAttribute('select');
2666     $self->debug(qq{evaluating copy-of with select "$select":});;
2667    
2668     $self->_indent();
2669     if ($select) {
2670     $nodelist = $self->_get_node_set ($select, $self->xml_document(),
2671     $current_xml_selection_path,
2672     $current_xml_node, $variables);
2673     } else {
2674     $self->warn(q{expected attribute "select" in <} .
2675     $self->xsl_ns() . q{copy-of>});
2676     }
2677     foreach my $node (@$nodelist) {
2678     $self->_add_node ($node, $current_result_node, "deep");
2679     }
2680    
2681     $self->_outdent();
2682     }
2683    
2684     sub _copy {
2685     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2686     $current_result_node, $variables, $oldvariables) = @_;
2687    
2688    
2689     $self->debug("evaluating copy:");;
2690    
2691     $self->_indent();
2692     if ($current_xml_node->getNodeType == ATTRIBUTE_NODE) {
2693     my $attribute = $current_xml_node->cloneNode(0);
2694     $current_result_node->setAttributeNode($attribute);
2695     } elsif (($current_xml_node->getNodeType == COMMENT_NODE)
2696     || ($current_xml_node->getNodeType == PROCESSING_INSTRUCTION_NODE)) {
2697     $self->_add_node ($current_xml_node, $current_result_node);
2698     } else {
2699     $self->_add_node ($current_xml_node, $current_result_node);
2700     $self->_evaluate_template ($xsl_node,
2701     $current_xml_node,
2702     $current_xml_selection_path,
2703     $current_result_node->getLastChild,
2704     $variables, $oldvariables);
2705     }
2706     $self->_outdent();
2707     }
2708    
2709     sub _text {
2710     #=item addText (text)
2711     #
2712     #Appends the specified string to the last child if it is a Text node, or else
2713     #appends a new Text node (with the specified text.)
2714     #
2715     #Return Value: the last child if it was a Text node or else the new Text node.
2716     my ($self, $xsl_node, $current_result_node) = @_;
2717    
2718     $self->debug("inserting text:");
2719    
2720     $self->_indent();
2721    
2722     $self->debug("stripping node to text:");
2723    
2724     $self->_indent();
2725     my $text = $self->__string__ ($xsl_node);
2726     $self->_outdent();
2727    
2728     if ($text ne '') {
2729     my $node = $self->xml_document()->createTextNode ($text);
2730     if ($xsl_node->getAttribute ('disable-output-escaping') eq 'yes')
2731     {
2732     $self->debug("disabling output escaping");
2733     bless $node,'XML::XSLT::DOM::TextDOE' ;
2734     }
2735     $self->_move_node ($node, $current_result_node);
2736     } else {
2737     $self->debug("nothing left..");
2738     }
2739    
2740     $current_result_node->normalize();
2741    
2742     $self->_outdent();
2743     }
2744    
2745     sub _attribute {
2746     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2747     $current_result_node, $variables, $oldvariables) = @_;
2748    
2749     my $name = $xsl_node->getAttribute ('name');
2750     $self->debug(qq{inserting attribute named "$name":});
2751     $self->_indent();
2752    
2753     if ($name) {
2754     if ( $name =~ /^xmlns:/ )
2755     {
2756     $self->debug("Won't create namespace declaration");
2757     }
2758     else
2759     {
2760     my $result = $self->xml_document()->createDocumentFragment;
2761    
2762     $self->_evaluate_template ($xsl_node,
2763     $current_xml_node,
2764     $current_xml_selection_path,
2765     $result, $variables, $oldvariables);
2766    
2767     $self->_indent();
2768     my $text = $self->fix_attribute_value($self->__string__ ($result));
2769    
2770    
2771     $self->_outdent();
2772    
2773     $current_result_node->setAttribute($name, $text);
2774     $result->dispose();
2775     }
2776     } else {
2777     $self->warn(q{expected attribute "name" in <} .
2778     $self->xsl_ns() . q{attribute>});
2779     }
2780     $self->_outdent();
2781     }
2782    
2783     sub _comment {
2784     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2785     $current_result_node, $variables, $oldvariables) = @_;
2786    
2787     $self->debug("inserting comment:");
2788    
2789     $self->_indent();
2790    
2791     my $result = $self->xml_document()->createDocumentFragment;
2792    
2793     $self->_evaluate_template ($xsl_node,
2794     $current_xml_node,
2795     $current_xml_selection_path,
2796     $result, $variables, $oldvariables);
2797    
2798     $self->_indent();
2799     my $text = $self->__string__ ($result);
2800     $self->_outdent();
2801    
2802     $self->_move_node ($self->xml_document()->createComment ($text), $current_result_node);
2803     $result->dispose();
2804    
2805     $self->_outdent();
2806     }
2807    
2808     sub _variable {
2809     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2810     $current_result_node, $variables, $params, $is_param) = @_;
2811    
2812     my $varname = $xsl_node->getAttribute ('name');
2813    
2814     if ($varname) {
2815     $self->debug("definition of variable \$$varname:");;
2816    
2817     $self->_indent();
2818    
2819     if ( $is_param and exists $$params{$varname} ) {
2820     # copy from parent-template
2821    
2822     $$variables{$varname} = $$params{$varname};
2823    
2824     } else {
2825     # new variable definition
2826    
2827     my $value = $xsl_node->getAttribute ('select');
2828    
2829     if (! $value) {
2830     #tough case, evaluate content as template
2831    
2832     $value = $self->xml_document()->createDocumentFragment;
2833    
2834     $self->_evaluate_template ($xsl_node,
2835     $current_xml_node,
2836     $current_xml_selection_path,
2837     $value, $variables, $params);
2838     }
2839    
2840     $$variables{$varname} = $value;
2841     }
2842    
2843     $self->_outdent();
2844     } else {
2845     $self->warn(q{expected attribute "name" in <} .
2846     $self->xsl_ns() . q{param> or <} .
2847     $self->xsl_ns() . q{variable>});
2848     }
2849     }
2850    
2851     # not implemented - but log it and make it go away
2852    
2853     sub _sort
2854     {
2855     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2856     $current_result_node, $variables, $params, $is_param) = @_;
2857    
2858     $self->debug("dummy process for sort");
2859     }
2860    
2861     # Not quite sure how fallback should be implemented as the spec seems a
2862     # little vague to me
2863    
2864     sub _fallback
2865     {
2866     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2867     $current_result_node, $variables, $params, $is_param) = @_;
2868    
2869     $self->debug("dummy process for fallback");
2870     }
2871    
2872     # This is a no-op - attribute-sets should not appear within templates and
2873     # we have already processed the stylesheet wide ones.
2874    
2875     sub _attribute_set
2876     {
2877     my ($self, $xsl_node, $current_xml_node, $current_xml_selection_path,
2878     $current_result_node, $variables, $params, $is_param) = @_;
2879    
2880     $self->debug("in _attribute_set");
2881     }
2882    
2883     sub _indent
2884     {
2885     my ( $self ) = @_;
2886     $self->{INDENT} += $self->{INDENT_INCR};
2887    
2888     }
2889    
2890     sub _outdent
2891     {
2892     my ( $self ) = @_;
2893     $self->{INDENT} -= $self->{INDENT_INCR};
2894     }
2895    
2896     sub fix_attribute_value
2897     {
2898     my ( $self, $text ) = @_;
2899    
2900     # The spec say's that there can't be a literal line break in the
2901     # attributes value - white space at the beginning or the end is
2902     # almost certainly an mistake.
2903    
2904     $text =~ s/^\s+//g;
2905     $text =~ s/\s+$//g;
2906    
2907     if ( $text )
2908     {
2909     $text =~ s/([\x0A\x0D])/sprintf("\&#%02X;",ord $1)/eg;
2910     }
2911    
2912     return $text;
2913     }
2914    
2915     1;
2916    
2917     __DATA__
2918    
2919     =head1 SYNOPSIS
2920    
2921     use XML::XSLT;
2922    
2923     my $xslt = XML::XSLT->new ($xsl, warnings => 1);
2924    
2925     $xslt->transform ($xmlfile);
2926     print $xslt->toString;
2927    
2928     $xslt->dispose();
2929    
2930     =head1 DESCRIPTION
2931    
2932     This module implements the W3C's XSLT specification. The goal is full
2933     implementation of this spec, but we have not yet achieved
2934     that. However, it already works well. See L<XML::XSLT Commands> for
2935     the current status of each command.
2936    
2937     XML::XSLT makes use of XML::DOM and LWP::Simple, while XML::DOM
2938     uses XML::Parser. Therefore XML::Parser, XML::DOM and LWP::Simple
2939     have to be installed properly for XML::XSLT to run.
2940    
2941     =head1 Specifying Sources
2942    
2943     The stylesheets and the documents may be passed as filenames, file
2944     handles regular strings, string references or DOM-trees. Functions
2945     that require sources (e.g. new), will accept either a named parameter
2946     or simply the argument.
2947    
2948     Either of the following are allowed:
2949    
2950     my $xslt = XML::XSLT->new($xsl);
2951     my $xslt = XML::XSLT->new(Source => $xsl);
2952    
2953     In documentation, the named parameter `Source' is always shown, but it
2954     is never required.
2955    
2956     =head2 METHODS
2957    
2958     =over 4
2959    
2960     =item new(Source => $xml [, %args])
2961    
2962     Returns a new XSLT parser object. Valid flags are:
2963    
2964     =over 2
2965    
2966     =item DOMparser_args
2967    
2968     Hashref of arguments to pass to the XML::DOM::Parser object's parse
2969     method.
2970    
2971     =item variables
2972    
2973     Hashref of variables and their values for the stylesheet.
2974    
2975     =item base
2976    
2977     Base of URL for file inclusion.
2978    
2979     =item debug
2980    
2981     Turn on debugging messages.
2982    
2983     =item warnings
2984    
2985     Turn on warning messages.
2986    
2987     =item indent
2988    
2989     Starting amount of indention for debug messages. Defaults to 0.
2990    
2991     =item indent_incr
2992    
2993     Amount to indent each level of debug message. Defaults to 1.
2994    
2995     =back
2996    
2997     =item open_xml(Source => $xml [, %args])
2998    
2999     Gives the XSLT object new XML to process. Returns an XML::DOM object
3000     corresponding to the XML.
3001    
3002     =over 4
3003    
3004     =item base
3005    
3006     The base URL to use for opening documents.
3007    
3008     =item parser_args
3009    
3010     Arguments to pase to the parser.
3011    
3012     =back
3013    
3014     =item open_xsl(Source => $xml, [, %args])
3015    
3016     Gives the XSLT object a new stylesheet to use in processing XML.
3017     Returns an XML::DOM object corresponding to the stylesheet. Any
3018     arguments present are passed to the XML::DOM::Parser.
3019    
3020     =over 4
3021    
3022     =item base
3023    
3024     The base URL to use for opening documents.
3025    
3026     =item parser_args
3027    
3028     Arguments to pase to the parser.
3029    
3030     =back
3031    
3032     =item process(%variables)
3033    
3034     Processes the previously loaded XML through the stylesheet using the
3035     variables set in the argument.
3036    
3037     =item transform(Source => $xml [, %args])
3038    
3039     Processes the given XML through the stylesheet. Returns an XML::DOM
3040     object corresponding to the transformed XML. Any arguments present
3041     are passed to the XML::DOM::Parser.
3042    
3043     =item serve(Source => $xml [, %args])
3044    
3045     Processes the given XML through the stylesheet. Returns a string
3046     containg the result. Example:
3047    
3048     use XML::XSLT qw(serve);
3049    
3050     $xslt = XML::XSLT->new($xsl);
3051     print $xslt->serve $xml;
3052    
3053     =over 4
3054    
3055     =item http_headers
3056    
3057     If true, then prepends the appropriate HTTP headers (e.g. Content-Type,
3058     Content-Length);
3059    
3060     Defaults to true.
3061    
3062     =item xml_declaration
3063    
3064     If true, then the result contains the appropriate <?xml?> header.
3065    
3066     Defaults to true.
3067    
3068     =item xml_version
3069    
3070     The version of the XML.
3071    
3072     Defaults to 1.0.
3073    
3074     =item doctype
3075    
3076     The type of DOCTYPE this document is. Defaults to SYSTEM.
3077    
3078     =back
3079    
3080     =item toString
3081    
3082     Returns the result of transforming the XML with the stylesheet as a
3083     string.
3084    
3085     =item to_dom
3086    
3087     Returns the result of transforming the XML with the stylesheet as an
3088     XML::DOM object.
3089    
3090     =item media_type
3091    
3092     Returns the media type (aka mime type) of the object.
3093    
3094     =item dispose
3095    
3096     Executes the C<dispose> method on each XML::DOM object.
3097    
3098     =back
3099    
3100     =head1 XML::XSLT Commands
3101    
3102     =over 4
3103    
3104     =item xsl:apply-imports no
3105    
3106     Not supported yet.
3107    
3108     =item xsl:apply-templates limited
3109    
3110     Attribute 'select' is supported to the same extent as xsl:value-of
3111     supports path selections.
3112    
3113     Not supported yet:
3114     - attribute 'mode'
3115     - xsl:sort and xsl:with-param in content
3116    
3117     =item xsl:attribute partially
3118    
3119     Adds an attribute named to the value of the attribute 'name' and as value
3120     the stringified content-template.
3121    
3122     Not supported yet:
3123     - attribute 'namespace'
3124    
3125     =item xsl:attribute-set yes
3126    
3127     Partially
3128    
3129     =item xsl:call-template yes
3130    
3131     Takes attribute 'name' which selects xsl:template's by name.
3132    
3133     Weak support:
3134     - xsl:with-param (select attrib not supported)
3135    
3136     Not supported yet:
3137     - xsl:sort
3138    
3139     =item xsl:choose yes
3140    
3141     Tests sequentially all xsl:whens until one succeeds or
3142     until an xsl:otherwise is found. Limited test support, see xsl:when
3143    
3144     =item xsl:comment yes
3145    
3146     Supported.
3147    
3148     =item xsl:copy partially
3149    
3150     =item xsl:copy-of limited
3151    
3152     Attribute 'select' functions as well as with
3153     xsl:value-of
3154    
3155     =item xsl:decimal-format no
3156    
3157     Not supported yet.
3158    
3159     =item xsl:element yes
3160    
3161     =item xsl:fallback no
3162    
3163     Not supported yet.
3164    
3165     =item xsl:for-each limited
3166    
3167     Attribute 'select' functions as well as with
3168     xsl:value-of
3169    
3170     Not supported yet:
3171     - xsl:sort in content
3172    
3173     =item xsl:if limited
3174    
3175     Identical to xsl:when, but outside xsl:choose context.
3176    
3177     =item xsl:import no
3178    
3179     Not supported yet.
3180    
3181     =item xsl:include yes
3182    
3183     Takes attribute href, which can be relative-local,
3184     absolute-local as well as an URL (preceded by
3185     identifier http:).
3186    
3187     =item xsl:key no
3188    
3189     Not supported yet.
3190    
3191     =item xsl:message no
3192    
3193     Not supported yet.
3194    
3195     =item xsl:namespace-alias no
3196    
3197     Not supported yet.
3198    
3199     =item xsl:number no
3200    
3201     Not supported yet.
3202    
3203     =item xsl:otherwise yes
3204    
3205     Supported.
3206    
3207     =item xsl:output limited
3208    
3209     Only the initial xsl:output element is used. The "text" output method
3210     is not supported, but shouldn't be difficult to implement. Only the
3211     "doctype-public", "doctype-system", "omit-xml-declaration", "method",
3212     and "encoding" attributes have any support.
3213    
3214     =item xsl:param experimental
3215    
3216     Synonym for xsl:variable (currently). See xsl:variable for support.
3217    
3218     =item xsl:preserve-space no
3219    
3220     Not supported yet. Whitespace is always preserved.
3221    
3222     =item xsl:processing-instruction yes
3223    
3224     Supported.
3225    
3226     =item xsl:sort no
3227    
3228     Not supported yet.
3229    
3230     =item xsl:strip-space no
3231    
3232     Not supported yet. No whitespace is stripped.
3233    
3234     =item xsl:stylesheet limited
3235    
3236     Minor namespace support: other namespace than 'xsl:' for xsl-commands
3237     is allowed if xmlns-attribute is present. xmlns URL is verified.
3238     Other attributes are ignored.
3239    
3240     =item xsl:template limited
3241    
3242     Attribute 'name' and 'match' are supported to minor extend.
3243     ('name' must match exactly and 'match' must match with full
3244     path or no path)
3245    
3246     Not supported yet:
3247     - attributes 'priority' and 'mode'
3248    
3249     =item xsl:text yes
3250    
3251     Supported.
3252    
3253     =item xsl:transform limited
3254    
3255     Synonym for xsl:stylesheet
3256    
3257     =item xsl:value-of limited
3258    
3259     Inserts attribute or element values. Limited support:
3260    
3261     <xsl:value-of select="."/>
3262    
3263     <xsl:value-of select="/root-elem"/>
3264    
3265     <xsl:value-of select="elem"/>
3266    
3267     <xsl:value-of select="//elem"/>
3268    
3269     <xsl:value-of select="elem[n]"/>
3270    
3271     <xsl:value-of select="//elem[n]"/>
3272    
3273     <xsl:value-of select="@attr"/>
3274    
3275     <xsl:value-of select="text()"/>
3276    
3277     <xsl:value-of select="processing-instruction()"/>
3278    
3279     <xsl:value-of select="comment()"/>
3280    
3281     and combinations of these.
3282    
3283     Not supported yet:
3284     - attribute 'disable-output-escaping'
3285    
3286     =item xsl:variable experimental
3287    
3288     Very limited. It should be possible to define a variable and use it with
3289     &lt;xsl:value select="$varname" /&gt; within the same template.
3290    
3291     =item xsl:when limited
3292    
3293     Only inside xsl:choose. Limited test support:
3294    
3295     <xsl:when test="@attr='value'">
3296    
3297     <xsl:when test="elem='value'">
3298    
3299     <xsl:when test="path/[@attr='value']">
3300    
3301     <xsl:when test="path/[elem='value']">
3302    
3303     <xsl:when test="path">
3304    
3305     path is supported to the same extend as with xsl:value-of
3306    
3307     =item xsl:with-param experimental
3308    
3309     It is currently not functioning. (or is it?)
3310    
3311     =back
3312    
3313     =head1 SUPPORT
3314    
3315     General information, bug reporting tools, the latest version, mailing
3316     lists, etc. can be found at the XML::XSLT homepage:
3317    
3318     http://xmlxslt.sourceforge.net/
3319    
3320     =head1 DEPRECATIONS
3321    
3322     Methods and interfaces from previous versions that are not documented in this
3323     version are deprecated. Each of these deprecations can still be used
3324     but will produce a warning when the deprecation is first used. You
3325     can use the old interfaces without warnings by passing C<new()> the
3326     flag C<use_deprecated>. Example:
3327    
3328     $parser = XML::XSLT->new($xsl, "FILE",
3329     use_deprecated => 1);
3330    
3331     The deprecated methods will disappear by the time a 1.0 release is made.
3332    
3333     The deprecated methods are :
3334    
3335     =over 2
3336    
3337     =item output_string
3338    
3339     use toString instead
3340    
3341     =item result_string
3342    
3343     use toString instead
3344    
3345     =item output
3346    
3347     use toString instead
3348    
3349     =item result
3350    
3351     use toString instead
3352    
3353     =item result_mime_type
3354    
3355     use media_type instead
3356    
3357     =item output_mime_type
3358    
3359     use media_type instead
3360    
3361     =item result_tree
3362    
3363     use to_dom instead
3364    
3365     =item output_tree
3366    
3367     use to_dom instead
3368    
3369     =item transform_document
3370    
3371     use transform instead
3372    
3373     =item process_project
3374    
3375     use process instead
3376    
3377     =item open_project
3378    
3379     use C<Source> argument to B<new()> and B<transform> instead.
3380    
3381     =item print_output
3382    
3383     use B<serve()> instead.
3384    
3385     =back
3386    
3387     =head1 BUGS
3388    
3389     Yes.
3390    
3391     =head1 HISTORY
3392    
3393     Geert Josten and Egon Willighagen developed and maintained XML::XSLT
3394     up to version 0.22. At that point, Mark Hershberger started moving
3395     the project to Sourceforge and began working on it with Bron Gondwana.
3396    
3397     =head1 LICENCE
3398    
3399     Copyright (c) 1999 Geert Josten & Egon Willighagen. All Rights
3400     Reserverd. This module is free software, and may be distributed under
3401     the same terms and conditions as Perl.
3402    
3403     =head1 AUTHORS
3404    
3405     Geert Josten <gjosten@sci.kun.nl>
3406    
3407     Egon Willighagen <egonw@sci.kun.nl>
3408    
3409     Mark A. Hershberger <mah@everybody.org>
3410    
3411     Bron Gondwana <perlcode@brong.net>
3412    
3413     Jonathan Stowe <jns@gellyfish.com>
3414    
3415     =head1 SEE ALSO
3416    
3417     L<XML::DOM>, L<LWP::Simple>, L<XML::Parser>
3418    
3419     =cut

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed