File Coverage

blib/lib/XML/XSH/Functions.pm
Criterion Covered Total %
statement 118 2082 5.6
branch 0 1238 0.0
condition 0 431 0.0
subroutine 28 248 11.2
pod 0 185 0.0
total 146 4184 3.4


line stmt bran cond sub pod time code
1             # -*- cperl -*-
2             # $Id: Functions.pm,v 1.73 2003/09/10 15:54:09 pajas Exp $
3              
4             package XML::XSH::Functions;
5              
6 4     4   3754196 eval "no encoding";
  4         64144  
  4         33  
7             undef $@;
8 4     4   20 use strict;
  4         6  
  4         103  
9 4     4   19 no warnings;
  4         8  
  4         162  
10              
11 4     4   3949 use XML::XSH::Help;
  4         10  
  4         1258  
12 4     4   9645 use XML::XSH::Iterators;
  4         12  
  4         114  
13 4     4   18 use IO::File;
  4         7  
  4         576  
14              
15 4     4   18 use Exporter;
  4         8  
  4         240  
16 4         2468 use vars qw/@ISA @EXPORT_OK %EXPORT_TAGS $VERSION $REVISION $OUT $LOCAL_ID $LOCAL_NODE
17             $_xml_module $_sigint
18             $_xsh $_xpc $_parser %_nodelist @stored_variables
19             $_newdoc
20             $TRAP_SIGINT $TRAP_SIGPIPE $_die_on_err $_on_exit
21             %_doc %_files %_defs %_includes %_chr %_ns
22             $ENCODING $QUERY_ENCODING
23             $INDENT $BACKUPS $SWITCH_TO_NEW_DOCUMENTS $EMPTY_TAGS $SKIP_DTD
24             $QUIET $DEBUG $TEST_MODE
25             $VALIDATION $RECOVERING $PARSER_EXPANDS_ENTITIES $KEEP_BLANKS
26             $PEDANTIC_PARSER $LOAD_EXT_DTD $PARSER_COMPLETES_ATTRIBUTES
27             $PARSER_EXPANDS_XINCLUDE
28             $XPATH_AXIS_COMPLETION
29             $XPATH_COMPLETION $DEFAULT_FORMAT
30 4     4   17 /;
  4         6  
31              
32             BEGIN {
33 4     4   11 $VERSION='1.8.3';
34 4         13 $REVISION='$Revision: 1.73 $';
35 4         32 @ISA=qw(Exporter);
36 4         18 my @PARAM_VARS=qw/$ENCODING
37             $QUERY_ENCODING
38             $INDENT
39             $EMPTY_TAGS
40             $SKIP_DTD
41             $BACKUPS
42             $SWITCH_TO_NEW_DOCUMENTS
43             $QUIET
44             $DEBUG
45             $TEST_MODE
46             $VALIDATION
47             $RECOVERING
48             $PARSER_EXPANDS_ENTITIES
49             $XPATH_AXIS_COMPLETION
50             $XPATH_COMPLETION
51             $KEEP_BLANKS
52             $PEDANTIC_PARSER
53             $LOAD_EXT_DTD
54             $PARSER_COMPLETES_ATTRIBUTES
55             $PARSER_EXPANDS_XINCLUDE
56             $DEFAULT_FORMAT
57             /;
58 4         10 *EMPTY_TAGS=*XML::LibXML::setTagCompression;
59 4         8 *SKIP_DTD=*XML::LibXML::skipDTD;
60 4         30 @EXPORT_OK=(qw(&xsh_init &xsh &xsh_get_output
61             &xsh_set_output &xsh_set_parser
62             &set_quiet &set_debug &set_compile_only_mode
63             &create_doc &open_doc &set_doc
64             &xsh_pwd &xsh_local_id &get_doc &out
65             &toUTF8 &fromUTF8 &set_local_doc
66             &xsh_xml_parser &xsh_parse_string &xsh_docs
67             ),@PARAM_VARS);
68 4         54 %EXPORT_TAGS = (
69             default => [@EXPORT_OK],
70             param_vars => [@PARAM_VARS]
71             );
72              
73 4         7 $TRAP_SIGINT=0;
74 4         7 $_xml_module='XML::XSH::LibXMLCompat';
75 4         10 $INDENT=1;
76 4         7 $EMPTY_TAGS=1; # no effect (reseted by XML::LibXML)
77 4         9 $SKIP_DTD=0; # no effect (reseted by XML::LibXML)
78 4         6 $BACKUPS=1;
79 4         7 $SWITCH_TO_NEW_DOCUMENTS=1;
80 4         6 $ENCODING='utf-8';
81 4         8 $QUERY_ENCODING='utf-8';
82 4         5 $QUIET=0;
83 4         14 $DEBUG=0;
84 4         6 $TEST_MODE=0;
85 4         6 $VALIDATION=0;
86 4         5 $RECOVERING=0;
87 4         6 $PARSER_EXPANDS_ENTITIES=1;
88 4         11 $KEEP_BLANKS=1;
89 4         7 $PEDANTIC_PARSER=0;
90 4         4 $LOAD_EXT_DTD=0;
91 4         6 $PARSER_COMPLETES_ATTRIBUTES=1;
92 4         6 $PARSER_EXPANDS_XINCLUDE=0;
93 4         10 $XPATH_COMPLETION=1;
94 4         7 $XPATH_AXIS_COMPLETION='always'; # never / when-empty
95 4         5 $DEFAULT_FORMAT='xml';
96 4         8 $_newdoc=1;
97 4         10 $_die_on_err=1;
98 4         7 %_nodelist=();
99              
100 4         33 %_chr = ( n => "\n", t => "\t", r => "\r",
101             f => "\f", b => "\b", a => "\a",
102             e => "\e" );
103 4         25 autoflush STDOUT;
104 4         179 autoflush STDERR;
105             }
106              
107 0 0   0 0   sub min { $_[0] > $_[1] ? $_[1] : $_[0] }
108              
109             sub out {
110 0 0 0 0 0   if (ref($OUT) eq 'GLOB' or ref($OUT) eq 'Term::ReadLine::Gnu::Var') {
111 0           print $OUT @_;
112             } else {
113 0           $OUT->print(@_);
114             }
115             }
116              
117             sub __debug {
118 0     0     _err(@_);
119             }
120              
121             sub __bug {
122 0     0     _err("BUG: ",@_);
123             }
124              
125              
126             # initialize XSH and XML parsers
127             sub xsh_init {
128 0     0 0   my $module=shift;
129 0 0         shift unless ref($_[0]);
130 0 0         if (ref($_[0])) {
131 0           $OUT=$_[0];
132             } else {
133 0           $OUT=\*STDOUT;
134             }
135 0 0         $_xml_module=$module if $module;
136 0           eval "require $_xml_module;";
137 0 0         if ($@) {
138 0           _err(
139             "\n------------------------------------------------------------\n",
140             $@,
141             "\n------------------------------------------------------------.\n",
142             "I suspect you have not installed XML::LibXML properly.\n",
143             "Please install and try again. If you are 100% sure you have, send\n",
144             "a full bug report to \n");
145 0           exit 1;
146             }
147 0           my $mod=$_xml_module->module();
148 0 0         if ($] >= 5.008) {
149 0           require Encode;
150 0           *encodeToUTF8=*Encode::decode;
151 0           *decodeFromUTF8=*Encode::encode;
152             } else {
153 4     4   1400 no strict 'refs';
  4         7  
  4         4008  
154 0           *encodeToUTF8=*{"$mod"."::encodeToUTF8"};
  0            
155 0           *decodeFromUTF8=*{"$mod"."::decodeFromUTF8"};
  0            
156             }
157 0           $_parser = $_xml_module->new_parser();
158              
159 0           xpc_init();
160 0           xsh_rd_parser_init();
161             }
162              
163             sub xsh_rd_parser_init {
164 0 0   0 0   if (eval { require XML::XSH::Parser; }) {
  0            
165 0           $_xsh=XML::XSH::Parser->new();
166             } else {
167 0           print STDERR "Parsing raw grammar...\n";
168 0           require XML::XSH::Grammar;
169 0           $_xsh=XML::XSH::Grammar->new();
170 0           print STDERR "... done.\n";
171 0 0         unless ($QUIET) {
172 0           print STDERR << 'EOF';
173             NOTE: To avoid this, you should regenerate the XML::XSH::Parser.pm
174             module from XML::XSH::Grammar.pm module by changing to XML/XSH/
175             directory in your load-path and running the following command:
176              
177             perl -MGrammar -e XML::XSH::Grammar::compile
178              
179             EOF
180             }
181             }
182 0           return $_xsh;
183             }
184              
185 0     0 0   sub set_validation { $VALIDATION=$_[0]; 1; }
  0            
186 0     0 0   sub set_recovering { $RECOVERING=$_[0]; 1; }
  0            
187 0     0 0   sub set_expand_entities { $PARSER_EXPANDS_ENTITIES=$_[0]; 1; }
  0            
188 0     0 0   sub set_keep_blanks { $KEEP_BLANKS=$_[0]; 1; }
  0            
189 0     0 0   sub set_pedantic_parser { $PEDANTIC_PARSER=$_[0]; 1; }
  0            
190 0     0 0   sub set_load_ext_dtd { $LOAD_EXT_DTD=$_[0]; 1; }
  0            
191 0     0 0   sub set_complete_attributes { $PARSER_COMPLETES_ATTRIBUTES=$_[0]; 1; }
  0            
192 0     0 0   sub set_expand_xinclude { $PARSER_EXPANDS_XINCLUDE=$_[0]; 1; }
  0            
193 0     0 0   sub set_indent { $INDENT=$_[0]; 1; }
  0            
194 0     0 0   sub set_empty_tags { $EMPTY_TAGS=$_[0]; 1; }
  0            
195 0     0 0   sub set_skip_dtd { $SKIP_DTD=$_[0]; 1; }
  0            
196 0     0 0   sub set_backups { $BACKUPS=$_[0]; 1; }
  0            
197 0     0 0   sub set_cdonopen { $SWITCH_TO_NEW_DOCUMENTS=$_[0]; 1; }
  0            
198 0     0 0   sub set_xpath_completion { $XPATH_COMPLETION=$_[0]; 1; }
  0            
199 0     0 0   sub set_xpath_axis_completion { $XPATH_AXIS_COMPLETION=$_[0];
200 0 0         if ($XPATH_AXIS_COMPLETION!~/^always|when-empty|never$/) {
201 0           $XPATH_AXIS_COMPLETION='never';
202             }
203 0           1; }
204              
205 0     0 0   sub get_validation { $VALIDATION }
206 0     0 0   sub get_recovering { $RECOVERING }
207 0     0 0   sub get_expand_entities { $PARSER_EXPANDS_ENTITIES }
208 0     0 0   sub get_keep_blanks { $KEEP_BLANKS }
209 0     0 0   sub get_pedantic_parser { $PEDANTIC_PARSER }
210 0     0 0   sub get_load_ext_dtd { $LOAD_EXT_DTD }
211 0     0 0   sub get_complete_attributes { $PARSER_COMPLETES_ATTRIBUTES }
212 0     0 0   sub get_expand_xinclude { $PARSER_EXPANDS_XINCLUDE }
213 0     0 0   sub get_indent { $INDENT }
214 0     0 0   sub get_empty_tags { $EMPTY_TAGS }
215 0     0 0   sub get_skip_dtd { $SKIP_DTD }
216 0     0 0   sub get_backups { $BACKUPS }
217 0     0 0   sub get_cdonopen { $SWITCH_TO_NEW_DOCUMENTS }
218 0     0 0   sub get_xpath_completion { $XPATH_COMPLETION }
219 0     0 0   sub get_xpath_axis_completion { $XPATH_AXIS_COMPLETION }
220              
221              
222             # initialize global XPathContext
223             sub xpc_init {
224 0 0   0 0   unless (eval { require XML::LibXML::XPathContext;
  0            
225 0           $_xpc=XML::LibXML::XPathContext->new();
226             }) {
227 0           require XML::XSH::DummyXPathContext;
228 0           print STDERR ("Warning: XML::LibXML::XPathContext not found!\n".
229             "XSH will lack namespace and function registering functionality!\n\n");
230 0           $_xpc=XML::XSH::DummyXPathContext->new();
231             }
232 0           $_xpc->registerVarLookupFunc(\&xpath_var_lookup,undef);
233 0           $_xpc->registerNs('xsh',$XML::XSH::xshNS);
234             $_xpc->registerFunctionNS('doc',$XML::XSH::xshNS,
235             sub {
236 0 0   0     die "Wrong number of arguments for function doc(id)!" if (@_!=1);
237 0           my ($id)=literal_value($_[0]);
238 0 0         die "Wrong number of arguments for function doc(id)!" if (@_!=1);
239 0 0         die "Document does not exist!" unless (exists($_doc{$id}));
240 0           return $_doc{$id};
241 0           });
242             $_xpc->registerFunctionNS('matches',$XML::XSH::xshNS,
243             sub {
244 0 0   0     die "Wrong number of arguments for function matches(string,regexp)!" if (@_!=2);
245 0           my ($string,$regexp)=@_;
246 0           $regexp=literal_value($regexp);
247 4     4   3294 use utf8;
  4         41  
  4         26  
248 0 0         my $ret=literal_value($string)=~m{$regexp} ?
249             XML::LibXML::Boolean->True : XML::LibXML::Boolean->False;
250 0           $ret;
251 0           });
252             $_xpc->registerFunctionNS('grep',$XML::XSH::xshNS,
253             sub {
254 0 0   0     die "Wrong number of arguments for function grep(list,regexp)!" if (@_!=2);
255 0           my ($nodelist,$regexp)=@_;
256 0 0 0       die "1st argument must be a node-list in grep(list,regexp)!"
257             unless (ref($nodelist) and $nodelist->isa('XML::LibXML::NodeList'));
258 4     4   490 use utf8;
  4         7  
  4         13  
259 0           [grep { $_->to_literal=~m{$regexp} } @$nodelist];
  0            
260 0           });
261             $_xpc->registerFunctionNS('same',$XML::XSH::xshNS,
262             sub {
263 0 0   0     die "Wrong number of arguments for function same(node,node)!" if (@_!=2);
264 0           my ($nodea,$nodeb)=@_;
265 0 0 0       die "1st argument must be a node in grep(list,regexp)!"
266             unless (ref($nodea) and $nodea->isa('XML::LibXML::NodeList'));
267 0 0 0       die "2nd argument must be a node in grep(list,regexp)!"
268             unless (ref($nodeb) and $nodeb->isa('XML::LibXML::NodeList'));
269 0   0       return XML::LibXML::Boolean->new($nodea->size() && $nodeb->size() &&
270             $nodea->[0]->isSameNode($nodea->[0]));
271 0           });
272             }
273              
274             sub list_flags {
275 0   0 0 0   print "validation ".(get_validation() or "0").";\n";
276 0   0       print "recovering ".(get_recovering() or "0").";\n";
277 0   0       print "parser_expands_entities ".(get_expand_entities() or "0").";\n";
278 0   0       print "parser_expands_xinclude ".(get_expand_xinclude() or "0").";\n";
279 0   0       print "keep_blanks ".(get_keep_blanks() or "0").";\n";
280 0   0       print "pedantic_parser ".(get_pedantic_parser() or "0").";\n";
281 0   0       print "load_ext_dtd ".(get_load_ext_dtd() or "0").";\n";
282 0   0       print "complete_attributes ".(get_complete_attributes() or "0").";\n";
283 0   0       print "indent ".(get_indent() or "0").";\n";
284 0   0       print "empty_tags ".(get_empty_tags() or "0").";\n";
285 0   0       print "skip_dtd ".(get_skip_dtd() or "0").";\n";
286 0 0         print ((get_backups() ? "backups" : "nobackups"),";\n");
287 0 0         print (($QUIET ? "quiet" : "verbose"),";\n");
288 0 0         print (($DEBUG ? "debug" : "nodebug"),";\n");
289 0 0         print (($TEST_MODE ? "run-mode" : "test-mode"),";\n");
290 0   0       print "switch_to_new_documents ".(get_cdonopen() or "0").";\n";;
291 0           print "encoding '$ENCODING';\n";
292 0           print "query_encoding '$QUERY_ENCODING';\n";
293 0   0       print "xpath_completion ".(get_xpath_completion() or "0").";\n";
294 0           print "xpath_axis_completion \'".get_xpath_axis_completion()."';\n";
295             }
296              
297             sub toUTF8 {
298             # encode/decode from UTF8 returns undef if string not marked as utf8
299             # by perl (for example ascii)
300 0     0 0   my $res=eval { encodeToUTF8($_[0],$_[1]) };
  0            
301 0 0         if ($@ =~ /^SIGINT/) {
302 0           die $@
303             } else {
304 0           undef $@;
305             }
306 0 0         return defined($res) ? $res : $_[1];
307             }
308              
309             sub fromUTF8 {
310             # encode/decode from UTF8 returns undef if string not marked as utf8
311             # by perl (for example ascii)
312 0     0 0   my $res=eval { decodeFromUTF8($_[0],$_[1]) };
  0            
313 0 0         if ($@ =~ /^SIGINT/) {
314 0           die $@
315             } else {
316 0           undef $@;
317             }
318 0 0         return defined($res) ? $res : $_[1];
319             }
320              
321             # evaluate a XSH command
322             sub xsh {
323 0 0   0 0   xsh_init() unless (ref($_xsh));
324 0 0         if (ref($_xsh)) {
325 0           my $code=join "",@_;
326 0 0         return ($code=~/^\s*$/) ? 1 : $_xsh->startrule($code);
327             } else {
328 0           die "XSH init failed!\n";
329             }
330             }
331              
332             # setup output stream
333             sub xsh_set_output {
334 0     0 0   $OUT=$_[0];
335 0           return 1;
336             }
337              
338             # get output stream
339             sub xsh_get_output {
340 0     0 0   return $OUT;
341             }
342              
343             sub xsh_docs {
344 0     0 0   return keys %_doc;
345             }
346              
347             sub xsh_parse_string {
348 0   0 0 0   my $format=$_[1] || $DEFAULT_FORMAT;
349 0 0         if ($format eq 'xml') {
    0          
    0          
350 0           my $xmldecl;
351 0 0         $xmldecl="" unless $_[0]=~/^\s*\<\?xml /;
352 0           return $_xml_module->parse_string($_parser,$xmldecl.$_[0]);
353             } elsif ($format eq 'html') {
354 0           return $_xml_module->parse_html_string($_parser,$_[0]);
355             } elsif ($format eq 'docbook') {
356 0           print "parsing SGML\n";
357 0           return $_xml_module->parse_sgml_string($_parser,$_[0]);
358             }
359             }
360              
361             sub xsh_xml_parser {
362 0 0   0 0   xsh_init() unless ref($_parser);
363 0           return $_parser;
364             }
365              
366             # store a pointer to an XSH-Grammar parser
367             sub xsh_set_parser {
368 0     0 0   $_xsh=$_[0];
369 0           return 1;
370             }
371              
372             # print version info
373             sub print_version {
374 0     0 0   out("Main program: $::VERSION $::REVISION\n");
375 0           out("XML::XSH::Functions: $VERSION $REVISION\n");
376 0           out("XML::LibXML: $XML::LibXML::VERSION\n");
377             # out($_xml_module->module(),"\t",$_xml_module->version(),"\n");
378 0 0         out("XML::LibXSLT $XML::LibXSLT::VERSION\n")
379             if defined($XML::LibXSLT::VERSION);
380 0 0         out("XML::LibXML::XPathContext $XML::LibXML::XPathContext::VERSION\n")
381             if defined($XML::LibXML::XPathContext::VERSION);
382 0           return 1;
383             }
384              
385             # print a list of all open files
386             sub files {
387 0     0 0   out(map { "$_ = $_files{$_}\n" } sort keys %_files);
  0            
388 0           return 1;
389             }
390              
391             sub docs {
392 0     0 0   return sort keys %_files;
393             }
394              
395             sub _doc {
396 0 0   0     return $_doc{$_[0]} if exists($_doc{$_[0]});
397             }
398              
399             sub xpath_var_lookup {
400 0     0 0   my ($data,$name,$ns)=@_;
401 4     4   5148 no strict;
  4         7  
  4         499  
402 0 0         if ($ns eq "") {
403 0 0 0       if ($name=~/^_\.(.*)$/ and exists($_nodelist{$1})) {
    0          
404 0           return $_nodelist{$1}[1];
405 0           } elsif (defined(${"XML::XSH::Map::$name"})) {
406 0           return ${"XML::XSH::Map::$name"};
  0            
407             } else {
408 0           die "Undefined nodelist variable `$name'\n";
409             }
410             }
411             }
412              
413             # return a value of the given XSH string or nodelist variable
414             sub var_value {
415 4     4   19 no strict;
  4         7  
  4         494  
416 0 0 0 0 0   if ($_[0]=~/^\$(.*)/ and defined(${"XML::XSH::Map::$1"})) {
  0 0 0        
417 0           return "".${"XML::XSH::Map::$1"};
  0            
418             } elsif ($_[0]=~/^\%(.*)/ and exists($_nodelist{$1})) {
419 0           return $_nodelist{$1};
420             } else {
421 0           return undef;
422             }
423             }
424              
425             sub string_vars {
426 4     4   19 no strict;
  4         6  
  4         267  
427 0     0 0   return sort grep { defined(${"XML::XSH::Map::$_"}) } keys %{"XML::XSH::Map::"};
  0            
  0            
  0            
428             }
429              
430             sub nodelist_vars {
431 4     4   17 no strict;
  4         5  
  4         172  
432 0     0 0   return sort keys %_nodelist;
433             }
434              
435             # print a list of XSH variables and their values
436             sub variables {
437 4     4   16 no strict;
  4         7  
  4         408  
438 0     0 0   foreach (keys %{"XML::XSH::Map::"}) {
  0            
439 0 0         out("\$$_='",fromUTF8($ENCODING,${"XML::XSH::Map::$_"}),"';\n") if defined(${"XML::XSH::Map::$_"});
  0            
  0            
440             }
441 0           return 1;
442             }
443              
444             # print value of an XSH variable
445             sub print_var {
446 4     4   16 no strict;
  4         6  
  4         7775  
447 0 0   0 0   if ($_[0]=~/^\$?(.*)/) {
448 0 0         out("\$$1='",fromUTF8($ENCODING,${"XML::XSH::Map::$1"}),"';\n") if defined(${"XML::XSH::Map::$1"});
  0            
  0            
449 0           return 1;
450             }
451 0           return 0;
452             }
453              
454 0     0 0   sub echo { out(fromUTF8($ENCODING,join " ",expand(@_)),"\n"); return 1; }
  0            
455 0     0 0   sub set_quiet { $QUIET=$_[0]; return 1; }
  0            
456 0     0 0   sub set_debug { $DEBUG=$_[0]; return 1; }
  0            
457 0     0 0   sub set_compile_only_mode { $TEST_MODE=$_[0]; return 1; }
  0            
458              
459             sub test_enc {
460 0     0 0   my ($enc)=@_;
461 0 0 0       if (defined(toUTF8($enc,'')) and
462             defined(fromUTF8($enc,''))) {
463 0           return 1;
464             } else {
465 0           _err("Error: Cannot convert between $enc and utf-8\n");
466 0           return 0;
467             }
468             }
469              
470             sub set_encoding {
471 0     0 0   my $enc=expand($_[0]);
472 0           my $ok=test_enc($enc);
473 0 0         $ENCODING=$enc if $ok;
474 0           return $ok;
475             }
476              
477             sub set_qencoding {
478 0     0 0   my $enc=expand($_[0]);
479 0           my $ok=test_enc($enc);
480 0 0         $QUERY_ENCODING=$enc if $ok;
481 0           return $ok;
482             }
483              
484 0     0 0   sub print_encoding { print "$ENCODING\n"; return 1; }
  0            
485 0     0 0   sub print_qencoding { print "$QUERY_ENCODING\n"; return 1; }
  0            
486              
487             sub sigint {
488 0 0   0 0   if ($TRAP_SIGINT) {
489 0           print STDERR "\nCtrl-C pressed. \n";
490 0           die "SIGINT";
491             } else {
492 0           print STDERR "\nCtrl-C pressed. \n";
493 0           exit 1;
494             }
495             }
496              
497             sub sigpipe {
498 0 0   0 0   if ($TRAP_SIGPIPE) {
499 0           die "SIGPIPE";
500             } else {
501 0           _err('broken pipe (SIGPIPE)');
502 0           exit 1;
503             }
504             }
505              
506             sub flagsigint {
507 0     0 0   print STDERR "\nCtrl-C pressed. \n";
508 0           $_sigint=1;
509             }
510              
511             sub propagate_flagsigint {
512 0 0   0 0   if ($_sigint) {
513 0           $_sigint=0;
514 0           die 'SIGINT';
515             }
516             }
517              
518              
519             sub convertFromDocEncoding ($$\$) {
520 0     0 0   my ($doc,$encoding,$str)=@_;
521 0           return fromUTF8($encoding, toUTF8($_xml_module->doc_encoding($doc), $str));
522             }
523              
524             sub _err {
525 0     0     print STDERR @_,"\n";
526             }
527              
528             # if the argument is non-void then print it and return 0; return 1 otherwise
529             sub _check_err {
530 0     0     my ($err,$survive_int)=@_;
531 0 0         if ($err) {
532 0 0         if ($err=~/^SIGINT/) {
    0          
533 0 0         if ($survive_int) {
534 0           $err=~s/ at (?:.|\n)*$//;
535 0           _err($err);
536 0           return 0;
537             } else {
538 0           die $err; # propagate
539             }
540             } elsif ($_die_on_err) {
541 0 0         if ($err=~/^SIGPIPE/) {
542 0           _err('broken pipe (SIGPIPE)');
543             } else {
544 0           die $err; # propagate
545             }
546             } else {
547 0 0         if ($err=~/^SIGPIPE/) {
548 0           _err('broken pipe (SIGPIPE)');
549             } else {
550 0           _err($err);
551             }
552 0           return 0;
553             }
554             }
555 0           return 1;
556             }
557              
558             # return current document id
559             sub xsh_local_id {
560 0     0 0   return $LOCAL_ID;
561             }
562              
563              
564             # return current node for given document or document root if
565             # current node is not from the given document
566             sub get_local_node {
567 0     0 0   my ($id)=@_;
568 0 0 0       if ($LOCAL_NODE and $id eq $LOCAL_ID) {
569 0           return $LOCAL_NODE;
570             } else {
571 0 0         $id=$LOCAL_ID if ($id eq "");
572 0 0         return $_doc{$id} ? $_doc{$id} : undef;
573             }
574             }
575              
576             # return current document's id (and optionally the doc itself) if id is void
577             sub _id {
578 0     0     my ($id)=@_;
579 0 0         if ($id eq "") {
580 0           $id=$LOCAL_ID;
581 0 0         print STDERR "assuming current document $id\n" if $DEBUG;
582             }
583 0 0         return wantarray ? ($id,$_doc{$id}) : $id;
584             }
585              
586             # try to find a document ID by its node
587             sub _find_id {
588 0     0     my ($node)=@_;
589 0 0         if (ref($node)) {
590 0           my $doc=$_xml_module->owner_document($node);
591 0           foreach my $id (keys %_doc) {
592 0 0         if ($_xml_module->xml_equal($_doc{$id},$doc)) {
593 0 0         print STDERR "FOUND ID: $id\n" if $DEBUG;
594 0           return $id;
595             }
596             }
597 0           print STDERR "Error: no document found for current node\n";
598 0           my $uri=$_xml_module->doc_URI($doc);
599 0 0         if ($uri ne "") {
600 0 0         pirnt STDERR "Using document('$uri')\n" if $DEBUG;
601 0           return "document('$uri')";
602             }
603             }
604 0           return "";
605             }
606              
607             # extract document id, xpath query string and document pointer from XPath type
608             sub _xpath {
609 0     0     my ($id,$query)=expand(@{$_[0]});
  0            
610 0           ($id,my $doc)=_id($id);
611 0           return ($id,$query,$doc);
612             }
613              
614             # make given node current (no checking!)
615             sub set_local_node {
616 0     0 0   my ($node)=@_;
617 0 0         if (ref($node)) {
618 0           $LOCAL_NODE=$node;
619 0           $LOCAL_ID=_find_id($node);
620             } else {
621 0           $LOCAL_NODE=undef;
622 0           $LOCAL_ID=undef;
623             }
624             }
625              
626             # make root of the document the current node (no checking!)
627             sub set_local_doc {
628 0     0 0   my ($id)=@_;
629 0           $LOCAL_NODE=$_doc{$id};
630 0           $LOCAL_ID=$id;
631             }
632              
633              
634             # set current node to given XPath
635             sub set_local_xpath {
636 0     0 0   my ($xp)=@_;
637 0           my ($id,$query,$doc)=_xpath($xp);
638 0 0         unless (ref($doc)) {
639 0           die "No such document '$id'!\n";
640             }
641 0 0         if ($query eq "") {
642 0           set_local_doc($id);
643 0           return 1;
644             }
645 0 0         return 0 unless ref($doc);
646 0           my ($newlocal);
647 0           $newlocal=find_nodes($xp)->[0];
648 0 0         if (ref($newlocal)) {
649 0           set_local_node($newlocal);
650             } else {
651 0           die "No node in document $id matches XPath $query!\n";
652             }
653              
654 0           return 1;
655             }
656              
657             # return XPath identifying a node within its parent's subtree
658             sub node_address {
659 0     0 0   my ($node)=@_;
660 0           my $name;
661 0 0 0       if ($_xml_module->is_element($node)) {
    0          
    0          
    0          
    0          
662 0           $name=$node->getName();
663             } elsif ($_xml_module->is_text($node) or
664             $_xml_module->is_cdata_section($node)) {
665 0           $name="text()";
666             } elsif ($_xml_module->is_comment($node)) {
667 0           $name="comment()";
668             } elsif ($_xml_module->is_pi($node)) {
669 0           $name="processing-instruction()";
670             } elsif ($_xml_module->is_attribute($node)) {
671 0           return "@".$node->getName();
672             }
673 0 0         if ($node->parentNode) {
674 0           my @children;
675 0 0         if ($_xml_module->is_element($node)) {
676 0           @children=$node->parentNode->findnodes("./*[name()='$name']");
677             } else {
678 0           @children=$node->parentNode->findnodes("./$name");
679             }
680 0 0 0       if (@children == 1 and $_xml_module->xml_equal($node,$children[0])) {
681 0           return "$name";
682             }
683 0           for (my $pos=0;$pos<@children;$pos++) {
684 0 0         return "$name"."[".($pos+1)."]"
685             if ($_xml_module->xml_equal($node,$children[$pos]));
686             }
687 0           return undef;
688             } else {
689 0           return ();
690             }
691             }
692              
693             # parent element (even for attributes)
694             sub tree_parent_node {
695 0     0 0   my $node=$_[0];
696 0 0         if ($_xml_module->is_attribute($node)) {
697 0           return $node->ownerElement();
698             } else {
699 0           return $node->parentNode();
700             }
701             }
702              
703             # return canonical xpath for the given or current node
704             sub pwd {
705 0   0 0 0   my $node=$_[0] || $LOCAL_NODE || $_doc{$LOCAL_ID};
706 0 0         return undef unless ref($node);
707 0           my @pwd=();
708 0           do {
709 0           unshift @pwd,node_address($node);
710 0           $node=tree_parent_node($node);
711             } while ($node);
712 0           my $pwd="/".join "/",@pwd;
713 0           return $pwd;
714             }
715              
716             # return canonical xpath for current node (encoded)
717             sub xsh_pwd {
718 0     0 0   my $pwd;
719 0           my ($id, $doc)=_id();
720 0 0         return undef unless $doc;
721 0           $pwd=fromUTF8($ENCODING,pwd());
722 0           return $pwd;
723             }
724              
725             # print current node's xpath
726             sub print_pwd {
727 0     0 0   my $pwd=xsh_pwd();
728 0 0         if ($pwd) {
729 0           out("$pwd\n\n");
730 0           return $pwd;
731             } else {
732 0           return 0;
733             }
734             }
735              
736             # evaluate variable and xpath expresions given string
737             sub _expand {
738 0     0     my $l=$_[0];
739 0           my $k;
740 4     4   21 no strict;
  4         8  
  4         1927  
741 0           $l=~/^/o;
742 0           while ($l !~ /\G$/gsco) {
743 0 0 0       if ($l=~/\G\\(.|\n)/gsco) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
744 0 0         if (exists($_chr{$1})) {
745 0           $k.=$_chr{$1};
746             } else {
747 0           $k.=$1;
748             }
749             } elsif ($l=~/\G([^\\\$]+)/gsco) {
750 0           $k.=$1;
751             } elsif ($l=~/\G\$\{([a-zA-Z_][a-zA-Z0-9_]*)\}/gsco
752             or $l=~/\G\$([a-zA-Z_][a-zA-Z0-9_]*)/gsco) {
753 0           $k.=${"XML::XSH::Map::$1"};
  0            
754             } elsif ($l=~/\G\$\{\{\{(.+?)\}\}\}/gsco) {
755 0           $k.=perl_eval($1);
756             } elsif ($l=~/\G\$\{\{\s*([a-zA-Z_][a-zA-Z0-9_]*):(?!:)(.*?)\}\}/gsco) {
757 0           $k.=count([$1,$2]);
758             } elsif ($l=~/\G\$\{\{([^\{].*?)\}\}/gsco) {
759 0           $k.=count([undef,$1]);
760             } elsif ($l=~/\G\$\{\(\s*([a-zA-Z_][a-zA-Z0-9_]*):(?!:)(.*?)\)\}/gsco) {
761 0           $k.=eval_xpath_literal([$1,$2]);
762             } elsif ($l=~/\G\$\{\((.+?)\)\}/gsco) {
763 0           $k.=eval_xpath_literal([undef,$1]);
764             } elsif ($l=~/\G(.|\n)/gsco) {
765 0           $k.=$1;
766             }
767             }
768 0           return $k;
769             }
770              
771             # expand one or all parameters (according to return context)
772             sub expand {
773 0 0   0 0   return wantarray ? (map { _expand($_) } @_) : _expand($_[0]);
  0            
774             }
775              
776             # assign a value to a variable
777             sub _assign {
778 0     0     my ($name,$value)=@_;
779 4     4   20 no strict 'refs';
  4         6  
  4         491  
780 0           $name=~/^\$(.+)/;
781 0           ${"XML::XSH::Map::$1"}=$value;
  0            
782 0 0         print STDERR "\$$1=",${"XML::XSH::Map::$1"},"\n" if $DEBUG;
  0            
783 0           return 1;
784             }
785              
786             sub _undef {
787 0     0     my ($name)=@_;
788 4     4   17 no strict 'refs';
  4         13  
  4         17692  
789 0           $name=~/^\$(.+)/;
790 0           undef ${"XML::XSH::Map::$1"};
  0            
791 0           return 1;
792             }
793              
794             sub literal_value {
795 0 0   0 0   return ref($_[0]) ? $_[0]->value() : $_[0];
796             }
797              
798             # evaluate xpath and assign the result to a variable
799             sub xpath_assign {
800 0     0 0   my ($name,$xp)=@_;
801 0           _assign($name,count($xp));
802 0           return 1;
803             }
804              
805             sub xpath_assign_local {
806 0     0 0   store_variables(0,$_[0]);
807 0           xpath_assign(@_);
808 0           return 1;
809             }
810              
811             sub nodelist_assign_local {
812 0     0 0   my ($name)=@_;
813 0           $name=expand($name);
814 0           store_variables(0,"\%$name");
815 0           nodelist_assign(@_);
816 0           return 1;
817             }
818              
819             sub make_local {
820 0     0 0   foreach (@_) {
821 0 0         if ($_->[0] eq '$') {
822 0           xpath_assign_local($_->[1],undef);
823             } else {
824 0           nodelist_assign_local($_->[1],undef);
825             }
826             }
827             }
828              
829              
830             sub get_stored_nodelists {
831 0     0 0   return grep { ref($_) } map { @$_ } @stored_variables;
  0            
  0            
832             }
833              
834             sub store_variables {
835 0     0 0   my ($new,@vars)=@_;
836 0           my $pool;
837 0 0 0       if ($new) {
    0          
838 0           $pool=[];
839             } elsif (@stored_variables and ref($stored_variables[$#stored_variables])) {
840 0           $pool=$stored_variables[$#stored_variables];
841             } else {
842 0           print STDERR "WARNING: Ignoring attempt to make a local variable outside a localizable context!\n";
843 0           return 0;
844             }
845              
846 0           foreach (@vars) {
847 0           my $value=var_value($_);
848 0           push @$pool, $_ => $value;
849             }
850 0 0         push @stored_variables, $pool if ($new);
851              
852 0           return 1;
853             }
854              
855             sub restore_variables {
856 0     0 0   my $pool=pop @stored_variables;
857 0 0         unless (ref($pool)) {
858 0           __bug("Local variable pool is empty, which was not expected!\n");
859 0           return 0;
860             }
861 0           while (@$pool) {
862 0           my ($value,$name)=(pop(@$pool), pop(@$pool));
863 0 0         if ($name =~ m/^\$/) {
    0          
864 0 0         if (defined($value)) {
865 0           _assign($name,$value);
866             } else {
867 0           _undef($name);
868             }
869             } elsif ($name =~ m/^\%(.*)$/) {
870 0 0         if (defined($value)) {
871 0           $_nodelist{$1}=$value;
872             } else {
873 0           delete $_nodelist{$1};
874             }
875             } else {
876 0           __bug("Invalid variable name $1\n");
877             }
878             }
879 0           return 1;
880             }
881              
882             sub _xpc_find_nodes {
883 0     0     my ($node,$query)=@_;
884 0           $_xpc->setContextNode($node);
885 0           return $_xpc->findnodes($query);
886             }
887              
888             # findnodes wrapper which handles both xpaths and nodelist variables
889             sub _find_nodes {
890 0     0     my ($context,$q)=@_;
891 0 0         if ($q=~s/^\%([a-zA-Z_][a-zA-Z0-9_]*)(.*)$/\$_.$1$2/) { # node-list
892 0           my $query=$2;
893 0           my $name=$1;
894 0 0         unless (exists($_nodelist{$name})) {
895 0           die "No such nodelist '\%$name'\n";
896             }
897 0 0         if ($query =~ /\S/) {
898 0 0         if ($_xpc->isa('XML::LibXML::XPathContext')) {
899 0 0         if ($query =~m|^\s*\[(\d+)\](.*)$|) { # index on a node-list
900             return exists($_nodelist{$name}->[1]->[$1+1]) ?
901 0 0         scalar(_xpc_find_nodes($_nodelist{$name}->[1]->[$1],'./self::*'.$2)) : [];
902             } else {
903 0           return scalar(_xpc_find_nodes($_nodelist{$name}->[0], $q));
904             }
905             } else {
906             # workaround for dummy XPathContext
907 0 0         if ($query =~m|^\s*\[(\d+)\](.*)$|) { # index on a node-list
    0          
908             return $_nodelist{$name}->[1]->[$1+1] ?
909 0 0         [ grep {defined($_)} $_nodelist{$name}->[1]->[$1]->findnodes('./self::*'.$2) ] : [];
  0            
910             } elsif ($query =~m|^\s*\[|) { # filter in a nodelist
911 0           return [ grep {defined($_)} map { ($_->findnodes('./self::*'.$query)) }
  0            
912 0           @{$_nodelist{$name}->[1]}
  0            
913             ];
914             }
915 0           return [ grep {defined($_)} map { ($_->findnodes('.'.$query)) }
  0            
916 0           @{$_nodelist{$name}->[1]}
  0            
917             ];
918             }
919             } else {
920 0           return $_nodelist{$name}->[1];
921             }
922             } else {
923 0           return scalar(_xpc_find_nodes($context,$q));
924             }
925             }
926              
927             # _find_nodes wrapper with q-decoding
928             sub find_nodes {
929 0     0 0   my ($id,$query,$doc)=_xpath($_[0]);
930 0 0         if ($query eq "") { $query="."; }
  0            
931 0 0         unless (ref($doc)) {
932 0           die "No such document '$id'!\n";
933             }
934              
935 0           return _find_nodes(get_local_node($id),toUTF8($QUERY_ENCODING,$query));
936             }
937              
938             sub count_xpath {
939 0     0 0   my ($node,$xp)=@_;
940 0           my $result;
941 0           $_xpc->setContextNode($node);
942 0           $result=$_xpc->find($xp);
943              
944 0 0         if (ref($result)) {
945 0 0 0       if ($result->isa('XML::LibXML::NodeList')) {
    0          
    0          
946 0           return $result->size();
947             } elsif ($result->isa('XML::LibXML::Literal')) {
948 0           return $result->value();
949             } elsif ($result->isa('XML::LibXML::Number') or
950             $result->isa('XML::LibXML::Boolean')) {
951 0           return $result->value();
952             }
953             } else {
954 0           return $result;
955             }
956             }
957              
958             # assign a result of xpath search to a nodelist variable
959             sub nodelist_assign {
960 0     0 0   my ($name,$xp)=@_;
961 0           $name=expand($name);
962 0           my ($id,$query,$doc)=_xpath($xp);
963 0 0         if ($doc) {
964 0 0         if ($query eq "") {
965 0           $_nodelist{$name}=[$doc,[]];
966             } else {
967 0           $_nodelist{$name}=[$doc,find_nodes($xp)];
968 0 0         print STDERR "\nStored ",scalar(@{$_nodelist{$name}->[1]})," node(s).\n" unless "$QUIET";
  0            
969             }
970             }
971             }
972              
973             sub has_all_ancestors {
974 0     0 0   my ($node)=@_;
975 0           while ($node) {
976 0 0         return 1 if ($_xml_module->is_document($node));
977 0           $node=$node->parentNode;
978             }
979 0           return 0;
980             }
981              
982             # remove unbounded nodes from all nodelists of a given document
983             sub remove_dead_nodes_from_nodelists {
984 0     0 0   my ($doc)=@_;
985 0           foreach my $list (values(%_nodelist),get_stored_nodelists()) {
986 0 0         if ($_xml_module->xml_equal($doc,$list->[0])) {
987 0           $list->[1]=[ grep { has_all_ancestors($_) } @{$list->[1]} ];
  0            
  0            
988             }
989             }
990             }
991              
992             # remove given node and all its descendants from all nodelists
993             sub remove_node_from_nodelists {
994 0     0 0   my ($node,$doc)=@_;
995 0           foreach my $list (values(%_nodelist),get_stored_nodelists()) {
996 0 0         if ($_xml_module->xml_equal($doc,$list->[0])) {
997 0           $list->[1]=[ grep { !is_ancestor_or_self($node,$_) } @{$list->[1]} ];
  0            
  0            
998             }
999             }
1000             }
1001              
1002             # create new document
1003             sub create_doc {
1004 0     0 0   my ($id,$root_element,$format)=expand @_;
1005 0           $id=_id($id);
1006 0           my $doc;
1007 0 0         $root_element="<$root_element/>" unless ($root_element=~/^\s*
1008 0           $root_element=toUTF8($QUERY_ENCODING,$root_element);
1009 0           $root_element=~s/^\s+//;
1010 0           $doc=xsh_parse_string($root_element,$format);
1011 0           set_doc($id,$doc,"new_document$_newdoc.xml");
1012 0           $_newdoc++;
1013              
1014 0 0         set_local_doc($id) if $SWITCH_TO_NEW_DOCUMENTS;
1015 0           return $doc;
1016             }
1017              
1018             # bind a document with a given id and filename
1019             sub set_doc {
1020 0     0 0   my ($id,$doc,$file)=@_;
1021 0           $_doc{$id}=$doc;
1022 0           $_files{$id}=$file;
1023 0           return $doc;
1024             }
1025              
1026             # return DOM of the document identified by given id
1027             sub get_doc {
1028 0     0 0   return $_doc{$_[0]};
1029             }
1030              
1031             # create a new document by parsing a file
1032             sub open_doc {
1033 0     0 0   my ($id,$file)=expand @_[0,1];
1034 0           my $format;
1035             my $source;
1036 0 0         if ($_[2]=~/(?:open)?(?:(?:\s*|_|-)(HTML|XML|DOCBOOK|html|xml|docbook))?(?:(?:\s*|_|-)(FILE|file|PIPE|pipe|STRING|string))?/) {
1037 0   0       $format = lc($1) || $DEFAULT_FORMAT;
1038 0   0       $source = lc($2) || 'file';
1039             } else {
1040 0           $format=$DEFAULT_FORMAT;
1041 0           $source='file';
1042             }
1043 0           $file=expand($file);
1044 0           $file=~s{^(\~[^\/]*)}{(glob($1))[0]}eg;
  0            
1045 0           $id=_id($id);
1046 0 0         print STDERR "open [$file] as [$id]\n" if "$DEBUG";
1047 0 0 0       if ($id eq "" or $file eq "") {
1048 0 0         print STDERR "hint: open identifier=file-name\n" unless "$QUIET";
1049 0           return;
1050             }
1051 0 0 0       if (($source ne 'file') or
      0        
      0        
1052             (-f $file) or $file eq "-" or
1053             ($file=~/^[a-z]+:/)) {
1054 0 0         print STDERR "parsing $file\n" unless "$QUIET";
1055              
1056 0           my $doc;
1057 0 0         if ($source eq 'pipe') {
    0          
1058 0           open my $F,"$file|";
1059 0 0         $F || die "Cannot open pipe to $file: $!\n";
1060 0 0         if ($format eq 'xml') {
    0          
    0          
1061 0           $doc=$_xml_module->parse_fh($_parser,$F);
1062             } elsif ($format eq 'html') {
1063 0           $doc=$_xml_module->parse_html_fh($_parser,$F);
1064             } elsif ($format eq 'docbook') {
1065 0           $doc=$_xml_module->parse_sgml_fh($_parser,$F,$QUERY_ENCODING);
1066             }
1067 0           close $F;
1068             } elsif ($source eq 'string') {
1069 0           my $root_element=$file;
1070 0 0         $root_element="<$root_element/>" unless ($root_element=~/^\s*
1071 0           $root_element=toUTF8($QUERY_ENCODING,$root_element);
1072 0           $root_element=~s/^\s+//;
1073 0           $doc=xsh_parse_string($root_element,$format);
1074 0           set_doc($id,$doc,"new_document$_newdoc.xml");
1075 0           $_newdoc++;
1076             } else {
1077 0 0         if ($format eq 'xml') {
    0          
    0          
1078 0           $doc=$_xml_module->parse_file($_parser,$file);
1079             } elsif ($format eq 'html') {
1080 0           $doc=$_xml_module->parse_html_file($_parser,$file);
1081             } elsif ($format eq 'docbook') {
1082 0           $doc=$_xml_module->parse_sgml_file($_parser,$file,$QUERY_ENCODING);
1083             }
1084             }
1085 0 0         print STDERR "done.\n" unless "$QUIET";
1086 0           set_doc($id,$doc,$file);
1087 0 0         set_local_doc($id) if $SWITCH_TO_NEW_DOCUMENTS;
1088            
1089             # if ($@ =~ /^'' at /) {
1090             # print STDERR
1091             # "\nError: ",
1092             # "Parsing failed. LibXML returned no error message!\n";
1093             # print STDERR "Hint: Maybe you are trying to parse with validation on,\n".
1094             # "but your document has no DTD? Consider 'validation 0'.\n" if get_validation();
1095             # return 0;
1096             # }
1097             # return _check_err($@);
1098             } else {
1099 0           die "file not exists: $file\n";
1100 0           return 0;
1101             }
1102             }
1103              
1104             # close a document and destroy all nodelists that belong to it
1105             sub close_doc {
1106 0     0 0   my ($id)=expand(@_);
1107 0           $id=_id($id);
1108 0 0         unless (exists($_doc{$id})) {
1109 0           die "No such document '$id'!\n";
1110             }
1111 0 0         out("closing file $_files{$id}\n") unless "$QUIET";
1112 0           delete $_files{$id};
1113 0           foreach (values %_nodelist) {
1114 0 0         if ($_->[0]==$_doc{$id}) {
1115 0           delete $_nodelist{$_};
1116             }
1117             }
1118 0           delete $_doc{$id};
1119 0 0         if (xsh_local_id() eq $id) {
1120 0 0         if ($_doc{'scratch'}) {
1121 0           set_local_xpath(['scratch','/']);
1122             } else {
1123 0           set_local_node(undef);
1124             }
1125             }
1126 0           return 1;
1127             }
1128              
1129             sub open_io_file {
1130 0     0 0   my ($file)=@_;
1131 0 0         if ($file=~/^\s*[|>]/) {
    0          
1132 0           return IO::File->new($file);
1133             } elsif ($file=~/.gz\s*$/) {
1134 0           return IO::File->new("| gzip -c > $file");
1135             } else {
1136 0           return IO::File->new(">$file");
1137             }
1138             }
1139              
1140             sub is_xinclude {
1141 0     0 0   my ($node)=@_;
1142             return
1143 0   0       $_xml_module->is_xinclude_start($node) ||
1144             ($_xml_module->is_element($node) and
1145             $node->namespaceURI() eq 'http://www.w3.org/2001/XInclude' and
1146             $node->localname() eq 'include');
1147             }
1148              
1149             sub xinclude_start_tag {
1150 0     0 0   my ($xi)=@_;
1151 0           my %xinc = map { $_->nodeName() => $_->value() } $xi->attributes();
  0            
1152 0 0         $xinc{parse}='xml' if ($xinc{parse} eq "");
1153 0           return "<".$xi->nodeName()." href='".$xinc{href}."' parse='".$xinc{parse}."'>";
1154             }
1155              
1156             sub xinclude_end_tag {
1157 0     0 0   my ($xi)=@_;
1158 0           return "nodeName().">";
1159             }
1160              
1161             sub xinclude_print {
1162 0     0 0   my ($doc,$F,$node,$enc)=@_;
1163 0 0         return unless ref($node);
1164 0 0 0       if ($_xml_module->is_element($node) || $_xml_module->is_document($node)) {
1165 0 0         $F->print(fromUTF8($enc,start_tag($node))) if $_xml_module->is_element($node);
1166 0           my $child=$node->firstChild();
1167 0           while ($child) {
1168 0 0         if (is_xinclude($child)) {
    0          
1169 0           my %xinc = map { $_->nodeName() => $_->value() } $child->attributes();
  0            
1170 0   0       $xinc{parse}||='xml';
1171 0   0       $xinc{encoding}||=$enc; # may be used even to convert included XML
1172 0           my $elements=0;
1173 0           my @nodes=();
1174 0           my $node;
1175 0           my $expanded=$_xml_module->is_xinclude_start($child);
1176 0 0         if ($expanded) {
1177 0           $node=$child->nextSibling(); # in case of special XINCLUDE node
1178             } else {
1179 0           $node=$child->firstChild(); # in case of include element from XInclude NS
1180             }
1181 0           my $nested=0;
1182 0   0       while ($node and not($_xml_module->is_xinclude_end($node)
      0        
1183             and $nested==0
1184             and $expanded)) {
1185 0 0         if ($_xml_module->is_xinclude_start($node)) { $nested++ }
  0 0          
1186 0           elsif ($_xml_module->is_xinclude_end($node)) { $nested-- }
1187 0           push @nodes,$node;
1188 0 0         $elements++ if $_xml_module->is_element($node);
1189 0           $node=$node->nextSibling();
1190             }
1191 0 0 0       if ($nested>0) {
    0 0        
    0 0        
    0 0        
    0          
1192 0           print STDERR "Error: Unbalanced nested XInclude nodes.\n",
1193             " Ignoring this XInclude span!\n";
1194 0           $F->print("");
1195             } elsif (!$node and $_xml_module->is_xinclude_start($child)) {
1196 0           print STDERR "Error: XInclude end node not found.\n",
1197             " Ignoring this XInclude span!\n";
1198 0           $F->print("");
1199             } elsif ($xinc{parse} ne 'text' and $elements==0) {
1200 0           print STDERR "Warning: XInclude: No elements found in XInclude span.\n",
1201             " Ignoring whole XInclude span!\n";
1202 0           $F->print("");
1203             } elsif ($xinc{parse} ne 'xml' and $elements>1) {
1204 0           print STDERR "Error: XInclude: More than one element found in XInclude span.\n",
1205             " Ignoring whole XInclude span!\n";
1206 0           $F->print("");
1207             } elsif ($xinc{parse} eq 'text' and $elements>0) {
1208 0           print STDERR "Warning: XInclude: Element(s) found in textual XInclude span.\n",
1209             " Skipping whole XInclude span!\n";
1210 0           $F->print("");
1211             } else {
1212 0           $F->print(fromUTF8($enc,xinclude_start_tag($child)));
1213 0           save_xinclude_chunk($doc,\@nodes,$xinc{href},$xinc{parse},$xinc{encoding});
1214 0           $F->print(fromUTF8($enc,xinclude_end_tag($child)));
1215 0 0         $child=$node if ($expanded); # jump to XINCLUDE end node
1216             }
1217             } elsif ($_xml_module->is_xinclude_end($child)) {
1218 0           $F->print("");
1219             } else {
1220 0           xinclude_print($doc,$F,$child,$enc); # call recursion
1221             }
1222 0           $child=$child->nextSibling();
1223             }
1224 0 0         $F->print(fromUTF8($enc,end_tag($node))) if $_xml_module->is_element($node);
1225             } else {
1226 0           $F->print(fromUTF8($enc,$_xml_module->toStringUTF8($node,$INDENT)));
1227             }
1228             }
1229              
1230             sub save_xinclude_chunk {
1231 0     0 0   my ($doc,$nodes,$file,$parse,$enc)=@_;
1232              
1233 0 0         return unless @$nodes>0;
1234              
1235 0 0         if ($BACKUPS) {
1236 0           eval { rename $file, $file."~"; };
  0            
1237 0           _check_err($@);
1238             }
1239 0           my $F=open_io_file($file);
1240 0 0         $F || die "Cannot open $file\n";
1241              
1242 0 0         if ($parse eq 'text') {
1243 0           foreach my $node (@$nodes) {
1244 0           $F->print(fromUTF8($enc,literal_value($node->to_literal)));
1245             }
1246             } else {
1247 0 0         my $version=$doc->can('getVersion') ? $doc->getVersion() : '1.0';
1248 0           $F->print("\n");
1249 0           foreach my $node (@$nodes) {
1250 0           xinclude_print($doc,$F,$node,$enc);
1251             }
1252 0           $F->print("\n");
1253             }
1254 0           $F->close();
1255             }
1256              
1257             # save a document
1258             sub save_doc {
1259 0     0 0   my $type=$_[0];
1260 0           my ($id,$file,$enc)=expand($_[1],$_[2],@{$_[3]});
  0            
1261              
1262 0           ($id,my $doc)=_id($id);
1263 0 0         unless (ref($doc)) {
1264 0           die "No such document '$id'!\n";
1265             }
1266              
1267 0           my $format=$DEFAULT_FORMAT;
1268 0           my $target='file';
1269 0 0         if ($type=~/save(?:as|_as|-as)?(?:(?:\s*|_|-)(HTML|html|XML|xml|XINCLUDE|Xinclude|xinclude))?(?:(?:\s*|_|-)(FILE|file|PIPE|pipe|STRING|string))?/) {
1270 0 0         $format = lc($1) if $1;
1271 0 0         $target = lc($2) if $2;
1272             }
1273              
1274 0 0 0       if ($target eq 'file' and $file eq "") {
1275 0           $file=$_files{$id};
1276 0 0         if ($BACKUPS) {
1277 0           eval { rename $file, $file."~"; };
  0            
1278 0           _check_err($@);
1279             }
1280             }
1281              
1282 0   0       $enc = $enc || $_xml_module->doc_encoding($doc) || 'utf-8';
1283 0 0         print STDERR "saving $id=$_files{$id} to $file as $format (encoding $enc)\n" if "$DEBUG";
1284              
1285 0 0         if ($format eq 'xinclude') {
1286 0 0         if ($format ne 'file') {
1287 0           print STDERR "Saving to a ".uc($target)." not supported for XInclude\n";
1288             } else {
1289 0           save_xinclude_chunk($doc,[$doc->childNodes()],$file,'xml',$enc);
1290             }
1291             } else {
1292 0 0         if ($format eq 'xml') {
    0          
    0          
1293 0 0 0       if (lc($_xml_module->doc_encoding($doc)) ne lc($enc)
      0        
1294             and not($_xml_module->doc_encoding($doc) eq "" and
1295             lc($enc) eq 'utf-8')
1296             ) {
1297 0           $_xml_module->set_encoding($doc,$enc);
1298             }
1299 0 0         if ($target eq 'file') {
    0          
    0          
1300 0 0         if ($file=~/\.gz\s*$/) {
1301 0           $doc->setCompression(6);
1302             } else {
1303 0           $doc->setCompression(-1);
1304             }
1305 0           $doc->toFile($file,$INDENT); # should be document-encoding encoded
1306 0           $_files{$id}=$file;
1307             } elsif ($target eq 'pipe') {
1308 0           $file=~s/^\s*\|?//g;
1309 0   0       open my $F,"| $file" || die "Cannot open pipe to $file\n";
1310 0           $doc->toFH($F,$INDENT);
1311 0           close $F;
1312             } elsif ($target eq 'string') {
1313 0 0         if ($file =~ /^\$?([a-zA-Z_][a-zA-Z0-9_]*)$/) {
1314 4     4   26 no strict qw(refs);
  4         6  
  4         57544  
1315 0           ${"XML::XSH::Map::$1"}=$doc->toString($INDENT);
  0            
1316             } else {
1317 0           out($doc->toString($INDENT));
1318             }
1319             }
1320             } elsif ($format eq 'html') {
1321 0           my $F;
1322 0 0         if ($target eq 'file') {
    0          
    0          
1323 0 0         ($F=open_io_file($file)) || die "Cannot open $file\n";
1324 0           $_files{$id}=$file;
1325             } elsif ($target eq 'pipe') {
1326 0           $file=~s/^\s*\|?//g;
1327 0           open $F,"| $file";
1328 0 0         $F || die "Cannot open pipe to $file\n";
1329             } elsif ($target eq 'string') {
1330 0           $F=$OUT;
1331             }
1332 0 0         $F->print("\n")
1333             unless ($_xml_module->has_dtd($doc));
1334 0           $F->print(fromUTF8($enc, toUTF8($_xml_module->doc_encoding($doc),
1335             $doc->toStringHTML())));
1336              
1337 0 0         $F->close() unless $target eq 'string';
1338             } elsif ($format eq 'docbook') {
1339 0           print STDERR "Docbook is not supported output format!\n";
1340             }
1341             }
1342              
1343 0 0 0       print STDERR "Document $id written.\n" unless ($@ or "$QUIET");
1344 0           return 1;
1345             }
1346              
1347              
1348             # create start tag for an element
1349              
1350             ###
1351             ### Workaround of a bug in XML::LibXML:
1352             ### getNamespaces, getName returns prefix only,
1353             ### prefix returns prefix not xmlns, getAttributes contains also namespaces
1354             ### findnodes('namespace::*') returns (namespaces,undef)
1355             ###
1356              
1357             sub start_tag {
1358 0     0 0   my ($element)=@_;
1359             return "<".$element->nodeName().
1360 0 0         join("",map { " ".$_->nodeName()."=\"".$_->nodeValue()."\"" }
  0            
1361             $element->attributes())
1362             # findnodes('attribute::*'))
1363             # . join("",map { " xmlns:".$_->getName()."=\"".$_->nodeValue()."\"" }
1364             # $element->can('getNamespaces') ?
1365             # $element->getNamespaces() :
1366             # $element->findnodes('namespace::*')
1367             # )
1368             .($element->hasChildNodes() ? ">" : "/>");
1369             }
1370              
1371             # create close tag for an element
1372             sub end_tag {
1373 0     0 0   my ($element)=@_;
1374 0 0         return $element->hasChildNodes() ? "getName().">" : "";
1375             }
1376              
1377             # convert a subtree to an XML string to the given depth
1378             sub to_string {
1379 0     0 0   my ($node,$depth,$folding)=@_;
1380 0           my $result;
1381 0 0         if ($node) {
1382 0 0 0       if (ref($node) and $_xml_module->is_element($node) and $folding and
      0        
      0        
1383             $node->hasAttributeNS($XML::XSH::xshNS,'fold')) {
1384 0 0         if ($depth>=0) {
1385 0           $depth = min($depth,$node->getAttributeNS($XML::XSH::xshNS,'fold'));
1386             } else {
1387 0           $depth = $node->getAttributeNS($XML::XSH::xshNS,'fold');
1388             }
1389             }
1390              
1391 0 0 0       if ($depth<0 and !$folding) {
    0 0        
    0 0        
      0        
1392 0 0         $result=ref($node) ? $_xml_module->toStringUTF8($node,$INDENT) : $node;
1393             } elsif (ref($node) and $_xml_module->is_element($node) and $depth==0) {
1394 0 0         $result=start_tag($node).
1395             ($node->hasChildNodes() ? "...".end_tag($node) : "");
1396             } elsif ($depth>0 or $folding) {
1397 0 0         if (!ref($node)) {
    0          
    0          
1398 0           $result=$node;
1399             } elsif ($_xml_module->is_element($node)) {
1400             $result= start_tag($node).
1401 0           join("",map { to_string($_,$depth-1,$folding) } $node->childNodes).
  0            
1402             end_tag($node);
1403             } elsif ($_xml_module->is_document($node)) {
1404 0 0 0       if ($node->can('getVersion') and $node->can('getEncoding')) {
1405 0 0 0       $result=
1406             'getVersion() || '1.0').'"'.
1407             ($node->getEncoding() ne "" ? ' encoding="'.$node->getEncoding().'"' : '').
1408             '?>'."\n";
1409             }
1410             $result.=
1411 0           join("\n",map { to_string($_,$depth-1,$folding) }
1412 0 0         grep { $SKIP_DTD ? !$_xml_module->is_dtd($_) : 1 } $node->childNodes);
  0            
1413             } else {
1414 0           $result=$_xml_module->toStringUTF8($node,$INDENT);
1415             }
1416             } else {
1417 0 0         $result = ref($node) ? $_xml_module->toStringUTF8($node,$INDENT) : $node;
1418             }
1419             }
1420 0           return $result;
1421             }
1422              
1423             # list nodes matching given XPath argument to a given depth
1424             sub list {
1425 0     0 0   my ($xp,$depth)=@_;
1426 0           my ($id,$query,$doc)=_xpath($xp);
1427 0           my $folding;
1428 0 0         if ($depth=~/^fold/) {
1429 0           $folding = 1;
1430 0           $depth=-1;
1431             }
1432 0 0         unless (ref($doc)) {
1433 0           die "No such document '$id'!\n";
1434             }
1435 0 0         print STDERR "listing $query from $id=$_files{$id}\n\n" if "$DEBUG";
1436              
1437 0           my $ql=find_nodes($xp);
1438 0           foreach (@$ql) {
1439 0 0         print STDERR "checking for folding\n" if "$DEBUG";
1440 0   0       my $fold=$folding && ($_xml_module->is_element($_) || $_xml_module->is_document($_)) &&
1441             $_->findvalue("count(.//\@*[local-name()='fold' and namespace-uri()='$XML::XSH::xshNS'])");
1442 0 0         print STDERR "folding: $fold\n" if "$DEBUG";
1443 0           out (fromUTF8($ENCODING,to_string($_,$depth,$fold)),"\n");
1444             }
1445 0 0         print STDERR "\nFound ",scalar(@$ql)," node(s).\n" unless "$QUIET";
1446              
1447 0           return 1;
1448             }
1449              
1450             # list namespaces in scope of the given nodes
1451             sub list_namespaces {
1452 0   0 0 0   my $xp = $_[0] || [undef,'.'];
1453 0           my ($id,$query,$doc)=_xpath($xp);
1454 0 0         unless (ref($doc)) {
1455 0           die "No such document '$id'!\n";
1456             }
1457 0 0         print STDERR "listing namespaces for $query from $id=$_files{$id}\n\n" if "$DEBUG";
1458              
1459 0           my $ql=find_nodes($xp);
1460 0           foreach my $node (@$ql) {
1461 0           my $n=$node;
1462 0           my %namespaces;
1463 0           while ($n) {
1464 0           foreach my $ns ($n->getNamespaces) {
1465             $namespaces{$ns->getName()}=$ns->getData()
1466 0 0         unless (exists($namespaces{$ns->getName()}));
1467             }
1468 0           $n=$n->parentNode();
1469             }
1470 0           out(fromUTF8($ENCODING,pwd($node)),":\n");
1471 0           foreach (sort { $a cmp $b } keys %namespaces) {
  0            
1472             out("xmlns", ($_ ne "" ? ":" : ""),
1473             fromUTF8($ENCODING,$_),"=\"",
1474 0 0         fromUTF8($ENCODING,$namespaces{$_}),"\"\n");
1475             }
1476 0           out("\n");
1477             }
1478 0           return 1;
1479             }
1480              
1481             sub mark_fold {
1482 0     0 0   my ($xp,$depth)=@_;
1483 0           $depth=expand($depth);
1484 0 0         $depth=0 if $depth eq "";
1485              
1486 0           my $l=find_nodes($xp);
1487 0           foreach my $node (@$l) {
1488 0 0         if ($_xml_module->is_element($node)) {
1489 0           $node->setAttributeNS($XML::XSH::xshNS,'xsh:fold',$depth);
1490             }
1491             }
1492 0           return 1;
1493             }
1494              
1495             sub mark_unfold {
1496 0     0 0   my ($xp)=@_;
1497 0           my ($id,$query,$doc)=_xpath($xp);
1498 0           my $l=find_nodes($xp);
1499 0           foreach my $node (@$l) {
1500 0 0 0       if ($_xml_module->is_element($node) and $node->hasAttributeNS($XML::XSH::xshNS,'fold')) {
1501 0           remove_node($node->getAttributeNodeNS($XML::XSH::xshNS,'fold'));
1502             }
1503             }
1504 0           remove_dead_nodes_from_nodelists($doc);
1505 0           return 1;
1506             }
1507              
1508              
1509             # print canonical xpaths identifying nodes matching given XPath
1510             sub locate {
1511 0     0 0   my ($xp)=@_;
1512 0           my ($id,$query,$doc)=_xpath($xp);
1513              
1514 0 0         print STDERR "locating $query from $id=$_files{$id}\n\n" if "$DEBUG";
1515 0 0         unless (ref($doc)) {
1516 0           die "No such document '$id'!\n";
1517             }
1518 0           my $ql=find_nodes($xp);
1519 0           foreach (@$ql) {
1520 0           out(fromUTF8($ENCODING,pwd($_)),"\n");
1521             }
1522 0 0         print STDERR "\nFound ",scalar(@$ql)," node(s).\n" unless "$QUIET";
1523 0           return 1;
1524             }
1525              
1526             # evaluate given xpath and output the result
1527             sub count {
1528 0     0 0   my ($xp)=@_;
1529 0           my ($id,$query,$doc)= _xpath($xp);
1530              
1531 0 0 0       return undef if ($id eq "" or $query eq "");
1532 0 0         unless (ref($doc)) {
1533 0           die "No such document: $id\n";
1534             }
1535 0 0         print STDERR "Query $query on $id=$_files{$id}\n" if $DEBUG;
1536 0           my $result=undef;
1537              
1538 0 0         if ($query=~/^%/) {
1539 0           $result=find_nodes($xp);
1540 0           $result=scalar(@$result);
1541             } else {
1542 0           $query=toUTF8($QUERY_ENCODING,$query);
1543 0 0         print STDERR "query: $query\n" if "$DEBUG";
1544 0           $result=fromUTF8($ENCODING,count_xpath(get_local_node($id), $query));
1545 0 0         print STDERR "result: $result" if "$DEBUG";
1546             }
1547 0           return $result;
1548             }
1549              
1550             # evaluate given xpath and return the text content of the result
1551             sub eval_xpath_literal {
1552 0     0 0   my ($xp)=@_;
1553 0           my ($id,$query)=_xpath($xp);
1554 0           $_xpc->setContextNode(get_local_node($id));
1555 0           my $result = $_xpc->find(toUTF8($QUERY_ENCODING,$query));
1556 0 0         if (!ref($result)) {
1557 0           return $result;
1558             } else {
1559 0 0         if ($result->isa('XML::LibXML::NodeList')) {
1560 0 0         if (wantarray) {
    0          
1561 0           return map { literal_value($_->to_literal) } @$result;
  0            
1562             } elsif ($result->[0]) {
1563 0           return literal_value($result->[0]->to_literal);
1564             } else {
1565 0           return '';
1566             }
1567             } else {
1568 0           return literal_value($result->to_literal);
1569             }
1570             }
1571             }
1572              
1573              
1574             # remove nodes matching given XPath from a document and
1575             # remove all their descendants from all nodelists
1576             sub prune {
1577 0     0 0   my ($xp)=@_;
1578 0           my ($id,$query,$doc)=_xpath($xp);
1579 0 0         unless (ref($doc)) {
1580 0           die "No such document '$id'!\n";
1581             }
1582 0           my $i=0;
1583              
1584 0           my $ql=find_nodes($xp);
1585 0           foreach my $node (@$ql) {
1586 0           remove_node($node,get_keep_blanks());
1587 0           $i++;
1588             }
1589 0           remove_dead_nodes_from_nodelists($doc);
1590 0 0         print STDERR "$i node(s) removed from $id=$_files{$id}\n" unless "$QUIET";
1591 0           return 1;
1592             }
1593              
1594             # evaluate given perl expression
1595             sub eval_substitution {
1596 0     0 0   my ($val,$expr)=@_;
1597 0 0         $_ = fromUTF8($QUERY_ENCODING,$val) if defined($val);
1598              
1599 0           eval "package XML::XSH::Map; no strict 'vars'; $expr";
1600 0 0         die $@ if $@; # propagate
1601 0           return toUTF8($QUERY_ENCODING,$_);
1602             }
1603              
1604             # sort given nodelist according to the given xsh code and perl code
1605             sub perlsort {
1606 0     0 0   my ($crit,$perl,$var)=@_;
1607 0           $var=expand($var);
1608 0 0         return 1 unless (exists($_nodelist{$var}));
1609 0 0         return 1 unless ref(my $list=$_nodelist{$var});
1610 0           my $doc=$list->[0];
1611              
1612             my @list = map {
1613 0           local $LOCAL_NODE=$_;
1614 0           local $LOCAL_ID=_find_id($_);
1615 0 0         [$_, (ref($crit) eq 'ARRAY') ? eval_xpath_literal($crit) : scalar(perl_eval($crit))]
1616 0           } @{$list->[1]};
  0            
1617              
1618 0           @{$list->[1]} = map { $_->[0] }
  0            
1619             sort {
1620 0           local $XML::XSH::Map::a = $a->[1];
  0            
1621 0           local $XML::XSH::Map::b = $b->[1];
1622 0           my $result=eval "package XML::XSH::Map; no strict 'vars'; $perl";
1623 0 0         die $@ if ($@); # propagate
1624             $result;
1625             } @list;
1626              
1627 0           return 1;
1628             }
1629              
1630             # Evaluate given perl expression over every element matching given XPath.
1631             # The element is passed to the expression by its name or value in the $_
1632             # variable.
1633             sub perlmap {
1634 0     0 0   my ($q, $expr)=@_;
1635 0           my ($id,$query,$doc)=_xpath($q);
1636              
1637 0 0         print STDERR "Executing $expr on $query in $id=$_files{$id}\n" if "$DEBUG";
1638 0 0         unless ($doc) {
1639 0           die "No such document $id\n";
1640             }
1641              
1642 0           my $sdoc=get_local_node($id);
1643              
1644 0           my $ql=_find_nodes($sdoc, toUTF8($QUERY_ENCODING,$query));
1645 0           foreach my $node (@$ql) {
1646 0 0 0       if ($_xml_module->is_attribute($node)) {
    0          
    0          
1647 0           my $val=$node->getValue();
1648 0           $node->setValue(eval_substitution("$val",$expr));
1649             } elsif ($_xml_module->is_element($node)) {
1650 0           my $val=$node->getName();
1651 0 0         if ($node->can('setName')) {
1652 0           $node->setName(eval_substitution("$val",$expr));
1653             } else {
1654 0           _err "Node renaming not supported by ",ref($node);
1655             }
1656             } elsif ($node->can('setData') and $node->can('getData')) {
1657 0           my $val=$node->getData();
1658 0           $node->setData(eval_substitution("$val",$expr));
1659             }
1660             }
1661 0           return 1;
1662             }
1663              
1664             sub perlrename {
1665 0     0 0   my ($q, $expr)=@_;
1666 0           my ($id,$query,$doc)=_xpath($q);
1667              
1668 0 0         print STDERR "Executing $expr on $query in $id=$_files{$id}\n" if "$DEBUG";
1669 0 0         unless ($doc) {
1670 0           die "No such document $id\n";
1671             }
1672              
1673 0           my $sdoc=get_local_node($id);
1674              
1675 0           my $ql=_find_nodes($sdoc, toUTF8($QUERY_ENCODING,$query));
1676 0           foreach my $node (@$ql) {
1677 0 0 0       if ($_xml_module->is_attribute($node) ||
      0        
1678             $_xml_module->is_element($node) ||
1679             $_xml_module->is_pi($node)) {
1680 0 0         if ($node->can('setName')) {
1681 0           my $val=$node->getName();
1682 0           $node->setName(eval_substitution("$val",$expr));
1683             } else {
1684 0           _err "Node renaming not supported by ",ref($node);
1685             }
1686             }
1687             }
1688 0           return 1;
1689             }
1690              
1691             sub set_attr_ns {
1692 0     0 0   my ($node,$ns,$name,$value)=@_;
1693 0 0         if ($ns eq "") {
1694 0           $node->setAttribute($name,$value);
1695             } else {
1696 0           $node->setAttributeNS("$ns",$name,$value);
1697             }
1698             }
1699              
1700             # return NS prefix used in the given name
1701             sub name_prefix {
1702 0 0   0 0   if ($_[0]=~/^([^:]+):/) {
1703 0           return $1;
1704             }
1705             }
1706              
1707             # try to safely clone a node
1708             sub node_copy {
1709 0     0 0   my ($node,$ns,$dest_doc,$dest)=@_;
1710              
1711 0           my $copy;
1712 0 0 0       if ($_xml_module->is_element($node) and !$node->hasChildNodes) {
    0          
1713             # -- prepare NS
1714 0 0         $ns=$node->namespaceURI() if ($ns eq "");
1715 0 0 0       if ($ns eq "" and name_prefix($node->getName) ne "") {
1716 0           $ns=$dest->lookupNamespaceURI(name_prefix($node->getName));
1717             }
1718             # --
1719             $copy=new_element($dest_doc,$node->getName(),$ns,
1720 0           [map { [$_->nodeName(),$_->nodeValue(), $_->namespaceURI()] } $node->attributes],$dest);
  0            
1721             } elsif ($_xml_module->is_document_fragment($node)) {
1722 0           $copy=$_parser->parse_xml_chunk($node->toString());
1723             } else {
1724 0           $copy=$_xml_module->clone_node($dest_doc,$node);
1725             }
1726             }
1727              
1728             # get element-children of a node (e.g. of a document fragment)
1729             sub get_subelements {
1730 0     0 0   my ($docfrag)=@_;
1731 0           return grep { $_xml_module->is_element($_) } $docfrag->childNodes();
  0            
1732             }
1733              
1734             sub get_following_siblings {
1735 0     0 0   my ($node)=@_;
1736 0           my @siblings;
1737 0           $node=$node->nextSibling();
1738 0           while ($node) {
1739 0           push @siblings,$node;
1740 0           $node=$node->nextSibling();
1741             }
1742 0           return @siblings;
1743             }
1744              
1745             # create new document element before the given nodelist
1746             sub new_document_element {
1747 0     0 0   my ($doc,$node,@nodelist)=@_;
1748 0           $doc->setDocumentElement($node);
1749 0           foreach my $n (reverse @nodelist) {
1750 0           $doc->removeChild($n);
1751 0           $doc->insertAfter($n,$node);
1752             }
1753             }
1754              
1755             # safely insert source node after, before or instead of the
1756             # destination node. Safety means here that nodes inserted on the
1757             # document level are given special care. the source node may only be
1758             # a document fragment, element, text, CDATA, Comment, Entity or
1759             # a PI (i.e. not an attribute).
1760              
1761             sub safe_insert {
1762 0     0 0   my ($source,$dest,$where) = @_;
1763 0           my $parent=$dest->parentNode();
1764 0 0         return unless $parent;
1765 0 0         if ($_xml_module->is_document($parent)) {
1766              
1767             # placing a node on the document-level
1768             # SOURCE: Element
1769 0 0 0       if ($_xml_module->is_element($source)) {
    0 0        
      0        
1770 0 0         if ($where eq 'after') {
    0          
    0          
1771 0 0         if ($parent->getDocumentElement()) {
1772 0           die("Error: cannot insert another element into /:\n",
1773             " there's one document element already!");
1774             } else {
1775 0           new_document_element($parent,$source,
1776             get_following_siblings($dest));
1777             }
1778 0           return 'keep';
1779             } elsif ($where eq 'before') {
1780 0 0         if ($parent->getDocumentElement()) {
1781 0           die("Error: cannot insert another element into /:\n",
1782             " there's one document element already!");
1783             } else {
1784 0           new_document_element($parent,$source,
1785             $dest,get_following_siblings($dest));
1786             }
1787 0           return 'keep';
1788             } elsif ($where eq 'replace') {
1789             # maybe we are loosing the document element here !
1790 0 0         if ($parent->getDocumentElement()) {
1791 0 0         if ($_xml_module->is_element($dest)) {
1792 0           my $nextnode = $parent->getDocumentElement()->nextSibling();
1793 0           new_document_element($parent,$source,
1794             $dest,get_following_siblings($dest));
1795             } else {
1796 0           die("Error: cannot insert another element into /:\n",
1797             " there's one document element already!");
1798             }
1799             } else {
1800 0           new_document_element($parent,$source,
1801             $dest,get_following_siblings($dest));
1802             }
1803 0           return 'remove';
1804             }
1805             } # SOURCE: PI or Comment or DocFragment with PI's or Comments
1806             elsif ($_xml_module->is_pi($source) ||
1807             $_xml_module->is_comment($source) ||
1808             $_xml_module->is_entity_reference($source) ||
1809             $_xml_module->is_document_fragment($source)) {
1810             # placing a node into an element
1811 0 0         if ($where eq 'after') {
    0          
    0          
1812 0           $parent->insertAfter($source,$dest);
1813 0           return 'keep';
1814             } elsif ($where eq 'before') {
1815 0           $parent->insertBefore($source,$dest);
1816 0           return 'keep';
1817             } elsif ($where eq 'replace') {
1818             # maybe we are loosing the document element here !
1819 0           $parent->insertBefore($source,$dest);
1820 0           return 'remove';
1821             }
1822             } else {
1823 0           die("Error: cannot insert node ",ref($source)," on a document level");
1824             }
1825             } else {
1826 0 0         if ($where eq 'after') {
    0          
    0          
1827 0           $parent->insertAfter($source,$dest);
1828 0           return 'keep';
1829             } elsif ($where eq 'before') {
1830 0           $parent->insertBefore($source,$dest);
1831 0           return 'keep';
1832             } elsif ($where eq 'replace') {
1833 0           $parent->insertBefore($source,$dest);
1834 0           return 'remove';
1835             }
1836             }
1837             }
1838              
1839             # insert given node to given destination performing
1840             # node-type conversion if necessary
1841             sub insert_node {
1842 0     0 0   my ($node,$dest,$dest_doc,$where,$ns)=@_;
1843              
1844 0 0         if ($_xml_module->is_document($node)) {
1845 0           die "Error: Can't insert/copy/move document nodes!";
1846             }
1847              
1848             # destination: Attribute
1849 0 0 0       if ($_xml_module->is_attribute($dest)) {
    0 0        
    0 0        
    0 0        
1850             # source: Text, CDATA, Comment, Entity, Element
1851 0 0 0       if ($_xml_module->is_text($node) ||
    0 0        
      0        
      0        
1852             $_xml_module->is_cdata_section($node) ||
1853             $_xml_module->is_comment($node) ||
1854             $_xml_module->is_element($node) ||
1855             $_xml_module->is_pi($node)) {
1856 0 0         my $val = $_xml_module->is_element($node) ?
1857             $node->textContent() : $node->getData();
1858 0 0 0       if ($where eq 'replace' or $where eq 'into') {
    0 0        
    0 0        
1859 0           $val=~s/^\s+|\s+$//g;
1860             # xcopy will replace the value several times, which may not be intended
1861 0           set_attr_ns($dest->ownerElement(),$dest->namespaceURI(),$dest->getName(),$val);
1862 0           return 'keep'; # as opposed to 'remove'
1863             } elsif ($where eq 'before' or $where eq 'prepend') {
1864 0           $val=~s/^\s+//g;
1865 0           set_attr_ns($dest->ownerElement(),$dest->namespaceURI(),$dest->getName(),
1866             $val.$dest->getValue());
1867             } elsif ($where eq 'after' or $where eq 'append') {
1868 0           $val=~s/\s+$//g;
1869 0           set_attr_ns($dest->ownerElement(),$dest->namespaceURI(),$dest->getName(),
1870             $dest->getValue().$val);
1871             }
1872              
1873             }
1874             # source: Attribute
1875             elsif ($_xml_module->is_attribute($node)) {
1876 0           my $name=$node->getName();
1877 0           my $value = $node->getValue();
1878 0 0 0       if ($where eq 'replace' or $where eq 'after' or $where eq 'before') {
      0        
1879             # -- prepare NS
1880 0 0         $ns=$node->namespaceURI() if ($ns eq "");
1881 0 0 0       if ($ns eq "" and name_prefix($name) ne "") {
1882 0           $ns=$dest->lookupNamespaceURI(name_prefix($name))
1883             }
1884             # --
1885 0           my $elem=$dest->ownerElement();
1886 0           set_attr_ns($elem,"$ns",$name,$value);
1887 0 0 0       if ($where eq 'replace' and $name ne $dest->getName()) {
1888 0           return 'remove'; # remove the destination node in the end
1889             } else {
1890 0           return 'keep'; # no need to remove the destination node
1891             }
1892             } else {
1893             # -- prepare NS
1894 0           $ns=$dest->namespaceURI(); # given value of $ns is ignored here
1895             # --
1896 0 0         if ($where eq 'append') {
    0          
    0          
1897 0           set_attr_ns($dest->ownerElement(),"$ns",$dest->getName,$dest->getValue().$value);
1898             } elsif ($where eq 'into') {
1899 0           set_attr_ns($dest->ownerElement(),"$ns",$dest->getName(),$value);
1900             } elsif ($where eq 'prepend') {
1901 0           set_attr_ns($dest->ownerElement(),"$ns",$dest->getName(),$value.$dest->getValue());
1902             }
1903             }
1904             } else {
1905 0           _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
1906             ref($node)," $where ",ref($dest),"!");
1907 0           return 1;
1908             }
1909             }
1910             # destination: Document
1911             elsif ($_xml_module->is_document($dest)) {
1912             # source: Attribute, Text, CDATA
1913 0 0 0       if ($_xml_module->is_attribute($node) or
    0 0        
1914             $_xml_module->is_text($node) or
1915             $_xml_module->is_cdata_section($node)
1916             ) {
1917 0           _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
1918             ref($node)," $where ",ref($dest),"!");
1919 0           return 1;
1920             } elsif ($_xml_module->is_element($node)) {
1921             # source: Element
1922 0           my $copy=node_copy($node,$ns,$dest_doc,$dest);
1923 0           my $destnode;
1924             my $newwhere;
1925 0 0         if ($where =~ /^(?:after|append|into)/) {
    0          
    0          
1926 0           $newwhere='after';
1927 0           $destnode=$dest->lastChild();
1928             } elsif ($where =~ /^(?:before|prepend)/) {
1929 0           $newwhere='before';
1930 0           $destnode=$dest->firstChild();
1931             } elsif ($where eq 'replace') {
1932 0           _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
1933             ref($node)," $where ",ref($dest),"!");
1934 0           return 1;
1935             }
1936 0 0         if ($destnode) {
1937 0           return safe_insert($copy,$destnode,$newwhere);
1938             } else {
1939 0           new_document_element($dest,$copy);
1940 0           return 1;
1941             }
1942             } else {
1943             # source: Chunk, PI, Comment, Entity
1944 0           my $copy=node_copy($node,$ns,$dest_doc,$dest);
1945 0 0         if ($where =~ /^(?:after|append|into)/) {
    0          
    0          
1946             # rather than appendChild which does not work
1947             # for Chunks!
1948 0           $dest->insertAfter($copy,$dest->lastChild());
1949             } elsif ($where =~ /^(?:before|prepend)/) {
1950 0           $dest->insertBefore($copy,$dest->firstChild());
1951             } elsif ($where eq 'replace') {
1952 0           _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
1953             ref($node)," $where ",ref($dest),"!");
1954 0           return 1;
1955             }
1956             }
1957             }
1958             # destination: Element
1959             elsif ($_xml_module->is_element($dest)) {
1960             # source: Attribute
1961 0 0         if ($_xml_module->is_attribute($node)) {
1962             # -- prepare NS
1963 0 0         $ns=$node->namespaceURI() if ($ns eq "");
1964 0 0 0       if ($ns eq "" and name_prefix($node->getName) ne "") {
1965 0           $ns=$dest->lookupNamespaceURI(name_prefix($node->getName))
1966             }
1967             # --
1968 0 0 0       if ($where eq 'into' or $where eq 'append' or $where eq 'prepend') {
    0 0        
1969 0           set_attr_ns($dest,"$ns",$node->getName(),$node->getValue());
1970             } elsif ($where eq 'replace') {
1971 0           my $parent=$dest->parentNode();
1972 0 0         if ($_xml_module->is_element($parent)) {
1973 0           set_attr_ns($dest,"$ns",$node->getName(),$node->getValue());
1974             } else {
1975 0           _err("Warning: Cannot replace ",ref($node)," with ",ref($parent),
1976             ": parent node is not an element!");
1977 0           return 1;
1978             }
1979 0           return 'remove';
1980             } else {
1981 0           _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
1982             ref($node)," $where ",ref($dest),"!");
1983 0           return 1;
1984             # # converting attribute to element
1985             # my $new=new_element($dest_doc,$node->getName(),$ns,$dest);
1986             # $new->appendText($node->getValue());
1987             # my $parent=$dest->parentNode();
1988             # if ($_xml_module->is_element($parent)) {
1989             # if ($where eq 'before' or $where eq 'after') {
1990             # safe_insert($new,$dest,$where);
1991             # }
1992             # } elsif ($where eq 'append') {
1993             # $dest->appendChild($new);
1994             # } elsif ($where eq 'prepend') {
1995             # $dest->insertBefore($new,$dest->firstChild());
1996             # }
1997             }
1998             }
1999             # source: Any but Attribute
2000             else {
2001 0           my $copy=node_copy($node,$ns,$dest_doc,$dest);
2002 0 0 0       if ($where eq 'after' or $where eq 'before' or $where eq 'replace') {
    0 0        
    0 0        
2003 0           return safe_insert($copy,$dest,$where);
2004             } elsif ($where eq 'into' or $where eq 'append') {
2005 0           $dest->appendChild($copy);
2006             } elsif ($where eq 'prepend') {
2007 0 0         if ($dest->hasChildNodes()) {
2008 0           $dest->insertBefore($copy,$dest->firstChild());
2009             } else {
2010 0           $dest->appendChild($copy);
2011             }
2012             }
2013             }
2014             }
2015             # destination: Text, CDATA, Comment, PI
2016             elsif ($_xml_module->is_text($dest) ||
2017             $_xml_module->is_cdata_section($dest) ||
2018             $_xml_module->is_comment($dest) ||
2019             $_xml_module->is_pi($dest) ||
2020             $_xml_module->is_entity_reference($dest)
2021             ) {
2022 0 0 0       if ($where =~ /^(?:into|append|prepend)$/ and
      0        
2023             ($_xml_module->is_entity_reference($dest) ||
2024             $_xml_module->is_entity_reference($node))) {
2025 0           _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
2026             ref($node)," $where ",ref($dest),"!");
2027 0           return 1;
2028             }
2029 0 0 0       if ($where eq 'into') {
    0          
    0          
    0          
2030 0 0         my $value=$_xml_module->is_element($node) ?
2031             $node->textContent() : $node->getData();
2032 0           $dest->setData($value);
2033             } elsif ($where eq 'append') {
2034 0 0         my $value=$_xml_module->is_element($node) ?
2035             $node->textContent() : $node->getData();
2036 0           $dest->setData($dest->getData().$value);
2037             } elsif ($where eq 'prepend') {
2038 0 0         my $value=$_xml_module->is_element($node) ?
2039             $node->textContent() : $node->getData();
2040 0           $dest->setData($value.$dest->getData());
2041             }
2042             # replace + source: Attribute
2043             elsif ($where eq 'replace' and $_xml_module->is_attribute($node)) {
2044 0           my $parent=$dest->parentNode();
2045             # -- prepare NS
2046 0 0         $ns=$node->namespaceURI() if ($ns eq "");
2047 0 0 0       if ($ns eq "" and name_prefix($node->getName) ne "") {
2048 0           $ns=$dest->lookupNamespaceURI(name_prefix($node->getName));
2049             }
2050             # --
2051 0 0         if ($_xml_module->is_element($parent)) {
2052 0           set_attr_ns($dest,"$ns",$node->getName(),$node->getValue());
2053             }
2054 0           return 'remove';
2055             } else {
2056 0           my $parent=$dest->parentNode();
2057 0           my $new;
2058             # source: Attribute
2059 0 0         if ($_xml_module->is_attribute($node)) {
2060 0           _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
2061             ref($node)," $where ",ref($dest),"!");
2062 0           return 1;
2063             # # implicit conversion of attribute to element
2064             # # -- prepare NS
2065             # $ns=$node->namespaceURI() if ($ns eq "");
2066             # if ($ns eq "" and name_prefix($node->getName) ne "") {
2067             # $ns=$parent->lookupNamespaceURI(name_prefix($node->getName));
2068             # }
2069             # # --
2070             # $new=new_element($dest_doc,$node->getName(),$ns,$dest);
2071             # $new->appendText($node->getValue());
2072             }
2073             # source: All other
2074             else {
2075 0           $new=node_copy($node,$ns,$dest_doc,$dest);
2076             }
2077 0 0         if ($where =~ /^(?:after|before|replace)$/) {
2078 0           return safe_insert($new,$dest,$where);
2079             }
2080             }
2081             } else {
2082 0           print STDERR "Warning: unsupported/unknown destination type: ",ref($dest),"\n";
2083             }
2084 0           return 1;
2085             }
2086              
2087             # copy nodes matching one XPath expression to locations determined by
2088             # other XPath expression
2089             sub copy {
2090 0     0 0   my ($fxp,$txp,$where,$all_to_all)=@_;
2091 0           my ($fid,$fq,$fdoc)=_xpath($fxp); # from xpath
2092 0           my ($tid,$tq,$tdoc)=_xpath($txp); # to xpath
2093              
2094 0 0         unless (ref($fdoc)) {
2095 0           die "No such document '$fid'!\n";
2096             }
2097 0 0         unless (ref($tdoc)) {
2098 0           die "No such document '$tid'!\n";
2099             }
2100 0           my ($fl,$tl);
2101              
2102 0           $fl=find_nodes($fxp);
2103 0           $tl=find_nodes($txp);
2104              
2105 0 0         unless (@$tl) {
2106 0 0         print STDERR "No matching nodes found for $tq in $tid=$_files{$tid}\n" unless "$QUIET";
2107 0           return 0;
2108             }
2109 0           my $some_nodes_removed=0;
2110 0 0         if ($all_to_all) {
2111 0           foreach my $tp (@$tl) {
2112 0           my $replace=0;
2113 0           foreach my $fp (@$fl) {
2114 0   0       $replace = ((insert_node($fp,$tp,$tdoc,$where) eq 'remove') || $replace);
2115             }
2116 0 0         if ($replace) {
2117 0           $some_nodes_removed=1;
2118 0           remove_node($tp);
2119             }
2120             }
2121             } else {
2122 0   0       while (ref(my $fp=shift @$fl) and ref(my $tp=shift @$tl)) {
2123 0           my $replace=insert_node($fp,$tp,$tdoc,$where);
2124 0 0         if ($replace eq 'remove') {
2125 0           $some_nodes_removed=1;
2126 0           remove_node($tp);
2127             }
2128             }
2129             }
2130 0 0         if ($some_nodes_removed) {
2131 0           remove_dead_nodes_from_nodelists($tdoc);
2132             }
2133 0           return 1;
2134             }
2135              
2136             # parse a string and create attribute nodes
2137             sub create_attributes {
2138 0     0 0   my ($exp)=@_;
2139 0           my (@ret,$value,$name);
2140 0           while ($exp!~/\G$/gsco) {
2141 0 0         if ($exp=~/\G\s*([^ \n\r\t=]+)=/gsco) {
2142 0           my $name=$1;
2143 0 0         print STDERR "attribute_name=$1\n" if $DEBUG;
2144 0 0 0       if ($exp=~/\G"((?:[^\\"]|\\.)*)"/gsco or
      0        
2145             $exp=~/\G'((?:[^\\']|\\.)*)'/gsco or
2146             $exp=~/\G(.*?\S)(?=\s*[^ \n\r\t=]+=|\s*$)/gsco) {
2147 0           $value=$1;
2148 0           $value=~s/\\(.)/$1/g;
2149 0 0         print STDERR "creating $name=$value attribute\n" if $DEBUG;
2150 0           push @ret,[$name,$value];
2151             } else {
2152 0           $exp=~/\G(\S*\s*)/gsco;
2153 0           print STDERR "ignoring $name=$1\n";
2154             }
2155             } else {
2156 0           $exp=~/\G(\S*\s*)/gsco;
2157 0           print STDERR "ignoring characters $1\n";
2158             }
2159             }
2160 0           return @ret;
2161             }
2162              
2163             sub new_element {
2164 0     0 0   my ($doc,$name,$ns,$attrs,$dest)=@_;
2165 0           my $el;
2166             my $prefix;
2167 0 0         if ($name=~/^([^:>]+):(.*)$/) {
2168 0           $prefix=$1;
2169 0 0         die "Error: undefined namespace prefix `$prefix'\n" if ($ns eq "");
2170 0 0 0       if ($dest && $_xml_module->is_element($dest)) {
2171 0           $el=$dest->addNewChild($ns,$name);
2172 0           $el->unbindNode();
2173             } else {
2174 0           $el=$doc->createElementNS($ns,$name);
2175             }
2176             } else {
2177 0           $el=$doc->createElement($name);
2178             }
2179 0 0         if (ref($attrs)) {
2180 0           foreach (@$attrs) {
2181 0 0 0       if ($ns ne "" and ($_->[0]=~/^${prefix}:/)) {
    0          
    0          
2182 0 0         print STDERR "NS: $ns\n" if $DEBUG;
2183 0           $el->setAttributeNS($ns,$_->[0],$_->[1]);
2184             } elsif ($_->[0] eq "xmlns:(.*)") {
2185             # don't redeclare NS if already declared on destination node
2186 0 0 0       unless ($1 eq $ns or $dest->lookupNamespaceURI($1) eq $_->[2]) {
2187 0 0         $el->setAttribute($_->[0],$_->[1]) unless ($_->[1] eq $ns);
2188             }
2189             } elsif ($_->[0]=~/^([^:>]+):/) {
2190 0           my $lprefix=$1;
2191 0 0         if ($_->[2] ne "") {
2192 0           $el->setAttributeNS($_->[2],$_->[0],$_->[1]);
2193             } else {
2194             # add the attribute anyway (may have wrong qname!)
2195 0           $el->setAttribute($_->[0],$_->[1]);
2196             }
2197             } else {
2198 0 0 0       next if ($_->[0] eq "xmlns:$prefix" and $_->[1] eq $ns);
2199 0           $el->setAttribute($_->[0],$_->[1]); # what about other namespaces?
2200             }
2201             }
2202             }
2203 0           return $el;
2204             }
2205              
2206             # create nodes from their textual representation
2207             sub create_nodes {
2208 0     0 0   my ($type,$exp,$doc,$ns)=@_;
2209 0           my @nodes=();
2210             # return undef unless ($exp ne "" and ref($doc));
2211 0 0         if ($type eq 'attribute') {
    0          
    0          
    0          
    0          
    0          
    0          
2212 0           foreach (create_attributes($exp)) {
2213 0           my $at;
2214 0 0 0       if ($_->[0]=~/^([^:]+):/ and $1 ne 'xmlns') {
2215 0 0         die "Error: undefined namespace prefix `$1'\n" if ($ns eq "");
2216 0           $at=$doc->createAttributeNS($ns,$_->[0],$_->[1]);
2217             } else {
2218 0           $at=$doc->createAttribute($_->[0],$_->[1]);
2219             }
2220 0           push @nodes,$at;
2221             }
2222             } elsif ($type eq 'element') {
2223 0           my ($name,$attributes);
2224 0 0         if ($exp=~/^\]+)(\s+.*)?(?:\/?\>)?\s*$/) {
2225 0 0         print STDERR "element_name=$1\n" if $DEBUG;
2226 0 0         print STDERR "attributes=$2\n" if $DEBUG;
2227 0           my ($elt,$att)=($1,$2);
2228 0           my $el;
2229 0 0         if ($elt=~/^([^:>]+):(.*)$/) {
2230 0 0         print STDERR "NS: $ns\n" if $DEBUG;
2231 0 0         print STDERR "Name: $elt\n" if $DEBUG;
2232 0 0         die "Error: undefined namespace prefix `$1'\n" if ($ns eq "");
2233 0           $el=$doc->createElementNS($ns,$elt);
2234             } else {
2235 0           $el=$doc->createElement($elt);
2236             }
2237 0 0         if ($att ne "") {
2238 0           $att=~s/\/?\>?$//;
2239 0           foreach (create_attributes($att)) {
2240 0 0         print STDERR "atribute: ",$_->[0],"=",$_->[1],"\n" if $DEBUG;
2241 0 0 0       if ($elt=~/^([^:]+):/ and $1 ne 'xmlns') {
2242 0 0         print STDERR "NS: $ns\n" if $DEBUG;
2243 0 0         die "Error: undefined namespace prefix `$1'\n" if ($ns eq "");
2244 0           $el->setAttributeNS($ns,$_->[0],$_->[1]);
2245             } else {
2246 0           $el->setAttribute($_->[0],$_->[1]);
2247             }
2248             }
2249             }
2250 0           push @nodes,$el;
2251             } else {
2252 0 0         print STDERR "invalid element $exp\n" unless "$QUIET";
2253             }
2254             } elsif ($type eq 'text') {
2255 0           push @nodes,$doc->createTextNode($exp);
2256 0 0         print STDERR "text=$exp\n" if $DEBUG;
2257             } elsif ($type eq 'entity_reference') {
2258 0           push @nodes,$doc->createEntityReference($exp);
2259 0 0         print STDERR "entity_reference=$exp\n" if $DEBUG;
2260             } elsif ($type eq 'cdata') {
2261 0           push @nodes,$doc->createCDATASection($exp);
2262 0 0         print STDERR "cdata=$exp\n" if $DEBUG;
2263             } elsif ($type eq 'pi') {
2264 0           my ($name,$data)=($exp=~/^\s*(?:\<\?)?(\S+)(?:\s+(.*?)(?:\?\>)?)?$/);
2265 0           my $pi = $doc->createProcessingInstruction($name);
2266 0           $pi->setData($data);
2267 0 0         print STDERR "pi=\n" if $DEBUG;
2268 0           push @nodes,$pi;
2269             # print STDERR "cannot add PI yet\n" if $DEBUG;
2270             } elsif ($type eq 'comment') {
2271 0           push @nodes,$doc->createComment($exp);
2272 0 0         print STDERR "comment=$exp\n" if $DEBUG;
2273             }
2274 0           return @nodes;
2275             }
2276              
2277             # create new nodes from an expression and insert them to locations
2278             # identified by XPath
2279             sub insert {
2280 0     0 0   my ($type,$exp,$xpath,$where,$ns,$to_all)=@_;
2281              
2282 0           $exp = expand($exp);
2283 0           $ns = expand($ns);
2284              
2285 0           my ($tid,$tq,$tdoc)=_xpath($xpath); # destination(s)
2286              
2287 0 0         return 0 unless ref($tdoc);
2288              
2289 0           my @nodes;
2290 0           $ns=toUTF8($QUERY_ENCODING,$ns);
2291 0 0         unless ($type eq 'chunk') {
2292 0           $exp=toUTF8($QUERY_ENCODING,$exp);
2293 0           @nodes=grep {ref($_)} create_nodes($type,$exp,$tdoc,$ns);
  0            
2294 0 0         return unless @nodes;
2295             } else {
2296 0 0         if ($exp !~/^\s*]*encoding=[^>]*?>/) {
2297 0           $exp=toUTF8($QUERY_ENCODING,$exp);
2298             }
2299 0           @nodes=grep {ref($_)} ($_parser->parse_xml_chunk($exp));
  0            
2300             }
2301 0           my $tl=find_nodes($xpath);
2302 0           my $some_nodes_removed=0;
2303 0 0         if ($to_all) {
    0          
2304 0           foreach my $tp (@$tl) {
2305 0           my $replace=0;
2306 0           foreach my $node (@nodes) {
2307 0   0       $replace = (insert_node($node,$tp,$tdoc,$where) eq 'remove') || $replace;
2308             }
2309 0 0         if ($replace) {
2310 0           $some_nodes_removed=1;
2311 0           remove_node($tp);
2312             }
2313             }
2314             } elsif ($tl->[0]) {
2315 0           foreach my $node (@nodes) {
2316 0 0         if (ref($tl->[0])) {
2317 0 0         if (insert_node($node,$tl->[0],$tdoc,$where) eq 'remove') {
2318 0           $some_nodes_removed=1;
2319 0           remove_node($tl->[0]);
2320             }
2321             }
2322             }
2323             }
2324 0 0         if ($some_nodes_removed) {
2325 0           remove_dead_nodes_from_nodelists($tdoc);
2326             }
2327 0           return 1;
2328             }
2329              
2330             # normalize nodes
2331             sub normalize_nodes {
2332 0     0 0   my ($xp)=@_;
2333 0           my ($id,$query,$doc)=_xpath($xp);
2334              
2335 0 0         print STDERR "normalizing $query from $id=$_files{$id}\n\n" if "$DEBUG";
2336 0 0         unless (ref($doc)) {
2337 0           die "No such document '$id'!\n";
2338             }
2339 0           my $ql=find_nodes($xp);
2340 0           foreach (@$ql) {
2341 0           $_->normalize();
2342             }
2343 0           return 1;
2344             }
2345              
2346             sub _trim_ws {
2347 0     0     my ($text)=@_;
2348 0           $text=~s/^\s*//;
2349 0           $text=~s/\s*$//;
2350 0           return $text;
2351             }
2352              
2353             # strip whitespace from given nodes
2354             sub strip_ws {
2355 0     0 0   my ($xp)=@_;
2356 0           my ($id,$query,$doc)=_xpath($xp);
2357              
2358 0 0         print STDERR "stripping whitespace in $query from $id=$_files{$id}\n\n" if "$DEBUG";
2359 0 0         unless (ref($doc)) {
2360 0           die "No such document '$id'!\n";
2361             }
2362 0           my $ql=find_nodes($xp);
2363 0           foreach my $node (@$ql) {
2364 0 0 0       if ($_xml_module->is_text($node)
    0 0        
    0 0        
    0          
2365             or
2366             $_xml_module->is_cdata_section($node)
2367             or
2368             $_xml_module->is_comment($node)
2369             ) {
2370 0           my $data=_trim_ws($node->getData());
2371 0 0         if ($data ne "") {
2372 0           $node->setData($data);
2373             } else {
2374 0           $node->unbindNode();
2375             }
2376             } elsif ($_xml_module->is_pi($node)) {
2377 0           $node->setData(_trim_ws($node->getData($node)));
2378             } elsif ($_xml_module->is_attribute($node)) {
2379 0           $node->setValue(_trim_ws($node->getValue));
2380             } elsif ($_xml_module->is_element($node) or
2381             $_xml_module->is_document($node)) {
2382             # traverse children, skip comments, strip text nodes
2383             # until first element or PI or text node containing
2384             # a non-ws character
2385 0           my $child=$node->firstChild();
2386 0           while ($child) {
2387 0 0 0       if ($_xml_module->is_text($child) or
    0 0        
2388             $_xml_module->is_cdata_section($child)) {
2389 0           my $data=_trim_ws($child->getData());
2390 0 0         if ($data ne "") {
2391 0           $child->setData($data);
2392 0           last;
2393             } else {
2394 0           $child->unbindNode();
2395             }
2396             } elsif ($_xml_module->is_element($child) or
2397             $_xml_module->is_pi($child)) {
2398 0           last;
2399             }
2400 0           $child=$child->nextSibling();
2401             }
2402             # traverse children (upwards), skip comments, strip text nodes
2403             # until first element or PI or text node containing a non-ws
2404             # character
2405 0           my $child=$node->lastChild();
2406 0           while ($child) {
2407 0 0 0       if ($_xml_module->is_text($child) or
    0 0        
2408             $_xml_module->is_cdata_section($child)) {
2409 0           my $data=_trim_ws($child->getData());
2410 0 0         if ($data ne "") {
2411 0           $child->setData($data);
2412 0           last;
2413             } else {
2414 0           $child->unbindNode();
2415             }
2416             } elsif ($_xml_module->is_element($child) or
2417             $_xml_module->is_pi($child)) {
2418 0           last;
2419             }
2420 0           $child=$child->previousSibling();
2421             }
2422             }
2423             }
2424 0           return 1;
2425             }
2426              
2427             # fetch document's DTD
2428             sub get_dtd {
2429 0     0 0   my ($doc)=@_;
2430 0           my $dtd;
2431 0           $dtd=$_xml_module->get_dtd($doc,$QUIET);
2432              
2433 0           return $dtd;
2434             }
2435              
2436             # check document validity
2437             sub validate_doc {
2438 0     0 0   my ($show_errors,$schema,$id)=@_;
2439 0           $id=expand $id;
2440 0           __debug("SCHEMA @$schema");
2441 0           my @schema = expand @$schema;
2442 0           __debug("SCHEMA @schema");
2443 0           ($id,my $doc)=_id($id);
2444 0 0         unless (ref($doc)) {
2445 0           die "No such document '$id' (to validate)!\n";
2446             }
2447              
2448 0 0         if ($doc->can('is_valid')) {
2449 0 0         if (@schema) {
2450 0           my $type = shift @schema;
2451 0           my $format = shift @schema;
2452 0 0         if ($type eq 'DTD') {
    0          
    0          
2453 0           my $dtd;
2454 0 0         eval { XML::LibXML::Dtd->can('new') } ||
  0            
2455             die "DTD validation not supported by your version of XML::LibXML\n";
2456 0 0         if ($format eq 'FILE') {
    0          
2457 0           __debug("PUBLIC $schema[0], SYSTEM $schema[1]");
2458 0           $dtd=XML::LibXML::Dtd->new(@schema);
2459 0           __debug($dtd);
2460             } elsif ($format eq 'STRING') {
2461 0           __debug("STRING $schema[0]");
2462 0           $dtd=XML::LibXML::Dtd->parse_string($schema[0]);
2463 0           __debug($dtd);
2464 0           __debug($dtd->toString());
2465             } else {
2466 0           die "Unknown DTD format '$format!'\n";
2467             }
2468 0 0         if ($show_errors) {
2469 0           $doc->validate($dtd);
2470             } else {
2471 0 0         out(($doc->is_valid($dtd) ? "yes\n" : "no\n"));
2472             }
2473             } elsif ($type eq 'RNG') {
2474 0 0         eval { XML::LibXML::RelaxNG->can('new') } ||
  0            
2475             die "RelaxNG validation not supported by your version of XML::LibXML\n";
2476 0           my $rng;
2477 0 0         if ($format eq 'FILE') {
    0          
    0          
2478 0           $rng=XML::LibXML::RelaxNG->new(location => $schema[0]);
2479             } elsif ($format eq 'STRING') {
2480 0           $rng=XML::LibXML::RelaxNG->new(string => $schema[0]);
2481             } elsif ($format eq 'DOC') {
2482 0           my $rngdoc=_doc($schema[0]);
2483 0 0         unless (ref($rngdoc)) {
2484 0           die "No such document '$schema[0]'!\n";
2485             }
2486 0           $rng=XML::LibXML::RelaxNG->new(DOM => $rngdoc);
2487             } else {
2488 0           die "Unknown RelaxNG format '$format!'\n";
2489             }
2490 0           eval { $rng->validate($doc) };
  0            
2491 0 0         if ($show_errors) {
2492 0           die "$@\n";
2493             } else {
2494 0 0         out($@ ? "no\n" : "yes\n");
2495             }
2496             } elsif ($type eq 'XSD') {
2497 0 0         eval { XML::LibXML::Schema->can('new') } ||
  0            
2498             die "Schema validation not supported by your version of XML::LibXML\n";
2499 0           my $xsd;
2500 0 0         if ($format eq 'FILE') {
    0          
    0          
2501 0           $xsd=XML::LibXML::Schema->new(location => $schema[0]);
2502             } elsif ($format eq 'STRING') {
2503 0           $xsd=XML::LibXML::Schema->new(string => $schema[0]);
2504             } elsif ($format eq 'DOC') {
2505 0           my $xsddoc=_doc($schema[0]);
2506 0 0         unless (ref($xsddoc)) {
2507 0           die "No such document '$schema[0]'!\n";
2508             }
2509 0           $xsd=XML::LibXML::Schema->new(string => $xsddoc->toString());
2510             } else {
2511 0           die "Unknown Schema format '$format!'\n";
2512             }
2513 0           eval { $xsd->validate($doc) };
  0            
2514 0 0         if ($show_errors) {
2515 0           die "$@\n";
2516             } else {
2517 0 0         out($@ ? "no\n" : "yes\n");
2518             }
2519             }
2520             } else {
2521 0 0         if ($show_errors) {
2522 0           $doc->validate();
2523             } else {
2524 0 0         out(($doc->is_valid() ? "yes\n" : "no\n"));
2525             }
2526             }
2527             } else {
2528 0           die("Vaidation not supported by ",ref($doc));
2529             }
2530 0           return 1;
2531             }
2532              
2533             # process XInclude elements in a document
2534             sub process_xinclude {
2535 0     0 0   my ($id)=expand @_;
2536 0           ($id, my $doc)=_id($id);
2537 0 0         unless (ref($doc)) {
2538 0           die "No such document '$id'!\n";
2539             }
2540 0           $_xml_module->doc_process_xinclude($_parser,$doc);
2541 0           return 1;
2542             }
2543              
2544             # print document's DTD
2545             sub list_dtd {
2546 0     0 0   my ($id)=expand @_;
2547 0           ($id, my $doc)=_id($id);
2548 0 0         unless (ref($doc)) {
2549 0           die "No such document '$id'!\n";
2550             }
2551 0           my $dtd=get_dtd($doc);
2552              
2553 0 0         if ($dtd) {
2554 0           out(fromUTF8($ENCODING,$_xml_module->toStringUTF8($dtd)),"\n");
2555             }
2556 0           return 1;
2557             }
2558              
2559             # print document's encoding
2560             sub print_enc {
2561 0     0 0   my ($id)=expand @_;
2562 0           ($id, my $doc)=_id($id);
2563 0 0         unless (ref($doc)) {
2564 0           die "No such document '$id'!\n";
2565             }
2566 0           out($_xml_module->doc_encoding($doc),"\n");
2567 0           return 1;
2568             }
2569              
2570             sub set_doc_enc {
2571 0     0 0   my ($encoding,$id)=expand @_;
2572 0           ($id, my $doc)=_id($id);
2573 0 0         unless (ref($doc)) {
2574 0           die "No such document '$id'!\n";
2575             }
2576 0           $_xml_module->set_encoding($doc,$encoding);
2577 0           return 1;
2578             }
2579              
2580             sub set_doc_standalone {
2581 0     0 0   my ($standalone,$id)=expand @_;
2582 0           ($id, my $doc)=_id($id);
2583 0 0         unless (ref($doc)) {
2584 0           die "No such document '$id'!\n";
2585             }
2586 0 0         $standalone=1 if $standalone=~/yes/i;
2587 0 0         $standalone=0 if $standalone=~/no/i;
2588 0           $_xml_module->set_standalone($doc,$standalone);
2589 0           return 1;
2590             }
2591              
2592             sub doc_info {
2593 0     0 0   my ($id)=expand @_;
2594 0           ($id, my $doc)=_id($id);
2595 0 0         unless (ref($doc)) {
2596 0           die "No such document '$id'!\n";
2597             }
2598 0           out("type=",$doc->nodeType,"\n");
2599 0           out("version=",$doc->version(),"\n");
2600 0           out("encoding=",$doc->encoding(),"\n");
2601 0           out("standalone=",$doc->standalone(),"\n");
2602 0           out("compression=",$doc->compression(),"\n");
2603             }
2604              
2605             # create an identical copy of a document
2606             sub clone {
2607 0     0 0   my ($id1,$id2)=@_;
2608 0           ($id2, my $doc)=_id(expand $id2);
2609              
2610 0 0 0       return if ($id2 eq "" or $id2 eq "" or !ref($doc));
      0        
2611 0 0         print STDERR "duplicating $id2=$_files{$id2}\n" unless "$QUIET";
2612              
2613             set_doc($id1,$_xml_module->parse_string($_parser,
2614             $doc->toString($INDENT)),
2615 0           $_files{$id2});
2616 0 0         print STDERR "done.\n" unless "$QUIET";
2617 0           return 1;
2618             }
2619              
2620             # test if $nodea is an ancestor of $nodeb
2621             sub is_ancestor_or_self {
2622 0     0 0   my ($nodea,$nodeb)=@_;
2623 0           while ($nodeb) {
2624 0 0         if ($_xml_module->xml_equal($nodea,$nodeb)) {
2625 0           return 1;
2626             }
2627 0           $nodeb=tree_parent_node($nodeb);
2628             }
2629             }
2630              
2631             # remove node and all its surrounding whitespace textual siblings
2632             # from a document; remove all its descendant from all nodelists
2633             # change current element to the nearest ancestor
2634             sub remove_node {
2635 0     0 0   my ($node,$trim_space)=@_;
2636 0 0         if (is_ancestor_or_self($node,$LOCAL_NODE)) {
2637 0           $LOCAL_NODE=tree_parent_node($node);
2638             }
2639 0           my $doc;
2640 0           $doc=$_xml_module->owner_document($node);
2641 0 0         if ($trim_space) {
2642 0           my $sibling=$node->nextSibling();
2643 0 0 0       if ($sibling and
      0        
2644             $_xml_module->is_text($sibling) and
2645             $sibling->getData =~ /^\s+$/) {
2646             # remove_node_from_nodelists($sibling,$doc);
2647 0           $_xml_module->remove_node($sibling);
2648             }
2649             }
2650             # remove_node_from_nodelists($node,$doc);
2651 0           $_xml_module->remove_node($node);
2652             }
2653              
2654             # move nodes matching one XPath expression to locations determined by
2655             # other XPath expression
2656             sub move {
2657 0     0 0   my ($xp)=@_; #source xpath
2658 0           my ($id,$query,$doc)= _xpath($xp);
2659 0           my $sourcenodes;
2660 0 0         unless (ref($doc)) {
2661 0           die "No such document '$id'!\n";
2662             }
2663 0           my $i=0;
2664 0           $sourcenodes=find_nodes($xp);
2665 0 0         if (copy(@_)) {
2666 0           foreach my $node (@$sourcenodes) {
2667 0           remove_node($node);
2668 0           $i++;
2669             }
2670 0 0         if ($i) {
2671 0           remove_dead_nodes_from_nodelists($doc);
2672             }
2673 0           return 1;
2674             } else {
2675 0           return 0;
2676             }
2677             }
2678              
2679             # call a shell command and print out its output
2680             sub sh {
2681 0     0 0   my $cmd=expand($_[0]);
2682 0           out(`$cmd`);
2683 0           return 1;
2684             }
2685              
2686             # print the result of evaluating an XPath expression in scalar context
2687             sub print_count {
2688 0     0 0   my $count=count(@_);
2689 0           out("$count\n");
2690 0           return 1;
2691             }
2692              
2693             sub perl_eval {
2694 0 0   0 0   if (wantarray) {
2695 0           my @result=eval("package XML::XSH::Map; no strict 'vars'; $_[0]");
2696 0 0         die $@ if $@;
2697 0           return @result;
2698             } else {
2699 0           my $result=eval("package XML::XSH::Map; no strict 'vars'; $_[0]");
2700 0 0         die $@ if $@;
2701 0           return $result;
2702             }
2703             }
2704              
2705             # evaluate a perl expression
2706             # (OBSOLETE! and print out the result)
2707             sub print_eval {
2708 0     0 0   my ($expr)=@_;
2709 0           my $result=perl_eval($expr);
2710             # out("$result\n") unless "$QUIET";
2711 0           return 1;
2712             }
2713              
2714             # change current directory
2715             sub cd {
2716 0 0   0 0   unless (chdir $_[0]) {
2717 0           print STDERR "Can't change directory to $_[0]\n";
2718 0           return 0;
2719             } else {
2720 0 0         print "$_[0]\n" unless "$QUIET";
2721             }
2722 0           return 1;
2723             }
2724              
2725             # call methods from a list
2726             sub run_commands {
2727 0 0   0 0   return 0 unless ref($_[0]) eq "ARRAY";
2728 0           my @cmds=@{$_[0]};
  0            
2729 0           my $top_level=$_[1];
2730 0           my $trapsignals=$top_level;
2731 0           my $result=0;
2732              
2733 0           my ($cmd,@params);
2734              
2735             # make sure errors throw exceptions
2736 0 0         local $_die_on_err=1 unless ($top_level);
2737              
2738 0           store_variables(1);
2739 0           eval {
2740 0 0         local $SIG{INT}=\&sigint if $trapsignals;
2741 0 0         local $SIG{PIPE}=\&sigpipe if $trapsignals;
2742 0           foreach my $run (@cmds) {
2743 0 0         if (ref($run) eq 'ARRAY') {
2744 0           ($cmd,@params)=@$run;
2745 0 0         if ($cmd eq "test-mode") { $TEST_MODE=1; $result=1; next; }
  0            
  0            
  0            
2746 0 0         if ($cmd eq "run-mode") { $TEST_MODE=0; $result=1; next; }
  0            
  0            
  0            
2747 0 0         next if $TEST_MODE;
2748 0           $result=&{$cmd}(@params);
  0            
2749             } else {
2750 0           $result=1;
2751             }
2752             }
2753             };
2754 0           do {
2755 0           local $SIG{INT}=\&flagsigint;
2756 0           restore_variables();
2757 0           propagate_flagsigint();
2758             };
2759 0 0 0       if (!$trapsignals and $@ =~ /^SIGINT|^SIGPIPE/) {
2760 0           die $@
2761             } else {
2762 0           _check_err($@,1);
2763             }
2764 0           return $result;
2765             }
2766              
2767             # redirect output and call methods from a list
2768             sub pipe_command {
2769 0 0   0 0   return 1 if $TEST_MODE;
2770              
2771 0     0     local $SIG{PIPE}=sub { };
2772 0           my ($cmd,$pipe)=@_;
2773              
2774 0 0         return 0 unless (ref($cmd) eq 'ARRAY');
2775              
2776 0 0         if ($pipe ne '') {
2777 0           my $out=$OUT;
2778 0           local *PIPE;
2779 0 0         print STDERR "openning pipe $pipe\n" if $DEBUG;
2780 0           eval {
2781 0 0         open(PIPE,"| $pipe") || die "cannot open pipe $pipe\n";
2782 0           $OUT=\*PIPE;
2783 0           run_commands($cmd);
2784             };
2785 0           do {
2786 0           local $SIG{INT}=\&flagsigint;
2787 0           $OUT=$out;
2788 0           close PIPE;
2789 0           propagate_flagsigint();
2790             };
2791 0 0         die $@ if $@; # propagate
2792             }
2793 0           return 1;
2794             }
2795              
2796             # redirect output to a string and call methods from a list
2797             sub string_pipe_command {
2798 0     0 0   my ($cmd,$name)=@_;
2799 0 0         return 0 unless (ref($cmd) eq 'ARRAY');
2800 0 0         if ($name ne '') {
2801 0           my $out=$OUT;
2802 0 0         print STDERR "Pipe to $name\n" if $DEBUG;
2803 0           $OUT=new IO::MyString;
2804 0           eval {
2805 0           run_commands($cmd);
2806             };
2807 0           do {
2808 0           local $SIG{INT}=\&flagsigint;
2809 0 0         _assign($name,$OUT->value()) unless $@;
2810 0           $OUT=$out;
2811 0           propagate_flagsigint();
2812             };
2813 0 0         die $@ if $@; # propagate
2814             }
2815 0           return 0;
2816             }
2817              
2818              
2819             # call methods as long as given XPath returns positive value
2820             sub while_statement {
2821 0     0 0   my ($xp,$command)=@_;
2822 0           my $result=1;
2823 0 0         if (ref($xp) eq 'ARRAY') {
2824 0           while (count($xp)) {
2825 0           eval {
2826 0   0       $result = run_commands($command) && $result;
2827             };
2828 0 0 0       if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
    0          
2829 0 0 0       if ($@->label =~ /^(?:next|last|redo)$/ and $@->[1]>1) {
2830 0           $@->[1]--;
2831 0           die $@; # propagate to a higher level
2832             }
2833 0 0         if ($@->label eq 'next') {
    0          
    0          
2834 0           next;
2835             } elsif ($@->label eq 'last') {
2836 0           last;
2837             } elsif ($@->label eq 'redo') {
2838 0           redo;
2839             } else {
2840 0           die $@; # propagate
2841             }
2842             } elsif ($@) {
2843 0           die $@; # propagate
2844             }
2845             }
2846             } else {
2847 0           while (perl_eval($xp)) {
2848 0           eval {
2849 0   0       $result = run_commands($command) && $result;
2850             };
2851 0 0 0       if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
    0          
2852 0 0 0       if ($@->label =~ /^(?:next|last|redo)$/ and $@->[1]>1) {
2853 0           $@->[1]--;
2854 0           die $@; # propagate to a higher level
2855             }
2856 0 0         if ($@->label eq 'next') {
    0          
    0          
2857 0           next;
2858             } elsif ($@->label eq 'last') {
2859 0           last;
2860             } elsif ($@->label eq 'redo') {
2861 0           redo;
2862             } else {
2863 0           die $@; # propagate
2864             }
2865             } elsif ($@) {
2866 0           die $@; # propagate
2867             }
2868             }
2869             }
2870 0           return $result;
2871             }
2872              
2873             sub throw_exception {
2874 0     0 0   die expand($_[0])."\n";
2875             }
2876              
2877             sub try_catch {
2878 0     0 0   my ($try,$catch,$var)=@_;
2879 0           eval {
2880 0           local $TRAP_SIGPIPE=1;
2881 0           local $SIG{INT}=\&sigint;
2882 0           local $SIG{PIPE}=\&sigpipe;
2883             # local $_die_on_err=1; # make sure errors cause an exception
2884 0           run_commands($try);
2885             };
2886 0 0 0       if (ref($@) and $@->isa('XML::XSH::Internal::UncatchableException')) {
    0          
2887 0           die $@; # propagate
2888             } elsif ($@) {
2889 0 0         if ($@ =~ /^SIGINT/) {
2890 0           die $@; # propagate sigint
2891             } else {
2892 0 0         chomp($@) unless ref($@);
2893 0 0 0       if (ref($var) and @{$var}>1) {
  0            
2894 0           store_variables(1,$var->[0]);
2895 0           _assign($var->[0],$@);
2896 0           eval {
2897 0           run_commands($catch);
2898             };
2899 0           do {
2900 0           local $SIG{INT}=\&flagsigint;
2901 0           restore_variables();
2902 0           propagate_flagsigint();
2903             };
2904 0 0         die $@ if $@; # propagate
2905             } else {
2906 0 0         _assign($var->[0],$@) if ref($var);
2907 0           run_commands($catch);
2908             }
2909             }
2910             }
2911             }
2912              
2913             sub loop_next {
2914 0     0 0   die XML::XSH::Internal::LoopTerminatingException->new('next',expand(@_));
2915             }
2916             sub loop_prev {
2917 0     0 0   die XML::XSH::Internal::LoopTerminatingException->new('prev',expand(@_));
2918             }
2919             sub loop_redo {
2920 0     0 0   die XML::XSH::Internal::LoopTerminatingException->new('redo',expand(@_));
2921             }
2922             sub loop_last {
2923 0     0 0   die XML::XSH::Internal::LoopTerminatingException->new('last',expand(@_));
2924             }
2925              
2926             # call methods on every node matching an XPath
2927             sub foreach_statement {
2928 0     0 0   my ($xp,$command)=@_;
2929 0 0         if (ref($xp) eq 'ARRAY') {
2930 0           my ($id,$query,$doc)=_xpath($xp);
2931 0 0         unless (ref($doc)) {
2932 0           die "No such document '$id'!\n";
2933             }
2934 0           my $old_local=$LOCAL_NODE;
2935 0           my $old_id=$LOCAL_ID;
2936 0           eval {
2937 0           my $ql=find_nodes($xp);
2938 0           foreach my $node (@$ql) {
2939 0           $LOCAL_NODE=$node;
2940 0           $LOCAL_ID=_find_id($node);
2941 0           eval {
2942 0           run_commands($command);
2943             };
2944 0 0 0       if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
    0          
2945 0 0 0       if ($@->label =~ /^(?:next|last|redo)$/ and $@->[1]>1) {
2946 0           $@->[1]--;
2947 0           die $@; # propagate to a higher level
2948             }
2949 0 0         if ($@->label eq 'next') {
    0          
    0          
2950 0           next;
2951             } elsif ($@->label eq 'last') {
2952 0           last;
2953             } elsif ($@->label eq 'redo') {
2954 0           redo;
2955             } else {
2956 0           die $@; # propagate
2957             }
2958             } elsif ($@) {
2959 0           die $@; # propagate
2960             }
2961             }
2962             };
2963 0           do {
2964 0           local $SIG{INT}=\&flagsigint;
2965 0           $LOCAL_NODE=$old_local;
2966 0           $LOCAL_ID=$old_id;
2967 0           propagate_flagsigint();
2968             };
2969 0 0         die $@ if $@; # propagate
2970             } else {
2971 0           foreach $XML::XSH::Map::__ (perl_eval($xp)) {
2972 0           eval {
2973 0           run_commands($command);
2974             };
2975 0 0 0       if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
    0          
2976 0 0 0       if ($@->label =~ /^(?:next|last|redo)$/ and $@->[1]>1) {
2977 0           $@->[1]--;
2978 0           die $@; # propagate to a higher level
2979             }
2980 0 0         if ($@->label eq 'next') {
    0          
    0          
2981 0           next;
2982             } elsif ($@->label eq 'last') {
2983 0           last;
2984             } elsif ($@->label eq 'redo') {
2985 0           redo;
2986             } else {
2987 0           die $@; # propagate
2988             }
2989             } elsif ($@) {
2990 0           die $@; # propagate
2991             }
2992             }
2993             }
2994 0           return 1;
2995             }
2996              
2997             # run commands if given XPath holds
2998             sub if_statement {
2999 0     0 0   my @cases=@_;
3000             # print STDERR "Parsed $xp\n";
3001 0           foreach (@cases) {
3002 0           my ($xp,$command)=@$_;
3003 0 0 0       if (!defined($xp) or
      0        
      0        
      0        
3004             (ref($xp) eq 'ARRAY') && count($xp) ||
3005             !ref($xp) && perl_eval($xp)) {
3006 0           return run_commands($command);
3007             }
3008             }
3009 0           return 1;
3010             }
3011              
3012             # run commands unless given XPath holds
3013             sub unless_statement {
3014 0     0 0   my ($xp,$command,$else)=@_;
3015 0 0 0       unless ((ref($xp) eq 'ARRAY')&&count($xp) ||
3016             !ref($xp) && perl_eval($xp)) {
3017 0           return run_commands($command);
3018             } else {
3019 0 0         return ref($else) ? run_commands($else->[1]) : 1;
3020             }
3021             }
3022              
3023             # transform a document with an XSLT stylesheet
3024             # and create a new document from the result
3025             sub xslt {
3026 0     0 0   my ($id,$stylefile,$newid)=expand @_[0..2];
3027 0           $id=_id($id);
3028 0           my $params=$_[3];
3029 0 0         print STDERR "running xslt on @_\n" if "$DEBUG";
3030 0 0         return unless $_doc{$id};
3031 0           my %params;
3032 0 0         %params=map { expand($_) } map { @$_ } @$params if ref($params);
  0            
  0            
3033 0 0         if ($DEBUG) {
3034 0           print STDERR map { "$_ -> $params{$_} " } keys %params;
  0            
3035 0           print STDERR "\n";
3036             }
3037              
3038 0 0 0       if ((-f $stylefile) or
3039             ($stylefile=~/^[a-z]+:/)) {
3040 0           require XML::LibXSLT;
3041              
3042 0           local *SAVE;
3043              
3044 0           my $_xsltparser=XML::LibXSLT->new();
3045 0           my $st=$_xsltparser->parse_stylesheet_file($stylefile);
3046 0           $stylefile=~s/\..*$//;
3047 0           my $doc=$st->transform($_doc{$id},%params);
3048             set_doc($newid,$doc,
3049 0           "$stylefile"."_transformed_".$_files{$id});
3050             } else {
3051 0           die "File not exists $stylefile\n";
3052             }
3053 0           return 1;
3054             }
3055              
3056             # perform xupdate processing over a document
3057             sub xupdate {
3058 0     0 0   my ($xupdate_id,$id)=expand(@_);
3059 0           $id=_id($id);
3060 0 0 0       if (get_doc($xupdate_id) and get_doc($id)) {
3061 0           require XML::XUpdate::LibXML;
3062 0           require XML::Normalize::LibXML;
3063 0           my $xupdate = XML::XUpdate::LibXML->new();
3064 0           $XML::XUpdate::LibXML::debug=1;
3065 0           $xupdate->process(get_doc($id)->getDocumentElement(),get_doc($xupdate_id));
3066             } else {
3067 0 0         if (get_doc($xupdate_id)) {
3068 0           die "No such document $id\n";
3069             } else {
3070 0           die "No such document $xupdate_id\n";
3071             }
3072 0           return 0;
3073             }
3074             }
3075              
3076 0     0 0   sub call_return { die XML::XSH::Internal::SubTerminatingException->new('return'); }
3077              
3078             # call a named set of commands
3079             sub call {
3080 0     0 0   my ($name,$args)=@_;
3081 0           $name=expand($name);
3082 0 0         if (exists $_defs{$name}) {
3083 0           my @vars=();
3084 0 0         if (ref($args)) {
3085 0           @vars=@{ $_defs{$name} };
  0            
3086 0           shift @vars;
3087             }
3088 0           my $result;
3089 0           store_variables(1,@vars);
3090 0           eval {
3091 0 0         if (ref($args)) {
3092 0           my $var;
3093 0           foreach (@$args) {
3094 0           $var=shift @vars;
3095 0 0         if (defined($var)) {
3096 0 0         if ($var =~ /^\$/) {
    0          
3097 0           _assign($var,expand($_)); # string assignment
3098             } elsif ($var =~ /^\%(.*)$/) {
3099 0           local $QUIET=1;
3100 0           nodelist_assign($1,$_); # nodelist assignment
3101             }
3102             }
3103             }
3104             }
3105 0           $result = run_commands($_defs{$name}->[0]);
3106             };
3107 0           do {
3108 0           local $SIG{INT}=\&flagsigint;
3109 0 0         restore_variables() if (ref($args));
3110 0           propagate_flagsigint();
3111             };
3112 0 0 0       if (ref($@) and $@->isa('XML::XSH::Internal::SubTerminatingException')) {
3113 0           undef $@;
3114 0           return 1;
3115             }
3116 0 0         die $@ if $@; # propagate
3117 0           return $result;
3118             } else {
3119 0           die "ERROR: $name not defined\n";
3120             }
3121             }
3122              
3123              
3124             sub undef_sub {
3125 0     0 0   my ($name)=@_;
3126 0 0         if (exists($_defs{$name})) {
3127 0           delete $_defs{$name};
3128             } else {
3129 0           foreach (keys %_defs) {
3130 0 0         delete $_defs{$_} if /^$name$/;
3131             }
3132             }
3133             }
3134              
3135             # define a named set of commands
3136             sub def {
3137 0     0 0   my ($name,$block,$args)=@_;
3138 0           my ($command)=@$block;
3139 0 0         if (exists($_defs{$name})) {
3140 0           my ($prevcmd, @prevargs)=@{$_defs{$name}};
  0            
3141 0 0         if ($prevcmd) {
    0          
3142 0           _err "Error: Subroutine $name already defined!";
3143 0           return 0;
3144             } elsif (!$command) {
3145 0           _err "Error: Subroutine $name already pre-declared!";
3146 0           return 0;
3147             } else {
3148 0 0         if (@$args != @prevargs) {
3149 0           _err "Error: Different number of arguments in declaration and pre-declarartion of $name!";
3150 0           return 0;
3151             }
3152 0           my $parg;
3153 0           foreach (@$args) {
3154 0           $parg=shift @prevargs;
3155 0 0         if (substr($parg,0,1) ne substr($_,0,1)) {
3156 0           _err "Error: Argument types of $_ and $parg in declarations of $name do not match!";
3157 0           return 0;
3158             }
3159             }
3160             }
3161             }
3162 0           $_defs{$name} = [ $command, @$args ];
3163 0           return 1;
3164             }
3165              
3166             # return a list of all definined subroutines
3167             sub defs {
3168 0     0 0   return sort keys %_defs;
3169             }
3170              
3171             # list all defined subroutines
3172             sub list_defs {
3173 0     0 0   foreach (sort keys (%_defs)) {
3174 0           out(join(" ",$_,@{ $_defs{$_} }[1..$#{ $_defs{$_} }] ),"\n" );
  0            
  0            
3175             }
3176 0           return 1;
3177             }
3178              
3179             # load a file
3180             sub load {
3181 0     0 0   my ($file)=@_;
3182 0           my $l;
3183 0 0         print STDERR "loading file $file\n" unless "$QUIET";
3184 0           local *F;
3185 0 0         if (open F,"$file") {
3186 0           return join "",;
3187             } else {
3188 0           die "ERROR: couldn't open input file $file";
3189             }
3190             }
3191              
3192             # call XSH to evaluate commands from a given file
3193             sub include {
3194 0     0 0   my $f=expand(shift);
3195 0           my $conditionally = shift;
3196 0 0 0       if (!$conditionally || !$_includes{$f}) {
3197 0           $_includes{$f}=1;
3198 0           my $l=load($f);
3199 0           return $_xsh->startrule($l);
3200             }
3201             }
3202              
3203             # print help
3204             sub help {
3205 0     0 0   my ($command)=expand @_;
3206 0 0         if ($command) {
3207 0 0         if (exists($XML::XSH::Help::HELP{$command})) {
3208 0           out($XML::XSH::Help::HELP{$command}->[0]);
3209             } else {
3210             my @possible =
3211 0           grep { index($_,$command)==0 }
  0            
3212             keys(%XML::XSH::Help::HELP);
3213 0           my %h = map { $XML::XSH::Help::HELP{$_} => $_ } @possible;
  0            
3214 0 0         if (keys(%h) == 1) {
    0          
3215 0           out($XML::XSH::Help::HELP{$possible[0]}->[0]);
3216 0           return 1;
3217             } elsif (keys(%h) > 1) {
3218 0           out("No help available on $command\n");
3219 0           out("Did you mean some of ", join(', ',@possible)," ?\n");
3220             } else {
3221 0           out("No help available on $command\n");
3222 0           return 0;
3223             }
3224             }
3225             } else {
3226 0           out($XML::XSH::Help::HELP);
3227             }
3228 0           return 1;
3229             }
3230              
3231             # load catalog file to the parser
3232             sub load_catalog {
3233 0     0 0   $_xml_module->load_catalog($_parser,expand($_[0]));
3234 0           return 1;
3235             }
3236              
3237             sub stream_process_node {
3238 0     0 0   my ($node,$command,$input,$id)=@_;
3239 0           set_doc($id,$_xml_module->owner_document($node),$input);
3240 0           my $old_local=$LOCAL_NODE;
3241 0           my $old_id=$LOCAL_ID;
3242 0           eval {
3243 0           foreach (1) {
3244 0           $LOCAL_NODE=$node;
3245 0           $LOCAL_ID=$id;
3246 0           eval {
3247 0           run_commands($command);
3248             };
3249 0 0 0       if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
    0          
3250 0 0 0       if ($@->label =~ /^(?:next|redo)$/ and $@->[1]>1) {
3251 0           $@->[1]--;
3252 0           die $@; # propagate to a higher level
3253             }
3254 0 0         if ($@->label eq 'next') {
    0          
3255 0           last;
3256             } elsif ($@->label eq 'redo') {
3257 0           redo;
3258             } else {
3259 0           die $@; # propagate
3260             }
3261             } elsif ($@) {
3262 0           die $@; # propagate
3263             }
3264             }
3265             };
3266 0           do {
3267 0           local $SIG{INT}=\&flagsigint;
3268 0           delete $_doc{$id};
3269 0           delete $_files{$id};
3270 0           $LOCAL_NODE=$old_local;
3271 0           $LOCAL_ID=$old_id;
3272 0           propagate_flagsigint();
3273             };
3274 0 0         die $@ if $@; # propagate
3275             }
3276              
3277             sub stream_process {
3278 0     0 0   my ($itype, $input, $otype, $output, $process)=@_;
3279 0           ($input,$output)=expand($input,$output);
3280 0           require XML::Filter::DOMFilter::LibXML;
3281 0           require XML::LibXML::SAX;
3282 0           require XML::SAX::Writer;
3283              
3284 0           my $out;
3285             my $termout;
3286 0           my $i=1;
3287 0           $i++ while (exists($_doc{"_stream_$i"}));
3288 0 0         if ($otype =~ /pipe/i) {
    0          
3289 0           open $out,"| $output";
3290 0 0         $out || die "Cannot open pipe to $output\n";
3291             } elsif ($otype =~ /string/i) {
3292 0 0         if ($output =~ /^\$?([a-zA-Z_][a-zA-Z0-9_]*)$/) {
    0          
3293 4     4   44 no strict qw(refs);
  4         9  
  4         9518  
3294 0           $out=\${"XML::XSH::Map::$1"};
  0            
3295             } elsif (ref($OUT)=~/Term::ReadLine/) {
3296 0           $out = *$OUT;
3297 0           $termout=1;
3298             } else {
3299 0           $out = $OUT;
3300 0           $termout=1;
3301             }
3302             } else {
3303 0           $out = $output;
3304             }
3305             my $parser=XML::LibXML::SAX
3306             ->new( Handler =>
3307             XML::Filter::DOMFilter::LibXML
3308             ->new(Handler =>
3309             XML::SAX::Writer::XML
3310             ->new(
3311             Output => $out,
3312             Writer => 'XML::SAX::Writer::XMLEnc'
3313             ),
3314             XPathContext => $_xpc,
3315             Process => [
3316             map {
3317 0           $_->[0] => [\&stream_process_node,$_->[1],
  0            
3318             $input,"_stream_$i"] }
3319             @$process
3320             ]
3321             )
3322             );
3323 0 0         if ($itype =~ /pipe/i) {
    0          
3324 0           open my $F,"$input|";
3325 0 0         $F || die "Cannot open pipe to $input: $!\n";
3326 0           $parser->parse_fh($F);
3327 0           close $F;
3328             } elsif ($itype =~ /string/i) {
3329 0           $parser->parse_string($input);
3330             } else { #file
3331 0           $parser->parse_uri($input);
3332             }
3333 0 0         if ($otype =~ /pipe/i) {
3334 0           close($out);
3335             }
3336 0 0         if ($termout) { out("\n"); }
  0            
3337 0           return 1;
3338             }
3339              
3340             sub iterate {
3341 0     0 0   my ($code,$axis,$nodefilter,$filter)=@_;
3342              
3343 0 0         return unless get_local_node(_id());
3344              
3345 0           $axis =~ s/::$//;
3346 0           $axis=~s/-/_/g;
3347              
3348 0 0         $filter =~ s/^\[\s*((?:.|\n)*?)\s*\]$/$1/ if defined $filter;
3349 0           my $test;
3350 0 0         if ($nodefilter eq "comment()") {
3351 0           $test = q{ $_xml_module->is_comment($_[0]) }
3352 0 0         } if ($nodefilter eq "text()") {
    0          
    0          
    0          
3353 0           $test = q{ $_xml_module->is_text_or_cdata($_[0]) }
3354             } elsif ($nodefilter =~ /processing-instruction\((\s*['"]([^'"]+)['"]\s*)?\)$/) {
3355 0           $test = q{ $_xml_module->is_pi($_[0]) };
3356 0 0         $test .= qq{ && (\$_[0]->nodeName eq '$1') } if $1 ne "";
3357             } elsif ($nodefilter eq 'node()') {
3358 0           $test = '1 ';
3359             } elsif ($nodefilter =~ /^(?:([^:]+):)?(.+)$/) {
3360 0           $test = q{ $_xml_module->is_element($_[0]) };
3361 0 0         $test .= qq{ && (\$_[0]->getLocalName() eq '$2') } unless ($2 eq '*');
3362 0 0         if ($1 ne "") {
3363 0           my $ns = get_local_node(_id())->lookupNamespaceURI($1);
3364 0 0         die("Unrecognized namespace prefix '$1:'!") if ($ns eq "");
3365 0           $test .= qq{ && (\$_[0]->namespaceURI() eq '$ns') };
3366             }
3367             }
3368              
3369 0 0         die("Position index filter not supported for iteration ([$filter])") if $filter =~ /^\d+$/;
3370 0 0         if ($filter ne '') {
3371 0           $filter =~ s/\\/\\\\/g;
3372 0           $filter =~ s/'/\\'/g;
3373 0           $test .= qq{ && count_xpath(\$_[0],'$filter') };
3374             }
3375              
3376 0           my $filter_sub = eval "sub { $test }";
3377 0           my $iterator;
3378 0           do {
3379 0           my $start=get_local_node(_id());
3380 0           $iterator=XML::XSH::Iterators->create_iterator($start,$axis,$filter_sub);
3381             };
3382 0 0         return 1 unless defined $iterator;
3383              
3384 0           my $old_local=$LOCAL_NODE;
3385 0           my $old_id=$LOCAL_ID;
3386              
3387 0           eval {
3388 0           ITER: while ($iterator->current()) {
3389 0           $LOCAL_NODE=$iterator->current();
3390 0           eval {
3391 0           run_commands($code);
3392             };
3393 0 0 0       if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
    0          
3394 0 0 0       if ($@->label =~ /^(?:next|last|redo|prev)$/ and $@->[1]>1) {
3395 0           $@->[1]--;
3396 0           die $@; # propagate to a higher level
3397             }
3398 0 0         if ($@->label eq 'next') {
    0          
    0          
    0          
3399 0 0         $iterator->next() || last;
3400 0           next;
3401             } elsif ($@->label eq 'prev') {
3402 0 0         $iterator->prev() || die("No previous node to iterate to!");
3403 0           next;
3404             } elsif ($@->label eq 'last') {
3405 0           last;
3406             } elsif ($@->label eq 'redo') {
3407 0           redo;
3408             } else {
3409 0           die $@; # propagate
3410             }
3411             } elsif ($@) {
3412 0           die $@; # propagate
3413             }
3414 0 0         $iterator->next() || last;
3415             }
3416             };
3417 0           do {
3418 0           local $SIG{INT}=\&flagsigint;
3419 0           $LOCAL_NODE=$old_local;
3420 0           $LOCAL_ID=$old_id;
3421 0           propagate_flagsigint();
3422             };
3423 0 0         die $@ if $@; # propagate
3424 0           return 1;
3425             }
3426              
3427             # quit
3428             sub quit {
3429 0 0   0 0   if (ref($_on_exit)) {
3430 0           &{$_on_exit->[0]}($_[0],@{$_on_exit}[1..$#$_on_exit]); # run on exit hook
  0            
  0            
3431             }
3432 0           exit(int($_[0]));
3433             }
3434              
3435             sub register_ns {
3436 0     0 0   my ($prefix,$ns)=expand(@_);
3437 0           $_ns{$prefix}=$ns;
3438 0           $_xpc->registerNs($prefix,$ns);
3439 0           return 1;
3440             }
3441              
3442             sub unregister_ns {
3443 0     0 0   my ($prefix)=expand(@_);
3444 0           delete $_ns{$prefix};
3445 0           $_xpc->unregisterNs($prefix);
3446 0           return 1;
3447             }
3448              
3449             sub register_func {
3450 0     0 0   my ($name,$code)=(expand($_[0]),$_[1]);
3451 0           my $sub;
3452 0 0         if ($code =~ /^\s*{/) {
    0          
3453 0           $sub=eval("package XML::XSH::Map; no strict; sub $code");
3454             } elsif ($code =~/^\s*([A-Za-z_][A-Za-z_0-9]*(::[A-Za-z_][A-Za-z_0-9]*)*)\s*$/) {
3455 0 0         if ($2 ne "") {
3456 0           $sub=\&{"$1"};
  0            
3457             } else {
3458 0           $sub=\&{"XML::XSH::Map::$1"};
  0            
3459             }
3460             } else {
3461 0           $sub=eval("package XML::XSH::Map; no strict; sub { $code }");
3462             }
3463 0 0         die $@ if $@;
3464 0 0         if ($name =~ /^([^:]+):(.*)$/) {
3465 0 0         if (exists($_ns{$1})) {
3466 0           $_xpc->registerFunctionNS($2, $_ns{$1}, $sub);
3467             } else {
3468 0           die "Registration failed: unknown namespace prefix $1!\n";
3469             }
3470             } else {
3471 0           $_xpc->registerFunction($name, $sub);
3472             }
3473 0           return 1;
3474             }
3475              
3476             sub unregister_func {
3477 0     0 0   my ($name)=expand(@_);
3478 0           $_xpc->unregisterFunction($name);
3479 0           return 1;
3480             }
3481              
3482             #######################################################################
3483             #######################################################################
3484              
3485              
3486             package XML::XSH::Map;
3487              
3488             import XML::XSH::Functions ':param_vars';
3489              
3490             # make this command available from perl expressions
3491             sub echo {
3492 0     0     &XML::XSH::Functions::out(XML::XSH::Functions::fromUTF8($XML::XSH::Functions::ENCODING,join("",@_)));
3493 0           return 1;
3494             }
3495              
3496             # make this command available from perl expressions
3497             sub xsh {
3498 0     0     &XML::XSH::Functions::xsh(join "",@_);
3499             }
3500              
3501             sub count {
3502 0     0     my $xp=$_[0];
3503 0           $xp=~/^(?:([a-zA-Z_][a-zA-Z0-9_]*):(?!:))?((?:.|\n)*)$/;
3504 0           return &XML::XSH::Functions::count([$1,$2]);
3505             }
3506              
3507             sub xml_list {
3508 0     0     my ($xp)=@_;
3509 0           $xp=~/^(?:([a-zA-Z_][a-zA-Z0-9_]*):(?!:))?((?:.|\n)*)$/;
3510 0           my ($id,$query,$doc)=&XML::XSH::Functions::_xpath([$1,$2]);
3511              
3512 0 0         unless (ref($doc)) {
3513 0           die "No such document '$id'!\n";
3514             }
3515 0           my $ql=&XML::XSH::Functions::find_nodes([$id,$query]);
3516 0           my $result='';
3517 0           foreach (@$ql) {
3518 0           $result.=$_->toString();
3519             }
3520 0           return $result;
3521             }
3522              
3523             sub literal {
3524 0     0     my ($xp)=@_;
3525 0           my $xp=$_[0];
3526 0           $xp=~/^(?:([a-zA-Z_][a-zA-Z0-9_]*):(?!:))?((?:.|\n)*)$/;
3527 0           return XML::XSH::Functions::eval_xpath_literal([$1,$2]);
3528             }
3529              
3530             sub type {
3531 0     0     my ($xp)=@_;
3532 0 0         $xp='.' if $xp eq "";
3533 0           $xp=~/^(?:([a-zA-Z_][a-zA-Z0-9_]*):(?!:))?((?:.|\n)*)$/;
3534 0           my ($id,$query,$doc)=&XML::XSH::Functions::_xpath([$1,$2]);
3535              
3536 0 0         unless (ref($doc)) {
3537 0           die "No such document '$id'!\n";
3538             }
3539 0           my $ql=&XML::XSH::Functions::find_nodes([$id,$query]);
3540              
3541              
3542 0           my $xm=$XML::XSH::Functions::_xml_module;
3543 0           my @result;
3544 0           foreach (@$ql) {
3545 0 0         if ($xm->is_element($_)) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3546 0           push @result, 'element';
3547             } elsif ($xm->is_attribute($_)) {
3548 0           push @result, 'attribute';
3549             } elsif ($xm->is_text($_)) {
3550 0           push @result, 'text';
3551             } elsif ($xm->is_cdata_section($_)) {
3552 0           push @result, 'cdata';
3553             } elsif ($xm->is_pi($_)) {
3554 0           push @result, 'pi';
3555             } elsif ($xm->is_entity_reference($_)) {
3556 0           push @result, 'entity_reference';
3557             } elsif ($xm->is_document($_)) {
3558 0           push @result, 'document';
3559             } elsif ($xm->is_document_fragment($_)) {
3560 0           push @result, 'chunk';
3561             } elsif ($xm->is_comment($_)) {
3562 0           push @result, 'comment';
3563             } elsif ($xm->is_namespace($_)) {
3564 0           push @result, 'namespace';
3565             } else {
3566 0           push @result, 'unknown';
3567             }
3568 0 0         return $result[0] unless (wantarray);
3569             }
3570 0           return @result;
3571             }
3572              
3573             #######################################################################
3574             #######################################################################
3575              
3576             package XML::XSH::Internal::Exception;
3577              
3578             sub new {
3579 0   0 0     my $class=(ref($_[0]) || $_[0]);
3580 0           shift;
3581 0           return bless [@_], $class;
3582             }
3583              
3584             sub set_label {
3585 0     0     my ($label)=@_;
3586 0           return $_[0]->[0]=$label;
3587             }
3588              
3589             sub label {
3590 0     0     return $_[0]->[0];
3591             }
3592              
3593             sub value {
3594 0     0     my ($index)=@_;
3595 0           return $_[0]->[$index];
3596             }
3597              
3598             sub set_value {
3599 0     0     my ($index,$value)=@_;
3600 0           return $_[0]->[$index]=$value;
3601             }
3602              
3603             package XML::XSH::Internal::UncatchableException;
3604 4     4   33 use vars qw(@ISA);
  4         14  
  4         368  
3605             @ISA=qw(XML::XSH::Internal::Exception);
3606              
3607             package XML::XSH::Internal::LoopTerminatingException;
3608 4     4   24 use vars qw(@ISA);
  4         7  
  4         194  
3609             @ISA=qw(XML::XSH::Internal::UncatchableException);
3610              
3611             package XML::XSH::Internal::SubTerminatingException;
3612 4     4   18 use vars qw(@ISA);
  4         11  
  4         265  
3613             @ISA=qw(XML::XSH::Internal::UncatchableException);
3614              
3615              
3616             #######################################################################
3617             #######################################################################
3618              
3619             package IO::MyString;
3620              
3621 4     4   21 use vars qw(@ISA);
  4         7  
  4         617  
3622             @ISA=qw(IO::Handle);
3623              
3624             sub new {
3625 0   0 0     my $class=(ref($_[0]) || $_[0]);
3626 0           return bless [""], $class;
3627             }
3628              
3629             sub print {
3630 0     0     my $self=shift;
3631 0           $self->[0].=join("",@_);
3632             }
3633              
3634             sub value {
3635 0     0     return $_[0]->[0];
3636             }
3637              
3638             sub close {
3639 0     0     $_[0]->[0]=undef;
3640             }
3641              
3642             package XML::SAX::Writer::XMLEnc;
3643 4     4   19 use vars qw(@ISA);
  4         7  
  4         687  
3644             @ISA=qw(XML::SAX::Writer::XML);
3645              
3646             sub xml_decl {
3647 0     0     my ($self,$data) = @_;
3648 0 0         if ($data->{Encoding}) {
3649 0           $self->{EncodeTo}=$data->{Encoding};
3650 0           $self->setConverter();
3651             }
3652 0           $self->SUPER::xml_decl($data);
3653             }
3654              
3655             1;