File Coverage

blib/lib/XML/XSLT.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

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