XML-XSH2
view release on metacpan or search on metacpan
lib/XML/XSH2/Functions.pm view on Meta::CPAN
# initialize global XPathContext
sub xpc_init {
$_xpc=new_xpath_context();
$_ns{xsh}=$XML::XSH2::xshNS;
}
sub init_XPATH_funcs {
my ($xpc,$ns)=@_;
foreach my $name (get_XPATH_extensions()) {
my $func=$name; $func =~ s/-/_/g;
$xpc->registerFunctionNS($name,$ns,\&{"XPATH_$func"});
}
}
sub new_xpath_context {
my $xpc;
unless (eval { require XML::LibXML::XPathContext;
$xpc=XML::LibXML::XPathContext->new();
}) {
require XML::XSH2::DummyXPathContext;
print STDERR ("Warning: XML::LibXML::XPathContext not found!\n".
"XSH will lack namespace and function registering functionality!\n\n");
return XML::XSH2::DummyXPathContext->new();
}
$xpc = XML::LibXML::XPathContext->new();
$xpc->registerVarLookupFunc(\&xpath_var_lookup,undef);
$xpc->registerNs('xsh',$XML::XSH2::xshNS);
init_XPATH_funcs($xpc,$XML::XSH2::xshNS);
return $xpc;
}
sub clone_xpc {
my $xpc = new_xpath_context();
foreach (keys(%_ns)) {
$xpc->registerNs($_,$_ns{$_});
}
foreach (keys(%_func)) {
if (/\n/) {
my ($name,$ns)=/^(.*)\n((?:.|\n)*)$/;
$xpc->registerFunctionNS($name, $ns, $_func{$_});
} else {
$xpc->registerFunction($_, $_func{$_});
}
}
$xpc->setContextNode($_xpc->getContextNode());
return $xpc;
}
sub xpath_extensions {
my $opts = shift;
init_XPATH_funcs($_xpc,shift);
return 1;
}
# ===================== XPATH EXT FUNC ================
sub get_XPATH_extensions {
qw( current doc filename grep id2 if join lc uc ucfirst lcfirst
lineno evaluate map matches match max min new-attribute
new-cdata new-chunk new-comment new-element new-element-ns new-pi
new-text node-type parse path reverse same serialize split sprintf
strmax strmin subst substr sum times var document documents lookup span context
resolve-uri base-uri document-uri
)
}
sub XPATH_doc {
die "Wrong number of arguments for function xsh:doc(nodeset)!\n" if (@_!=1);
my ($nodelist)=@_;
die "1st argument must be a nodeset in xsh:doc(nodeset)!\n"
unless (ref($nodelist) and UNIVERSAL::isa($nodelist,'XML::LibXML::NodeList'));
use utf8;
return XML::LibXML::NodeList->new(grep { ref($_) } map { $_->ownerDocument } @$nodelist);
}
sub XPATH_filename {
die "Wrong number of arguments for function xsh:filename(nodeset?) or xsh:document-uri(nodeset?)!\n" if (@_>1);
my $doc;
if (@_) {
die "1st argument must be a node in xsh:filename(nodeset?) or xsh:document-uri(nodeset?)!\n"
unless (ref($_[0]) and UNIVERSAL::isa($_[0],'XML::LibXML::NodeList'));
}
if ($_[0]) {
return XML::LibXML::Literal->new('') unless $_[0][0];
$doc = $_[0][0]->ownerDocument;
} else {
$doc = $XML::XSH2::Functions::_xpc->getContextNode()->ownerDocument;
}
use utf8;
return XML::LibXML::Literal->new($doc->URI());
}
sub XPATH_resolve_uri {
die "Wrong number of arguments for function xsh:resolve-uri(relative-URI,base-URI?)!\n" if (@_>2 or @_==0);
my ($rel,$base)=map literal_value($_), @_;
return XML::LibXML::Literal->new(XML::XSH2::Map::resolve_uri($rel,$base)->as_string);
}
sub XPATH_document_uri {
&XPATH_filename;
}
sub XPATH_base_uri {
die "Wrong number of arguments for function xsh:base_uri(node?)!\n" if (@_>1);
my $node;
if (@_) {
die "1st argument must be a node in xsh:base_uri(node?)!\n"
unless (ref($_[0]) and UNIVERSAL::isa($_[0],'XML::LibXML::NodeList'));
}
if ($_[0]) {
return XML::LibXML::Literal->new('') unless $_[0][0];
$node = $_[0][0];
} else {
$node = $XML::XSH2::Functions::_xpc->getContextNode();
}
use utf8;
return XML::LibXML::Literal->new($node->baseURI() || '');
}
lib/XML/XSH2/Functions.pm view on Meta::CPAN
sub XPATH_new_element {
die "Wrong number of arguments for function xsh:new-element(string, [string,string,...])!\n"
unless (scalar(@_)%2);
my ($name,%attrs)=map {literal_value($_)} @_;
my $doc = $_xpc->getContextNode;
unless (ref($doc) and ref($doc = $doc->ownerDocument())) {
die "No context document\n";
}
my $e = $doc->createElement($name);
foreach my $aname (keys %attrs) {
$e->setAttribute($aname,$attrs{$aname});
}
return XML::LibXML::NodeList->new($e);
}
sub XPATH_new_element_ns {
die "Wrong number of arguments for function xsh:new-element-ns(string, string, [string,string])!\n"
unless (@_ and (scalar(@_)+1)%2);
my ($name,$ns,%attrs)=map {literal_value($_)} @_;
my $doc = $_xpc->getContextNode;
unless (ref($doc) and ref($doc = $doc->ownerDocument())) {
die "No context document\n";
}
# __debug("ns: $ns");
my $e=$doc->createElementNS("$ns",$name);
# my ($prefix,$name) = split ':',$name;
# my $e=XML::LibXML::Element->new($name);
# $e->setNamespace("$ns","$prefix",1);
foreach my $aname (keys %attrs) {
$e->setAttribute($aname,$attrs{$aname});
}
return XML::LibXML::NodeList->new($e);
}
sub XPATH_new_text {
die "Wrong number of arguments for function xsh:new-text(string)!\n"
if (@_!=1);
my $text=literal_value(shift);
my $doc = $_xpc->getContextNode;
unless (ref($doc) and ref($doc = $doc->ownerDocument())) {
die "No context document\n";
}
my $t=$doc->createTextNode($text);
return XML::LibXML::NodeList->new($t);
}
sub XPATH_new_comment {
die "Wrong number of arguments for function xsh:new-comment(string)!\n"
if (@_!=1);
my $text=literal_value(shift);
my $doc = $_xpc->getContextNode;
unless (ref($doc) and ref($doc = $doc->ownerDocument())) {
die "No context document\n";
}
my $t=$doc->createComment($text);
return XML::LibXML::NodeList->new($t);
}
sub XPATH_new_cdata {
die "Wrong number of arguments for function xsh:new-cdata(string)!\n"
if (@_!=1);
my $name=literal_value(shift);
my $doc = $_xpc->getContextNode;
unless (ref($doc) and ref($doc = $doc->ownerDocument())) {
die "No context document\n";
}
my $t=$doc->createCDATASection($name);
return XML::LibXML::NodeList->new($t);
}
sub XPATH_new_pi {
die "Wrong number of arguments for function xsh:new-pi(string,[ string])!\n"
if (!@_ or @_>2);
my ($name,$value)=map { literal_value($_) } @_;
my $doc = $_xpc->getContextNode;
unless (ref($doc) and ref($doc = $doc->ownerDocument())) {
die "No context document\n";
}
my $pi = $doc->createPI($name => $value);
return XML::LibXML::NodeList->new($pi);
}
sub XPATH_new_chunk {
die "Wrong number of arguments for function xsh:new-chunk(string,[ string])!\n"
if (@_!=1);
return XPATH_parse(@_);
}
sub XPATH_times {
die "Wrong number of arguments for function xsh:times(string,float)!\n"
if (@_!=2);
my ($string,$times)=@_;
$times=literal_value($times);
$string=literal_value($string);
return XML::LibXML::Literal->new($times x $string);
}
sub XPATH_if {
die "Wrong number of arguments for function xsh:if(object,object,object)!\n"
if (@_!=3);
my ($test, $if, $else)=@_;
if (ref($test) and
(UNIVERSAL::isa($test,'XML::LibXML::NodeList') and @$test
or $test->to_literal->value)
or $test) {
return $if;
} else {
return $else;
}
}
sub XPATH_id2 {
die "Wrong number of arguments for function xsh:id2(object,string)!\n"
if (@_!=2);
my ($nl, $id)=@_;
die "Wrong type of argument 1 for function xsh:id2(object,string)!\n"
if (!ref($nl) or not UNIVERSAL::isa($nl,"XML::LibXML::NodeList"));
die "Argument 2 for function xsh:id2(object,string) isn't a valid qname!\n"
if ($id =~ /\'/);
my $res=XML::LibXML::NodeList->new();
lib/XML/XSH2/Functions.pm view on Meta::CPAN
return 0;
}
}
return 1;
}
# return current node for given document or document root if
# current node is not from the given document
sub xsh_context_node {
return $_xpc->getContextNode;
}
sub xsh_context_var {
my $node = xsh_context_node();
if ($node) {
return xsh_search_docvar($node);
}
return "";
}
# set current node to given XPath
sub set_local_xpath {
my ($opts,$exp)=@_;
$exp = "/" if ($exp eq "");
_set_context([_ev_nodelist($exp)->shift()]);
return 1;
}
sub cannon_name {
my ($node)=@_;
my $local_name =$node->localname();
my $uri = $node->namespaceURI();
if ($uri ne '') {
my $prefix=$node->prefix;
#if ($prefix eq '') {
my %r = reverse %_ns;
$prefix = $r{ $uri };
if ($prefix ne '') {
return $prefix.':'.$local_name
} elsif(my $parent = $node->parentNode) {
$prefix = $parent->lookupNamespacePrefix($uri);
if ($prefix ne '') {
return $prefix.':'.$local_name
}
}
return '*[name()="'.$node->getName().'"]';
}
return $local_name;
}
# return XPath identifying a node within its parent's subtree
sub node_address {
my $node = shift || $_xpc->getContextNode();
my $no_parent = shift;
my $name;
if ($_xml_module->is_element($node)) {
$name=cannon_name($node);
} 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 "@".cannon_name($node);
}
if (!$no_parent and $node->parentNode) {
my @children;
# if ($_xml_module->is_element($node)) {
# @children=$_xpc->findnodes("./$name",$node->parentNode);
# } else {
my $context = $_xpc->getContextNode;
@children= eval { $_xpc->findnodes("./$name",$node->parentNode) };
# }
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 "??$name??";
} 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();
}
}
# get node's ID
sub node_id {
my ($node)=@_;
if ($node) {
for my $attr ($node->attributes) {
if ($attr->can('isId') and $attr->isId) {
my $value = $attr->value;
return $value if defined $value;
}
}
}
return undef;
}
# return canonical xpath for the given or current node
sub pwd {
my $node=shift || $_xpc->getContextNode();
my $use_id = shift;
return undef unless ref($node);
return $node->nodePath() if !$STRICT_PWD and UNIVERSAL::can($node,'nodePath');
lib/XML/XSH2/Functions.pm view on Meta::CPAN
$prefix = _ev_string($prefix) if $prefix;
$uri = _ev_string($uri);
my $node = $_xpc->getContextNode;
if ($node && $_xml_module->is_element($node)) {
$prefix = $node->prefix unless defined $prefix;
return $node->setNamespaceDeclURI($prefix,$uri);
} else {
_err("The context node is not an element");
}
}
# use the XPathToXML module to build
# up a XML structure
sub xpath_set {
my ($opts,$exp,$value)=@_;
require XML::XSH2::XPathToXML;
my $xtx = XML::XSH2::XPathToXML->new(namespaces => \%_ns,
XPathContext => $_xpc,
node => xsh_context_node(),
);
$value = _ev($value);
$exp = _expand($exp);
if (ref($value) and UNIVERSAL::isa($value,'XML::LibXML::NodeList')) {
my $result = $xtx->createNode($exp);
if ($_xml_module->is_element($result)) {
# if it's an element, try to clone or attach given nodes
foreach my $node (@$value) {
if ($_xml_module->is_document_fragment($node) or
$node->parentNode and
$_xml_module->is_document_fragment($node->parentNode)) {
# it's a fragment
$result->appendChild($node);
} else {
# safely insert a copy
insert_node($node,$result,undef,'into',undef,undef);
}
}
} else {
$result->setValue(to_literal($value));
}
return $result;
} else {
return $xtx->createNode($exp,to_literal($value));
}
}
# insert given node to given destination performing
# node-type conversion if necessary
sub insert_node {
my ($node,$dest,$dest_doc,$where,$ns,$rl)=@_;
if ($_xml_module->is_document($node)) {
die "Error: Can't insert/copy/move document nodes!\n";
}
if (!defined($dest_doc)) {
$dest_doc = $_xml_module->owner_document($dest);
}
# 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);
push @$rl,$dest->ownerElement()->getAttributeNodeNS($dest->namespaceURI(),$dest->getName()) if defined($rl);
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());
push @$rl,$dest->ownerElement()->getAttributeNodeNS($dest->namespaceURI(),$dest->getName()) if defined($rl);
} elsif ($where eq 'after' or $where eq 'append') {
$val=~s/\s+$//g;
set_attr_ns($dest->ownerElement(),$dest->namespaceURI(),$dest->getName(),
$dest->getValue().$val);
push @$rl,$dest->ownerElement()->getAttributeNodeNS($dest->namespaceURI(),$dest->getName()) if defined($rl);
}
}
# 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);
push @$rl,$elem->getAttributeNodeNS("$ns",$name) if defined($rl);
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());
}
push @$rl,$dest->ownerElement()->getAttributeNodeNS("$ns",$dest->getName()) if defined($rl);
}
} 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;
}
push @$rl,_expand_fragment($copy) if defined($rl);
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;
}
push @$rl,_expand_fragment($copy) if (defined($rl));
}
}
# 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());
push @$rl,$dest->getAttributeNodeNS("$ns",$node->getName()) if defined($rl);
} elsif ($where eq 'replace') {
my $parent=$dest->parentNode();
if ($_xml_module->is_element($parent)) {
set_attr_ns($dest,"$ns",$node->getName(),$node->getValue());
push @$rl,$dest->getAttributeNodeNS("$ns",$node->getName()) if defined($rl);
} 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') {
push @$rl,_expand_fragment($copy) if defined($rl);
return safe_insert($copy,$dest,$where);
} elsif ($where eq 'into' or $where eq 'append') {
$dest->appendChild($copy);
push @$rl,_expand_fragment($copy) if defined($rl);
} elsif ($where eq 'prepend') {
if ($dest->hasChildNodes()) {
$dest->insertBefore($copy,$dest->firstChild());
} else {
$dest->appendChild($copy);
}
push @$rl,_expand_fragment($copy) if defined($rl);
}
}
}
# 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();
$value = "" unless defined $value;
$dest->setData($value);
push @$rl,$dest if defined($rl);
} elsif ($where eq 'append') {
my $value=$_xml_module->is_element($node) ?
$node->textContent() : $node->getData();
$dest->setData($dest->getData().$value);
push @$rl,$dest if defined($rl);
} elsif ($where eq 'prepend') {
my $value=$_xml_module->is_element($node) ?
$node->textContent() : $node->getData();
$dest->setData($value.$dest->getData());
push @$rl,$dest if defined($rl);
}
# 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());
push @$rl,$dest->getAttributeNodeNS("$ns",$node->getName()) if defined($rl);
}
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());
}
lib/XML/XSH2/Functions.pm view on Meta::CPAN
}
if ($dest && $_xml_module->is_element($dest)) {
print STDERR "DEST is element\n" if $DEBUG;
$el=$dest->addNewChild($ns,$name);
if ($prefix eq "" and $ns eq "" and $dest->lookupNamespaceURI(undef) ne "") {
print STDERR "CLEAR Default NS\n" if $DEBUG;
$el->setNamespace('','',1);
} else {
print STDERR "prefix: $prefix, ns: $ns, lookup: ",$dest->lookupNamespaceURI(undef),".\n" if $DEBUG;
print STDERR $dest->toString(1),"\n" if $DEBUG;
}
$el->unbindNode();
} elsif ($ns ne '') {
print STDERR "DEST is not element, NS: $ns\n" if $DEBUG;
$el=$doc->createElementNS($ns,$name);
} else {
print STDERR "DEST is not element no NS\n" if $DEBUG;
$el=$doc->createElement($name);
}
if (ref($attrs)) {
foreach (@$attrs) {
if ($ns ne "" and ($_->[0]=~/^\Q${prefix}\E:/)) {
print STDERR "NS: $ns\n" if $DEBUG;
$el->setAttributeNS($ns,$_->[0],$_->[1]);
} elsif ($_->[0] =~ "xmlns:(.*)") {
print STDERR "xmlns: $1\n" if $DEBUG;
# don't redeclare NS if already declared on destination node
unless ($_->[1] eq $ns or $dest->lookupNamespaceURI($1) eq $_->[2]) {
$el->setNamespace($_->[1],$1,0) unless ($_->[1] eq $ns);
}
} elsif ($_->[0] eq "xmlns") {
print STDERR "xmlns: @$_\n" if $DEBUG;
# don't redeclare NS if already declared on destination node
unless ($->[1] eq $ns or $dest->lookupNamespaceURI('') eq $_->[2]) {
$el->setNamespace($_->[1],'',0) 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,$str,$doc,$ns)=@_;
my @nodes=();
die "No document for create $type $str for.\n" unless ref($doc);
die "Can't create $type from empty specification.\n"
if ($str eq "" and $type !~ /text|cdata|comment/);
# return undef unless ($str ne "" and ref($doc));
if ($type eq 'chunk') {
@nodes=map {$_->childNodes()}
grep {ref($_)} ($_parser->parse_xml_chunk($str));
} else {
if ($type eq 'attribute') {
foreach (create_attributes($str)) {
my $at;
if ($_->[0]=~/^([^:]+):/ and $1 ne 'xmlns') {
$ns = get_registered_ns($1) if $ns eq "";
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 ($str=~/^\<?([^ \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=~/^([^:>]+):(.*)$/ or $ns ne "") {
print STDERR "Name: $elt\n" if $DEBUG;
if ($ns eq "") {
print STDERR "NS prefix registered as: $ns\n" if $DEBUG;
$ns = get_registered_ns($1) if $ns eq "";
} else {
print STDERR "NS: $ns\n" if $DEBUG;
}
die "Error: undefined namespace prefix `$1'\n" if ($1 ne "" and $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;
# __debug("ns: $ns\n".$el->toString());
} else {
print STDERR "invalid element $str\n" unless "$QUIET";
}
} elsif ($type eq 'text') {
push @nodes,$doc->createTextNode($str);
print STDERR "text=$str\n" if $DEBUG;
} elsif ($type eq 'entity_reference') {
push @nodes,$doc->createEntityReference($str);
print STDERR "entity_reference=$str\n" if $DEBUG;
} elsif ($type eq 'cdata') {
push @nodes,$doc->createCDATASection($str);
print STDERR "cdata=$str\n" if $DEBUG;
} elsif ($type eq 'pi') {
my ($name,$data)=($str=~/^\s*(?:\<\?)?(\S+)(?:\s+(.*?)(?:\?\>)?)?$/);
$data = "" unless defined $data;
my $pi = $doc->createPI($name,$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($str);
print STDERR "comment=$str\n" if $DEBUG;
} else {
die "unknown type: $type\n";
}
}
return @nodes;
}
sub run_editor {
my ($data,$editor,$encoding)=@_;
($editor) = grep {$_ ne ""} $editor,$ENV{VISUAL},$ENV{EDITOR},'vi';
$encoding = $QUERY_ENCODING unless $encoding;
my $dir = tempdir( CLEANUP => 1 );
my ($fh, $filename) = tempfile( DIR => $dir );
binmode $fh,'bytes';
$fh->print(fromUTF8($encoding,$data));
$fh->flush if $fh->can('flush');
close($fh);
if (system($editor." ".$filename) == 0) {
open $fh,$filename;
binmode $fh,'bytes';
$data= join "",map toUTF8($encoding,$_),<$fh>;
close $fh;
} else {
$data=undef;
}
unlink $filename;
unlink $dir;
return $data;
}
sub ask_user {
my ($question, $answers) = @_;
print STDERR $question;
STDERR->flush;
my $reply = <STDIN>;
chomp $reply;
if ($answers ne "") {
while ($reply !~ /^$answers$/) {
print STDERR "Answer ",join("/",split(/\|/,$answers)),": ";
STDERR->flush;
$reply = <STDIN>;
chomp $reply;
}
}
return $reply;
}
############### END OF AUXILIARY FUNCTIONS ###############
sub edit {
my ($opts,$exp,$variable)=@_;
$opts = _ev_opts($opts);
my $rl = _prepare_result_nl();
my $ql;
unless ($variable) {
$exp = '.' if $exp eq '';
$ql =_ev_nodelist($exp);
unless (@$ql) {
_warn("No nodes matching $exp");
return $rl;
}
# prune nodes included in subtrees of already present nodes
# cause they would get replaced anyway
my %n;
$ql = [ grep {
my $d=$_; my $ret=1;
while ($d) {
if (exists ($n{$$d})) { $ret = 0; last; }
else { $d=$d->parentNode; }
}
$n{$$_}=1; $ret } @$ql ];
}
my $data;
my $node_idx = 0;
my $fix;
my $node;
my $nodes = scalar(@$ql) unless $variable;
while ($variable or ($node = $ql->[$node_idx++])) {
if ($variable) {
$data=_ev_literal($exp)
} else {
my $pwd = pwd($node);
if ($fix) {
undef $fix;
} else {
if ($_xml_module->is_attribute($node)) {
$data=$node->value;
} elsif ($_xml_module->is_element($node) or
$_xml_module->is_document($node) or
$_xml_module->is_text_or_cdata($node) or
$_xml_module->is_comment($node) or
$_xml_module->is_pi($node)) {
$data=$_xml_module->toStringUTF8($node,$opts->{noindent} ? 0 :$INDENT);
} else {
die("Cannot edit ".ref($node)."\n");
}
}
$data="<!-- XSH-COMMENT: $pwd ".
($opts->{all} ? "($node_idx/$nodes) " : "")."-->\n"
.$data unless $opts->{'no-comment'};
}
my $replacement = run_editor($data,$opts->{editor},$opts->{encoding});
$replacement =~ s/^\s*<!-- XSH-COMMENT: [^>]*-->[ \t]*\n?// unless $variable;
chomp $replacement unless $variable;
while ($replacement eq "" and not($opts->{'allow-empty'})) {
if (-t) {
my $response = ask_user("Result is empty! Is that correct? (yes/no/stop): ",
"y|n|s|yes|no|stop");
if ($response =~ /^y/) {
last;
} elsif ($response =~ /^s/) {
return $variable ? $data : $rl;
} else {
$replacement = run_editor($data,$opts->{editor},$opts->{encoding});
$replacement =~ s/^\s*<!-- XSH-COMMENT: [^>]*-->[ \t]*\n?//;
}
} else {
die("Result is empty, ignoring changes!\n".
"Hint: use --allow-empty option or remove command.\n");
}
}
if ($variable) {
if ($exp) {
_assign($exp,$replacement);
}
return $replacement;
} elsif ($_xml_module->is_attribute($node)) {
$node->setValue($replacement) if defined $replacement;
push @$rl, $node if defined $rl;
} else {
local $RECOVERING=$opts->{recover} ? 1 : $RECOVERING;
local $KEEP_BLANKS=$opts->{'keep-blanks'} ? 1 : !$INDENT;
my $chunk;
if ($_xml_module->is_document($node)) {
$chunk = eval { $_xml_module->parse_string($_parser,$replacement) };
} else {
$chunk = eval { $_xml_module->parse_chunk($_parser,$replacement); };
}
if ($@ or not ref($chunk)) {
if (-t) {
my $c = ask_user("$@\n"."Parse error! Press:\n".
" 1 - continue with next node\n".
" 2 - fix the error in the editor\n".
" 3 - restart editor on this node (discarding changes)\n".
" 4 - stop\n\n".
"Your choice: ","1|2|3|4");
if ($c == 1) {
next;
} elsif ($c == 2) {
$data = $replacement;
lib/XML/XSH2/Functions.pm view on Meta::CPAN
last if ($n->isSameNode($end_node));
$n=$n->nextSibling();
}
die "Error: Node ".pwd($end_node).
" isn't following sibling of ".pwd($node)."!\n" unless $n;
if ($_xml_module->is_document($parent)) {
# check that document element is within the span
my $docel=$parent->getDocumentElement();
my $found=0;
foreach my $n (@span) {
if ($n->isSameNode($docel)) {
$found=1;
last;
}
}
die "Cannot wrap span: ".pwd($node).
" .. ".pwd($end_node)." (document already has a root element)\n"
unless $found;
replace_document_element($docel,$el);
foreach my $n (@span) {
$n->unbindNode();
$el->appendChild($n);
}
} else {
$parent->insertBefore($el,$node);
foreach my $n (@span) {
$n->unbindNode();
$el->appendChild($n);
}
}
push @$rl, $el if defined $rl;
}
return $rl;
}
# normalize nodes
sub normalize_nodes {
my ($opts,$exp)=@_;
my $ql=_ev_nodelist($exp);
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 ($opts,$exp)=@_;
my $ql=_ev_nodelist($exp);
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 "") {
$data = "" unless defined $data;
$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 "") {
$data = "" unless defined $data;
$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 "") {
$data = "" unless defined $data;
$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 ($opts,$exp)=@_;
my $doc = _ev_doc($exp);
$opts = _ev_opts($opts);
if ($opts->{dtd}+$opts->{schema}+$opts->{relaxng}>1) {
die "You can only specify one validation schema at a time\n";
}
if (grep(exists($opts->{$_}), qw(file doc string))>1) {
die "You can only specify one of --file, --doc, --string at a time\n";
}
$opts->{dtd} = 1 unless $opts->{schema} or $opts->{relaxng};
if (exists($opts->{public}) ne "" and not $opts->{dtd}) {
die "--public ID can only be used for DTD validation (--dtd)\n";
}
$opts->{file} = _tilde_expand($opts->{file}) if exists($opts->{file});
my $ret = 0;
if ($doc->can('is_valid')) {
if (!$opts->{dtd} or exists($opts->{file}) or exists($opts->{string}) or
exists($opts->{doc}) or exists($opts->{public})) {
if ($opts->{dtd}) {
my $dtd;
eval { XML::LibXML::Dtd->can('new') } ||
die "DTD validation not supported by your version of XML::LibXML\n";
if (exists($opts->{file}) or exists($opts->{public})) {
$dtd=XML::LibXML::Dtd->new($opts->{public},$opts->{file});
} elsif (exists($opts->{string})) {
$dtd=XML::LibXML::Dtd->parse_string($opts->{string});
} else {
die "Can't use --doc with DTD validation\n";
}
if ($opts->{yesno}) {
lib/XML/XSH2/Functions.pm view on Meta::CPAN
} else {
$out = $OUT;
$termout=1;
}
} else {
$out = $output;
}
my $parser=XML::LibXML::SAX
->new( Handler =>
XML::Filter::DOMFilter::LibXML
->new($opts->{'no-output'} ? ()
: (Handler => XML::SAX::Writer::XML
->new(
Output => $out,
Writer => 'XML::SAX::Writer::XMLEnc'
)),
XPathContext => $_xpc,
Process => [
map {
$_->[0] => [\&stream_process_node,$_->[1],
$input] }
@$process
]
)
);
my $old_context = _save_context();
my $error;
eval {
if (exists $opts->{'input-pipe'}) {
open my $F,"$input|";
$F || die "Cannot open pipe to $input: $!\n";
$parser->parse_file($F);
close $F;
} elsif (exists $opts->{'input-string'}) {
$parser->parse_string($input);
} else { #file
$parser->parse_uri($input);
}
if (exists $opts->{'output-pipe'}) {
close($out);
}
if ($termout) { out("\n"); }
1 } or $error = $@;
_set_context($old_context);
die $error if $error;
return 1
}
sub iterate {
my ($code,$axis,$nodefilter,$filter)=@_;
$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 = xsh_context_node()->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{ && \$_xpc->find('$filter',\$_[0]) };
}
$test = "1" if $test eq "";
my $filter_sub = eval "sub { $test }";
die $@ if $@;
my $iterator;
do {
my $start=xsh_context_node();
$iterator=XML::XSH2::Iterators->create_iterator($start,$axis,$filter_sub);
};
return 1 unless defined $iterator;
my $old_context=_save_context();
my $count = 1;
my $pos = 1;
eval {
ITER: while ($iterator->current()) {
_set_context([$iterator->current(),$count,$pos]);
eval {
run_commands($code);
};
if (ref($@) and UNIVERSAL::isa($@,'XML::XSH2::Internal::LoopTerminatingException')) {
if ($@->label =~ /^(?:next|last|redo|prev)$/ and $@->[1]>1) {
$@->[1]--;
die $@; # propagate to a higher level
}
if ($@->label eq 'next') {
$count ++; $pos ++;
$iterator->next() || last;
next;
} elsif ($@->label eq 'prev') {
$pos --;
$iterator->prev() || die("No previous node to iterate to!");
next;
} elsif ($@->label eq 'last') {
last;
} elsif ($@->label eq 'redo') {
redo;
} else {
lib/XML/XSH2/Functions.pm view on Meta::CPAN
return $r{$_[0]};
}
sub register_func {
my ($opts,$name,$code)=@_;
$name=_ev_string($name);
my $sub;
if ($code =~ /^\s*{/) {
my $lex = lexicalize("sub $code");
$sub = eval($lex);
} 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::XSH2::Map::$1"};
}
} else {
$sub = eval(lexicalize("sub \{ $code \}"));
}
die $@ if $@;
if ($name =~ /^([^:]+):(.*)$/) {
if (exists($_ns{$1})) {
$_func{"$2\n$_ns{$1}"}=$sub;
$_xpc->registerFunctionNS($2, $_ns{$1}, $sub);
} else {
die "Registration failed: unknown namespace prefix $1!\n";
}
} else {
$_func{$name}=$sub;
$_xpc->registerFunction($name, $sub);
}
return 1;
}
sub unregister_func {
my ($opts,$name)=@_;
if ($name =~ /^([^:]+):(.*)$/) {
if (exists($_ns{$1})) {
delete $_func{"$2\n$_ns{$1}"};
$_xpc->unregisterFunctionNS($2, $_ns{$1});
} else {
die "Registration failed: unknown namespace prefix $1!\n";
}
} else {
delete $_func{$name};
$_xpc->unregisterFunction($name);
}
return 1;
}
sub node_type {
my ($node)=@_;
return undef unless $node;
if ($_xml_module->is_element($node)) {
return 'element';
} elsif ($_xml_module->is_attribute($node)) {
return 'attribute';
} elsif ($_xml_module->is_text($node)) {
return 'text';
} elsif ($_xml_module->is_cdata_section($node)) {
return 'cdata';
} elsif ($_xml_module->is_pi($node)) {
return 'pi';
} elsif ($_xml_module->is_entity_reference($node)) {
return 'entity_reference';
} elsif ($_xml_module->is_document($node)) {
return 'document';
} elsif ($_xml_module->is_document_fragment($node)) {
return 'chunk';
} elsif ($_xml_module->is_comment($node)) {
return 'comment';
} elsif ($_xml_module->is_namespace($node)) {
return 'namespace';
} else {
return 'unknown';
}
}
#######################################################################
#######################################################################
package XML::XSH2::Map;
BEGIN {
import XML::XSH2::Functions ':param_vars';
*fromUTF8 = *XML::XSH2::Functions::fromUTF8;
*toUTF8 = *XML::XSH2::Functions::toUTF8;
}
sub call {
XML::XSH2::Functions::call({},0,@_);
}
sub serialize {
my $exp=$_[0];
my $ql;
if (ref($exp)) {
if (UNIVERSAL::isa($exp,'XML::LibXML::NodeList')) {
$ql=$exp;
} elsif (UNIVERSAL::isa($exp,'XML::LibXML::Node')) {
$ql=[$exp];
} else {
$ql=&XML::XSH2::Functions::_ev_nodelist($exp);
}
} else {
$ql=&XML::XSH2::Functions::_ev_nodelist($exp);
}
my $result='';
foreach (@$ql) {
$result.=$_->toString();
}
return $result;
}
sub literal {
my $xp=$_[0] || current();
return XML::XSH2::Functions::to_literal(ref($xp) ? $xp : XML::XSH2::Functions::_ev($xp));
}
( run in 0.693 second using v1.01-cache-2.11-cpan-39bf76dae61 )