XML-XSH
view release on metacpan or search on metacpan
lib/XML/XSH/Functions.pm view on Meta::CPAN
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;
}
lib/XML/XSH/Functions.pm view on Meta::CPAN
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)$/) {
lib/XML/XSH/Functions.pm view on Meta::CPAN
}
}
}
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=~/^\<?([^ \t\n\/\<\>]+)(\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=<?$name ... $data?>\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*<?xml [^>]*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) {
lib/XML/XSH/Functions.pm view on Meta::CPAN
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
}
lib/XML/XSH/Functions.pm view on Meta::CPAN
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);
( run in 0.816 second using v1.01-cache-2.11-cpan-39bf76dae61 )