232 lines
7.6 KiB
Perl
232 lines
7.6 KiB
Perl
# $Id: /xmltwig/trunk/Twig/XPath.pm 32 2008-01-18T13:11:52.128782Z mrodrigu $
|
|
package XML::Twig::XPath;
|
|
use strict;
|
|
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; }
|
|
|
|
#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, ''); }
|
|
}
|
|
|
|
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}; }
|
|
|
|
1
|
|
|