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

# -*- cperl -*-
# $Id: Functions.pm,v 1.73 2003/09/10 15:54:09 pajas Exp $

package XML::XSH::Functions;

eval "no encoding";
undef $@;
use strict;
no warnings;

use XML::XSH::Help;
use XML::XSH::Iterators;
use IO::File;

use Exporter;
use vars qw/@ISA @EXPORT_OK %EXPORT_TAGS $VERSION $REVISION $OUT $LOCAL_ID $LOCAL_NODE
            $_xml_module $_sigint
            $_xsh $_xpc $_parser %_nodelist @stored_variables
            $_newdoc
            $TRAP_SIGINT $TRAP_SIGPIPE $_die_on_err $_on_exit
            %_doc %_files %_defs %_includes %_chr %_ns
	    $ENCODING $QUERY_ENCODING
	    $INDENT $BACKUPS $SWITCH_TO_NEW_DOCUMENTS $EMPTY_TAGS $SKIP_DTD
	    $QUIET $DEBUG $TEST_MODE
	    $VALIDATION $RECOVERING $PARSER_EXPANDS_ENTITIES $KEEP_BLANKS
	    $PEDANTIC_PARSER $LOAD_EXT_DTD $PARSER_COMPLETES_ATTRIBUTES
	    $PARSER_EXPANDS_XINCLUDE
	    $XPATH_AXIS_COMPLETION
	    $XPATH_COMPLETION $DEFAULT_FORMAT
	  /;

BEGIN {
  $VERSION='1.8.3';
  $REVISION='$Revision: 1.73 $';
  @ISA=qw(Exporter);
  my @PARAM_VARS=qw/$ENCODING
		    $QUERY_ENCODING
		    $INDENT
                    $EMPTY_TAGS
                    $SKIP_DTD
		    $BACKUPS
		    $SWITCH_TO_NEW_DOCUMENTS
		    $QUIET
		    $DEBUG
		    $TEST_MODE
		    $VALIDATION
		    $RECOVERING
		    $PARSER_EXPANDS_ENTITIES
		    $XPATH_AXIS_COMPLETION
		    $XPATH_COMPLETION
		    $KEEP_BLANKS
		    $PEDANTIC_PARSER
		    $LOAD_EXT_DTD
		    $PARSER_COMPLETES_ATTRIBUTES
		    $PARSER_EXPANDS_XINCLUDE
		    $DEFAULT_FORMAT
		    /;
  *EMPTY_TAGS=*XML::LibXML::setTagCompression;
  *SKIP_DTD=*XML::LibXML::skipDTD;
  @EXPORT_OK=(qw(&xsh_init &xsh &xsh_get_output
                &xsh_set_output &xsh_set_parser
                &set_quiet &set_debug &set_compile_only_mode
		&create_doc &open_doc &set_doc
		&xsh_pwd &xsh_local_id &get_doc &out
		&toUTF8 &fromUTF8 &set_local_doc
		&xsh_xml_parser &xsh_parse_string &xsh_docs
	       ),@PARAM_VARS);
  %EXPORT_TAGS = (
		  default => [@EXPORT_OK],
		  param_vars => [@PARAM_VARS]
		 );

  $TRAP_SIGINT=0;
  $_xml_module='XML::XSH::LibXMLCompat';
  $INDENT=1;
  $EMPTY_TAGS=1; # no effect (reseted by XML::LibXML)
  $SKIP_DTD=0;   # no effect (reseted by XML::LibXML)
  $BACKUPS=1;
  $SWITCH_TO_NEW_DOCUMENTS=1;
  $ENCODING='utf-8';
  $QUERY_ENCODING='utf-8';
  $QUIET=0;
  $DEBUG=0;
  $TEST_MODE=0;
  $VALIDATION=0;
  $RECOVERING=0;
  $PARSER_EXPANDS_ENTITIES=1;
  $KEEP_BLANKS=1;
  $PEDANTIC_PARSER=0;
  $LOAD_EXT_DTD=0;
  $PARSER_COMPLETES_ATTRIBUTES=1;
  $PARSER_EXPANDS_XINCLUDE=0;
  $XPATH_COMPLETION=1;
  $XPATH_AXIS_COMPLETION='always'; # never / when-empty
  $DEFAULT_FORMAT='xml';
  $_newdoc=1;
  $_die_on_err=1;
  %_nodelist=();

  %_chr = ( n => "\n", t => "\t", r => "\r",
	    f => "\f", b => "\b", a => "\a",
	    e => "\e" );
  autoflush STDOUT;
  autoflush STDERR;
}

sub min { $_[0] > $_[1] ? $_[1] : $_[0] }

sub out {
  if (ref($OUT) eq 'GLOB' or ref($OUT) eq 'Term::ReadLine::Gnu::Var') {
    print $OUT @_;
  } else {
    $OUT->print(@_);
  }
}

sub __debug {
  _err(@_);
}

sub __bug {
  _err("BUG: ",@_);
}


# initialize XSH and XML parsers
sub xsh_init {
  my $module=shift;
  shift unless ref($_[0]);
  if (ref($_[0])) {
    $OUT=$_[0];
  } else {
    $OUT=\*STDOUT;
  }
  $_xml_module=$module if $module;
  eval "require $_xml_module;";
  if ($@) {
    _err(
      "\n------------------------------------------------------------\n",
      $@,
      "\n------------------------------------------------------------.\n",
      "I suspect you have not installed XML::LibXML properly.\n",
      "Please install and try again. If you are 100% sure you have, send\n",
      "a full bug report to \n");
    exit 1;
  }
  my $mod=$_xml_module->module();
  if ($] >= 5.008) {
    require Encode;
    *encodeToUTF8=*Encode::decode;
    *decodeFromUTF8=*Encode::encode;
  } else {
    no strict 'refs';
    *encodeToUTF8=*{"$mod"."::encodeToUTF8"};
    *decodeFromUTF8=*{"$mod"."::decodeFromUTF8"};
  }
  $_parser = $_xml_module->new_parser();

  xpc_init();
  xsh_rd_parser_init();
}

sub xsh_rd_parser_init {
  if (eval { require XML::XSH::Parser; }) {
    $_xsh=XML::XSH::Parser->new();
  } else {
    print STDERR "Parsing raw grammar...\n";
    require XML::XSH::Grammar;
    $_xsh=XML::XSH::Grammar->new();
    print STDERR "... done.\n";
    unless ($QUIET) {
      print STDERR << 'EOF';
NOTE: To avoid this, you should regenerate the XML::XSH::Parser.pm
      module from XML::XSH::Grammar.pm module by changing to XML/XSH/
      directory in your load-path and running the following command:

         perl -MGrammar -e XML::XSH::Grammar::compile

EOF
    }
  }
  return $_xsh;
}

sub set_validation	     { $VALIDATION=$_[0]; 1; }
sub set_recovering	     { $RECOVERING=$_[0]; 1; }
sub set_expand_entities	     { $PARSER_EXPANDS_ENTITIES=$_[0]; 1; }
sub set_keep_blanks	     { $KEEP_BLANKS=$_[0]; 1; }
sub set_pedantic_parser	     { $PEDANTIC_PARSER=$_[0]; 1; }
sub set_load_ext_dtd	     { $LOAD_EXT_DTD=$_[0]; 1; }
sub set_complete_attributes  { $PARSER_COMPLETES_ATTRIBUTES=$_[0]; 1; }
sub set_expand_xinclude	     { $PARSER_EXPANDS_XINCLUDE=$_[0]; 1; }
sub set_indent		     { $INDENT=$_[0]; 1; }
sub set_empty_tags           { $EMPTY_TAGS=$_[0]; 1; }
sub set_skip_dtd             { $SKIP_DTD=$_[0]; 1; }
sub set_backups		     { $BACKUPS=$_[0]; 1; }
sub set_cdonopen	     { $SWITCH_TO_NEW_DOCUMENTS=$_[0]; 1; }
sub set_xpath_completion     { $XPATH_COMPLETION=$_[0]; 1; }
sub set_xpath_axis_completion { $XPATH_AXIS_COMPLETION=$_[0];
				if ($XPATH_AXIS_COMPLETION!~/^always|when-empty|never$/) {
				  $XPATH_AXIS_COMPLETION='never';
				}
				1; }

sub get_validation	     { $VALIDATION }
sub get_recovering	     { $RECOVERING }
sub get_expand_entities	     { $PARSER_EXPANDS_ENTITIES }
sub get_keep_blanks	     { $KEEP_BLANKS }
sub get_pedantic_parser	     { $PEDANTIC_PARSER }
sub get_load_ext_dtd	     { $LOAD_EXT_DTD }
sub get_complete_attributes  { $PARSER_COMPLETES_ATTRIBUTES }
sub get_expand_xinclude	     { $PARSER_EXPANDS_XINCLUDE }
sub get_indent		     { $INDENT }
sub get_empty_tags           { $EMPTY_TAGS }
sub get_skip_dtd             { $SKIP_DTD }
sub get_backups		     { $BACKUPS }
sub get_cdonopen	     { $SWITCH_TO_NEW_DOCUMENTS }
sub get_xpath_completion     { $XPATH_COMPLETION }
sub get_xpath_axis_completion { $XPATH_AXIS_COMPLETION }


# initialize global XPathContext
sub xpc_init {
  unless (eval { require XML::LibXML::XPathContext;
		 $_xpc=XML::LibXML::XPathContext->new();
	       }) {
    require XML::XSH::DummyXPathContext;
    print STDERR ("Warning: XML::LibXML::XPathContext not found!\n".
		  "XSH will lack namespace and function registering functionality!\n\n");
    $_xpc=XML::XSH::DummyXPathContext->new();
  }
  $_xpc->registerVarLookupFunc(\&xpath_var_lookup,undef);
  $_xpc->registerNs('xsh',$XML::XSH::xshNS);
  $_xpc->registerFunctionNS('doc',$XML::XSH::xshNS,
			  sub {
			    die "Wrong number of arguments for function doc(id)!" if (@_!=1);
			    my ($id)=literal_value($_[0]);
			    die "Wrong number of arguments for function doc(id)!" if (@_!=1);
			    die "Document does not exist!" unless (exists($_doc{$id}));
			    return $_doc{$id};
			  });
  $_xpc->registerFunctionNS('matches',$XML::XSH::xshNS,
			  sub {
			    die "Wrong number of arguments for function matches(string,regexp)!" if (@_!=2);
			    my ($string,$regexp)=@_;
			    $regexp=literal_value($regexp);
			    use utf8;
			    my $ret=literal_value($string)=~m{$regexp} ?
			      XML::LibXML::Boolean->True : XML::LibXML::Boolean->False;
			    $ret;
			  });
  $_xpc->registerFunctionNS('grep',$XML::XSH::xshNS,
			  sub {
			    die "Wrong number of arguments for function grep(list,regexp)!" if (@_!=2);
			    my ($nodelist,$regexp)=@_;
			    die "1st argument must be a node-list in grep(list,regexp)!"
			      unless (ref($nodelist) and $nodelist->isa('XML::LibXML::NodeList'));
			    use utf8;
			    [grep { $_->to_literal=~m{$regexp} } @$nodelist];
			  });
  $_xpc->registerFunctionNS('same',$XML::XSH::xshNS,
			  sub {
			    die "Wrong number of arguments for function same(node,node)!" if (@_!=2);
			    my ($nodea,$nodeb)=@_;
			    die "1st argument must be a node in grep(list,regexp)!"
			      unless (ref($nodea) and $nodea->isa('XML::LibXML::NodeList'));
			    die "2nd argument must be a node in grep(list,regexp)!"
			      unless (ref($nodeb) and $nodeb->isa('XML::LibXML::NodeList'));
			    return XML::LibXML::Boolean->new($nodea->size() && $nodeb->size() &&
							     $nodea->[0]->isSameNode($nodea->[0]));
			  });
}

sub list_flags {
  print "validation ".(get_validation() or "0").";\n";
  print "recovering ".(get_recovering() or "0").";\n";
  print "parser_expands_entities ".(get_expand_entities() or "0").";\n";
  print "parser_expands_xinclude ".(get_expand_xinclude() or "0").";\n";
  print "keep_blanks ".(get_keep_blanks() or "0").";\n";
  print "pedantic_parser ".(get_pedantic_parser() or "0").";\n";
  print "load_ext_dtd ".(get_load_ext_dtd() or "0").";\n";
  print "complete_attributes ".(get_complete_attributes() or "0").";\n";
  print "indent ".(get_indent() or "0").";\n";
  print "empty_tags ".(get_empty_tags() or "0").";\n";
  print "skip_dtd ".(get_skip_dtd() or "0").";\n";
  print ((get_backups() ? "backups" : "nobackups"),";\n");
  print (($QUIET ? "quiet" : "verbose"),";\n");
  print (($DEBUG ? "debug" : "nodebug"),";\n");
  print (($TEST_MODE ? "run-mode" : "test-mode"),";\n");
  print "switch_to_new_documents ".(get_cdonopen() or "0").";\n";;
  print "encoding '$ENCODING';\n";
  print "query_encoding '$QUERY_ENCODING';\n";
  print "xpath_completion ".(get_xpath_completion() or "0").";\n";
  print "xpath_axis_completion \'".get_xpath_axis_completion()."';\n";
}

sub toUTF8 {
  # encode/decode from UTF8 returns undef if string not marked as utf8
  # by perl (for example ascii)
  my $res=eval { encodeToUTF8($_[0],$_[1]) };
  if ($@ =~ /^SIGINT/) {
    die $@
  } else {
    undef $@;
  }
  return defined($res) ? $res : $_[1];
}

sub fromUTF8 {
  # encode/decode from UTF8 returns undef if string not marked as utf8
  # by perl (for example ascii)
  my $res=eval { decodeFromUTF8($_[0],$_[1]) };
  if ($@ =~ /^SIGINT/) {
    die $@
  } else {
    undef $@;
  }
  return defined($res) ? $res : $_[1];
}

# evaluate a XSH command
sub xsh {
  xsh_init() unless (ref($_xsh));
  if (ref($_xsh)) {
    my $code=join "",@_;
    return ($code=~/^\s*$/) ? 1 : $_xsh->startrule($code);
  } else {
    die "XSH init failed!\n";
  }
}

# setup output stream
sub xsh_set_output {
  $OUT=$_[0];
  return 1;
}

# get output stream
sub xsh_get_output {
  return $OUT;
}

sub xsh_docs {
  return keys %_doc;
}

sub xsh_parse_string {
  my $format=$_[1] || $DEFAULT_FORMAT;
  if ($format eq 'xml') {
    my $xmldecl;
    $xmldecl="" unless $_[0]=~/^\s*\<\?xml /;
    return $_xml_module->parse_string($_parser,$xmldecl.$_[0]);
  } elsif ($format eq 'html') {
    return $_xml_module->parse_html_string($_parser,$_[0]);
  } elsif ($format eq 'docbook') {
    print "parsing SGML\n";
    return $_xml_module->parse_sgml_string($_parser,$_[0]);
  }
}

sub xsh_xml_parser {
  xsh_init() unless ref($_parser);
  return $_parser;
}

# store a pointer to an XSH-Grammar parser
sub xsh_set_parser {
  $_xsh=$_[0];
  return 1;
}

# print version info
sub print_version {
  out("Main program:              $::VERSION $::REVISION\n");
  out("XML::XSH::Functions:       $VERSION $REVISION\n");
  out("XML::LibXML:               $XML::LibXML::VERSION\n");
#  out($_xml_module->module(),"\t",$_xml_module->version(),"\n");
  out("XML::LibXSLT               $XML::LibXSLT::VERSION\n")
    if defined($XML::LibXSLT::VERSION);
  out("XML::LibXML::XPathContext  $XML::LibXML::XPathContext::VERSION\n")
    if defined($XML::LibXML::XPathContext::VERSION);
  return 1;
}

# print a list of all open files
sub files {
  out(map { "$_ = $_files{$_}\n" } sort keys %_files);
  return 1;
}

sub docs {
  return sort keys %_files;
}

sub _doc {
  return $_doc{$_[0]} if exists($_doc{$_[0]});
}

sub xpath_var_lookup {
  my ($data,$name,$ns)=@_;
  no strict;
  if ($ns eq "") {
    if ($name=~/^_\.(.*)$/ and exists($_nodelist{$1})) {
      return $_nodelist{$1}[1];
    } elsif (defined(${"XML::XSH::Map::$name"})) {
      return ${"XML::XSH::Map::$name"};
    } else {
      die "Undefined nodelist variable `$name'\n";
    }
  }
}

# return a value of the given XSH string or nodelist variable
sub var_value {
  no strict;
  if ($_[0]=~/^\$(.*)/ and defined(${"XML::XSH::Map::$1"})) {
    return "".${"XML::XSH::Map::$1"};
  } elsif ($_[0]=~/^\%(.*)/ and exists($_nodelist{$1})) {
    return $_nodelist{$1};
  } else {
    return undef;
  }
}

sub string_vars {
  no strict;
  return sort grep { defined(${"XML::XSH::Map::$_"}) } keys %{"XML::XSH::Map::"};
}

sub nodelist_vars {
  no strict;
  return sort keys %_nodelist;
}

# print a list of XSH variables and their values
sub variables {
  no strict;
  foreach (keys %{"XML::XSH::Map::"}) {
    out("\$$_='",fromUTF8($ENCODING,${"XML::XSH::Map::$_"}),"';\n") if defined(${"XML::XSH::Map::$_"});
  }
  return 1;
}

# print value of an XSH variable
sub print_var {
  no strict;
  if ($_[0]=~/^\$?(.*)/) {
    out("\$$1='",fromUTF8($ENCODING,${"XML::XSH::Map::$1"}),"';\n") if defined(${"XML::XSH::Map::$1"});
    return 1;
  }
  return 0;
}

sub echo { out(fromUTF8($ENCODING,join " ",expand(@_)),"\n"); return 1; }
sub set_quiet { $QUIET=$_[0]; return 1; }
sub set_debug { $DEBUG=$_[0]; return 1; }
sub set_compile_only_mode { $TEST_MODE=$_[0]; return 1; }

sub test_enc {
  my ($enc)=@_;
  if (defined(toUTF8($enc,'')) and
      defined(fromUTF8($enc,''))) {
    return 1;
  } else {
    _err("Error: Cannot convert between $enc and utf-8\n");
    return 0;
  }
}

sub set_encoding {
  my $enc=expand($_[0]);
  my $ok=test_enc($enc);
  $ENCODING=$enc if $ok;
  return $ok;
}

sub set_qencoding {
  my $enc=expand($_[0]);
  my $ok=test_enc($enc);
  $QUERY_ENCODING=$enc if $ok;
  return $ok;
}

sub print_encoding { print "$ENCODING\n"; return 1; }
sub print_qencoding { print "$QUERY_ENCODING\n"; return 1; }

sub sigint {
  if ($TRAP_SIGINT) {
    print STDERR "\nCtrl-C pressed. \n";
    die "SIGINT";
  } else {
    print STDERR "\nCtrl-C pressed. \n";
    exit 1;
  }
}

sub sigpipe {
  if ($TRAP_SIGPIPE) {
    die "SIGPIPE";
  } else {
    _err('broken pipe (SIGPIPE)');
    exit 1;
  }
}

sub flagsigint {
  print STDERR "\nCtrl-C pressed. \n";
  $_sigint=1;
}

sub propagate_flagsigint {
  if ($_sigint) {
    $_sigint=0;
    die 'SIGINT';
  }
}


sub convertFromDocEncoding ($$\$) {
  my ($doc,$encoding,$str)=@_;
  return fromUTF8($encoding, toUTF8($_xml_module->doc_encoding($doc), $str));
}

sub _err {
  print STDERR @_,"\n";
}

# if the argument is non-void then print it and return 0; return 1 otherwise
sub _check_err {
  my ($err,$survive_int)=@_;
  if ($err) {
    if ($err=~/^SIGINT/) {
      if ($survive_int) {
	$err=~s/ at (?:.|\n)*$//;
	_err($err);
	return 0;
      } else {
	die $err; # propagate
      }
    } elsif ($_die_on_err) {
      if ($err=~/^SIGPIPE/) {
	_err('broken pipe (SIGPIPE)');
      } else {
	die $err; # propagate
      }
    } else {
      if ($err=~/^SIGPIPE/) {
	_err('broken pipe (SIGPIPE)');
      } else {
	_err($err);
      }
      return 0;
    }
  }
  return 1;
}

# return current document id
sub xsh_local_id {
  return $LOCAL_ID;
}


# return current node for given document or document root if
# current node is not from the given document
sub get_local_node {
  my ($id)=@_;
  if ($LOCAL_NODE and $id eq $LOCAL_ID) {
    return $LOCAL_NODE;
  } else {
    $id=$LOCAL_ID if ($id eq "");
    return $_doc{$id} ? $_doc{$id} : undef;
  }
}

# return current document's id (and optionally the doc itself) if id is void
sub _id {
  my ($id)=@_;
  if ($id eq "") {
    $id=$LOCAL_ID;
    print STDERR "assuming current document $id\n" if $DEBUG;
  }
  return wantarray ? ($id,$_doc{$id}) : $id;
}

# try to find a document ID by its node
sub _find_id {
  my ($node)=@_;
  if (ref($node)) {
    my $doc=$_xml_module->owner_document($node);
    foreach my $id (keys %_doc) {
      if ($_xml_module->xml_equal($_doc{$id},$doc)) {
	print STDERR "FOUND ID: $id\n" if $DEBUG;
	return $id;
      }
    }
    print STDERR "Error: no document found for current node\n";
    my $uri=$_xml_module->doc_URI($doc);
    if ($uri ne "") {
      pirnt STDERR "Using document('$uri')\n" if $DEBUG;
      return "document('$uri')";
    }
  }
  return "";
}

# extract document id, xpath query string and document pointer from XPath type
sub _xpath {
  my ($id,$query)=expand(@{$_[0]});
  ($id,my $doc)=_id($id);
  return ($id,$query,$doc);
}

# make given node current (no checking!)
sub set_local_node {
  my ($node)=@_;
  if (ref($node)) {
    $LOCAL_NODE=$node;
    $LOCAL_ID=_find_id($node);
  } else {
    $LOCAL_NODE=undef;
    $LOCAL_ID=undef;
  }
}

# make root of the document the current node (no checking!)
sub set_local_doc {
  my ($id)=@_;
  $LOCAL_NODE=$_doc{$id};
  $LOCAL_ID=$id;
}


# set current node to given XPath
sub set_local_xpath {
  my ($xp)=@_;
  my ($id,$query,$doc)=_xpath($xp);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  if ($query eq "") {
    set_local_doc($id);
    return 1;
  }
  return 0 unless ref($doc);
  my ($newlocal);
  $newlocal=find_nodes($xp)->[0];
  if (ref($newlocal)) {
    set_local_node($newlocal);
  } else {
    die "No node in document $id matches XPath $query!\n";
  }

  return 1;
}

# return XPath identifying a node within its parent's subtree
sub node_address {
  my ($node)=@_;
  my $name;
  if ($_xml_module->is_element($node)) {
    $name=$node->getName();
  } elsif ($_xml_module->is_text($node) or
	   $_xml_module->is_cdata_section($node)) {
    $name="text()";
  } elsif ($_xml_module->is_comment($node)) {
    $name="comment()";
  } elsif ($_xml_module->is_pi($node)) {
    $name="processing-instruction()";
  } elsif ($_xml_module->is_attribute($node)) {
    return "@".$node->getName();
  }
  if ($node->parentNode) {
    my @children;
    if ($_xml_module->is_element($node)) {
      @children=$node->parentNode->findnodes("./*[name()='$name']");
    } else {
      @children=$node->parentNode->findnodes("./$name");
    }
    if (@children == 1 and $_xml_module->xml_equal($node,$children[0])) {
      return "$name";
    }
    for (my $pos=0;$pos<@children;$pos++) {
      return "$name"."[".($pos+1)."]"
	if ($_xml_module->xml_equal($node,$children[$pos]));
    }
    return undef;
  } else {
    return ();
  }
}

# parent element (even for attributes)
sub tree_parent_node {
  my $node=$_[0];
  if ($_xml_module->is_attribute($node)) {
    return $node->ownerElement();
  } else {
    return $node->parentNode();
  }
}

# return canonical xpath for the given or current node
sub pwd {
  my $node=$_[0] || $LOCAL_NODE || $_doc{$LOCAL_ID};
  return undef unless ref($node);
  my @pwd=();
  do {
    unshift @pwd,node_address($node);
    $node=tree_parent_node($node);
  } while ($node);
  my $pwd="/".join "/",@pwd;
  return $pwd;
}

# return canonical xpath for current node (encoded)
sub xsh_pwd {
  my $pwd;
  my ($id, $doc)=_id();
  return undef unless $doc;
  $pwd=fromUTF8($ENCODING,pwd());
  return $pwd;
}

# print current node's xpath
sub print_pwd {
  my $pwd=xsh_pwd();
  if ($pwd) {
    out("$pwd\n\n");
    return $pwd;
  } else {
    return 0;
  }
}

# evaluate variable and xpath expresions given string
sub _expand {
  my $l=$_[0];
  my $k;
  no strict;
  $l=~/^/o;
  while ($l !~ /\G$/gsco) {
    if ($l=~/\G\\(.|\n)/gsco) {
      if (exists($_chr{$1})) {
	$k.=$_chr{$1};
      } else {
	$k.=$1;
      }
    } elsif ($l=~/\G([^\\\$]+)/gsco) {
      $k.=$1;
    } elsif ($l=~/\G\$\{([a-zA-Z_][a-zA-Z0-9_]*)\}/gsco
	     or $l=~/\G\$([a-zA-Z_][a-zA-Z0-9_]*)/gsco) {
      $k.=${"XML::XSH::Map::$1"};
    } elsif ($l=~/\G\$\{\{\{(.+?)\}\}\}/gsco) {
      $k.=perl_eval($1);
    } elsif ($l=~/\G\$\{\{\s*([a-zA-Z_][a-zA-Z0-9_]*):(?!:)(.*?)\}\}/gsco) {
      $k.=count([$1,$2]);
    } elsif ($l=~/\G\$\{\{([^\{].*?)\}\}/gsco) {
      $k.=count([undef,$1]);
    } elsif ($l=~/\G\$\{\(\s*([a-zA-Z_][a-zA-Z0-9_]*):(?!:)(.*?)\)\}/gsco) {
      $k.=eval_xpath_literal([$1,$2]);
    } elsif ($l=~/\G\$\{\((.+?)\)\}/gsco) {
      $k.=eval_xpath_literal([undef,$1]);
    } elsif ($l=~/\G(.|\n)/gsco) {
      $k.=$1;
    }
  }
  return $k;
}

# expand one or all parameters (according to return context)
sub expand {
  return wantarray ? (map { _expand($_) } @_) : _expand($_[0]);
}

# assign a value to a variable
sub _assign {
  my ($name,$value)=@_;
  no strict 'refs';
  $name=~/^\$(.+)/;
  ${"XML::XSH::Map::$1"}=$value;
  print STDERR "\$$1=",${"XML::XSH::Map::$1"},"\n" if $DEBUG;
  return 1;
}

sub _undef {
  my ($name)=@_;
  no strict 'refs';
  $name=~/^\$(.+)/;
  undef ${"XML::XSH::Map::$1"};
  return 1;
}

sub literal_value {
  return ref($_[0]) ? $_[0]->value() : $_[0];
}

# evaluate xpath and assign the result to a variable
sub xpath_assign {
  my ($name,$xp)=@_;
  _assign($name,count($xp));
  return 1;
}

sub xpath_assign_local {
  store_variables(0,$_[0]);
  xpath_assign(@_);
  return 1;
}

sub nodelist_assign_local {
  my ($name)=@_;
  $name=expand($name);
  store_variables(0,"\%$name");
  nodelist_assign(@_);
  return 1;
}

sub make_local {
  foreach (@_) {
    if ($_->[0] eq '$') {
      xpath_assign_local($_->[1],undef);
    } else {
      nodelist_assign_local($_->[1],undef);
    }
  }
}


sub get_stored_nodelists {
  return grep { ref($_) } map { @$_ } @stored_variables;
}

sub store_variables {
  my ($new,@vars)=@_;
  my $pool;
  if ($new) {
    $pool=[];
  } elsif (@stored_variables and ref($stored_variables[$#stored_variables])) {
    $pool=$stored_variables[$#stored_variables];
  } else {
    print STDERR "WARNING: Ignoring attempt to make a local variable outside a localizable context!\n";
    return 0;
  }

  foreach (@vars) {
    my $value=var_value($_);
    push @$pool, $_ => $value;
  }
  push @stored_variables, $pool if ($new);

  return 1;
}

sub restore_variables {
  my $pool=pop @stored_variables;
  unless (ref($pool)) {
    __bug("Local variable pool is empty, which was not expected!\n");
    return 0;
  }
  while (@$pool) {
    my ($value,$name)=(pop(@$pool), pop(@$pool));
    if ($name =~ m/^\$/) {
      if (defined($value)) {
	_assign($name,$value);
      } else {
	_undef($name);
      }
    } elsif ($name =~ m/^\%(.*)$/) {
      if (defined($value)) {
	$_nodelist{$1}=$value;
      } else {
	delete $_nodelist{$1};
      }
    } else {
      __bug("Invalid variable name $1\n");
    }
  }
  return 1;
}

sub _xpc_find_nodes {
  my ($node,$query)=@_;
  $_xpc->setContextNode($node);
  return $_xpc->findnodes($query);
}

# findnodes wrapper which handles both xpaths and nodelist variables
sub _find_nodes {
  my ($context,$q)=@_;
  if ($q=~s/^\%([a-zA-Z_][a-zA-Z0-9_]*)(.*)$/\$_.$1$2/) { # node-list
    my $query=$2;
    my $name=$1;
    unless (exists($_nodelist{$name})) {
      die "No such nodelist '\%$name'\n";
    }
    if ($query =~ /\S/) {
      if ($_xpc->isa('XML::LibXML::XPathContext')) {
	if ($query =~m|^\s*\[(\d+)\](.*)$|) { # index on a node-list
	  return exists($_nodelist{$name}->[1]->[$1+1]) ?
	    scalar(_xpc_find_nodes($_nodelist{$name}->[1]->[$1],'./self::*'.$2)) : [];
	} else {
	  return scalar(_xpc_find_nodes($_nodelist{$name}->[0], $q));
	}
      } else {
	# workaround for dummy XPathContext
	if ($query =~m|^\s*\[(\d+)\](.*)$|) { # index on a node-list
	  return $_nodelist{$name}->[1]->[$1+1] ?
	    [ grep {defined($_)} $_nodelist{$name}->[1]->[$1]->findnodes('./self::*'.$2) ] : [];
	} elsif ($query =~m|^\s*\[|) { # filter in a nodelist
	  return [ grep {defined($_)} map { ($_->findnodes('./self::*'.$query)) }
		   @{$_nodelist{$name}->[1]}
		 ];
	}
	return [ grep {defined($_)} map { ($_->findnodes('.'.$query)) }
		 @{$_nodelist{$name}->[1]}
	       ];
      }
    } else {
      return $_nodelist{$name}->[1];
    }
  } else {
    return scalar(_xpc_find_nodes($context,$q));
  }
}

# _find_nodes wrapper with q-decoding
sub find_nodes {
  my ($id,$query,$doc)=_xpath($_[0]);
  if ($query eq "") { $query="."; }
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }

  return _find_nodes(get_local_node($id),toUTF8($QUERY_ENCODING,$query));
}

sub count_xpath {
  my ($node,$xp)=@_;
  my $result;
  $_xpc->setContextNode($node);
  $result=$_xpc->find($xp);

  if (ref($result)) {
    if ($result->isa('XML::LibXML::NodeList')) {
      return $result->size();
    } elsif ($result->isa('XML::LibXML::Literal')) {
      return $result->value();
    } elsif ($result->isa('XML::LibXML::Number') or
	     $result->isa('XML::LibXML::Boolean')) {
      return $result->value();
    }
  } else {
    return $result;
  }
}

# assign a result of xpath search to a nodelist variable
sub nodelist_assign {
  my ($name,$xp)=@_;
  $name=expand($name);
  my ($id,$query,$doc)=_xpath($xp);
  if ($doc) {
    if ($query eq "") {
      $_nodelist{$name}=[$doc,[]];
    } else {
      $_nodelist{$name}=[$doc,find_nodes($xp)];
      print STDERR "\nStored ",scalar(@{$_nodelist{$name}->[1]})," node(s).\n" unless "$QUIET";
    }
  }
}

sub has_all_ancestors {
  my ($node)=@_;
  while ($node) {
    return 1 if ($_xml_module->is_document($node));
    $node=$node->parentNode;
  }
  return 0;
}

# remove unbounded nodes from all nodelists of a given document
sub remove_dead_nodes_from_nodelists {
  my ($doc)=@_;
  foreach my $list (values(%_nodelist),get_stored_nodelists()) {
    if ($_xml_module->xml_equal($doc,$list->[0])) {
      $list->[1]=[ grep { has_all_ancestors($_) } @{$list->[1]} ];
    }
  }
}

# remove given node and all its descendants from all nodelists
sub remove_node_from_nodelists {
  my ($node,$doc)=@_;
  foreach my $list (values(%_nodelist),get_stored_nodelists()) {
    if ($_xml_module->xml_equal($doc,$list->[0])) {
      $list->[1]=[ grep { !is_ancestor_or_self($node,$_) } @{$list->[1]} ];
    }
  }
}

# create new document
sub create_doc {
  my ($id,$root_element,$format)=expand @_;
  $id=_id($id);
  my $doc;
  $root_element="<$root_element/>" unless ($root_element=~/^\s*
  $root_element=toUTF8($QUERY_ENCODING,$root_element);
  $root_element=~s/^\s+//;
  $doc=xsh_parse_string($root_element,$format);
  set_doc($id,$doc,"new_document$_newdoc.xml");
  $_newdoc++;

  set_local_doc($id) if $SWITCH_TO_NEW_DOCUMENTS;
  return $doc;
}

# bind a document with a given id and filename
sub set_doc {
  my ($id,$doc,$file)=@_;
  $_doc{$id}=$doc;
  $_files{$id}=$file;
  return $doc;
}

# return DOM of the document identified by given id
sub get_doc {
  return $_doc{$_[0]};
}

# create a new document by parsing a file
sub open_doc {
  my ($id,$file)=expand @_[0,1];
  my $format;
  my $source;
  if ($_[2]=~/(?:open)?(?:(?:\s*|_|-)(HTML|XML|DOCBOOK|html|xml|docbook))?(?:(?:\s*|_|-)(FILE|file|PIPE|pipe|STRING|string))?/) {
    $format = lc($1) || $DEFAULT_FORMAT;
    $source = lc($2) || 'file';
  } else {
    $format=$DEFAULT_FORMAT;
    $source='file';
  }
  $file=expand($file);
  $file=~s{^(\~[^\/]*)}{(glob($1))[0]}eg;
  $id=_id($id);
  print STDERR "open [$file] as [$id]\n" if "$DEBUG";
  if ($id eq "" or $file eq "") {
    print STDERR "hint: open identifier=file-name\n" unless "$QUIET";
    return;
  }
  if (($source ne 'file') or
      (-f $file) or $file eq "-" or
      ($file=~/^[a-z]+:/)) {
    print STDERR "parsing $file\n" unless "$QUIET";

    my $doc;
    if ($source eq 'pipe') {
      open my $F,"$file|";
      $F || die "Cannot open pipe to $file: $!\n";
      if ($format eq 'xml') {
	$doc=$_xml_module->parse_fh($_parser,$F);
      } elsif ($format eq 'html') {
	$doc=$_xml_module->parse_html_fh($_parser,$F);
      } elsif ($format eq 'docbook') {
	$doc=$_xml_module->parse_sgml_fh($_parser,$F,$QUERY_ENCODING);
      }
      close $F;
    } elsif ($source eq 'string') {
      my $root_element=$file;
      $root_element="<$root_element/>" unless ($root_element=~/^\s*
      $root_element=toUTF8($QUERY_ENCODING,$root_element);
      $root_element=~s/^\s+//;
      $doc=xsh_parse_string($root_element,$format);
      set_doc($id,$doc,"new_document$_newdoc.xml");
      $_newdoc++;
    } else  {
      if ($format eq 'xml') {
	$doc=$_xml_module->parse_file($_parser,$file);
      } elsif ($format eq 'html') {
	$doc=$_xml_module->parse_html_file($_parser,$file);
      } elsif ($format eq 'docbook') {
	$doc=$_xml_module->parse_sgml_file($_parser,$file,$QUERY_ENCODING);
      }
    }
    print STDERR "done.\n" unless "$QUIET";
    set_doc($id,$doc,$file);
    set_local_doc($id) if $SWITCH_TO_NEW_DOCUMENTS;

#     if ($@ =~ /^'' at /) {
#       print STDERR
# 	"\nError: ",
# 	"Parsing failed. LibXML returned no error message!\n";
#       print STDERR "Hint: Maybe you are trying to parse with validation on,\n".
# 	"but your document has no DTD? Consider 'validation 0'.\n" if get_validation();
#       return 0;
#     }
#     return _check_err($@);
  } else {
    die "file not exists: $file\n";
    return 0;
  }
}

# close a document and destroy all nodelists that belong to it
sub close_doc {
  my ($id)=expand(@_);
  $id=_id($id);
  unless (exists($_doc{$id})) {
    die "No such document '$id'!\n";
  }
  out("closing file $_files{$id}\n") unless "$QUIET";
  delete $_files{$id};
  foreach (values %_nodelist) {
    if ($_->[0]==$_doc{$id}) {
      delete $_nodelist{$_};
    }
  }
  delete $_doc{$id};
  if (xsh_local_id() eq $id) {
    if ($_doc{'scratch'}) {
      set_local_xpath(['scratch','/']);
    } else {
      set_local_node(undef);
    }
  }
  return 1;
}

sub open_io_file {
  my ($file)=@_;
  if ($file=~/^\s*[|>]/) {
    return IO::File->new($file);
  } elsif ($file=~/.gz\s*$/) {
    return IO::File->new("| gzip -c > $file");
  } else {
    return IO::File->new(">$file");
  }
}

sub is_xinclude {
  my ($node)=@_;
  return
    $_xml_module->is_xinclude_start($node) ||
    ($_xml_module->is_element($node) and
     $node->namespaceURI() eq 'http://www.w3.org/2001/XInclude' and
     $node->localname() eq 'include');
}

sub xinclude_start_tag {
  my ($xi)=@_;
  my %xinc = map { $_->nodeName() => $_->value() } $xi->attributes();
  $xinc{parse}='xml' if ($xinc{parse} eq "");
  return "<".$xi->nodeName()." href='".$xinc{href}."' parse='".$xinc{parse}."'>";
}

sub xinclude_end_tag {
  my ($xi)=@_;
  return "nodeName().">";
}

sub xinclude_print {
  my ($doc,$F,$node,$enc)=@_;
  return unless ref($node);
  if ($_xml_module->is_element($node) || $_xml_module->is_document($node)) {
    $F->print(fromUTF8($enc,start_tag($node))) if $_xml_module->is_element($node);
    my $child=$node->firstChild();
    while ($child) {
      if (is_xinclude($child)) {
	my %xinc = map { $_->nodeName() => $_->value() } $child->attributes();
	$xinc{parse}||='xml';
	$xinc{encoding}||=$enc; # may be used even to convert included XML
	my $elements=0;
	my @nodes=();
	my $node;
	my $expanded=$_xml_module->is_xinclude_start($child);
	if ($expanded) {
	  $node=$child->nextSibling(); # in case of special XINCLUDE node
	} else {
	  $node=$child->firstChild(); # in case of include element from XInclude NS
	}
	my $nested=0;
	while ($node and not($_xml_module->is_xinclude_end($node)
			     and $nested==0
			     and $expanded)) {
	  if ($_xml_module->is_xinclude_start($node)) { $nested++ }
	  elsif ($_xml_module->is_xinclude_end($node)) { $nested-- }
	  push @nodes,$node;
	  $elements++ if $_xml_module->is_element($node);
	  $node=$node->nextSibling();
	}
	if ($nested>0) {
	  print STDERR "Error: Unbalanced nested XInclude nodes.\n",
                       "       Ignoring this XInclude span!\n";
	  $F->print("");
	} elsif (!$node and $_xml_module->is_xinclude_start($child)) {
	  print STDERR "Error: XInclude end node not found.\n",
 	               "       Ignoring this XInclude span!\n";
	  $F->print("");
	} elsif ($xinc{parse} ne 'text' and $elements==0) {
	  print STDERR "Warning: XInclude: No elements found in XInclude span.\n",
                       "         Ignoring whole XInclude span!\n";
	  $F->print("");
	} elsif ($xinc{parse} ne 'xml' and $elements>1) {
	  print STDERR "Error: XInclude: More than one element found in XInclude span.\n",
                       "       Ignoring whole XInclude span!\n";
	  $F->print("");
	} elsif ($xinc{parse} eq 'text' and $elements>0) {
	  print STDERR "Warning: XInclude: Element(s) found in textual XInclude span.\n",
                       "         Skipping whole XInclude span!\n";
	  $F->print("");
	} else {
	  $F->print(fromUTF8($enc,xinclude_start_tag($child)));
	  save_xinclude_chunk($doc,\@nodes,$xinc{href},$xinc{parse},$xinc{encoding});
	  $F->print(fromUTF8($enc,xinclude_end_tag($child)));
	  $child=$node if ($expanded); # jump to XINCLUDE end node
	}
      } elsif ($_xml_module->is_xinclude_end($child)) {
	$F->print("");
      } else {
	xinclude_print($doc,$F,$child,$enc); # call recursion
      }
      $child=$child->nextSibling();
    }
    $F->print(fromUTF8($enc,end_tag($node))) if $_xml_module->is_element($node);
  } else {
    $F->print(fromUTF8($enc,$_xml_module->toStringUTF8($node,$INDENT)));
  }
}

sub save_xinclude_chunk {
  my ($doc,$nodes,$file,$parse,$enc)=@_;

  return unless @$nodes>0;

  if ($BACKUPS) {
    eval { rename $file, $file."~"; };
    _check_err($@);
  }
  my $F=open_io_file($file);
  $F || die "Cannot open $file\n";

  if ($parse eq 'text') {
    foreach my $node (@$nodes) {
      $F->print(fromUTF8($enc,literal_value($node->to_literal)));
    }
  } else {
    my $version=$doc->can('getVersion') ? $doc->getVersion() : '1.0';
    $F->print("\n");
    foreach my $node (@$nodes) {
      xinclude_print($doc,$F,$node,$enc);
    }
    $F->print("\n");
  }
  $F->close();
}

# save a document
sub save_doc {
  my $type=$_[0];
  my ($id,$file,$enc)=expand($_[1],$_[2],@{$_[3]});

  ($id,my $doc)=_id($id);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }

  my $format=$DEFAULT_FORMAT;
  my $target='file';
  if ($type=~/save(?:as|_as|-as)?(?:(?:\s*|_|-)(HTML|html|XML|xml|XINCLUDE|Xinclude|xinclude))?(?:(?:\s*|_|-)(FILE|file|PIPE|pipe|STRING|string))?/) {
    $format = lc($1) if $1;
    $target = lc($2) if $2;
  }

  if ($target eq 'file' and $file eq "") {
    $file=$_files{$id};
    if ($BACKUPS) {
      eval { rename $file, $file."~"; };
      _check_err($@);
    }
  }

  $enc = $enc || $_xml_module->doc_encoding($doc) || 'utf-8';
  print STDERR "saving $id=$_files{$id} to $file as $format (encoding $enc)\n" if "$DEBUG";

  if ($format eq 'xinclude') {
    if ($format ne 'file') {
      print STDERR "Saving to a ".uc($target)." not supported for XInclude\n";
    } else {
      save_xinclude_chunk($doc,[$doc->childNodes()],$file,'xml',$enc);
    }
  } else {
    if ($format eq 'xml') {
      if (lc($_xml_module->doc_encoding($doc)) ne lc($enc)
	  and not($_xml_module->doc_encoding($doc) eq "" and
	  lc($enc) eq 'utf-8')
	 ) {
	$_xml_module->set_encoding($doc,$enc);
      }
      if ($target eq 'file') {
	if ($file=~/\.gz\s*$/) {
	  $doc->setCompression(6);
	} else {
	  $doc->setCompression(-1);
	}
	$doc->toFile($file,$INDENT); # should be document-encoding encoded
	$_files{$id}=$file;
      } elsif ($target eq 'pipe') {
	$file=~s/^\s*\|?//g;
	open my $F,"| $file" || die "Cannot open pipe to $file\n";
	$doc->toFH($F,$INDENT);
	close $F;
      } elsif ($target eq 'string') {
	if ($file =~ /^\$?([a-zA-Z_][a-zA-Z0-9_]*)$/) {
	  no strict qw(refs);
	  ${"XML::XSH::Map::$1"}=$doc->toString($INDENT);
	} else {
	  out($doc->toString($INDENT));
	}
      }
    } elsif ($format eq 'html') {
      my $F;
      if ($target eq 'file') {
	($F=open_io_file($file)) || die "Cannot open $file\n";
	$_files{$id}=$file;
      } elsif ($target eq 'pipe') {
	$file=~s/^\s*\|?//g;
	open $F,"| $file";
	$F || die "Cannot open pipe to $file\n";
      } elsif ($target eq 'string') {
	$F=$OUT;
      }
      $F->print("\n")
	unless ($_xml_module->has_dtd($doc));
      $F->print(fromUTF8($enc, toUTF8($_xml_module->doc_encoding($doc),
				      $doc->toStringHTML())));

      $F->close() unless $target eq 'string';
    } elsif ($format eq 'docbook') {
      print STDERR "Docbook is not supported output format!\n";
    }
  }

  print STDERR "Document $id written.\n" unless ($@ or "$QUIET");
  return 1;
}


# create start tag for an element

###
### Workaround of a bug in XML::LibXML:
### getNamespaces, getName returns prefix only,
### prefix returns prefix not xmlns, getAttributes contains also namespaces
### findnodes('namespace::*') returns (namespaces,undef)
###

sub start_tag {
  my ($element)=@_;
  return "<".$element->nodeName().
    join("",map { " ".$_->nodeName()."=\"".$_->nodeValue()."\"" }
	 $element->attributes())
#	 findnodes('attribute::*'))
#      .    join("",map { " xmlns:".$_->getName()."=\"".$_->nodeValue()."\"" }
#		$element->can('getNamespaces') ?
#		$element->getNamespaces() :
#		$element->findnodes('namespace::*')
#		)
    .($element->hasChildNodes() ? ">" : "/>");
}

# create close tag for an element
sub end_tag {
  my ($element)=@_;
  return $element->hasChildNodes() ? "getName().">" : "";
}

# convert a subtree to an XML string to the given depth
sub to_string {
  my ($node,$depth,$folding)=@_;
  my $result;
  if ($node) {
    if (ref($node) and $_xml_module->is_element($node) and $folding and
	$node->hasAttributeNS($XML::XSH::xshNS,'fold')) {
      if ($depth>=0) {
	$depth = min($depth,$node->getAttributeNS($XML::XSH::xshNS,'fold'));
      } else {
	$depth = $node->getAttributeNS($XML::XSH::xshNS,'fold');
      }
    }

    if ($depth<0 and !$folding) {
      $result=ref($node) ? $_xml_module->toStringUTF8($node,$INDENT) : $node;
    } elsif (ref($node) and $_xml_module->is_element($node) and $depth==0) {
      $result=start_tag($node).
	($node->hasChildNodes() ? "...".end_tag($node) : "");
    } elsif ($depth>0 or $folding) {
      if (!ref($node)) {
	$result=$node;
      } elsif ($_xml_module->is_element($node)) {
	$result= start_tag($node).
	  join("",map { to_string($_,$depth-1,$folding) } $node->childNodes).
	    end_tag($node);
      } elsif ($_xml_module->is_document($node)) {
	if ($node->can('getVersion') and $node->can('getEncoding')) {
	  $result=
	    'getVersion() || '1.0').'"'.
	      ($node->getEncoding() ne "" ? ' encoding="'.$node->getEncoding().'"' : '').
		'?>'."\n";
	}
	$result.=
	  join("\n",map { to_string($_,$depth-1,$folding) }
	       grep { $SKIP_DTD ? !$_xml_module->is_dtd($_) : 1 } $node->childNodes);
      } else {
	$result=$_xml_module->toStringUTF8($node,$INDENT);
      }
    } else {
      $result = ref($node) ? $_xml_module->toStringUTF8($node,$INDENT) : $node;
    }
  }
  return $result;
}

# list nodes matching given XPath argument to a given depth
sub list {
  my ($xp,$depth)=@_;
  my ($id,$query,$doc)=_xpath($xp);
  my $folding;
  if ($depth=~/^fold/) {
    $folding = 1;
    $depth=-1;
  }
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  print STDERR "listing $query from $id=$_files{$id}\n\n" if "$DEBUG";

  my $ql=find_nodes($xp);
  foreach (@$ql) {
    print STDERR "checking for folding\n" if "$DEBUG";
    my $fold=$folding && ($_xml_module->is_element($_) || $_xml_module->is_document($_)) &&
      $_->findvalue("count(.//\@*[local-name()='fold' and namespace-uri()='$XML::XSH::xshNS'])");
    print STDERR "folding: $fold\n" if "$DEBUG";
    out (fromUTF8($ENCODING,to_string($_,$depth,$fold)),"\n");
  }
  print STDERR "\nFound ",scalar(@$ql)," node(s).\n" unless "$QUIET";

  return 1;
}

# list namespaces in scope of the given nodes
sub list_namespaces {
  my $xp = $_[0] || [undef,'.'];
  my ($id,$query,$doc)=_xpath($xp);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  print STDERR "listing namespaces for $query from $id=$_files{$id}\n\n" if "$DEBUG";

  my $ql=find_nodes($xp);
  foreach my $node (@$ql) {
    my $n=$node;
    my %namespaces;
    while ($n) {
      foreach my $ns ($n->getNamespaces) {
	$namespaces{$ns->getName()}=$ns->getData()
	  unless (exists($namespaces{$ns->getName()}));
      }
      $n=$n->parentNode();
    }
    out(fromUTF8($ENCODING,pwd($node)),":\n");
    foreach (sort { $a cmp $b } keys %namespaces) {
      out("xmlns", ($_ ne "" ? ":" : ""),
	  fromUTF8($ENCODING,$_),"=\"",
	  fromUTF8($ENCODING,$namespaces{$_}),"\"\n");
    }
    out("\n");
  }
  return 1;
}

sub mark_fold {
  my ($xp,$depth)=@_;
  $depth=expand($depth);
  $depth=0 if $depth eq "";

  my $l=find_nodes($xp);
  foreach my $node (@$l) {
    if ($_xml_module->is_element($node)) {
      $node->setAttributeNS($XML::XSH::xshNS,'xsh:fold',$depth);
    }
  }
  return 1;
}

sub mark_unfold {
  my ($xp)=@_;
  my ($id,$query,$doc)=_xpath($xp);
  my $l=find_nodes($xp);
  foreach my $node (@$l) {
    if ($_xml_module->is_element($node) and $node->hasAttributeNS($XML::XSH::xshNS,'fold')) {
      remove_node($node->getAttributeNodeNS($XML::XSH::xshNS,'fold'));
    }
  }
  remove_dead_nodes_from_nodelists($doc);
  return 1;
}


# print canonical xpaths identifying nodes matching given XPath
sub locate {
  my ($xp)=@_;
  my ($id,$query,$doc)=_xpath($xp);

  print STDERR "locating $query from $id=$_files{$id}\n\n" if "$DEBUG";
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  my $ql=find_nodes($xp);
  foreach (@$ql) {
    out(fromUTF8($ENCODING,pwd($_)),"\n");
  }
  print STDERR "\nFound ",scalar(@$ql)," node(s).\n" unless "$QUIET";
  return 1;
}

# evaluate given xpath and output the result
sub count {
  my ($xp)=@_;
  my ($id,$query,$doc)= _xpath($xp);

  return undef if ($id eq "" or $query eq "");
  unless (ref($doc)) {
    die "No such document: $id\n";
  }
  print STDERR "Query $query on $id=$_files{$id}\n" if $DEBUG;
  my $result=undef;

  if ($query=~/^%/) {
    $result=find_nodes($xp);
    $result=scalar(@$result);
  } else {
    $query=toUTF8($QUERY_ENCODING,$query);
    print STDERR "query: $query\n" if "$DEBUG";
    $result=fromUTF8($ENCODING,count_xpath(get_local_node($id), $query));
    print STDERR "result: $result" if "$DEBUG";
  }
  return $result;
}

# evaluate given xpath and return the text content of the result
sub eval_xpath_literal {
  my ($xp)=@_;
  my ($id,$query)=_xpath($xp);
  $_xpc->setContextNode(get_local_node($id));
  my $result = $_xpc->find(toUTF8($QUERY_ENCODING,$query));
  if (!ref($result)) {
    return $result;
  } else {
    if ($result->isa('XML::LibXML::NodeList')) {
      if (wantarray) {
	return map { literal_value($_->to_literal) } @$result;
      } elsif ($result->[0]) {
	return literal_value($result->[0]->to_literal);
      } else {
	return '';
      }
    } else {
      return literal_value($result->to_literal);
    }
  }
}


# remove nodes matching given XPath from a document and
# remove all their descendants from all nodelists
sub prune {
  my ($xp)=@_;
  my ($id,$query,$doc)=_xpath($xp);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  my $i=0;

  my $ql=find_nodes($xp);
  foreach my $node (@$ql) {
    remove_node($node,get_keep_blanks());
    $i++;
  }
  remove_dead_nodes_from_nodelists($doc);
  print STDERR "$i node(s) removed from $id=$_files{$id}\n" unless "$QUIET";
  return 1;
}

# evaluate given perl expression
sub eval_substitution {
  my ($val,$expr)=@_;
  $_ = fromUTF8($QUERY_ENCODING,$val) if defined($val);

  eval "package XML::XSH::Map; no strict 'vars'; $expr";
  die $@ if $@; # propagate
  return toUTF8($QUERY_ENCODING,$_);
}

# sort given nodelist according to the given xsh code and perl code
sub perlsort {
  my ($crit,$perl,$var)=@_;
  $var=expand($var);
  return 1 unless (exists($_nodelist{$var}));
  return 1 unless ref(my $list=$_nodelist{$var});
  my $doc=$list->[0];

  my @list = map {
      local $LOCAL_NODE=$_;
      local $LOCAL_ID=_find_id($_);
      [$_, (ref($crit) eq 'ARRAY') ? eval_xpath_literal($crit) : scalar(perl_eval($crit))]
    } @{$list->[1]};

  @{$list->[1]} = map { $_->[0] }
    sort {
      local $XML::XSH::Map::a = $a->[1];
      local $XML::XSH::Map::b = $b->[1];
      my $result=eval "package XML::XSH::Map; no strict 'vars'; $perl";
      die $@ if ($@); # propagate
      $result;
    } @list;

  return 1;
}

# Evaluate given perl expression over every element matching given XPath.
# The element is passed to the expression by its name or value in the $_
# variable.
sub perlmap {
  my ($q, $expr)=@_;
  my ($id,$query,$doc)=_xpath($q);

  print STDERR "Executing $expr on $query in $id=$_files{$id}\n" if "$DEBUG";
  unless ($doc) {
    die "No such document $id\n";
  }

  my $sdoc=get_local_node($id);

  my $ql=_find_nodes($sdoc, toUTF8($QUERY_ENCODING,$query));
  foreach my $node (@$ql) {
    if ($_xml_module->is_attribute($node)) {
      my $val=$node->getValue();
      $node->setValue(eval_substitution("$val",$expr));
    } elsif ($_xml_module->is_element($node)) {
      my $val=$node->getName();
      if ($node->can('setName')) {
	$node->setName(eval_substitution("$val",$expr));
      } else {
	_err "Node renaming not supported by ",ref($node);
      }
    } elsif ($node->can('setData') and $node->can('getData')) {
      my $val=$node->getData();
      $node->setData(eval_substitution("$val",$expr));
    }
  }
  return 1;
}

sub perlrename {
  my ($q, $expr)=@_;
  my ($id,$query,$doc)=_xpath($q);

  print STDERR "Executing $expr on $query in $id=$_files{$id}\n" if "$DEBUG";
  unless ($doc) {
    die "No such document $id\n";
  }

  my $sdoc=get_local_node($id);

  my $ql=_find_nodes($sdoc, toUTF8($QUERY_ENCODING,$query));
  foreach my $node (@$ql) {
    if ($_xml_module->is_attribute($node) ||
	$_xml_module->is_element($node) ||
	$_xml_module->is_pi($node)) {
      if ($node->can('setName')) {
	my $val=$node->getName();
	$node->setName(eval_substitution("$val",$expr));
      } else {
	_err "Node renaming not supported by ",ref($node);
      }
    }
  }
  return 1;
}

sub set_attr_ns {
  my ($node,$ns,$name,$value)=@_;
  if ($ns eq "") {
    $node->setAttribute($name,$value);
  } else {
    $node->setAttributeNS("$ns",$name,$value);
  }
}

# return NS prefix used in the given name
sub name_prefix {
  if ($_[0]=~/^([^:]+):/) {
    return $1;
  }
}

# try to safely clone a node
sub node_copy {
  my ($node,$ns,$dest_doc,$dest)=@_;

  my $copy;
  if ($_xml_module->is_element($node) and !$node->hasChildNodes) {
    # -- prepare NS
    $ns=$node->namespaceURI() if ($ns eq "");
    if ($ns eq "" and name_prefix($node->getName) ne "") {
      $ns=$dest->lookupNamespaceURI(name_prefix($node->getName));
    }
    # --
    $copy=new_element($dest_doc,$node->getName(),$ns,
		      [map { [$_->nodeName(),$_->nodeValue(), $_->namespaceURI()] } $node->attributes],$dest);
  } elsif ($_xml_module->is_document_fragment($node)) {
    $copy=$_parser->parse_xml_chunk($node->toString());
  } else {
    $copy=$_xml_module->clone_node($dest_doc,$node);
  }
}

# get element-children of a node (e.g. of a document fragment)
sub get_subelements {
  my ($docfrag)=@_;
  return grep { $_xml_module->is_element($_) } $docfrag->childNodes();
}

sub get_following_siblings {
  my ($node)=@_;
  my @siblings;
  $node=$node->nextSibling();
  while ($node) {
    push @siblings,$node;
    $node=$node->nextSibling();
  }
  return @siblings;
}

# create new document element before the given nodelist
sub new_document_element {
  my ($doc,$node,@nodelist)=@_;
  $doc->setDocumentElement($node);
  foreach my $n (reverse @nodelist) {
    $doc->removeChild($n);
    $doc->insertAfter($n,$node);
  }
}

# safely insert source node after, before or instead of the
# destination node. Safety means here that nodes inserted on the
# document level are given special care.  the source node may only be
# a document fragment, element, text, CDATA, Comment, Entity or
# a PI (i.e. not an attribute).

sub safe_insert {
  my ($source,$dest,$where) = @_;
  my $parent=$dest->parentNode();
  return unless $parent;
  if ($_xml_module->is_document($parent)) {

    # placing a node on the document-level
    # SOURCE: Element
    if ($_xml_module->is_element($source)) {
      if ($where eq 'after') {
	if ($parent->getDocumentElement()) {
	  die("Error: cannot insert another element into /:\n",
	       "  there's one document element already!");
	} else {
	  new_document_element($parent,$source,
			       get_following_siblings($dest));
	}
	return 'keep';
      } elsif ($where eq 'before') {
	if ($parent->getDocumentElement()) {
	  die("Error: cannot insert another element into /:\n",
	       "  there's one document element already!");
	} else {
	  new_document_element($parent,$source,
			       $dest,get_following_siblings($dest));
	}
	return 'keep';
      } elsif ($where eq 'replace') {
	# maybe we are loosing the document element here !
	if ($parent->getDocumentElement()) {
	  if ($_xml_module->is_element($dest)) {
	    my $nextnode = $parent->getDocumentElement()->nextSibling();
	    new_document_element($parent,$source,
				 $dest,get_following_siblings($dest));
	  } else {
	    die("Error: cannot insert another element into /:\n",
	         "  there's one document element already!");
	  }
	} else {
	  new_document_element($parent,$source,
			       $dest,get_following_siblings($dest));
	}
	return 'remove';
      }
    } # SOURCE: PI or Comment or DocFragment with PI's or Comments
    elsif ($_xml_module->is_pi($source) ||
	   $_xml_module->is_comment($source) ||
	   $_xml_module->is_entity_reference($source) ||
	   $_xml_module->is_document_fragment($source)) {
      # placing a node into an element
      if ($where eq 'after') {
	$parent->insertAfter($source,$dest);
	return 'keep';
      } elsif ($where eq 'before') {
	$parent->insertBefore($source,$dest);
	return 'keep';
      } elsif ($where eq 'replace') {
	# maybe we are loosing the document element here !
	$parent->insertBefore($source,$dest);
	return 'remove';
      }
    } else {
      die("Error: cannot insert node ",ref($source)," on a document level");
    }
  } else {
    if ($where eq 'after') {
      $parent->insertAfter($source,$dest);
      return 'keep';
    } elsif ($where eq 'before') {
      $parent->insertBefore($source,$dest);
      return 'keep';
    } elsif ($where eq 'replace') {
      $parent->insertBefore($source,$dest);
      return 'remove';
    }
  }
}

# insert given node to given destination performing
# node-type conversion if necessary
sub insert_node {
  my ($node,$dest,$dest_doc,$where,$ns)=@_;

  if ($_xml_module->is_document($node)) {
    die "Error: Can't insert/copy/move document nodes!";
  }

  # destination: Attribute
  if ($_xml_module->is_attribute($dest)) {
    # source: Text, CDATA, Comment, Entity, Element
    if ($_xml_module->is_text($node)           ||
	$_xml_module->is_cdata_section($node)  ||
	$_xml_module->is_comment($node) ||
	$_xml_module->is_element($node) ||
	$_xml_module->is_pi($node)) {
      my $val = $_xml_module->is_element($node) ?
	$node->textContent() : $node->getData();
      if ($where eq 'replace' or $where eq 'into') {
	$val=~s/^\s+|\s+$//g;
	# xcopy will replace the value several times, which may not be intended
	set_attr_ns($dest->ownerElement(),$dest->namespaceURI(),$dest->getName(),$val);
	return 'keep'; # as opposed to 'remove'
      } elsif ($where eq 'before' or $where eq 'prepend') {
	$val=~s/^\s+//g;
	set_attr_ns($dest->ownerElement(),$dest->namespaceURI(),$dest->getName(),
		    $val.$dest->getValue());
      } elsif ($where eq 'after' or $where eq 'append') {
	$val=~s/\s+$//g;
	set_attr_ns($dest->ownerElement(),$dest->namespaceURI(),$dest->getName(),
		    $dest->getValue().$val);
      }

    }
    # source: Attribute
    elsif ($_xml_module->is_attribute($node)) {
      my $name=$node->getName();
      my $value = $node->getValue();
      if ($where eq 'replace' or $where eq 'after' or $where eq 'before') {
	# -- prepare NS
	$ns=$node->namespaceURI() if ($ns eq "");
	if ($ns eq "" and name_prefix($name) ne "") {
	  $ns=$dest->lookupNamespaceURI(name_prefix($name))
	}
	# --
	my $elem=$dest->ownerElement();
	set_attr_ns($elem,"$ns",$name,$value);
	if ($where eq 'replace' and $name ne $dest->getName()) {
	  return 'remove'; # remove the destination node in the end
	} else {
	  return 'keep'; # no need to remove the destination node
	}
      } else {
	# -- prepare NS
	$ns=$dest->namespaceURI(); # given value of $ns is ignored here
	# --
	if ($where eq 'append') {
	  set_attr_ns($dest->ownerElement(),"$ns",$dest->getName,$dest->getValue().$value);
	} elsif ($where eq 'into') {
	  set_attr_ns($dest->ownerElement(),"$ns",$dest->getName(),$value);
	} elsif ($where eq 'prepend') {
	  set_attr_ns($dest->ownerElement(),"$ns",$dest->getName(),$value.$dest->getValue());
	}
      }
    } else {
      _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
            ref($node)," $where ",ref($dest),"!");
      return 1;
    }
  }
  # destination: Document
  elsif ($_xml_module->is_document($dest)) {
    # source: Attribute, Text, CDATA
    if ($_xml_module->is_attribute($node) or
	$_xml_module->is_text($node) or
	$_xml_module->is_cdata_section($node)
       ) {
      _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
            ref($node)," $where ",ref($dest),"!");
      return 1;
    } elsif ($_xml_module->is_element($node)) {
    # source: Element
      my $copy=node_copy($node,$ns,$dest_doc,$dest);
      my $destnode;
      my $newwhere;
      if ($where =~ /^(?:after|append|into)/) {
	$newwhere='after';
	$destnode=$dest->lastChild();
      } elsif ($where =~ /^(?:before|prepend)/) {
	$newwhere='before';
	$destnode=$dest->firstChild();
      } elsif ($where eq 'replace') {
	_err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
	     ref($node)," $where ",ref($dest),"!");
	return 1;
      }
      if ($destnode) {
	return safe_insert($copy,$destnode,$newwhere);
      } else {
	new_document_element($dest,$copy);
	return 1;
      }
    } else {
    # source: Chunk, PI, Comment, Entity
      my $copy=node_copy($node,$ns,$dest_doc,$dest);
      if ($where =~ /^(?:after|append|into)/) {
	# rather than appendChild which does not work
	# for Chunks!
	$dest->insertAfter($copy,$dest->lastChild());
      } elsif ($where =~ /^(?:before|prepend)/) {
	$dest->insertBefore($copy,$dest->firstChild());
      } elsif ($where eq 'replace') {
	_err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
	     ref($node)," $where ",ref($dest),"!");
	return 1;
      }
    }
  }
  # destination: Element
  elsif ($_xml_module->is_element($dest)) {
    # source: Attribute
    if ($_xml_module->is_attribute($node)) {
      # -- prepare NS
      $ns=$node->namespaceURI() if ($ns eq "");
      if ($ns eq "" and name_prefix($node->getName) ne "") {
	$ns=$dest->lookupNamespaceURI(name_prefix($node->getName))
      }
      # --
      if ($where eq 'into' or $where eq 'append' or $where eq 'prepend') {
	set_attr_ns($dest,"$ns",$node->getName(),$node->getValue());
      } elsif ($where eq 'replace') {
	my $parent=$dest->parentNode();
	if ($_xml_module->is_element($parent)) {
	  set_attr_ns($dest,"$ns",$node->getName(),$node->getValue());
	} else {
	  _err("Warning: Cannot replace ",ref($node)," with ",ref($parent),
               ": parent node is not an element!");
	  return 1;
	}
	return 'remove';
      } else {
	_err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
	     ref($node)," $where ",ref($dest),"!");
	return 1;
# 	# converting attribute to element
# 	my $new=new_element($dest_doc,$node->getName(),$ns,$dest);
# 	$new->appendText($node->getValue());
# 	my $parent=$dest->parentNode();
# 	if ($_xml_module->is_element($parent)) {
# 	  if ($where eq 'before' or $where eq 'after') {
# 	    safe_insert($new,$dest,$where);
# 	  }
# 	} elsif ($where eq 'append') {
# 	  $dest->appendChild($new);
# 	} elsif ($where eq 'prepend') {
# 	  $dest->insertBefore($new,$dest->firstChild());
# 	}
      }
    }
    # source: Any but Attribute
    else {
      my $copy=node_copy($node,$ns,$dest_doc,$dest);
      if ($where eq 'after' or $where eq 'before' or $where eq 'replace') {
	return safe_insert($copy,$dest,$where);
      } elsif ($where eq 'into' or $where eq 'append') {
	$dest->appendChild($copy);
      } elsif ($where eq 'prepend') {
	if ($dest->hasChildNodes()) {
	  $dest->insertBefore($copy,$dest->firstChild());
	} else {
	  $dest->appendChild($copy);
	}
      }
    }
  }
  # destination: Text, CDATA, Comment, PI
  elsif ($_xml_module->is_text($dest)          ||
	 $_xml_module->is_cdata_section($dest) ||
	 $_xml_module->is_comment($dest)       ||
	 $_xml_module->is_pi($dest) ||
	 $_xml_module->is_entity_reference($dest)
	) {
    if ($where =~ /^(?:into|append|prepend)$/ and
	($_xml_module->is_entity_reference($dest) ||
	 $_xml_module->is_entity_reference($node))) {
      _err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
	   ref($node)," $where ",ref($dest),"!");
      return 1;
    }
    if ($where eq 'into') {
      my $value=$_xml_module->is_element($node) ?
	$node->textContent() : $node->getData();
      $dest->setData($value);
    } elsif ($where eq 'append') {
      my $value=$_xml_module->is_element($node) ?
	$node->textContent() : $node->getData();
      $dest->setData($dest->getData().$value);
    } elsif ($where eq 'prepend') {
      my $value=$_xml_module->is_element($node) ?
	$node->textContent() : $node->getData();
      $dest->setData($value.$dest->getData());
    }
    # replace + source: Attribute
    elsif ($where eq 'replace' and $_xml_module->is_attribute($node)) {
      my $parent=$dest->parentNode();
      # -- prepare NS
      $ns=$node->namespaceURI() if ($ns eq "");
      if ($ns eq "" and name_prefix($node->getName) ne "") {
	$ns=$dest->lookupNamespaceURI(name_prefix($node->getName));
      }
      # --
      if ($_xml_module->is_element($parent)) {
	set_attr_ns($dest,"$ns",$node->getName(),$node->getValue());
      }
      return 'remove';
    } else {
      my $parent=$dest->parentNode();
      my $new;
      # source: Attribute
      if ($_xml_module->is_attribute($node)) {
	_err("Warning: Ignoring incompatible nodes in insert/copy/move operation:\n",
	     ref($node)," $where ",ref($dest),"!");
	return 1;
# 	# implicit conversion of attribute to element
# 	# -- prepare NS
# 	$ns=$node->namespaceURI() if ($ns eq "");
# 	if ($ns eq "" and name_prefix($node->getName) ne "") {
# 	  $ns=$parent->lookupNamespaceURI(name_prefix($node->getName));
# 	}
# 	# --
# 	$new=new_element($dest_doc,$node->getName(),$ns,$dest);
# 	$new->appendText($node->getValue());
      }
      # source: All other
      else {
	$new=node_copy($node,$ns,$dest_doc,$dest);
      }
      if ($where =~ /^(?:after|before|replace)$/) {
	return safe_insert($new,$dest,$where);
      }
    }
  } else {
    print STDERR "Warning: unsupported/unknown destination type: ",ref($dest),"\n";
  }
  return 1;
}

# copy nodes matching one XPath expression to locations determined by
# other XPath expression
sub copy {
  my ($fxp,$txp,$where,$all_to_all)=@_;
  my ($fid,$fq,$fdoc)=_xpath($fxp); # from xpath
  my ($tid,$tq,$tdoc)=_xpath($txp); # to xpath

  unless (ref($fdoc)) {
    die "No such document '$fid'!\n";
  }
  unless (ref($tdoc)) {
    die "No such document '$tid'!\n";
  }
  my ($fl,$tl);

  $fl=find_nodes($fxp);
  $tl=find_nodes($txp);

  unless (@$tl) {
    print STDERR "No matching nodes found for $tq in $tid=$_files{$tid}\n" unless "$QUIET";
    return 0;
  }
  my $some_nodes_removed=0;
  if ($all_to_all) {
    foreach my $tp (@$tl) {
      my $replace=0;
      foreach my $fp (@$fl) {
	$replace = ((insert_node($fp,$tp,$tdoc,$where) eq 'remove') || $replace);
      }
      if ($replace) {
	$some_nodes_removed=1;
	remove_node($tp);
      }
    }
  } else {
    while (ref(my $fp=shift @$fl) and ref(my $tp=shift @$tl)) {
      my $replace=insert_node($fp,$tp,$tdoc,$where);
      if ($replace eq 'remove') {
	$some_nodes_removed=1;
	remove_node($tp);
      }
    }
  }
  if ($some_nodes_removed) {
    remove_dead_nodes_from_nodelists($tdoc);
  }
  return 1;
}

# parse a string and create attribute nodes
sub create_attributes {
  my ($exp)=@_;
  my (@ret,$value,$name);
  while ($exp!~/\G$/gsco) {
    if ($exp=~/\G\s*([^ \n\r\t=]+)=/gsco) {
      my $name=$1;
      print STDERR "attribute_name=$1\n" if $DEBUG;
      if ($exp=~/\G"((?:[^\\"]|\\.)*)"/gsco or
	  $exp=~/\G'((?:[^\\']|\\.)*)'/gsco or
	  $exp=~/\G(.*?\S)(?=\s*[^ \n\r\t=]+=|\s*$)/gsco) {
	$value=$1;
	$value=~s/\\(.)/$1/g;
	print STDERR "creating $name=$value attribute\n" if $DEBUG;
	push @ret,[$name,$value];
      } else {
	$exp=~/\G(\S*\s*)/gsco;
	print STDERR "ignoring $name=$1\n";
      }
    } else {
      $exp=~/\G(\S*\s*)/gsco;
      print STDERR "ignoring characters $1\n";
    }
  }
  return @ret;
}

sub new_element {
  my ($doc,$name,$ns,$attrs,$dest)=@_;
  my $el;
  my $prefix;
  if ($name=~/^([^:>]+):(.*)$/) {
    $prefix=$1;
    die "Error: undefined namespace prefix `$prefix'\n"  if ($ns eq "");
    if ($dest && $_xml_module->is_element($dest)) {
      $el=$dest->addNewChild($ns,$name);
      $el->unbindNode();
    } else {
      $el=$doc->createElementNS($ns,$name);
    }
  } else {
    $el=$doc->createElement($name);
  }
  if (ref($attrs)) {
    foreach (@$attrs) {
      if ($ns ne "" and ($_->[0]=~/^${prefix}:/)) {
	print STDERR "NS: $ns\n" if $DEBUG;
	$el->setAttributeNS($ns,$_->[0],$_->[1]);
      } elsif  ($_->[0] eq "xmlns:(.*)") {
	# don't redeclare NS if already declared on destination node
	unless ($1 eq $ns or $dest->lookupNamespaceURI($1) eq $_->[2]) {
	  $el->setAttribute($_->[0],$_->[1]) unless ($_->[1] eq $ns);
	}
      } elsif ($_->[0]=~/^([^:>]+):/) {
	my $lprefix=$1;
	if ($_->[2] ne "") {
	  $el->setAttributeNS($_->[2],$_->[0],$_->[1]);
	} else {
	  # add the attribute anyway (may have wrong qname!)
	  $el->setAttribute($_->[0],$_->[1]);
	}
      } else {
	next if ($_->[0] eq "xmlns:$prefix" and $_->[1] eq $ns);
	$el->setAttribute($_->[0],$_->[1]); # what about other namespaces?
      }
    }
  }
  return $el;
}

# create nodes from their textual representation
sub create_nodes {
  my ($type,$exp,$doc,$ns)=@_;
  my @nodes=();
#  return undef unless ($exp ne "" and ref($doc));
  if ($type eq 'attribute') {
    foreach (create_attributes($exp)) {
      my $at;
      if  ($_->[0]=~/^([^:]+):/ and $1 ne 'xmlns') {
	die "Error: undefined namespace prefix `$1'\n"  if ($ns eq "");
	$at=$doc->createAttributeNS($ns,$_->[0],$_->[1]);
      } else {
	$at=$doc->createAttribute($_->[0],$_->[1]);
      }
      push @nodes,$at;
    }
  } elsif ($type eq 'element') {
    my ($name,$attributes);
    if ($exp=~/^\]+)(\s+.*)?(?:\/?\>)?\s*$/) {
      print STDERR "element_name=$1\n" if $DEBUG;
      print STDERR "attributes=$2\n" if $DEBUG;
      my ($elt,$att)=($1,$2);
      my $el;
      if ($elt=~/^([^:>]+):(.*)$/) {
	print STDERR "NS: $ns\n" if $DEBUG;
	print STDERR "Name: $elt\n" if $DEBUG;
	die "Error: undefined namespace prefix `$1'\n"  if ($ns eq "");
	$el=$doc->createElementNS($ns,$elt);
      } else {
	$el=$doc->createElement($elt);
      }
      if ($att ne "") {
	$att=~s/\/?\>?$//;
	foreach (create_attributes($att)) {
	  print STDERR "atribute: ",$_->[0],"=",$_->[1],"\n" if $DEBUG;
	  if ($elt=~/^([^:]+):/ and $1 ne 'xmlns') {
	    print STDERR "NS: $ns\n" if $DEBUG;
	    die "Error: undefined namespace prefix `$1'\n"  if ($ns eq "");
	    $el->setAttributeNS($ns,$_->[0],$_->[1]);
	  } else {
	    $el->setAttribute($_->[0],$_->[1]);
	  }
	}
      }
      push @nodes,$el;
    } else {
      print STDERR "invalid element $exp\n" unless "$QUIET";
    }
  } elsif ($type eq 'text') {
    push @nodes,$doc->createTextNode($exp);
    print STDERR "text=$exp\n" if $DEBUG;
  } elsif ($type eq 'entity_reference') {
    push @nodes,$doc->createEntityReference($exp);
    print STDERR "entity_reference=$exp\n" if $DEBUG;
  } elsif ($type eq 'cdata') {
    push @nodes,$doc->createCDATASection($exp);
    print STDERR "cdata=$exp\n" if $DEBUG;
  } elsif ($type eq 'pi') {
    my ($name,$data)=($exp=~/^\s*(?:\<\?)?(\S+)(?:\s+(.*?)(?:\?\>)?)?$/);
    my $pi = $doc->createProcessingInstruction($name);
    $pi->setData($data);
    print STDERR "pi=\n" if $DEBUG;
    push @nodes,$pi;
#    print STDERR "cannot add PI yet\n" if $DEBUG;
  } elsif ($type eq 'comment') {
    push @nodes,$doc->createComment($exp);
    print STDERR "comment=$exp\n" if $DEBUG;
  }
  return @nodes;
}

# create new nodes from an expression and insert them to locations
# identified by XPath
sub insert {
  my ($type,$exp,$xpath,$where,$ns,$to_all)=@_;

  $exp = expand($exp);
  $ns  = expand($ns);

  my ($tid,$tq,$tdoc)=_xpath($xpath); # destination(s)

  return 0 unless ref($tdoc);

  my @nodes;
  $ns=toUTF8($QUERY_ENCODING,$ns);
  unless ($type eq 'chunk') {
    $exp=toUTF8($QUERY_ENCODING,$exp);
    @nodes=grep {ref($_)} create_nodes($type,$exp,$tdoc,$ns);
    return unless @nodes;
  } else {
    if ($exp !~/^\s*]*encoding=[^>]*?>/) {
      $exp=toUTF8($QUERY_ENCODING,$exp);
    }
    @nodes=grep {ref($_)} ($_parser->parse_xml_chunk($exp));
  }
  my $tl=find_nodes($xpath);
  my $some_nodes_removed=0;
  if ($to_all) {
    foreach my $tp (@$tl) {
      my $replace=0;
      foreach my $node (@nodes) {
	$replace = (insert_node($node,$tp,$tdoc,$where) eq 'remove') || $replace;
      }
      if ($replace) {
	$some_nodes_removed=1;
	remove_node($tp);
      }
    }
  } elsif ($tl->[0]) {
    foreach my $node (@nodes) {
      if (ref($tl->[0])) {
	if (insert_node($node,$tl->[0],$tdoc,$where) eq 'remove') {
	  $some_nodes_removed=1;
	  remove_node($tl->[0]);
	}
      }
    }
  }
  if ($some_nodes_removed) {
    remove_dead_nodes_from_nodelists($tdoc);
  }
  return 1;
}

# normalize nodes
sub normalize_nodes {
  my ($xp)=@_;
  my ($id,$query,$doc)=_xpath($xp);

  print STDERR "normalizing $query from $id=$_files{$id}\n\n" if "$DEBUG";
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  my $ql=find_nodes($xp);
  foreach (@$ql) {
    $_->normalize();
  }
  return 1;
}

sub _trim_ws {
  my ($text)=@_;
  $text=~s/^\s*//;
  $text=~s/\s*$//;
  return $text;
}

# strip whitespace from given nodes
sub strip_ws {
  my ($xp)=@_;
  my ($id,$query,$doc)=_xpath($xp);

  print STDERR "stripping whitespace in $query from $id=$_files{$id}\n\n" if "$DEBUG";
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  my $ql=find_nodes($xp);
  foreach my $node (@$ql) {
    if ($_xml_module->is_text($node)
	or
	$_xml_module->is_cdata_section($node)
	or
	$_xml_module->is_comment($node)
       ) {
      my $data=_trim_ws($node->getData());
      if ($data ne "") {
	$node->setData($data);
      } else {
	$node->unbindNode();
      }
    } elsif ($_xml_module->is_pi($node)) {
      $node->setData(_trim_ws($node->getData($node)));
    } elsif ($_xml_module->is_attribute($node)) {
      $node->setValue(_trim_ws($node->getValue));
    } elsif ($_xml_module->is_element($node) or
	     $_xml_module->is_document($node)) {
      # traverse children, skip comments, strip text nodes
      # until first element or PI or text node containing
      # a non-ws character
      my $child=$node->firstChild();
      while ($child) {
	if ($_xml_module->is_text($child) or
	    $_xml_module->is_cdata_section($child)) {
	  my $data=_trim_ws($child->getData());
	  if ($data ne "") {
	    $child->setData($data);
	    last;
	  } else {
	    $child->unbindNode();
	  }
	} elsif ($_xml_module->is_element($child) or
		 $_xml_module->is_pi($child)) {
	  last;
	}
	$child=$child->nextSibling();
      }
      # traverse children (upwards), skip comments, strip text nodes
      # until first element or PI or text node containing a non-ws
      # character
      my $child=$node->lastChild();
      while ($child) {
	if ($_xml_module->is_text($child) or
	    $_xml_module->is_cdata_section($child)) {
	  my $data=_trim_ws($child->getData());
	  if ($data ne "") {
	    $child->setData($data);
	    last;
	  } else {
	    $child->unbindNode();
	  }
	} elsif ($_xml_module->is_element($child) or
		 $_xml_module->is_pi($child)) {
	  last;
	}
	$child=$child->previousSibling();
      }
    }
  }
  return 1;
}

# fetch document's DTD
sub get_dtd {
  my ($doc)=@_;
  my $dtd;
  $dtd=$_xml_module->get_dtd($doc,$QUIET);

  return $dtd;
}

# check document validity
sub validate_doc {
  my ($show_errors,$schema,$id)=@_;
  $id=expand $id;
  __debug("SCHEMA @$schema");
  my @schema = expand @$schema;
  __debug("SCHEMA @schema");
  ($id,my $doc)=_id($id);
  unless (ref($doc)) {
    die "No such document '$id' (to validate)!\n";
  }

  if ($doc->can('is_valid')) {
    if (@schema) {
      my $type = shift @schema;
      my $format = shift @schema;
      if ($type eq 'DTD') {
	my $dtd;
	eval { XML::LibXML::Dtd->can('new') } ||
	  die "DTD validation not supported by your version of XML::LibXML\n";
	if ($format eq 'FILE') {
	  __debug("PUBLIC $schema[0], SYSTEM $schema[1]");
	  $dtd=XML::LibXML::Dtd->new(@schema);
	  __debug($dtd);
	} elsif ($format eq 'STRING') {
	  __debug("STRING $schema[0]");
	  $dtd=XML::LibXML::Dtd->parse_string($schema[0]);
	  __debug($dtd);
	  __debug($dtd->toString());
	} else {
	  die "Unknown DTD format '$format!'\n";
	}
	if ($show_errors) {
	  $doc->validate($dtd);
	} else {
	  out(($doc->is_valid($dtd) ? "yes\n" : "no\n"));
	}
      } elsif ($type eq 'RNG') {
	eval { XML::LibXML::RelaxNG->can('new') } ||
	  die "RelaxNG validation not supported by your version of XML::LibXML\n";
	my $rng;
	if ($format eq 'FILE') {
	  $rng=XML::LibXML::RelaxNG->new(location => $schema[0]);
	} elsif ($format eq 'STRING') {
	  $rng=XML::LibXML::RelaxNG->new(string => $schema[0]);
	} elsif ($format eq 'DOC') {
	  my $rngdoc=_doc($schema[0]);
	  unless (ref($rngdoc)) {
	    die "No such document '$schema[0]'!\n";
	  }
	  $rng=XML::LibXML::RelaxNG->new(DOM => $rngdoc);
	} else {
	  die "Unknown RelaxNG format '$format!'\n";
	}
	eval { $rng->validate($doc) };
	if ($show_errors) {
	  die "$@\n";
	} else {
	  out($@ ? "no\n" : "yes\n");
	}
      } elsif ($type eq 'XSD') {
	eval { XML::LibXML::Schema->can('new') } ||
	  die "Schema validation not supported by your version of XML::LibXML\n";
	my $xsd;
	if ($format eq 'FILE') {
	  $xsd=XML::LibXML::Schema->new(location => $schema[0]);
	} elsif ($format eq 'STRING') {
	  $xsd=XML::LibXML::Schema->new(string => $schema[0]);
	} elsif ($format eq 'DOC') {
	  my $xsddoc=_doc($schema[0]);
	  unless (ref($xsddoc)) {
	    die "No such document '$schema[0]'!\n";
	  }
	  $xsd=XML::LibXML::Schema->new(string => $xsddoc->toString());
	} else {
	  die "Unknown Schema format '$format!'\n";
	}
	eval { $xsd->validate($doc) };
	if ($show_errors) {
	  die "$@\n";
	} else {
	  out($@ ? "no\n" : "yes\n");
	}
      }
    } else {
      if ($show_errors) {
	$doc->validate();
      } else {
	out(($doc->is_valid() ? "yes\n" : "no\n"));
      }
    }
  } else {
    die("Vaidation not supported by ",ref($doc));
  }
  return 1;
}

# process XInclude elements in a document
sub process_xinclude {
  my ($id)=expand @_;
  ($id, my $doc)=_id($id);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  $_xml_module->doc_process_xinclude($_parser,$doc);
  return 1;
}

# print document's DTD
sub list_dtd {
  my ($id)=expand @_;
  ($id, my $doc)=_id($id);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  my $dtd=get_dtd($doc);

  if ($dtd) {
    out(fromUTF8($ENCODING,$_xml_module->toStringUTF8($dtd)),"\n");
  }
  return 1;
}

# print document's encoding
sub print_enc {
  my ($id)=expand @_;
  ($id, my $doc)=_id($id);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  out($_xml_module->doc_encoding($doc),"\n");
  return 1;
}

sub set_doc_enc {
  my ($encoding,$id)=expand @_;
  ($id, my $doc)=_id($id);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  $_xml_module->set_encoding($doc,$encoding);
  return 1;
}

sub set_doc_standalone {
  my ($standalone,$id)=expand @_;
  ($id, my $doc)=_id($id);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  $standalone=1 if $standalone=~/yes/i;
  $standalone=0 if $standalone=~/no/i;
  $_xml_module->set_standalone($doc,$standalone);
  return 1;
}

sub doc_info {
  my ($id)=expand @_;
  ($id, my $doc)=_id($id);
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  out("type=",$doc->nodeType,"\n");
  out("version=",$doc->version(),"\n");
  out("encoding=",$doc->encoding(),"\n");
  out("standalone=",$doc->standalone(),"\n");
  out("compression=",$doc->compression(),"\n");
}

# create an identical copy of a document
sub clone {
  my ($id1,$id2)=@_;
  ($id2, my $doc)=_id(expand $id2);

  return if ($id2 eq "" or $id2 eq "" or !ref($doc));
  print STDERR "duplicating $id2=$_files{$id2}\n" unless "$QUIET";

  set_doc($id1,$_xml_module->parse_string($_parser,
					  $doc->toString($INDENT)),
	  $_files{$id2});
  print STDERR "done.\n" unless "$QUIET";
  return 1;
}

# test if $nodea is an ancestor of $nodeb
sub is_ancestor_or_self {
  my ($nodea,$nodeb)=@_;
  while ($nodeb) {
    if ($_xml_module->xml_equal($nodea,$nodeb)) {
      return 1;
    }
    $nodeb=tree_parent_node($nodeb);
  }
}

# remove node and all its surrounding whitespace textual siblings
# from a document; remove all its descendant from all nodelists
# change current element to the nearest ancestor
sub remove_node {
  my ($node,$trim_space)=@_;
  if (is_ancestor_or_self($node,$LOCAL_NODE)) {
    $LOCAL_NODE=tree_parent_node($node);
  }
  my $doc;
  $doc=$_xml_module->owner_document($node);
  if ($trim_space) {
    my $sibling=$node->nextSibling();
    if ($sibling and
	$_xml_module->is_text($sibling) and
	$sibling->getData =~ /^\s+$/) {
#      remove_node_from_nodelists($sibling,$doc);
      $_xml_module->remove_node($sibling);
    }
  }
#  remove_node_from_nodelists($node,$doc);
  $_xml_module->remove_node($node);
}

# move nodes matching one XPath expression to locations determined by
# other XPath expression
sub move {
  my ($xp)=@_; #source xpath
  my ($id,$query,$doc)= _xpath($xp);
  my $sourcenodes;
  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  my $i=0;
  $sourcenodes=find_nodes($xp);
  if (copy(@_)) {
    foreach my $node (@$sourcenodes) {
      remove_node($node);
      $i++;
    }
    if ($i) {
      remove_dead_nodes_from_nodelists($doc);
    }
    return 1;
  } else {
    return 0;
  }
}

# call a shell command and print out its output
sub sh {
  my $cmd=expand($_[0]);
  out(`$cmd`);
  return 1;
}

# print the result of evaluating an XPath expression in scalar context
sub print_count {
  my $count=count(@_);
  out("$count\n");
  return 1;
}

sub perl_eval {
  if (wantarray) {
    my @result=eval("package XML::XSH::Map; no strict 'vars'; $_[0]");
    die $@ if $@;
    return @result;
  } else {
    my $result=eval("package XML::XSH::Map; no strict 'vars'; $_[0]");
    die $@ if $@;
    return $result;
  }
}

# evaluate a perl expression
# (OBSOLETE! and print out the result)
sub print_eval {
  my ($expr)=@_;
  my $result=perl_eval($expr);
#  out("$result\n") unless "$QUIET";
  return 1;
}

# change current directory
sub cd {
  unless (chdir $_[0]) {
    print STDERR "Can't change directory to $_[0]\n";
    return 0;
  } else {
    print "$_[0]\n" unless "$QUIET";
  }
  return 1;
}

# call methods from a list
sub run_commands {
  return 0 unless ref($_[0]) eq "ARRAY";
  my @cmds=@{$_[0]};
  my $top_level=$_[1];
  my $trapsignals=$top_level;
  my $result=0;

  my ($cmd,@params);

  # make sure errors throw exceptions
  local $_die_on_err=1 unless ($top_level);

  store_variables(1);
  eval {
    local $SIG{INT}=\&sigint if $trapsignals;
    local $SIG{PIPE}=\&sigpipe if $trapsignals;
    foreach my $run (@cmds) {
      if (ref($run) eq 'ARRAY') {
	($cmd,@params)=@$run;
	if ($cmd eq "test-mode") { $TEST_MODE=1; $result=1; next; }
      if ($cmd eq "run-mode") { $TEST_MODE=0; $result=1; next; }
	next if $TEST_MODE;
	$result=&{$cmd}(@params);
      } else {
	$result=1;
      }
    }
  };
  do {
    local $SIG{INT}=\&flagsigint;
    restore_variables();
    propagate_flagsigint();
  };
  if (!$trapsignals and $@ =~ /^SIGINT|^SIGPIPE/) {
    die $@
  } else {
    _check_err($@,1);
  }
  return $result;
}

# redirect output and call methods from a list
sub pipe_command {
  return 1 if $TEST_MODE;

  local $SIG{PIPE}=sub { };
  my ($cmd,$pipe)=@_;

  return 0 unless (ref($cmd) eq 'ARRAY');

  if ($pipe ne '') {
    my $out=$OUT;
    local *PIPE;
    print STDERR "openning pipe $pipe\n" if $DEBUG;
    eval {
      open(PIPE,"| $pipe") || die "cannot open pipe $pipe\n";
      $OUT=\*PIPE;
      run_commands($cmd);
    };
    do {
      local $SIG{INT}=\&flagsigint;
      $OUT=$out;
      close PIPE;
      propagate_flagsigint();
    };
    die $@ if $@; # propagate
  }
  return 1;
}

# redirect output to a string and call methods from a list
sub string_pipe_command {
  my ($cmd,$name)=@_;
  return 0 unless (ref($cmd) eq 'ARRAY');
  if ($name ne '') {
    my $out=$OUT;
    print STDERR "Pipe to $name\n" if $DEBUG;
    $OUT=new IO::MyString;
    eval {
      run_commands($cmd);
    };
    do {
      local $SIG{INT}=\&flagsigint;
      _assign($name,$OUT->value()) unless $@;
      $OUT=$out;
      propagate_flagsigint();
    };
    die $@ if $@; # propagate
  }
  return 0;
}


# call methods as long as given XPath returns positive value
sub while_statement {
  my ($xp,$command)=@_;
  my $result=1;
  if (ref($xp) eq 'ARRAY') {
    while (count($xp)) {
      eval {
	$result = run_commands($command) && $result;
      };
      if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
	if ($@->label =~ /^(?:next|last|redo)$/ and $@->[1]>1) {
	  $@->[1]--;
	  die $@; # propagate to a higher level
	}
	if ($@->label eq 'next') {
	  next;
	} elsif ($@->label eq 'last') {
	  last;
	} elsif ($@->label eq 'redo') {
	  redo;
	} else {
	  die $@; # propagate
	}
      } elsif ($@) {
	die $@; # propagate
      }
    }
  } else {
    while (perl_eval($xp)) {
      eval {
	$result = run_commands($command) && $result;
      };
      if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
	if ($@->label =~ /^(?:next|last|redo)$/ and $@->[1]>1) {
	  $@->[1]--;
	  die $@; # propagate to a higher level
	}
	if ($@->label eq 'next') {
	  next;
	} elsif ($@->label eq 'last') {
	  last;
	} elsif ($@->label eq 'redo') {
	  redo;
	} else {
	  die $@; # propagate
	}
      } elsif ($@) {
	die $@; # propagate
      }
    }
  }
  return $result;
}

sub throw_exception {
  die expand($_[0])."\n";
}

sub try_catch {
  my ($try,$catch,$var)=@_;
  eval {
    local $TRAP_SIGPIPE=1;
    local $SIG{INT}=\&sigint;
    local $SIG{PIPE}=\&sigpipe;
#    local $_die_on_err=1; # make sure errors cause an exception
    run_commands($try);
  };
  if (ref($@) and $@->isa('XML::XSH::Internal::UncatchableException')) {
    die $@; # propagate
  } elsif ($@) {
    if ($@ =~ /^SIGINT/) {
      die $@; # propagate sigint
    } else {
      chomp($@) unless ref($@);
      if (ref($var) and @{$var}>1) {
	store_variables(1,$var->[0]);
	_assign($var->[0],$@);
	eval {
	  run_commands($catch);
	};
	do {
	  local $SIG{INT}=\&flagsigint;
	  restore_variables();
	  propagate_flagsigint();
	};
	die $@ if $@; # propagate
      } else {
	_assign($var->[0],$@) if ref($var);
	run_commands($catch);
      }
    }
  }
}

sub loop_next {
  die XML::XSH::Internal::LoopTerminatingException->new('next',expand(@_));
}
sub loop_prev {
  die XML::XSH::Internal::LoopTerminatingException->new('prev',expand(@_));
}
sub loop_redo {
  die XML::XSH::Internal::LoopTerminatingException->new('redo',expand(@_));
}
sub loop_last {
  die XML::XSH::Internal::LoopTerminatingException->new('last',expand(@_));
}

# call methods on every node matching an XPath
sub foreach_statement {
  my ($xp,$command)=@_;
  if (ref($xp) eq 'ARRAY') {
    my ($id,$query,$doc)=_xpath($xp);
    unless (ref($doc)) {
      die "No such document '$id'!\n";
    }
    my $old_local=$LOCAL_NODE;
    my $old_id=$LOCAL_ID;
    eval {
      my $ql=find_nodes($xp);
      foreach my $node (@$ql) {
	$LOCAL_NODE=$node;
	$LOCAL_ID=_find_id($node);
	eval {
	  run_commands($command);
	};
	if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
	  if ($@->label =~ /^(?:next|last|redo)$/ and $@->[1]>1) {
	    $@->[1]--;
	    die $@; # propagate to a higher level
	  }
	  if ($@->label eq 'next') {
	    next;
	  } elsif ($@->label eq 'last') {
	    last;
	  } elsif ($@->label eq 'redo') {
	    redo;
	  } else {
	    die $@; # propagate
	  }
	} elsif ($@) {
	  die $@; # propagate
	}
      }
    };
    do {
      local $SIG{INT}=\&flagsigint;
      $LOCAL_NODE=$old_local;
      $LOCAL_ID=$old_id;
      propagate_flagsigint();
    };
    die $@ if $@; # propagate
  } else {
    foreach $XML::XSH::Map::__ (perl_eval($xp)) {
      eval {
	run_commands($command);
      };
      if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
	if ($@->label =~ /^(?:next|last|redo)$/ and $@->[1]>1) {
	  $@->[1]--;
	  die $@; # propagate to a higher level
	}
	if ($@->label eq 'next') {
	  next;
	} elsif ($@->label eq 'last') {
	  last;
	} elsif ($@->label eq 'redo') {
	  redo;
	} else {
	  die $@; # propagate
	}
      } elsif ($@) {
	die $@; # propagate
      }
    }
  }
  return 1;
}

# run commands if given XPath holds
sub if_statement {
  my @cases=@_;
#  print STDERR "Parsed $xp\n";
  foreach (@cases) {
    my ($xp,$command)=@$_;
    if (!defined($xp) or
	(ref($xp) eq 'ARRAY') && count($xp) ||
	!ref($xp) && perl_eval($xp)) {
      return run_commands($command);
    }
  }
  return 1;
}

# run commands unless given XPath holds
sub unless_statement {
  my ($xp,$command,$else)=@_;
  unless ((ref($xp) eq 'ARRAY')&&count($xp) ||
	  !ref($xp) && perl_eval($xp)) {
    return run_commands($command);
  } else {
    return ref($else) ? run_commands($else->[1]) : 1;
  }
}

# transform a document with an XSLT stylesheet
# and create a new document from the result
sub xslt {
  my ($id,$stylefile,$newid)=expand @_[0..2];
  $id=_id($id);
  my $params=$_[3];
  print STDERR "running xslt on @_\n" if "$DEBUG";
  return unless $_doc{$id};
  my %params;
  %params=map { expand($_) } map { @$_ } @$params if ref($params);
  if ($DEBUG) {
    print STDERR map { "$_ -> $params{$_} " } keys %params;
    print STDERR "\n";
  }

  if ((-f $stylefile) or
      ($stylefile=~/^[a-z]+:/)) {
    require XML::LibXSLT;

    local *SAVE;

    my $_xsltparser=XML::LibXSLT->new();
    my $st=$_xsltparser->parse_stylesheet_file($stylefile);
    $stylefile=~s/\..*$//;
    my $doc=$st->transform($_doc{$id},%params);
    set_doc($newid,$doc,
	    "$stylefile"."_transformed_".$_files{$id});
  } else {
    die "File not exists $stylefile\n";
  }
  return 1;
}

# perform xupdate processing over a document
sub xupdate {
  my ($xupdate_id,$id)=expand(@_);
  $id=_id($id);
  if (get_doc($xupdate_id) and get_doc($id)) {
    require XML::XUpdate::LibXML;
    require XML::Normalize::LibXML;
    my $xupdate = XML::XUpdate::LibXML->new();
    $XML::XUpdate::LibXML::debug=1;
    $xupdate->process(get_doc($id)->getDocumentElement(),get_doc($xupdate_id));
  } else {
    if (get_doc($xupdate_id)) {
      die "No such document $id\n";
    } else {
      die "No such document $xupdate_id\n";
    }
    return 0;
  }
}

sub call_return { die XML::XSH::Internal::SubTerminatingException->new('return'); }

# call a named set of commands
sub call {
  my ($name,$args)=@_;
  $name=expand($name);
  if (exists $_defs{$name}) {
    my @vars=();
    if (ref($args)) {
      @vars=@{ $_defs{$name} };
      shift @vars;
    }
    my $result;
    store_variables(1,@vars);
    eval {
      if (ref($args)) {
	my $var;
	foreach (@$args) {
	  $var=shift @vars;
	  if (defined($var)) {
	    if ($var =~ /^\$/) {
	      _assign($var,expand($_)); # string assignment
	    } elsif ($var =~ /^\%(.*)$/) {
	      local $QUIET=1;
	      nodelist_assign($1,$_); # nodelist assignment
	    }
	  }
	}
      }
      $result = run_commands($_defs{$name}->[0]);
    };
    do {
      local $SIG{INT}=\&flagsigint;
      restore_variables() if (ref($args));
      propagate_flagsigint();
    };
    if (ref($@) and $@->isa('XML::XSH::Internal::SubTerminatingException')) {
      undef $@;
      return 1;
    }
    die $@ if $@; # propagate
    return $result;
  } else {
    die "ERROR: $name not defined\n";
  }
}


sub undef_sub {
  my ($name)=@_;
  if (exists($_defs{$name})) {
    delete $_defs{$name};
  } else {
    foreach (keys %_defs) {
      delete $_defs{$_} if /^$name$/;
    }
  }
}

# define a named set of commands
sub def {
  my ($name,$block,$args)=@_;
  my ($command)=@$block;
  if (exists($_defs{$name})) {
    my ($prevcmd, @prevargs)=@{$_defs{$name}};
    if ($prevcmd) {
      _err "Error: Subroutine $name already defined!";
      return 0;
    } elsif (!$command) {
      _err "Error: Subroutine $name already pre-declared!";
      return 0;
    } else {
      if (@$args != @prevargs) {
	_err "Error: Different number of arguments in declaration and pre-declarartion of $name!";
	return 0;
      }
      my $parg;
      foreach (@$args) {
	$parg=shift @prevargs;
	if (substr($parg,0,1) ne substr($_,0,1)) {
	  _err "Error: Argument types of $_ and $parg in declarations of $name do not match!";
	  return 0;
	}
      }
    }
  }
  $_defs{$name} = [ $command, @$args ];
  return 1;
}

# return a list of all definined subroutines
sub defs {
  return sort keys %_defs;
}

# list all defined subroutines
sub list_defs {
  foreach (sort keys (%_defs)) {
    out(join(" ",$_,@{ $_defs{$_} }[1..$#{ $_defs{$_} }] ),"\n" );
  }
  return 1;
}

# load a file
sub load {
  my ($file)=@_;
  my $l;
  print STDERR "loading file $file\n" unless "$QUIET";
  local *F;
  if (open F,"$file") {
    return join "",;
  } else {
    die "ERROR: couldn't open input file $file";
  }
}

# call XSH to evaluate commands from a given file
sub include {
  my $f=expand(shift);
  my $conditionally = shift;
  if (!$conditionally || !$_includes{$f}) {
    $_includes{$f}=1;
    my $l=load($f);
    return $_xsh->startrule($l);
  }
}

# print help
sub help {
  my ($command)=expand @_;
  if ($command) {
    if (exists($XML::XSH::Help::HELP{$command})) {
      out($XML::XSH::Help::HELP{$command}->[0]);
    } else {
      my @possible =
	grep { index($_,$command)==0 }
	  keys(%XML::XSH::Help::HELP);
      my %h = map { $XML::XSH::Help::HELP{$_} => $_ } @possible;
      if (keys(%h) == 1) {
	out($XML::XSH::Help::HELP{$possible[0]}->[0]);
	return 1;
      } elsif (keys(%h) > 1) {
	out("No help available on $command\n");
	out("Did you mean some of ", join(', ',@possible)," ?\n");
      } else {
	out("No help available on $command\n");
	return 0;
      }
    }
  } else {
    out($XML::XSH::Help::HELP);
  }
  return 1;
}

# load catalog file to the parser
sub load_catalog {
  $_xml_module->load_catalog($_parser,expand($_[0]));
  return 1;
}

sub stream_process_node {
  my ($node,$command,$input,$id)=@_;
  set_doc($id,$_xml_module->owner_document($node),$input);
  my $old_local=$LOCAL_NODE;
  my $old_id=$LOCAL_ID;
  eval {
    foreach (1) {
      $LOCAL_NODE=$node;
      $LOCAL_ID=$id;
      eval {
	run_commands($command);
      };
      if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
	if ($@->label =~ /^(?:next|redo)$/ and $@->[1]>1) {
	  $@->[1]--;
	  die $@; # propagate to a higher level
	}
	if ($@->label eq 'next') {
	  last;
	} elsif ($@->label eq 'redo') {
	  redo;
	} else {
	  die $@; # propagate
	}
      } elsif ($@) {
	die $@; # propagate
      }
    }
  };
  do {
    local $SIG{INT}=\&flagsigint;
    delete $_doc{$id};
    delete $_files{$id};
    $LOCAL_NODE=$old_local;
    $LOCAL_ID=$old_id;
    propagate_flagsigint();
  };
  die $@ if $@; # propagate
}

sub stream_process {
  my ($itype, $input, $otype, $output, $process)=@_;
  ($input,$output)=expand($input,$output);
  require XML::Filter::DOMFilter::LibXML;
  require XML::LibXML::SAX;
  require XML::SAX::Writer;

  my $out;
  my $termout;
  my $i=1;
  $i++ while (exists($_doc{"_stream_$i"}));
  if ($otype =~ /pipe/i) {
    open $out,"| $output";
    $out || die "Cannot open pipe to $output\n";
  } elsif ($otype =~ /string/i) {
    if ($output =~ /^\$?([a-zA-Z_][a-zA-Z0-9_]*)$/) {
      no strict qw(refs);
      $out=\${"XML::XSH::Map::$1"};
    } elsif (ref($OUT)=~/Term::ReadLine/) {
      $out = *$OUT;
      $termout=1;
    } else {
      $out = $OUT;
      $termout=1;
    }
  } else {
    $out = $output;
  }
  my $parser=XML::LibXML::SAX
    ->new( Handler =>
	   XML::Filter::DOMFilter::LibXML
	   ->new(Handler =>
		 XML::SAX::Writer::XML
		 ->new(
		       Output => $out,
		       Writer => 'XML::SAX::Writer::XMLEnc'
		      ),
		 XPathContext => $_xpc,
		 Process => [
			     map {
			       $_->[0] => [\&stream_process_node,$_->[1],
					   $input,"_stream_$i"] }
			     @$process
			    ]
		)
	 );
  if ($itype =~ /pipe/i) {
    open my $F,"$input|";
    $F || die "Cannot open pipe to $input: $!\n";
    $parser->parse_fh($F);
    close $F;
  } elsif ($itype =~ /string/i) {
    $parser->parse_string($input);
  } else  { #file
    $parser->parse_uri($input);
  }
  if ($otype =~ /pipe/i) {
    close($out);
  }
  if ($termout) { out("\n"); }
  return 1;
}

sub iterate {
  my ($code,$axis,$nodefilter,$filter)=@_;

  return unless get_local_node(_id());

  $axis =~ s/::$//;
  $axis=~s/-/_/g;

  $filter =~ s/^\[\s*((?:.|\n)*?)\s*\]$/$1/ if defined $filter;
  my $test;
  if ($nodefilter eq "comment()") {
    $test = q{ $_xml_module->is_comment($_[0]) }
  } if ($nodefilter eq "text()") {
    $test = q{ $_xml_module->is_text_or_cdata($_[0]) }
  } elsif ($nodefilter =~ /processing-instruction\((\s*['"]([^'"]+)['"]\s*)?\)$/) {
    $test = q{ $_xml_module->is_pi($_[0]) };
    $test .= qq{ && (\$_[0]->nodeName eq '$1') } if $1 ne "";
  } elsif ($nodefilter eq 'node()') {
    $test = '1 ';
  } elsif ($nodefilter =~ /^(?:([^:]+):)?(.+)$/) {
    $test = q{ $_xml_module->is_element($_[0]) };
    $test .= qq{ && (\$_[0]->getLocalName() eq '$2') } unless ($2 eq '*');
    if ($1 ne "") {
      my $ns = get_local_node(_id())->lookupNamespaceURI($1);
      die("Unrecognized namespace prefix '$1:'!") if ($ns eq "");
      $test .= qq{ && (\$_[0]->namespaceURI() eq '$ns') };
    }
  }

  die("Position index filter not supported for iteration ([$filter])") if $filter =~ /^\d+$/;
  if ($filter ne '') {
    $filter =~ s/\\/\\\\/g;
    $filter =~ s/'/\\'/g;
    $test .= qq{ && count_xpath(\$_[0],'$filter') };
  }

  my $filter_sub = eval "sub { $test }";
  my $iterator;
  do {
    my $start=get_local_node(_id());
    $iterator=XML::XSH::Iterators->create_iterator($start,$axis,$filter_sub);
  };
  return 1 unless defined $iterator;

  my $old_local=$LOCAL_NODE;
  my $old_id=$LOCAL_ID;

  eval {
  ITER: while ($iterator->current()) {
      $LOCAL_NODE=$iterator->current();
      eval {
	run_commands($code);
      };
      if (ref($@) and $@->isa('XML::XSH::Internal::LoopTerminatingException')) {
	if ($@->label =~ /^(?:next|last|redo|prev)$/ and $@->[1]>1) {
	  $@->[1]--;
	  die $@; # propagate to a higher level
	}
	if ($@->label eq 'next') {
	  $iterator->next() || last;
	  next;
	} elsif ($@->label eq 'prev') {
	  $iterator->prev() || die("No previous node to iterate to!");
	  next;
	} elsif ($@->label eq 'last') {
	  last;
	} elsif ($@->label eq 'redo') {
	  redo;
	} else {
	  die $@; # propagate
	}
      } elsif ($@) {
	die $@; # propagate
      }
      $iterator->next() || last;
    }
  };
  do {
    local $SIG{INT}=\&flagsigint;
    $LOCAL_NODE=$old_local;
    $LOCAL_ID=$old_id;
    propagate_flagsigint();
  };
  die $@ if $@; # propagate
  return 1;
}

# quit
sub quit {
  if (ref($_on_exit)) {
    &{$_on_exit->[0]}($_[0],@{$_on_exit}[1..$#$_on_exit]); # run on exit hook
  }
  exit(int($_[0]));
}

sub register_ns {
  my ($prefix,$ns)=expand(@_);
  $_ns{$prefix}=$ns;
  $_xpc->registerNs($prefix,$ns);
  return 1;
}

sub unregister_ns {
  my ($prefix)=expand(@_);
  delete $_ns{$prefix};
  $_xpc->unregisterNs($prefix);
  return 1;
}

sub register_func {
  my ($name,$code)=(expand($_[0]),$_[1]);
  my $sub;
  if ($code =~ /^\s*{/) {
    $sub=eval("package XML::XSH::Map; no strict; sub $code");
  } elsif ($code =~/^\s*([A-Za-z_][A-Za-z_0-9]*(::[A-Za-z_][A-Za-z_0-9]*)*)\s*$/) {
    if ($2 ne "") {
      $sub=\&{"$1"};
    } else {
      $sub=\&{"XML::XSH::Map::$1"};
    }
  } else {
    $sub=eval("package XML::XSH::Map; no strict; sub { $code }");
  }
  die $@ if $@;
  if ($name =~ /^([^:]+):(.*)$/) {
    if (exists($_ns{$1})) {
      $_xpc->registerFunctionNS($2, $_ns{$1}, $sub);
    } else {
      die "Registration failed: unknown namespace prefix $1!\n";
    }
  } else {
    $_xpc->registerFunction($name, $sub);
  }
  return 1;
}

sub unregister_func {
  my ($name)=expand(@_);
  $_xpc->unregisterFunction($name);
  return 1;
}

#######################################################################
#######################################################################


package XML::XSH::Map;

import XML::XSH::Functions ':param_vars';

# make this command available from perl expressions
sub echo {
  &XML::XSH::Functions::out(XML::XSH::Functions::fromUTF8($XML::XSH::Functions::ENCODING,join("",@_)));
  return 1;
}

# make this command available from perl expressions
sub xsh {
  &XML::XSH::Functions::xsh(join "",@_);
}

sub count {
  my $xp=$_[0];
  $xp=~/^(?:([a-zA-Z_][a-zA-Z0-9_]*):(?!:))?((?:.|\n)*)$/;
  return &XML::XSH::Functions::count([$1,$2]);
}

sub xml_list {
  my ($xp)=@_;
  $xp=~/^(?:([a-zA-Z_][a-zA-Z0-9_]*):(?!:))?((?:.|\n)*)$/;
  my ($id,$query,$doc)=&XML::XSH::Functions::_xpath([$1,$2]);

  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  my $ql=&XML::XSH::Functions::find_nodes([$id,$query]);
  my $result='';
  foreach (@$ql) {
    $result.=$_->toString();
  }
  return $result;
}

sub literal {
  my ($xp)=@_;
  my $xp=$_[0];
  $xp=~/^(?:([a-zA-Z_][a-zA-Z0-9_]*):(?!:))?((?:.|\n)*)$/;
  return XML::XSH::Functions::eval_xpath_literal([$1,$2]);
}

sub type {
  my ($xp)=@_;
  $xp='.' if $xp eq "";
  $xp=~/^(?:([a-zA-Z_][a-zA-Z0-9_]*):(?!:))?((?:.|\n)*)$/;
  my ($id,$query,$doc)=&XML::XSH::Functions::_xpath([$1,$2]);

  unless (ref($doc)) {
    die "No such document '$id'!\n";
  }
  my $ql=&XML::XSH::Functions::find_nodes([$id,$query]);


  my $xm=$XML::XSH::Functions::_xml_module;
  my @result;
  foreach (@$ql) {
    if ($xm->is_element($_)) {
      push @result, 'element';
    } elsif ($xm->is_attribute($_)) {
      push @result, 'attribute';
    } elsif ($xm->is_text($_)) {
      push @result, 'text';
    } elsif ($xm->is_cdata_section($_)) {
      push @result, 'cdata';
    } elsif ($xm->is_pi($_)) {
      push @result, 'pi';
    } elsif ($xm->is_entity_reference($_)) {
      push @result, 'entity_reference';
    } elsif ($xm->is_document($_)) {
      push @result, 'document';
    } elsif ($xm->is_document_fragment($_)) {
      push @result, 'chunk';
    } elsif ($xm->is_comment($_)) {
      push @result, 'comment';
    } elsif ($xm->is_namespace($_)) {
      push @result, 'namespace';
    } else {
      push @result, 'unknown';
    }
    return $result[0] unless (wantarray);
  }
  return @result;
}

#######################################################################
#######################################################################

package XML::XSH::Internal::Exception;

sub new {
  my $class=(ref($_[0]) || $_[0]);
  shift;
  return bless [@_], $class;
}

sub set_label {
  my ($label)=@_;
  return $_[0]->[0]=$label;
}

sub label {
  return $_[0]->[0];
}

sub value {
  my ($index)=@_;
  return $_[0]->[$index];
}

sub set_value {
  my ($index,$value)=@_;
  return $_[0]->[$index]=$value;
}

package XML::XSH::Internal::UncatchableException;
use vars qw(@ISA);
@ISA=qw(XML::XSH::Internal::Exception);

package XML::XSH::Internal::LoopTerminatingException;
use vars qw(@ISA);
@ISA=qw(XML::XSH::Internal::UncatchableException);

package XML::XSH::Internal::SubTerminatingException;
use vars qw(@ISA);
@ISA=qw(XML::XSH::Internal::UncatchableException);


#######################################################################
#######################################################################

package IO::MyString;

use vars qw(@ISA);
@ISA=qw(IO::Handle);

sub new {
  my $class=(ref($_[0]) || $_[0]);
  return bless [""], $class;
}

sub print {
  my $self=shift;
  $self->[0].=join("",@_);
}

sub value {
  return $_[0]->[0];
}

sub close {
  $_[0]->[0]=undef;
}

package XML::SAX::Writer::XMLEnc;
use vars qw(@ISA);
@ISA=qw(XML::SAX::Writer::XML);

sub xml_decl {
  my ($self,$data) = @_;
  if ($data->{Encoding}) {
    $self->{EncodeTo}=$data->{Encoding};
    $self->setConverter();
  }
  $self->SUPER::xml_decl($data);
}

1;