Initial Commit
This commit is contained in:
Riley Schneider
260
database/perl/vendor/lib/XML/Twig/XPath.pm
vendored
Normal file
260
database/perl/vendor/lib/XML/Twig/XPath.pm
vendored
Normal file
@@ -0,0 +1,260 @@
|
||||
# $Id: /xmltwig/trunk/Twig/XPath.pm 32 2008-01-18T13:11:52.128782Z mrodrigu $
|
||||
package XML::Twig::XPath;
|
||||
use strict;
|
||||
use warnings;
|
||||
use XML::Twig;
|
||||
|
||||
my $XPATH; # XPath engine (XML::XPath or XML::XPathEngine);
|
||||
my $XPATH_NUMBER; # <$XPATH>::Number, the XPath number class
|
||||
BEGIN
|
||||
{ foreach my $xpath_engine ( qw( XML::XPathEngine XML::XPath) )
|
||||
{ if( XML::Twig::_use( $xpath_engine) ) { $XPATH= $xpath_engine; last; } }
|
||||
unless( $XPATH) { die "cannot use XML::Twig::XPath: neither XML::XPathEngine 0.09+ nor XML::XPath are available"; }
|
||||
$XPATH_NUMBER= "${XPATH}::Number";
|
||||
}
|
||||
|
||||
|
||||
use vars qw($VERSION);
|
||||
$VERSION="0.02";
|
||||
|
||||
BEGIN
|
||||
{ package # hide from PAUSE
|
||||
XML::XPath::NodeSet;
|
||||
no warnings; # to avoid the "Subroutine sort redefined" message
|
||||
# replace the native sort routine by a Twig'd one
|
||||
sub sort
|
||||
{ my $self = CORE::shift;
|
||||
@$self = CORE::sort { $a->node_cmp( $b) } @$self;
|
||||
return $self;
|
||||
}
|
||||
|
||||
package # hide from PAUSE
|
||||
XML::XPathEngine::NodeSet;
|
||||
no warnings; # to avoid the "Subroutine sort redefined" message
|
||||
# replace the native sort routine by a Twig'd one
|
||||
sub sort
|
||||
{ my $self = CORE::shift;
|
||||
@$self = CORE::sort { $a->node_cmp( $b) } @$self;
|
||||
return $self;
|
||||
}
|
||||
}
|
||||
|
||||
package XML::Twig::XPath;
|
||||
|
||||
use base 'XML::Twig';
|
||||
|
||||
my $XP; # the global xp object;
|
||||
|
||||
sub to_number { return $XPATH_NUMBER->new( $_[0]->root->text); }
|
||||
|
||||
sub new
|
||||
{ my $class= shift;
|
||||
my $t= XML::Twig->new( elt_class => 'XML::Twig::XPath::Elt', @_);
|
||||
$t->{twig_xp}= $XPATH->new();
|
||||
bless $t, $class;
|
||||
return $t;
|
||||
}
|
||||
|
||||
|
||||
sub set_namespace { my $t= shift; $t->{twig_xp}->set_namespace( @_); }
|
||||
sub set_strict_namespaces { my $t= shift; $t->{twig_xp}->set_strict_namespaces( @_); }
|
||||
|
||||
sub node_cmp($$) { return $_[1] == $_[0] ? 0 : -1; } # document is before anything but itself
|
||||
|
||||
sub isElementNode { 0 }
|
||||
sub isAttributeNode { 0 }
|
||||
sub isTextNode { 0 }
|
||||
sub isProcessingInstructionNode { 0 }
|
||||
sub isPINode { 0 }
|
||||
sub isCommentNode { 0 }
|
||||
sub isNamespaceNode { 0 }
|
||||
sub getAttributes { [] }
|
||||
sub getValue { return $_[0]->root->text; }
|
||||
|
||||
sub findnodes { my( $t, $path)= @_; return $t->{twig_xp}->findnodes( $path, $t); }
|
||||
sub findnodes_as_string { my( $t, $path)= @_; return $t->{twig_xp}->findnodes_as_string( $path, $t); }
|
||||
sub findvalue { my( $t, $path)= @_; return $t->{twig_xp}->findvalue( $path, $t); }
|
||||
sub exists { my( $t, $path)= @_; return $t->{twig_xp}->exists( $path, $t); }
|
||||
sub find { my( $t, $path)= @_; return $t->{twig_xp}->find( $path, $t); }
|
||||
sub matches { my( $t, $path, $node)= @_; $node ||= $t; return $t->{twig_xp}->matches( $node, $path, $t) || 0; }
|
||||
|
||||
sub getNamespaces { $_[0]->root->getNamespaces(); }
|
||||
|
||||
#TODO: it would be nice to be able to pass in any object in this
|
||||
#distribution and cast it to the proper $XPATH class to use as a
|
||||
#variable (via 'nodes' argument or something)
|
||||
sub set_var {
|
||||
my ($t, $name, $value) = @_;
|
||||
if( ! ref $value) { $value= $t->findnodes( qq{"$value"}); }
|
||||
$t->{twig_xp}->set_var($name, $value);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# adds the appropriate methods to XML::Twig::Elt so XML::XPath can be used as the XPath engine
|
||||
package XML::Twig::XPath::Elt;
|
||||
use base 'XML::Twig::Elt';
|
||||
|
||||
*getLocalName= *XML::Twig::Elt::local_name;
|
||||
*getValue = *XML::Twig::Elt::text;
|
||||
sub isAttributeNode { 0 }
|
||||
sub isNamespaceNode { 0 }
|
||||
|
||||
sub to_number { return $XPATH_NUMBER->new( $_[0]->text); }
|
||||
|
||||
sub getAttributes
|
||||
{ my $elt= shift;
|
||||
my $atts= $elt->atts;
|
||||
# alternate, faster but less clean, way
|
||||
my @atts= map { bless( { name => $_, value => $atts->{$_}, elt => $elt },
|
||||
'XML::Twig::XPath::Attribute')
|
||||
}
|
||||
sort keys %$atts;
|
||||
# my @atts= map { XML::Twig::XPath::Attribute->new( $elt, $_) } sort keys %$atts;
|
||||
return wantarray ? @atts : \@atts;
|
||||
}
|
||||
|
||||
sub getNamespace
|
||||
{ my $elt= shift;
|
||||
my $prefix= shift() || $elt->ns_prefix;
|
||||
if( my $expanded= $elt->namespace( $prefix))
|
||||
{ return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
|
||||
else
|
||||
{ return XML::Twig::XPath::Namespace->new( $prefix, ''); }
|
||||
}
|
||||
|
||||
# returns namespaces declared in the element
|
||||
sub getNamespaces #_get_namespaces
|
||||
{ my( $elt)= @_;
|
||||
my @namespaces;
|
||||
foreach my $att ($elt->att_names)
|
||||
{ if( $att=~ m{^xmlns(?::(\w+))?$})
|
||||
{ my $prefix= $1 || '';
|
||||
my $expanded= $elt->att( $att);
|
||||
push @namespaces, XML::Twig::XPath::Namespace->new( $prefix, $expanded);
|
||||
}
|
||||
}
|
||||
return wantarray() ? @namespaces : \@namespaces;
|
||||
}
|
||||
|
||||
sub node_cmp($$)
|
||||
{ my( $a, $b)= @_;
|
||||
if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
|
||||
{ # 2 elts, compare them
|
||||
return $a->cmp( $b);
|
||||
}
|
||||
elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
|
||||
{ # elt <=> att, compare the elt to the att->{elt}
|
||||
# if the elt is the att->{elt} (cmp return 0) then -1, elt is before att
|
||||
return ($a->cmp( $b->{elt}) ) || -1 ;
|
||||
}
|
||||
elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
|
||||
{ # elt <=> document, elt is after document
|
||||
return 1;
|
||||
}
|
||||
else
|
||||
{ die "unknown node type ", ref( $b); }
|
||||
}
|
||||
|
||||
sub getParentNode
|
||||
{ return $_[0]->_parent
|
||||
|| $_[0]->twig;
|
||||
}
|
||||
|
||||
sub findnodes { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes( $path, $elt); }
|
||||
sub findnodes_as_string { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes_as_string( $path, $elt); }
|
||||
sub findvalue { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findvalue( $path, $elt); }
|
||||
sub exists { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->exists( $path, $elt); }
|
||||
sub find { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->find( $path, $elt); }
|
||||
sub matches { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->matches( $elt, $path, $elt->getParentNode) || 0; }
|
||||
|
||||
|
||||
1;
|
||||
|
||||
# this package is only used to allow XML::XPath as the XPath engine, otherwise
|
||||
# attributes are just attached to their parent element and are not considered objects
|
||||
|
||||
package XML::Twig::XPath::Attribute;
|
||||
|
||||
sub new
|
||||
{ my( $class, $elt, $att)= @_;
|
||||
return bless { name => $att, value => $elt->att( $att), elt => $elt }, $class;
|
||||
}
|
||||
|
||||
sub getValue { return $_[0]->{value}; }
|
||||
sub getName { return $_[0]->{name} ; }
|
||||
sub getLocalName { (my $name= $_[0]->{name}) =~ s{^.*:}{}; $name; }
|
||||
sub string_value { return $_[0]->{value}; }
|
||||
sub to_number { return $XPATH_NUMBER->new( $_[0]->{value}); }
|
||||
sub isElementNode { 0 }
|
||||
sub isAttributeNode { 1 }
|
||||
sub isNamespaceNode { 0 }
|
||||
sub isTextNode { 0 }
|
||||
sub isProcessingInstructionNode { 0 }
|
||||
sub isPINode { 0 }
|
||||
sub isCommentNode { 0 }
|
||||
sub toString { return qq{$_[0]->{name}="$_[0]->{value}"}; }
|
||||
|
||||
sub getNamespace
|
||||
{ my $att= shift;
|
||||
my $prefix= shift();
|
||||
if( ! defined( $prefix))
|
||||
{ if($att->{name}=~ m{^(.*):}) { $prefix= $1; }
|
||||
else { $prefix=''; }
|
||||
}
|
||||
|
||||
if( my $expanded= $att->{elt}->namespace( $prefix))
|
||||
{ return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
|
||||
}
|
||||
|
||||
sub node_cmp($$)
|
||||
{ my( $a, $b)= @_;
|
||||
if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
|
||||
{ # 2 attributes, compare their elements, then their name
|
||||
return ($a->{elt}->cmp( $b->{elt}) ) || ($a->{name} cmp $b->{name});
|
||||
}
|
||||
elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
|
||||
{ # att <=> elt : compare the att->elt and the elt
|
||||
# if att->elt is the elt (cmp returns 0) then 1 (elt is before att)
|
||||
return ($a->{elt}->cmp( $b) ) || 1 ;
|
||||
}
|
||||
elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
|
||||
{ # att <=> document, att is after document
|
||||
return 1;
|
||||
}
|
||||
else
|
||||
{ die "unknown node type ", ref( $b); }
|
||||
}
|
||||
|
||||
*cmp=*node_cmp;
|
||||
|
||||
1;
|
||||
|
||||
package XML::Twig::XPath::Namespace;
|
||||
|
||||
sub new
|
||||
{ my( $class, $prefix, $expanded)= @_;
|
||||
bless { prefix => $prefix, expanded => $expanded }, $class;
|
||||
}
|
||||
|
||||
sub isNamespaceNode { 1; }
|
||||
|
||||
sub getPrefix { $_[0]->{prefix}; }
|
||||
sub getExpanded { $_[0]->{expanded}; }
|
||||
sub getValue { $_[0]->{expanded}; }
|
||||
sub getData { $_[0]->{expanded}; }
|
||||
|
||||
sub node_cmp($$)
|
||||
{ my( $a, $b)= @_;
|
||||
if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Namespace'))
|
||||
{ # 2 attributes, compare their elements, then their name
|
||||
return $a->{prefix} cmp $b->{prefix};
|
||||
}
|
||||
else
|
||||
{ die "unknown node type ", ref( $b); }
|
||||
}
|
||||
|
||||
*cmp=*node_cmp;
|
||||
|
||||
1
|
||||
|
||||
Reference in New Issue
Block a user