Tree-XPathEngine-0.05/ 0000755 0000764 0000144 00000000000 10374646304 014267 5 ustar mrodrigu users Tree-XPathEngine-0.05/lib/ 0000755 0000764 0000144 00000000000 10374646304 015035 5 ustar mrodrigu users Tree-XPathEngine-0.05/lib/Tree/ 0000755 0000764 0000144 00000000000 10374646304 015734 5 ustar mrodrigu users Tree-XPathEngine-0.05/lib/Tree/XPathEngine/ 0000755 0000764 0000144 00000000000 10374646304 020106 5 ustar mrodrigu users Tree-XPathEngine-0.05/lib/Tree/XPathEngine/Number.pm 0000644 0000764 0000144 00000004111 10373565402 021667 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/Number.pm 17 2006-02-12T08:00:01.814064Z mrodrigu $
package Tree::XPathEngine::Number;
use Tree::XPathEngine::Boolean;
use Tree::XPathEngine::Literal;
use strict;
use overload
'""' => \&value,
'0+' => \&value,
'<=>' => \&xpath_cmp;
sub new {
my $class = shift;
my $number = shift;
if ($number !~ /^\s*[+-]?(\d+(\.\d*)?|\.\d+)\s*$/) {
$number = undef;
}
else {
$number =~ s/^\s*(.*)\s*$/$1/;
}
bless \$number, $class;
}
sub as_string {
my $self = shift;
defined $$self ? $$self : 'NaN';
}
sub as_xml {
my $self = shift;
return "" . (defined($$self) ? $$self : 'NaN') . "\n";
}
sub value {
my $self = shift;
$$self;
}
sub xpath_cmp {
my $self = shift;
my ($other, $swap) = @_;
if ($swap) {
return $other <=> $$self;
}
return $$self <=> $other;
}
sub evaluate {
my $self = shift;
$self;
}
sub xpath_to_boolean {
my $self = shift;
return $$self ? Tree::XPathEngine::Boolean->_true : Tree::XPathEngine::Boolean->_false;
}
sub xpath_to_literal { Tree::XPathEngine::Literal->new($_[0]->as_string); }
sub xpath_to_number { $_[0]; }
sub xpath_string_value { return $_[0]->value }
1;
__END__
=head1 NAME
Tree::XPathEngine::Number - Simple numeric values.
=head1 DESCRIPTION
This class holds simple numeric values. It doesn't support -0, +/- Infinity,
or NaN, as the XPath spec says it should, but I'm not hurting anyone I don't think.
=head1 API
=head2 new($num)
Creates a new Tree::XPathEngine::Number object, with the value in $num. Does some
rudimentary numeric checking on $num to ensure it actually is a number.
=head2 value()
Also as overloaded stringification. Returns the numeric value held.
=head2 Other Methods
Those are needed so the objects can be properly processed in various contexts
=over 4
=item as_string
=item as_xml
=item value
=item xpath_cmp
=item evaluate
=item xpath_to_boolean
=item xpath_to_literal
=item xpath_to_number
=item xpath_string_value
=back
=cut
Tree-XPathEngine-0.05/lib/Tree/XPathEngine/NodeSet.pm 0000644 0000764 0000144 00000010112 10373565402 021776 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/NodeSet.pm 17 2006-02-12T08:00:01.814064Z mrodrigu $
package Tree::XPathEngine::NodeSet;
use strict;
use Tree::XPathEngine::Boolean;
use overload
'""' => \&xpath_to_literal,
'bool' => \&xpath_to_boolean,
;
sub new {
my $class = shift;
bless [], $class;
}
sub sort {
my $self = CORE::shift;
@$self = CORE::sort { $a->xpath_cmp( $b) } @$self;
return $self;
}
sub remove_duplicates {
my $self = CORE::shift;
my @unique;
my $last_node=0;
foreach my $node (@$self) {
push @unique, $node unless( $node == $last_node);
$last_node= $node;
}
@$self= @unique;
return $self;
}
sub pop {
my $self = CORE::shift;
CORE::pop @$self;
}
sub push {
my $self = CORE::shift;
my (@nodes) = @_;
CORE::push @$self, @nodes;
}
sub append {
my $self = CORE::shift;
my ($nodeset) = @_;
CORE::push @$self, $nodeset->get_nodelist;
}
sub shift {
my $self = CORE::shift;
CORE::shift @$self;
}
sub unshift {
my $self = CORE::shift;
my (@nodes) = @_;
CORE::unshift @$self, @nodes;
}
sub prepend {
my $self = CORE::shift;
my ($nodeset) = @_;
CORE::unshift @$self, $nodeset->get_nodelist;
}
sub size {
my $self = CORE::shift;
scalar @$self;
}
sub get_node { # uses array index starting at 1, not 0
my $self = CORE::shift;
my ($pos) = @_;
$self->[$pos - 1];
}
sub xpath_get_root_node {
my $self = CORE::shift;
return $self->[0]->xpath_get_root_node;
}
sub get_nodelist {
my $self = CORE::shift;
@$self;
}
sub xpath_to_boolean {
my $self = CORE::shift;
return (@$self > 0) ? Tree::XPathEngine::Boolean->_true : Tree::XPathEngine::Boolean->_false;
}
sub xpath_string_value {
my $self = CORE::shift;
return '' unless @$self;
return $self->[0]->xpath_string_value;
}
sub xpath_to_literal {
my $self = CORE::shift;
return Tree::XPathEngine::Literal->new(
join('', map { $_->xpath_string_value } @$self)
);
}
sub xpath_to_number {
my $self = CORE::shift;
return Tree::XPathEngine::Number->new(
$self->xpath_to_literal
);
}
1;
__END__
=head1 NAME
Tree::XPathEngine::NodeSet - a list of XML document nodes
=head1 DESCRIPTION
An Tree::XPathEngine::NodeSet object contains an ordered list of nodes. The nodes
each take the same format as described in L.
=head1 SYNOPSIS
my $results = $xp->find('//someelement');
if (!$results->isa('Tree::XPathEngine::NodeSet')) {
print "Found $results\n";
exit;
}
foreach my $context ($results->get_nodelist) {
my $newresults = $xp->find('./other/element', $context);
...
}
=head1 API
=head2 new()
You will almost never have to create a new NodeSet object, as it is all
done for you by XPath.
=head2 get_nodelist()
Returns a list of nodes. See L for the format of
the nodes.
=head2 xpath_string_value()
Returns the string-value of the first node in the list.
See the XPath specification for what "string-value" means.
=head2 xpath_to_literal()
Returns the concatenation of all the string-values of all
the nodes in the list.
=head2 get_node($pos)
Returns the node at $pos. The node position in XPath is based at 1, not 0.
=head2 size()
Returns the number of nodes in the NodeSet.
=head2 pop()
Equivalent to perl's pop function.
=head2 push(@nodes)
Equivalent to perl's push function.
=head2 append($nodeset)
Given a nodeset, appends the list of nodes in $nodeset to the end of the
current list.
=head2 shift()
Equivalent to perl's shift function.
=head2 unshift(@nodes)
Equivalent to perl's unshift function.
=head2 prepend($nodeset)
Given a nodeset, prepends the list of nodes in $nodeset to the front of
the current list.
=head2 xpath_get_root_node
Returns the root node of the first node in the set
=head2 sort
Returns a sorted nodeset using the C method on nodes
=head2 remove_duplicates
Returns a sorted nodeset of unique nodes. The input nodeset MUST be sorted
=head2 xpath_to_boolean
Returns true if the nodeset is not empty
=head2 xpath_to_number
Returns the concatenation of all the string-values of all
the nodes in the list as a Tree::XPathEngine::Number object;
=cut
Tree-XPathEngine-0.05/lib/Tree/XPathEngine/Function.pm 0000644 0000764 0000144 00000025445 10374646276 022253 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/Function.pm 26 2006-02-15T15:46:06.515200Z mrodrigu $
package Tree::XPathEngine::Function;
use Tree::XPathEngine::Number;
use Tree::XPathEngine::Literal;
use Tree::XPathEngine::Boolean;
use Tree::XPathEngine::NodeSet;
use strict;
sub new {
my $class = shift;
my ($pp, $name, $params) = @_;
bless {
pp => $pp,
name => $name,
params => $params
}, $class;
}
sub as_string {
my $self = shift;
my $string = $self->{name} . "(";
my $second;
foreach (@{$self->{params}}) {
$string .= "," if $second++;
$string .= $_->as_string;
}
$string .= ")";
return $string;
}
sub evaluate {
my $self = shift;
my $node = shift;
if ($node->isa('Tree::XPathEngine::NodeSet')) {
$node = $node->get_node(1);
}
my @params;
foreach my $param (@{$self->{params}}) {
my $results = $param->evaluate($node);
push @params, $results;
}
$self->_execute($self->{name}, $node, @params);
}
sub _execute {
my $self = shift;
my ($name, $node, @params) = @_;
$name =~ s/-/_/g;
no strict 'refs';
$self->$name($node, @params);
}
# All functions should return one of:
# Tree::XPathEngine::Number
# Tree::XPathEngine::Literal (string)
# Tree::XPathEngine::NodeSet
# Tree::XPathEngine::Boolean
### NODESET FUNCTIONS ###
sub last {
my $self = shift;
my ($node, @params) = @_;
die "last: function doesn't take parameters\n" if (@params);
return Tree::XPathEngine::Number->new($self->{pp}->_get_context_size);
}
sub position {
my $self = shift;
my ($node, @params) = @_;
if (@params) {
die "position: function doesn't take parameters [ ", @params, " ]\n";
}
# return pos relative to axis direction
return Tree::XPathEngine::Number->new($self->{pp}->_get_context_pos);
}
sub count {
my $self = shift;
my ($node, @params) = @_;
die "count: Parameter must be a NodeSet\n" unless $params[0]->isa('Tree::XPathEngine::NodeSet');
return Tree::XPathEngine::Number->new($params[0]->size);
}
sub id {
my $self = shift;
my ($node, @params) = @_;
die "id: Function takes 1 parameter\n" unless @params == 1;
my $results = Tree::XPathEngine::NodeSet->new();
if ($params[0]->isa('Tree::XPathEngine::NodeSet')) {
# result is the union of applying id() to the
# string value of each node in the nodeset.
foreach my $node ($params[0]->get_nodelist) {
my $string = $node->xpath_string_value;
$results->append($self->id($node, Tree::XPathEngine::Literal->new($string)));
}
}
else { # The actual id() function...
my $string = $self->string($node, $params[0]);
$_ = $string->value; # get perl scalar
my @ids = split; # splits $_
foreach my $id (@ids) {
if (my $found = $node->get_element_by_id($id)) {
$results->push($found);
}
}
}
return $results;
}
sub name {
my $self = shift;
my ($node, @params) = @_;
if (@params > 1) {
die "name() function takes one or no parameters\n";
}
elsif (@params) {
my $nodeset = shift(@params);
$node = $nodeset->get_node(1);
}
return Tree::XPathEngine::Literal->new($node->xpath_get_name);
}
### STRING FUNCTIONS ###
sub string {
my $self = shift;
my ($node, @params) = @_;
die "string: Too many parameters\n" if @params > 1;
if (@params) {
return Tree::XPathEngine::Literal->new($params[0]->xpath_string_value);
}
# TODO - this MUST be wrong! - not sure now. -matt
return Tree::XPathEngine::Literal->new($node->xpath_string_value);
# default to nodeset with just $node in.
}
sub concat {
my $self = shift;
my ($node, @params) = @_;
die "concat: Too few parameters\n" if @params < 2;
my $string = join('', map {$_->xpath_string_value} @params);
return Tree::XPathEngine::Literal->new($string);
}
sub starts_with {
my $self = shift;
my ($node, @params) = @_;
die "starts-with: incorrect number of params\n" unless @params == 2;
my ($string1, $string2) = ($params[0]->xpath_string_value, $params[1]->xpath_string_value);
if (substr($string1, 0, length($string2)) eq $string2) {
return Tree::XPathEngine::Boolean->_true;
}
return Tree::XPathEngine::Boolean->_false;
}
sub contains {
my $self = shift;
my ($node, @params) = @_;
die "starts-with: incorrect number of params\n" unless @params == 2;
my $value = $params[1]->xpath_string_value;
if ($params[0]->xpath_string_value =~ /\Q$value\E/) {
return Tree::XPathEngine::Boolean->_true;
}
return Tree::XPathEngine::Boolean->_false;
}
sub substring_before {
my $self = shift;
my ($node, @params) = @_;
die "starts-with: incorrect number of params\n" unless @params == 2;
my $long = $params[0]->xpath_string_value;
my $short= $params[1]->xpath_string_value;
if( $long=~ m{^(.*?)\Q$short}) {
return Tree::XPathEngine::Literal->new($1);
}
else {
return Tree::XPathEngine::Literal->new('');
}
}
sub substring_after {
my $self = shift;
my ($node, @params) = @_;
die "starts-with: incorrect number of params\n" unless @params == 2;
my $long = $params[0]->xpath_string_value;
my $short= $params[1]->xpath_string_value;
if( $long=~ m{\Q$short\E(.*)$}) {
return Tree::XPathEngine::Literal->new($1);
}
else {
return Tree::XPathEngine::Literal->new('');
}
}
sub substring {
my $self = shift;
my ($node, @params) = @_;
die "substring: Wrong number of parameters\n" if (@params < 2 || @params > 3);
my ($str, $offset, $len);
$str = $params[0]->xpath_string_value;
$offset = $params[1]->value;
$offset--; # uses 1 based offsets
if (@params == 3) {
$len = $params[2]->value;
return Tree::XPathEngine::Literal->new(substr($str, $offset, $len));
}
else {
return Tree::XPathEngine::Literal->new(substr($str, $offset));
}
}
sub string_length {
my $self = shift;
my ($node, @params) = @_;
die "string-length: Wrong number of params\n" if @params > 1;
if (@params) {
return Tree::XPathEngine::Number->new(length($params[0]->xpath_string_value));
}
else {
return Tree::XPathEngine::Number->new(
length($node->xpath_string_value)
);
}
}
sub normalize_space {
my $self = shift;
my ($node, @params) = @_;
die "normalize-space: Wrong number of params\n" if @params > 1;
my $str;
if (@params) {
$str = $params[0]->xpath_string_value;
}
else {
$str = $node->xpath_string_value;
}
$str =~ s/^\s*//;
$str =~ s/\s*$//;
$str =~ s/\s+/ /g;
return Tree::XPathEngine::Literal->new($str);
}
sub translate {
my $self = shift;
my ($node, @params) = @_;
die "translate: Wrong number of params\n" if @params != 3;
local $_ = $params[0]->xpath_string_value;
my $find = $params[1]->xpath_string_value;
my $repl = $params[2]->xpath_string_value;
$repl= substr( $repl, 0, length( $find));
my %repl;
@repl{split //, $find}= split( //, $repl);
s{(.)}{exists $repl{$1} ? defined $repl{$1} ? $repl{$1} : '' : $1 }ges;
return Tree::XPathEngine::Literal->new($_);
}
### BOOLEAN FUNCTIONS ###
sub boolean {
my $self = shift;
my ($node, @params) = @_;
die "boolean: Incorrect number of parameters\n" if @params != 1;
return $params[0]->xpath_to_boolean;
}
sub not {
my $self = shift;
my ($node, @params) = @_;
$params[0] = $params[0]->xpath_to_boolean unless $params[0]->isa('Tree::XPathEngine::Boolean');
$params[0]->value ? Tree::XPathEngine::Boolean->_false : Tree::XPathEngine::Boolean->_true;
}
sub true {
my $self = shift;
my ($node, @params) = @_;
die "true: function takes no parameters\n" if @params > 0;
Tree::XPathEngine::Boolean->_true;
}
sub false {
my $self = shift;
my ($node, @params) = @_;
die "true: function takes no parameters\n" if @params > 0;
Tree::XPathEngine::Boolean->_false;
}
sub lang {
my $self = shift;
my ($node, @params) = @_;
die "lang: function takes 1 parameter\n" if @params != 1;
my $lang = $node->findvalue('(ancestor-or-self::*[@xml:lang]/@xml:lang)[last()]');
my $lclang = lc($params[0]->xpath_string_value);
# warn("Looking for lang($lclang) in $lang\n");
if (substr(lc($lang), 0, length($lclang)) eq $lclang) {
return Tree::XPathEngine::Boolean->_true;
}
else {
return Tree::XPathEngine::Boolean->_false;
}
}
### NUMBER FUNCTIONS ###
sub number {
my $self = shift;
my ($node, @params) = @_;
die "number: Too many parameters\n" if @params > 1;
if (@params) {
if ($params[0]->isa('Tree::XPathEngine::Node')) {
return Tree::XPathEngine::Number->new(
$params[0]->xpath_string_value
);
}
return $params[0]->xpath_to_number;
}
return Tree::XPathEngine::Number->new( $node->xpath_string_value );
}
sub sum {
my $self = shift;
my ($node, @params) = @_;
die "sum: Parameter must be a NodeSet\n" unless $params[0]->isa('Tree::XPathEngine::NodeSet');
my $sum = 0;
foreach my $node ($params[0]->get_nodelist) {
$sum += $self->number($node)->value;
}
return Tree::XPathEngine::Number->new($sum);
}
sub floor {
my $self = shift;
my ($node, @params) = @_;
require POSIX;
my $num = $self->number($node, @params);
return Tree::XPathEngine::Number->new(
POSIX::floor($num->value));
}
sub ceiling {
my $self = shift;
my ($node, @params) = @_;
require POSIX;
my $num = $self->number($node, @params);
return Tree::XPathEngine::Number->new(
POSIX::ceil($num->value));
}
sub round {
my $self = shift;
my ($node, @params) = @_;
my $num = $self->number($node, @params);
require POSIX;
return Tree::XPathEngine::Number->new(
POSIX::floor($num->value + 0.5)); # Yes, I know the spec says don't do this...
}
1;
__END__
=head1 NAME
Tree::XPathEngine::Function - evaluates XPath functions
=head1 METHODS
=head2 new
=head2 evaluate
evaluate the function on a nodeset
=head2 _execute
evaluate the function on a nodeset
=head2 as_string
dump the function call as a string
=head2 as_xml
dump the function call as xml
=head2 XPath methods
See the specs for details
=over 4
=item last
=item position
=item count
=item id
=item name
=item string
=item concat
=item starts_with
=item contains
=item substring
=item substring_after
=item substring_before
=item string_length
=item normalize_space
=item translate
=item boolean
=item not
=item true
=item false
=item lang
=item number
=item sum
=item floor
=item ceiling
=item round
=back
Tree-XPathEngine-0.05/lib/Tree/XPathEngine/Expr.pm 0000644 0000764 0000144 00000046413 10374061072 021363 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/Expr.pm 19 2006-02-13T10:40:57.804258Z mrodrigu $
package Tree::XPathEngine::Expr;
use strict;
sub new {
my $class = shift;
my ($pp) = @_;
bless { predicates => [], pp => $pp }, $class;
}
sub as_string {
my $self = shift;
local $^W; # Use of uninitialized value! grrr
my $string = "(" . $self->{lhs}->as_string;
$string .= " " . $self->{op} . " " if defined $self->{op};
$string .= $self->{rhs}->as_string if defined $self->{rhs};
$string .= ")";
foreach my $predicate (@{$self->{predicates}}) {
$string .= "[" . $predicate->as_string . "]";
}
return $string;
}
sub set_lhs {
my $self = shift;
$self->{lhs} = $_[0];
}
sub set_op {
my $self = shift;
$self->{op} = $_[0];
}
sub set_rhs {
my $self = shift;
$self->{rhs} = $_[0];
}
sub push_predicate {
my $self = shift;
die "Only 1 predicate allowed on FilterExpr in W3C XPath 1.0"
if @{$self->{predicates}};
push @{$self->{predicates}}, $_[0];
}
sub get_lhs { $_[0]->{lhs}; }
sub get_rhs { $_[0]->{rhs}; }
sub get_op { $_[0]->{op}; }
sub evaluate {
my $self = shift;
my $node = shift;
# If there's an op, result is result of that op.
# If no op, just resolve Expr
# warn "Evaluate Expr: ", $self->as_string, "\n";
my $results;
if ($self->{op}) {
die ("No RHS of ", $self->as_string) unless $self->{rhs};
$results = $self->_op_eval($node);
}
else {
$results = $self->{lhs}->evaluate($node);
}
if (my @predicates = @{$self->{predicates}}) {
if (!$results->isa('Tree::XPathEngine::NodeSet')) {
die "Can't have predicates execute on object type: " . ref($results);
}
# filter initial nodeset by each predicate
foreach my $predicate (@{$self->{predicates}}) {
$results = $self->filter_by_predicate($results, $predicate);
}
}
return $results;
}
sub _op_eval {
my $self = shift;
my $node = shift;
my $op = $self->{op};
for ($op) {
/^or$/ && do {
return _op_or($node, $self->{lhs}, $self->{rhs});
};
/^and$/ && do {
return _op_and($node, $self->{lhs}, $self->{rhs});
};
/^=~$/ && do {
return _op_match($node, $self->{lhs}, $self->{rhs});
};
/^!~$/ && do {
return _op_not_match($node, $self->{lhs}, $self->{rhs});
};
/^=$/ && do {
return _op_equals($node, $self->{lhs}, $self->{rhs});
};
/^!=$/ && do {
return _op_nequals($node, $self->{lhs}, $self->{rhs});
};
/^<=$/ && do {
return _op_le($node, $self->{lhs}, $self->{rhs});
};
/^>=$/ && do {
return _op_ge($node, $self->{lhs}, $self->{rhs});
};
/^>$/ && do {
return _op_gt($node, $self->{lhs}, $self->{rhs});
};
/^<$/ && do {
return _op_lt($node, $self->{lhs}, $self->{rhs});
};
/^\+$/ && do {
return _op_plus($node, $self->{lhs}, $self->{rhs});
};
/^-$/ && do {
return _op_minus($node, $self->{lhs}, $self->{rhs});
};
/^div$/ && do {
return _op_div($node, $self->{lhs}, $self->{rhs});
};
/^mod$/ && do {
return _op_mod($node, $self->{lhs}, $self->{rhs});
};
/^\*$/ && do {
return _op_mult($node, $self->{lhs}, $self->{rhs});
};
/^\|$/ && do {
return _op_union($node, $self->{lhs}, $self->{rhs});
};
die "No such operator, or operator unimplemented in ", $self->as_string, "\n";
}
}
# Operators
use Tree::XPathEngine::Boolean;
sub _op_or {
my ($node, $lhs, $rhs) = @_;
if($lhs->evaluate($node)->xpath_to_boolean->value) {
return Tree::XPathEngine::Boolean->_true;
}
else {
return $rhs->evaluate($node)->xpath_to_boolean;
}
}
sub _op_and {
my ($node, $lhs, $rhs) = @_;
if( ! $lhs->evaluate($node)->xpath_to_boolean->value ) {
return Tree::XPathEngine::Boolean->_false;
}
else {
return $rhs->evaluate($node)->xpath_to_boolean;
}
}
sub _op_equals {
my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
if ($lh_results->isa('Tree::XPathEngine::NodeSet') &&
$rh_results->isa('Tree::XPathEngine::NodeSet')) {
# _true if and only if there is a node in the
# first set and a node in the second set such
# that the result of performing the comparison
# on the string-values of the two nodes is true.
foreach my $lhnode ($lh_results->get_nodelist) {
foreach my $rhnode ($rh_results->get_nodelist) {
if ($lhnode->xpath_string_value eq $rhnode->xpath_string_value) {
return Tree::XPathEngine::Boolean->_true;
}
}
}
return Tree::XPathEngine::Boolean->_false;
}
elsif (($lh_results->isa('Tree::XPathEngine::NodeSet') ||
$rh_results->isa('Tree::XPathEngine::NodeSet')) &&
(!$lh_results->isa('Tree::XPathEngine::NodeSet') ||
!$rh_results->isa('Tree::XPathEngine::NodeSet'))) {
# (that says: one is a nodeset, and one is not a nodeset)
my ($nodeset, $other);
if ($lh_results->isa('Tree::XPathEngine::NodeSet')) {
$nodeset = $lh_results;
$other = $rh_results;
}
else {
$nodeset = $rh_results;
$other = $lh_results;
}
# _true if and only if there is a node in the
# nodeset such that the result of performing
# the comparison on (string_value($node))
# is true.
if ($other->isa('Tree::XPathEngine::Number')) {
foreach my $node ($nodeset->get_nodelist) {
local $^W; # argument isn't numeric
if ($node->xpath_string_value == $other->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
}
elsif ($other->isa('Tree::XPathEngine::Literal')) {
foreach my $node ($nodeset->get_nodelist) {
if ($node->xpath_string_value eq $other->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
}
elsif ($other->isa('Tree::XPathEngine::Boolean')) {
if ($nodeset->xpath_to_boolean->value == $other->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
return Tree::XPathEngine::Boolean->_false;
}
else { # Neither is a nodeset
if ($lh_results->isa('Tree::XPathEngine::Boolean') ||
$rh_results->isa('Tree::XPathEngine::Boolean')) {
# if either is a boolean
if ($lh_results->xpath_to_boolean->value == $rh_results->xpath_to_boolean->value) {
return Tree::XPathEngine::Boolean->_true;
}
return Tree::XPathEngine::Boolean->_false;
}
elsif ($lh_results->isa('Tree::XPathEngine::Number') ||
$rh_results->isa('Tree::XPathEngine::Number')) {
# if either is a number
local $^W; # 'number' might result in undef
if ($lh_results->xpath_to_number->value == $rh_results->xpath_to_number->value) {
return Tree::XPathEngine::Boolean->_true;
}
return Tree::XPathEngine::Boolean->_false;
}
else {
if ($lh_results->xpath_to_literal->value eq $rh_results->xpath_to_literal->value) {
return Tree::XPathEngine::Boolean->_true;
}
return Tree::XPathEngine::Boolean->_false;
}
}
}
sub _op_match
{ my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
my $rh_value = $rh_results->xpath_string_value;
if ($lh_results->isa('Tree::XPathEngine::NodeSet') )
{ foreach my $lhnode ($lh_results->get_nodelist)
{ if ($lhnode->xpath_string_value=~ m/$rh_value/) # / is important here, regexp is / delimited
{ return Tree::XPathEngine::Boolean->_true; }
}
return Tree::XPathEngine::Boolean->_false;
}
else
{ return $lh_results->xpath_string_value =~ m!$rh_value! ?
Tree::XPathEngine::Boolean->_true : Tree::XPathEngine::Boolean->_false;
}
}
sub _op_not_match
{ my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
my $rh_value = $rh_results->xpath_string_value;
if ($lh_results->isa('Tree::XPathEngine::NodeSet') )
{ foreach my $lhnode ($lh_results->get_nodelist)
{ if ($lhnode->xpath_string_value!~ m!$rh_value!)
{ return Tree::XPathEngine::Boolean->_true; }
}
return Tree::XPathEngine::Boolean->_false;
}
else
{ return $lh_results->xpath_string_value !~ m!$rh_value! ?
Tree::XPathEngine::Boolean->_true : Tree::XPathEngine::Boolean->_false;
}
}
sub _op_nequals {
my ($node, $lhs, $rhs) = @_;
if (_op_equals($node, $lhs, $rhs)->value) {
return Tree::XPathEngine::Boolean->_false;
}
return Tree::XPathEngine::Boolean->_true;
}
sub _op_le {
my ($node, $lhs, $rhs) = @_;
_op_ge($node, $rhs, $lhs);
}
sub _op_ge {
my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
if ($lh_results->isa('Tree::XPathEngine::NodeSet') &&
$rh_results->isa('Tree::XPathEngine::NodeSet')) {
foreach my $lhnode ($lh_results->get_nodelist) {
foreach my $rhnode ($rh_results->get_nodelist) {
my $lhNum = Tree::XPathEngine::Number->new($lhnode->xpath_string_value);
my $rhNum = Tree::XPathEngine::Number->new($rhnode->xpath_string_value);
local $^W; # Use of uninitialized value!
if ($lhNum->value >= $rhNum->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
}
return Tree::XPathEngine::Boolean->_false;
}
elsif (($lh_results->isa('Tree::XPathEngine::NodeSet') ||
$rh_results->isa('Tree::XPathEngine::NodeSet')) &&
(!$lh_results->isa('Tree::XPathEngine::NodeSet') ||
!$rh_results->isa('Tree::XPathEngine::NodeSet'))) {
# (that says: one is a nodeset, and one is not a nodeset)
if ($lh_results->isa('Tree::XPathEngine::NodeSet')) {
foreach my $node ($lh_results->get_nodelist) {
local $^W; # Use of uninitialized value!
if ($node->xpath_to_number->value >= $rh_results->xpath_to_number->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
}
else {
foreach my $node ($rh_results->get_nodelist) {
local $^W; # Use of uninitialized value!
if ( $lh_results->xpath_to_number->value >= $node->xpath_to_number->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
}
return Tree::XPathEngine::Boolean->_false;
}
else { # Neither is a nodeset
if ($lh_results->isa('Tree::XPathEngine::Boolean') ||
$rh_results->isa('Tree::XPathEngine::Boolean')) {
# if either is a boolean
if ($lh_results->xpath_to_boolean->xpath_to_number->value
>= $rh_results->xpath_to_boolean->xpath_to_number->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
else {
if ($lh_results->xpath_to_number->value >= $rh_results->xpath_to_number->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
return Tree::XPathEngine::Boolean->_false;
}
}
sub _op_gt {
my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
if ($lh_results->isa('Tree::XPathEngine::NodeSet') &&
$rh_results->isa('Tree::XPathEngine::NodeSet')) {
foreach my $lhnode ($lh_results->get_nodelist) {
foreach my $rhnode ($rh_results->get_nodelist) {
my $lhNum = Tree::XPathEngine::Number->new($lhnode->xpath_string_value);
my $rhNum = Tree::XPathEngine::Number->new($rhnode->xpath_string_value);
local $^W; # Use of uninitialized value!
if ($lhNum->value > $rhNum->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
}
return Tree::XPathEngine::Boolean->_false;
}
elsif (($lh_results->isa('Tree::XPathEngine::NodeSet') ||
$rh_results->isa('Tree::XPathEngine::NodeSet')) &&
(!$lh_results->isa('Tree::XPathEngine::NodeSet') ||
!$rh_results->isa('Tree::XPathEngine::NodeSet'))) {
# (that says: one is a nodeset, and one is not a nodeset)
if ($lh_results->isa('Tree::XPathEngine::NodeSet')) {
foreach my $node ($lh_results->get_nodelist) {
local $^W; # Use of uninitialized value!
if ($node->xpath_to_number->value > $rh_results->xpath_to_number->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
}
else {
foreach my $node ($rh_results->get_nodelist) {
local $^W; # Use of uninitialized value!
if ( $lh_results->xpath_to_number->value > $node->xpath_to_number->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
}
return Tree::XPathEngine::Boolean->_false;
}
else { # Neither is a nodeset
if ($lh_results->isa('Tree::XPathEngine::Boolean') ||
$rh_results->isa('Tree::XPathEngine::Boolean')) {
# if either is a boolean
if ($lh_results->xpath_to_boolean->value > $rh_results->xpath_to_boolean->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
else {
if ($lh_results->xpath_to_number->value > $rh_results->xpath_to_number->value) {
return Tree::XPathEngine::Boolean->_true;
}
}
return Tree::XPathEngine::Boolean->_false;
}
}
sub _op_lt {
my ($node, $lhs, $rhs) = @_;
_op_gt($node, $rhs, $lhs);
}
sub _op_plus {
my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
local $^W;
my $result =
$lh_results->xpath_to_number->value
+
$rh_results->xpath_to_number->value
;
return Tree::XPathEngine::Number->new($result);
}
sub _op_minus {
my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
local $^W;
my $result =
$lh_results->xpath_to_number->value
-
$rh_results->xpath_to_number->value
;
return Tree::XPathEngine::Number->new($result);
}
sub _op_div {
my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
local $^W;
my $result = eval {
$lh_results->xpath_to_number->value
/
$rh_results->xpath_to_number->value
;
};
if ($@) {
# assume divide by zero
# This is probably a terrible way to handle this!
# Ah well... who wants to live forever...
return Tree::XPathEngine::Literal->new('Infinity');
}
return Tree::XPathEngine::Number->new($result);
}
sub _op_mod {
my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
local $^W;
my $result =
$lh_results->xpath_to_number->value
%
$rh_results->xpath_to_number->value
;
return Tree::XPathEngine::Number->new($result);
}
sub _op_mult {
my ($node, $lhs, $rhs) = @_;
my $lh_results = $lhs->evaluate($node);
my $rh_results = $rhs->evaluate($node);
local $^W;
my $result =
$lh_results->xpath_to_number->value
*
$rh_results->xpath_to_number->value
;
return Tree::XPathEngine::Number->new($result);
}
sub _op_union {
my ($node, $lhs, $rhs) = @_;
my $lh_result = $lhs->evaluate($node);
my $rh_result = $rhs->evaluate($node);
if ($lh_result->isa('Tree::XPathEngine::NodeSet') &&
$rh_result->isa('Tree::XPathEngine::NodeSet')) {
my %found;
my $results = Tree::XPathEngine::NodeSet->new;
foreach my $lhnode ($lh_result->get_nodelist) {
$found{"$lhnode"}++;
$results->push($lhnode);
}
foreach my $rhnode ($rh_result->get_nodelist) {
$results->push($rhnode)
unless exists $found{"$rhnode"};
}
return $results->sort->remove_duplicates;
}
die "Both sides of a union must be Node Sets\n";
}
sub filter_by_predicate {
my $self = shift;
my ($nodeset, $predicate) = @_;
# See spec section 2.4, paragraphs 2 & 3:
# For each node in the node-set to be filtered, the predicate Expr
# is evaluated with that node as the context node, with the number
# of nodes in the node set as the context size, and with the
# proximity position of the node in the node set with respect to
# the axis as the context position.
if (!ref($nodeset)) { # use ref because nodeset has a bool context
die "No nodeset!!!";
}
# warn "Filter by predicate: $predicate\n";
my $newset = Tree::XPathEngine::NodeSet->new();
for(my $i = 1; $i <= $nodeset->size; $i++) {
# set context set each time 'cos a loc-path in the expr could change it
$self->{pp}->_set_context_set($nodeset);
$self->{pp}->_set_context_pos($i);
my $result = $predicate->evaluate($nodeset->get_node($i));
if ($result->isa('Tree::XPathEngine::Boolean')) {
if ($result->value) {
$newset->push($nodeset->get_node($i));
}
}
elsif ($result->isa('Tree::XPathEngine::Number')) {
if ($result->value == $i) {
$newset->push($nodeset->get_node($i));
}
}
else {
if ($result->xpath_to_boolean->value) {
$newset->push($nodeset->get_node($i));
}
}
}
return $newset;
}
1;
__END__
=head1 NAME
Tree::XPathEngine::Expr - handles expressions in XPath queries
=head1 METHODS
=head2 new
=head2 op_xml
=head2 get_lhs
=head2 set_lhs
=head2 get_rhs
=head2 set_rhs
=head2 push_predicate
=head2 set_op
=head2 get_op
=head2 evaluate
=head2 filter_by_predicate
=head2 as_string
dump the expression as a string
=head2 as_xml
dump the expression as xml
Tree-XPathEngine-0.05/lib/Tree/XPathEngine/Boolean.pm 0000644 0000764 0000144 00000002636 10373565402 022030 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/Boolean.pm 17 2006-02-12T08:00:01.814064Z mrodrigu $
package Tree::XPathEngine::Boolean;
use Tree::XPathEngine::Number;
use Tree::XPathEngine::Literal;
use strict;
use overload
'""' => \&value,
'<=>' => \&xpath_cmp;
sub _true {
my $class = shift;
my $val = 1;
bless \$val, $class;
}
sub _false {
my $class = shift;
my $val = 0;
bless \$val, $class;
}
sub value {
my $self = shift;
$$self;
}
sub xpath_cmp {
my $self = shift;
my ($other, $swap) = @_;
if ($swap) {
return $other <=> $$self;
}
return $$self <=> $other;
}
sub xpath_to_number { Tree::XPathEngine::Number->new($_[0]->value); }
sub xpath_to_boolean { $_[0]; }
sub xpath_to_literal { Tree::XPathEngine::Literal->new($_[0]->value ? "true" : "false"); }
sub xpath_string_value { return $_[0]->xpath_to_literal->value; }
1;
__END__
=head1 NAME
Tree::XPathEngine::Boolean - Boolean true/false values
=head1 DESCRIPTION
Tree::XPathEngine::Boolean objects implement simple boolean true/false objects.
=head1 API
=head2 Tree::XPathEngine::Boolean->_true
Creates a new Boolean object with a true value.
=head2 Tree::XPathEngine::Boolean->_false
Creates a new Boolean object with a false value.
=head2 value()
Returns true or false.
=head2 xpath_to_literal()
Returns the string "true" or "false".
=head2 xpath_string_value
=head2 xpath_cmp
=head2 xpath_to_boolean
=head2 xpath_to_number
Tree-XPathEngine-0.05/lib/Tree/XPathEngine/LocationPath.pm 0000644 0000764 0000144 00000002534 10374110372 023024 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/LocationPath.pm 22 2006-02-13T14:00:25.731780Z mrodrigu $
package Tree::XPathEngine::LocationPath;
use strict;
sub new {
my $class = shift;
my $self = [];
bless $self, $class;
}
sub as_string {
my $self = shift;
my $string;
for (my $i = 0; $i < @$self; $i++) {
$string .= $self->[$i]->as_string;
$string .= "/" if $self->[$i+1];
}
return $string;
}
sub as_xml {
my $self = shift;
my $string = "\n";
for (my $i = 0; $i < @$self; $i++) {
$string .= $self->[$i]->as_xml;
}
$string .= "\n";
return $string;
}
sub evaluate {
my $self = shift;
# context _MUST_ be a single node
my $context = shift;
die "No context" unless $context;
# I _think_ this is how it should work :)
my $nodeset = Tree::XPathEngine::NodeSet->new();
$nodeset->push($context);
foreach my $step (@$self) {
# For each step
# evaluate the step with the nodeset
my $pos = 1;
$nodeset = $step->evaluate($nodeset);
}
return $nodeset->remove_duplicates;
}
1;
__END__
=head1 NAME Tree::XPathEngine::LocationPath - a complete XPath location path
=head1 METHODS
=head2 new
creates the location path
=head2 evaluate
evaluates it in C<$context>
=head2 as_string
dumps the location path as a string
=head2 as_xml
dumps the location path as xml
Tree-XPathEngine-0.05/lib/Tree/XPathEngine/Root.pm 0000644 0000764 0000144 00000001763 10373565402 021374 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/Root.pm 17 2006-02-12T08:00:01.814064Z mrodrigu $
package Tree::XPathEngine::Root;
use strict;
use Tree::XPathEngine::NodeSet;
sub new {
my $class = shift;
my $self; # actually don't need anything here - just a placeholder
bless \$self, $class;
}
sub as_string {
# do nothing
}
sub as_xml {
return "\n";
}
sub evaluate {
my $self = shift;
my $nodeset = shift;
# warn "Eval ROOT\n";
# must only ever occur on 1 node
die "Can't go to root on > 1 node!" unless $nodeset->size == 1;
my $newset = Tree::XPathEngine::NodeSet->new();
$newset->push($nodeset->get_node(1)->xpath_get_root_node());
return $newset;
}
1;
__END__
=head1 NAME
Tree::XPathEngine::Root - going back to the root node in an XPath expression
=head1 METHODS
=head2 new
=head2 evaluate ($nodeset)
returns a nodeset containing the root node of the first element of the nodeset
=head2 as_string
=head2 as_xml
dumps the action as XML (as C<< >>)
Tree-XPathEngine-0.05/lib/Tree/XPathEngine/Step.pm 0000644 0000764 0000144 00000024163 10374644764 021375 0 ustar mrodrigu users # $id$
# $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/Step.pm 25 2006-02-15T15:34:11.453583Z mrodrigu $
package Tree::XPathEngine::Step;
use Tree::XPathEngine;
use strict;
# constants used to describe the test part of a step
sub test_name () { 0; } # Full name
sub test_any () { 1; } # *
sub test_attr_name () { 2; } # @attrib
sub test_attr_any () { 3; } # @*
sub test_nt_text () { 4; } # text()
sub test_nt_node () { 5; } # node()
sub new {
my $class = shift;
my ($pp, $axis, $test, $literal) = @_;
my $axis_method = "axis_$axis";
$axis_method =~ tr/-/_/;
my $self = {
pp => $pp, # the Tree::XPathEngine class
axis => $axis,
axis_method => $axis_method,
test => $test,
literal => $literal,
predicates => [],
};
bless $self, $class;
}
sub as_string {
my $self = shift;
my $string = $self->{axis} . "::";
my $test = $self->{test};
if ($test == test_nt_text) {
$string .= 'text()';
}
elsif ($test == test_nt_node) {
$string .= 'node()';
}
else {
$string .= $self->{literal};
}
foreach (@{$self->{predicates}}) {
next unless defined $_;
$string .= "[" . $_->as_string . "]";
}
return $string;
}
sub evaluate {
my $self = shift;
my $from = shift; # context nodeset
# warn "Step::evaluate called with ", $from->size, " length nodeset\n";
$self->{pp}->_set_context_set($from);
my $initial_nodeset = Tree::XPathEngine::NodeSet->new();
# See spec section 2.1, paragraphs 3,4,5:
# The node-set selected by the location step is the node-set
# that results from generating an initial node set from the
# axis and node-test, and then filtering that node-set by
# each of the predicates in turn.
# Make each node in the nodeset be the context node, one by one
for(my $i = 1; $i <= $from->size; $i++) {
$self->{pp}->_set_context_pos($i);
$initial_nodeset->append($self->evaluate_node($from->get_node($i)));
}
# warn "Step::evaluate initial nodeset size: ", $initial_nodeset->size, "\n";
$self->{pp}->_set_context_set(undef);
$initial_nodeset->sort;
return $initial_nodeset;
}
# Evaluate the step against a particular node
sub evaluate_node {
my $self = shift;
my $context = shift;
# warn "Evaluate node: $self->{axis}\n";
# warn "Node: ", $context->[node_name], "\n";
my $method = $self->{axis_method};
my $results = Tree::XPathEngine::NodeSet->new();
no strict 'refs';
eval {
#$method->($self, $context, $results);
$self->$method( $context, $results);
};
if ($@) {
die "axis $method not implemented [$@]\n";
}
# warn("results: ", join('><', map {$_->xpath_string_value} @$results), "\n");
# filter initial nodeset by each predicate
foreach my $predicate (@{$self->{predicates}}) {
$results = $self->filter_by_predicate($results, $predicate);
}
return $results;
}
sub axis_ancestor {
my $self = shift;
my ($context, $results) = @_;
my $parent = $context->xpath_get_parent_node;
while( $parent)
{ $results->push($parent) if (node_test($self, $parent));
$parent = $parent->xpath_get_parent_node;
}
return $results unless $parent;
}
sub axis_ancestor_or_self {
my $self = shift;
my ($context, $results) = @_;
START:
return $results unless $context;
if (node_test($self, $context)) {
$results->push($context);
}
$context = $context->xpath_get_parent_node;
goto START;
}
sub axis_attribute {
my $self = shift;
my ($context, $results) = @_;
foreach my $attrib ($context->xpath_get_attributes) {
if ($self->test_attribute($attrib)) {
$results->push($attrib);
}
}
}
sub axis_child {
my $self = shift;
my ($context, $results) = @_;
foreach my $node ($context->xpath_get_child_nodes) {
if (node_test($self, $node)) {
$results->push($node);
}
}
}
sub axis_descendant {
my $self = shift;
my ($context, $results) = @_;
my @stack = $context->xpath_get_child_nodes;
while (@stack) {
my $node = pop @stack;
if (node_test($self, $node)) {
$results->unshift($node);
}
push @stack, $node->xpath_get_child_nodes;
}
}
sub axis_descendant_or_self {
my $self = shift;
my ($context, $results) = @_;
my @stack = ($context);
while (@stack) {
my $node = pop @stack;
if (node_test($self, $node)) {
$results->unshift($node);
}
push @stack, $node->xpath_get_child_nodes;
}
}
sub axis_following {
my $self = shift;
my ($context, $results) = @_;
START:
my $parent = $context->xpath_get_parent_node;
return $results unless $parent;
while ($context = $context->xpath_get_next_sibling) {
axis_descendant_or_self($self, $context, $results);
}
$context = $parent;
goto START;
}
sub axis_following_sibling {
my $self = shift;
my ($context, $results) = @_;
while ($context = $context->xpath_get_next_sibling) {
if (node_test($self, $context)) {
$results->push($context);
}
}
}
sub axis_parent {
my $self = shift;
my ($context, $results) = @_;
my $parent = $context->xpath_get_parent_node;
return $results unless $parent;
if (node_test($self, $parent)) {
$results->push($parent);
}
}
sub axis_preceding {
my $self = shift;
my ($context, $results) = @_;
# all preceding nodes in document order, except ancestors
START:
my $parent = $context->xpath_get_parent_node;
return $results unless $parent;
while ($context = $context->xpath_get_previous_sibling) {
axis_descendant_or_self($self, $context, $results);
}
$context = $parent;
goto START;
}
sub axis_preceding_sibling {
my $self = shift;
my ($context, $results) = @_;
while ($context = $context->xpath_get_previous_sibling) {
if (node_test($self, $context)) {
$results->push($context);
}
}
}
sub axis_self {
my $self = shift;
my ($context, $results) = @_;
if (node_test($self, $context)) {
$results->push($context);
}
}
sub node_test {
my $self = shift;
my $node = shift;
# if node passes test, return true
my $test = $self->{test};
return 1 if $test == test_nt_node;
if ($test == test_any) {
return 1 if( $node->xpath_is_element_node && defined $node->xpath_get_name);
}
local $^W;
if ($test == test_name) {
return unless $node->xpath_is_element_node;
return 1 if $node->xpath_get_name eq $self->{literal};
}
elsif ($test == test_nt_text) {
return 1 if $node->xpath_is_text_node;
}
return; # fallthrough returns false
}
sub test_attribute {
my $self = shift;
my $node = shift;
# warn "test_attrib: '$self->{test}' against: ", $node->xpath_get_name, "\n";
# warn "node type: $node->[node_type]\n";
my $test = $self->{test};
if( ($test == test_attr_any) || ($test == test_nt_node)
|| ( ($test == test_attr_name) && ($node->xpath_get_name eq $self->{literal}) )
)
{ return 1; }
else
{ return; }
}
sub filter_by_predicate {
my $self = shift;
my ($nodeset, $predicate) = @_;
# See spec section 2.4, paragraphs 2 & 3:
# For each node in the node-set to be filtered, the predicate Expr
# is evaluated with that node as the context node, with the number
# of nodes in the node set as the context size, and with the
# proximity position of the node in the node set with respect to
# the axis as the context position.
if (!ref($nodeset)) { # use ref because nodeset has a bool context
die "No nodeset!!!";
}
# warn "Filter by predicate: $predicate\n";
my $newset = Tree::XPathEngine::NodeSet->new();
for(my $i = 1; $i <= $nodeset->size; $i++) {
# set context set each time 'cos a loc-path in the expr could change it
$self->{pp}->_set_context_set($nodeset);
$self->{pp}->_set_context_pos($i);
my $result = $predicate->evaluate($nodeset->get_node($i));
if ($result->isa('Tree::XPathEngine::Boolean')) {
if ($result->value) {
$newset->push($nodeset->get_node($i));
}
}
elsif ($result->isa('Tree::XPathEngine::Number')) {
if ($result->value == $i) {
$newset->push($nodeset->get_node($i));
}
}
else {
if ($result->xpath_to_boolean->value) {
$newset->push($nodeset->get_node($i));
}
}
}
return $newset;
}
1;
__END__
=head1 NAME
Tree::XPathEngine::Step - implements a step in an XPath location path
=head1 METHODS
These methods should probably not be called from outside of Tree::XPathEngine.
=head2 new
create the step
=head2 evaluate $nodeset
evaluate the step against a nodeset
=head2 evaluate_node $node
evaluate the step against a single node
=head2 axis methods
All these methods return the nodes along the chosen axis
=over 4
=item axis_ancestor
=item axis_ancestor_or_self
=item axis_attribute
=item axis_child
=item axis_descendant
=item axis_descendant_or_self
=item axis_following
=item axis_following_sibling
=item axis_parent
=item axis_preceding
=item axis_preceding_sibling
=item axis_self
=back
=head2 node_test
apply the node test to the nodes gathered by the axis method
=head2 test_attribute
test on attribute existence
=head2 filter_by_predicate
filter the results on a predicate
=head2 as_string
dump the step as a string
=head2 as_xml
dump the step as xml
=head1 Test type constants
These constants are used in this package and in Tree::XPathEngine to describe
the type of test in a step:
=over 4
=item test_name
=item test_any
=item test_attr_name
=item test_attr_any
=item test_nt_text
=item test_nt_node
=back
Tree-XPathEngine-0.05/lib/Tree/XPathEngine/Literal.pm 0000644 0000764 0000144 00000004344 10373565402 022043 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/Literal.pm 17 2006-02-12T08:00:01.814064Z mrodrigu $
package Tree::XPathEngine::Literal;
use Tree::XPathEngine::Boolean;
use Tree::XPathEngine::Number;
use strict;
use overload
'""' => \&value,
'cmp' => \&xpath_cmp;
sub new {
my $class = shift;
my ($string) = @_;
# $string =~ s/"/"/g;
# $string =~ s/'/'/g;
bless \$string, $class;
}
sub as_string {
my $self = shift;
my $string = $$self;
$string =~ s/'/'/g;
return "'$string'";
}
sub as_xml {
my $self = shift;
my $string = $$self;
return "$string\n";
}
sub value {
my $self = shift;
$$self;
}
sub xpath_cmp {
my $self = shift;
my ($cmp, $swap) = @_;
if ($swap) {
return $cmp cmp $$self;
}
return $$self cmp $cmp;
}
sub evaluate {
my $self = shift;
$self;
}
sub xpath_to_boolean {
my $self = shift;
return (length($$self) > 0) ? Tree::XPathEngine::Boolean->_true : Tree::XPathEngine::Boolean->_false;
}
sub xpath_to_number { return Tree::XPathEngine::Number->new($_[0]->value); }
sub xpath_to_literal { return $_[0]; }
sub xpath_string_value { return $_[0]->value; }
1;
__END__
=head1 NAME
Tree::XPathEngine::Literal - Simple string values.
=head1 DESCRIPTION
In XPath terms a Literal is what we know as a string.
=head1 API
=head2 new($string)
Create a new Literal object with the value in $string. Note that " and
' will be converted to " and ' respectively. That is not part of the XPath
specification, but I consider it useful. Note though that you have to go
to extraordinary lengths in an XML template file (be it XSLT or whatever) to
make use of this:
Which produces a Literal of:
I'm feeling "sad"
=head2 value()
Also overloaded as stringification, simply returns the literal string value.
=head2 xpath_cmp($literal)
Returns the equivalent of perl's cmp operator against the given $literal.
=head2 Other Methods
Those are needed so the objects can be properly processed in various contexts
=over 4
=item as_string
=item as_xml
=item value
=item evaluate
=item xpath_to_boolean
=item xpath_to_literal
=item xpath_to_number
=item xpath_string_value
=back
=cut
Tree-XPathEngine-0.05/lib/Tree/XPathEngine/Variable.pm 0000644 0000764 0000144 00000002657 10373565402 022201 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine/Variable.pm 17 2006-02-12T08:00:01.814064Z mrodrigu $
package Tree::XPathEngine::Variable;
use strict;
# This class does NOT contain 1 instance of a variable
# see the Tree::XPathEngine class for the instances
# This class simply holds the name of the var
sub new {
my $class = shift;
my ($pp, $name) = @_;
bless { name => $name, path_parser => $pp }, $class;
}
sub as_string {
my $self = shift;
'\$' . $self->{name};
}
sub as_xml {
my $self = shift;
return "" . $self->{name} . "\n";
}
sub xpath_get_value {
my $self = shift;
$self->{path_parser}->get_var($self->{name});
}
sub xpath_set_value {
my $self = shift;
my ($val) = @_;
$self->{path_parser}->set_var($self->{name}, $val);
}
sub evaluate {
my $self = shift;
my $val = $self->xpath_get_value;
return $val;
}
1;
__END__
=head1 NAME
Tree::XPathEngine::Variable - a variable in a Tree::XPathEngine object
=head1 METHODS
This class does NOT contain 1 instance of a variable, it's in the
Tree::XPathEngine class. This class simply holds the name of the var,
for use by the engine when evaluating the query
=head2 new
=head2 xpath_set_value
=head2 xpath_get_value
synonym of get_value
=head2 evaluate
=head2 as_string
dump the variable call in the XPath expression as a string
=head2 as_xml
dump the variable call in the XPath expression as xml
Tree-XPathEngine-0.05/lib/Tree/XPathEngine.pm 0000644 0000764 0000144 00000120532 10374645764 020460 0 ustar mrodrigu users #$Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine.pm 25 2006-02-15T15:34:11.453583Z mrodrigu $
package Tree::XPathEngine;
use warnings;
use strict;
use vars qw($VERSION $AUTOLOAD $revision);
$VERSION = '0.05';
$Tree::XPathEngine::DEBUG = 0;
use vars qw/
$WILD
$NUMBER_RE
$NODE_TYPE
$AXIS_NAME
%AXES
$LITERAL
$REGEXP_RE
$REGEXP_MOD_RE
%CACHE/;
use Tree::XPathEngine::Step;
use Tree::XPathEngine::Expr;
use Tree::XPathEngine::Function;
use Tree::XPathEngine::LocationPath;
use Tree::XPathEngine::Variable;
use Tree::XPathEngine::Literal;
use Tree::XPathEngine::Number;
use Tree::XPathEngine::NodeSet;
use Tree::XPathEngine::Root;
# Axis name to principal node type mapping
%AXES = (
'ancestor' => 'element',
'ancestor-or-self' => 'element',
'attribute' => 'attribute',
'child' => 'element',
'descendant' => 'element',
'descendant-or-self' => 'element',
'following' => 'element',
'following-sibling' => 'element',
'parent' => 'element',
'preceding' => 'element',
'preceding-sibling' => 'element',
'self' => 'element',
);
$WILD = qr{\*};
$NODE_TYPE = qr{(?:(text|node)\(\))};
$AXIS_NAME = '(?:' . join('|', keys %AXES) . ')::';
$NUMBER_RE = qr{(?:\d+(?:\.\d*)?|\.\d+)};
$REGEXP_RE = qr{(?:m?/(?:\\.|[^/])*/)};
$REGEXP_MOD_RE = qr{(?:[imsx]+)};
$LITERAL = qr{(?:"[^"]*"|'[^']*')};
sub new {
my $class = shift;
my( %option)= @_;
my $self = bless {}, $class;
$self->{NAME}= $option{xpath_name_re} || qr/(?:[A-Za-z_][\w.-]*)/;
$self->{NAME}= qr/(?:$self->{NAME})/; # add parens just to make sure we have them
_debug("New Parser being created.\n") if( $Tree::XPathEngine::DEBUG);
$self->{context_set} = Tree::XPathEngine::NodeSet->new();
$self->{context_pos} = undef; # 1 based position in array context
$self->{context_size} = 0; # total size of context
$self->{vars} = {};
$self->{direction} = 'forward';
$self->{cache} = {};
return $self;
}
sub find {
my $self = shift;
my( $path, $context) = @_;
my $parsed_path= $self->_parse( $path);
return $parsed_path->evaluate( $context);
}
sub matches {
my $self = shift;
my ($node, $path, $context) = @_;
my @nodes = $self->findnodes( $path, $context);
if (grep { "$node" eq "$_" } @nodes) { return 1; }
return;
}
sub findnodes {
my $self = shift;
my ($path, $context) = @_;
my $results = $self->find( $path, $context);
if ($results->isa('Tree::XPathEngine::NodeSet'))
{ return $results->get_nodelist; }
else
{ return (); }
}
sub findnodes_as_string {
my $self = shift;
my ($path, $context) = @_;
my $results = $self->find( $path, $context);
if ($results->isa('Tree::XPathEngine::NodeSet')) {
return join('', map { $_->to_string } $results->get_nodelist);
}
elsif ($results->isa('Tree::XPathEngine::Node')) {
return $results->to_string;
}
else {
return $results->value; # CHECK
}
}
sub findvalue {
my $self = shift;
my ($path, $context) = @_;
my $results = $self->find( $path, $context);
return $results ? $results->xpath_to_literal : '';
}
sub exists
{ my $self = shift;
my ($path, $context) = @_;
my @nodeset = $self->findnodes( $path, $context);
return scalar( @nodeset ) ? 1 : 0;
}
sub get_var {
my $self = shift;
my $var = shift;
$self->{vars}->{$var};
}
sub set_var {
my $self = shift;
my $var = shift;
my $val = shift;
$self->{vars}->{$var} = $val;
}
#sub _get_context_set { $_[0]->{context_set}; }
sub _set_context_set { $_[0]->{context_set} = $_[1]; }
sub _get_context_pos { $_[0]->{context_pos}; }
sub _set_context_pos { $_[0]->{context_pos} = $_[1]; }
sub _get_context_size { $_[0]->{context_set}->size; }
#sub _get_context_node { $_[0]->{context_set}->get_node($_[0]->{context_pos}); }
sub _parse {
my $self = shift;
my $path = shift;
if ($CACHE{$path}) {
return $CACHE{$path};
}
my $tokens = $self->_tokenize($path);
$self->{_tokpos} = 0;
my $tree = $self->_analyze($tokens);
if ($self->{_tokpos} < scalar(@$tokens)) {
# didn't manage to parse entire expression - throw an exception
die "Parse of expression $path failed - junk after end of expression: $tokens->[$self->{_tokpos}]";
}
$CACHE{$path} = $tree;
_debug("PARSED Expr to:\n", $tree->as_string, "\n") if( $Tree::XPathEngine::DEBUG);
return $tree;
}
sub _tokenize {
my $self = shift;
my $path = shift;
study $path;
my @tokens;
_debug("Parsing: $path\n") if( $Tree::XPathEngine::DEBUG);
# Bug: We don't allow "'@' NodeType" which is in the grammar, but I think is just plain stupid.
my $expected=''; # used to desambiguate conflicts (for REs)
while( length($path))
{ my $token='';
if( $expected eq 'RE' && ($path=~ m{\G\s*($REGEXP_RE $REGEXP_MOD_RE?)\s*}gcxs))
{ $token= $1; $expected=''; }
elsif($path =~ m/\G
\s* # ignore all whitespace
( # tokens
$LITERAL| # literal string
$NUMBER_RE| # digits
\.\.| # parent
\.| # current
($AXIS_NAME)?$NODE_TYPE| # node type test (probably useless in this context)
\@($self->{NAME}|$WILD)| # attribute
\$$self->{NAME}| # variable reference
($AXIS_NAME)?($self->{NAME}|$WILD)| # NAME,NodeType,Axis::Test
\!=|<=|\-|>=|\/\/|and|or|mod|div| # multi-char seps
=~|\!~| # regexp matching (not in the XPath spec)
[,\+=\|<>\/\(\[\]\)]| # single char seps
(?{_curr_match} = '';
return 0 unless $self->{_tokpos} < @$tokens;
local $^W;
# _debug ("match: $match\n") if( $Tree::XPathEngine::DEBUG);
if ($tokens->[$self->{_tokpos}] =~ /^$match$/) {
$self->{_curr_match} = $tokens->[$self->{_tokpos}];
$self->{_tokpos}++;
return 1;
}
else {
if ($fatal) {
die "Invalid token: ", $tokens->[$self->{_tokpos}], "\n";
}
else {
return 0;
}
}
}
sub _expr {
my ($self, $tokens) = @_;
_debug( "in _exprexpr\n") if( $Tree::XPathEngine::DEBUG);
return _or_expr($self, $tokens);
}
sub _or_expr {
my ($self, $tokens) = @_;
_debug( "in _or_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = _and_expr($self, $tokens);
while (_match($self, $tokens, 'or')) {
my $or_expr = Tree::XPathEngine::Expr->new($self);
$or_expr->set_lhs($expr);
$or_expr->set_op('or');
my $rhs = _and_expr($self, $tokens);
$or_expr->set_rhs($rhs);
$expr = $or_expr;
}
return $expr;
}
sub _and_expr {
my ($self, $tokens) = @_;
_debug( "in _and_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = _match_expr($self, $tokens);
while (_match($self, $tokens, 'and')) {
my $and_expr = Tree::XPathEngine::Expr->new($self);
$and_expr->set_lhs($expr);
$and_expr->set_op('and');
my $rhs = _match_expr($self, $tokens);
$and_expr->set_rhs($rhs);
$expr = $and_expr;
}
return $expr;
}
sub _match_expr {
my ($self, $tokens) = @_;
_debug( "in _match_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = _equality_expr($self, $tokens);
while (_match($self, $tokens, '[=!]~')) {
my $match_expr = Tree::XPathEngine::Expr->new($self);
$match_expr->set_lhs($expr);
$match_expr->set_op($self->{_curr_match});
my $rhs = _equality_expr($self, $tokens);
$match_expr->set_rhs($rhs);
$expr = $match_expr;
}
return $expr;
}
sub _equality_expr {
my ($self, $tokens) = @_;
_debug( "in _equality_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = _relational_expr($self, $tokens);
while (_match($self, $tokens, '!?=')) {
my $eq_expr = Tree::XPathEngine::Expr->new($self);
$eq_expr->set_lhs($expr);
$eq_expr->set_op($self->{_curr_match});
my $rhs = _relational_expr($self, $tokens);
$eq_expr->set_rhs($rhs);
$expr = $eq_expr;
}
return $expr;
}
sub _relational_expr {
my ($self, $tokens) = @_;
_debug( "in _relational_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = _additive_expr($self, $tokens);
while (_match($self, $tokens, '(<|>|<=|>=)')) {
my $rel_expr = Tree::XPathEngine::Expr->new($self);
$rel_expr->set_lhs($expr);
$rel_expr->set_op($self->{_curr_match});
my $rhs = _additive_expr($self, $tokens);
$rel_expr->set_rhs($rhs);
$expr = $rel_expr;
}
return $expr;
}
sub _additive_expr {
my ($self, $tokens) = @_;
_debug( "in _additive_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = _multiplicative_expr($self, $tokens);
while (_match($self, $tokens, '[\\+\\-]')) {
my $add_expr = Tree::XPathEngine::Expr->new($self);
$add_expr->set_lhs($expr);
$add_expr->set_op($self->{_curr_match});
my $rhs = _multiplicative_expr($self, $tokens);
$add_expr->set_rhs($rhs);
$expr = $add_expr;
}
return $expr;
}
sub _multiplicative_expr {
my ($self, $tokens) = @_;
_debug( "in _multiplicative_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = _unary_expr($self, $tokens);
while (_match($self, $tokens, '(\\*|div|mod)')) {
my $mult_expr = Tree::XPathEngine::Expr->new($self);
$mult_expr->set_lhs($expr);
$mult_expr->set_op($self->{_curr_match});
my $rhs = _unary_expr($self, $tokens);
$mult_expr->set_rhs($rhs);
$expr = $mult_expr;
}
return $expr;
}
sub _unary_expr {
my ($self, $tokens) = @_;
_debug( "in _unary_expr\n") if( $Tree::XPathEngine::DEBUG);
if (_match($self, $tokens, '-')) {
my $expr = Tree::XPathEngine::Expr->new($self);
$expr->set_lhs(Tree::XPathEngine::Number->new(0));
$expr->set_op('-');
$expr->set_rhs(_unary_expr($self, $tokens));
return $expr;
}
else {
return _union_expr($self, $tokens);
}
}
sub _union_expr {
my ($self, $tokens) = @_;
_debug( "in _union_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = _path_expr($self, $tokens);
while (_match($self, $tokens, '\\|')) {
my $un_expr = Tree::XPathEngine::Expr->new($self);
$un_expr->set_lhs($expr);
$un_expr->set_op('|');
my $rhs = _path_expr($self, $tokens);
$un_expr->set_rhs($rhs);
$expr = $un_expr;
}
return $expr;
}
sub _path_expr {
my ($self, $tokens) = @_;
_debug( "in _path_expr\n") if( $Tree::XPathEngine::DEBUG);
# _path_expr is _location_path | _filter_expr | _filter_expr '//?' _relative_location_path
# Since we are being predictive we need to find out which function to call next, then.
# LocationPath either starts with "/", "//", ".", ".." or a proper Step.
my $expr = Tree::XPathEngine::Expr->new($self);
my $test = $tokens->[$self->{_tokpos}];
# Test for AbsoluteLocationPath and AbbreviatedRelativeLocationPath
if ($test =~ /^(\/\/?|\.\.?)$/) {
# LocationPath
$expr->set_lhs(_location_path($self, $tokens));
}
# Test for AxisName::...
elsif (_is_step($self, $tokens)) {
$expr->set_lhs(_location_path($self, $tokens));
}
else {
# Not a LocationPath
# Use _filter_expr instead:
$expr = _filter_expr($self, $tokens);
if (_match($self, $tokens, '//?')) {
my $loc_path = Tree::XPathEngine::LocationPath->new();
push @$loc_path, $expr;
if ($self->{_curr_match} eq '//') {
push @$loc_path, Tree::XPathEngine::Step->new($self, 'descendant-or-self',
Tree::XPathEngine::Step::test_nt_node() );
}
push @$loc_path, _relative_location_path($self, $tokens);
my $new_expr = Tree::XPathEngine::Expr->new($self);
$new_expr->set_lhs($loc_path);
return $new_expr;
}
}
return $expr;
}
sub _filter_expr {
my ($self, $tokens) = @_;
_debug( "in _filter_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = _primary_expr($self, $tokens);
while (_match($self, $tokens, '\\[')) {
# really PredicateExpr...
$expr->push_predicate(_expr($self, $tokens));
_match($self, $tokens, '\\]', 1);
}
return $expr;
}
sub _primary_expr {
my ($self, $tokens) = @_;
_debug( "in _primary_expr\n") if( $Tree::XPathEngine::DEBUG);
my $expr = Tree::XPathEngine::Expr->new($self);
if (_match($self, $tokens, $LITERAL)) {
# new Literal with $self->{_curr_match}...
$self->{_curr_match} =~ m/^(["'])(.*)\1$/;
$expr->set_lhs(Tree::XPathEngine::Literal->new($2));
}
elsif (_match($self, $tokens, "$REGEXP_RE$REGEXP_MOD_RE?")) {
# new Literal with $self->{_curr_match} turned into a regexp...
my( $regexp, $mod)= $self->{_curr_match} =~ m{($REGEXP_RE)($REGEXP_MOD_RE?)};
$regexp=~ s{^m?s*/}{};
$regexp=~ s{/$}{};
if( $mod) { $regexp=~ "(?$mod:$regexp)"; } # move the mods inside the regexp
$expr->set_lhs(Tree::XPathEngine::Literal->new($regexp));
}
elsif (_match($self, $tokens, $NUMBER_RE)) {
# new Number with $self->{_curr_match}...
$expr->set_lhs(Tree::XPathEngine::Number->new($self->{_curr_match}));
}
elsif (_match($self, $tokens, '\\(')) {
$expr->set_lhs(_expr($self, $tokens));
_match($self, $tokens, '\\)', 1);
}
elsif (_match($self, $tokens, "\\\$$self->{NAME}")) {
# new Variable with $self->{_curr_match}...
$self->{_curr_match} =~ /^\$(.*)$/;
$expr->set_lhs(Tree::XPathEngine::Variable->new($self, $1));
}
elsif (_match($self, $tokens, $self->{NAME})) {
# check match not Node_Type - done in lexer...
# new Function
my $func_name = $self->{_curr_match};
_match($self, $tokens, '\\(', 1);
$expr->set_lhs(
Tree::XPathEngine::Function->new(
$self,
$func_name,
_arguments($self, $tokens)
)
);
_match($self, $tokens, '\\)', 1);
}
else {
die "Not a _primary_expr at ", $tokens->[$self->{_tokpos}], "\n";
}
return $expr;
}
sub _arguments {
my ($self, $tokens) = @_;
_debug( "in _arguments\n") if( $Tree::XPathEngine::DEBUG);
my @args;
if($tokens->[$self->{_tokpos}] eq ')') {
return \@args;
}
push @args, _expr($self, $tokens);
while (_match($self, $tokens, ',')) {
push @args, _expr($self, $tokens);
}
return \@args;
}
sub _location_path {
my ($self, $tokens) = @_;
_debug( "in _location_path\n") if( $Tree::XPathEngine::DEBUG);
my $loc_path = Tree::XPathEngine::LocationPath->new();
if (_match($self, $tokens, '/')) {
# root
_debug("h: Matched root\n") if( $Tree::XPathEngine::DEBUG);
push @$loc_path, Tree::XPathEngine::Root->new();
if (_is_step($self, $tokens)) {
_debug("Next is step\n") if( $Tree::XPathEngine::DEBUG);
push @$loc_path, _relative_location_path($self, $tokens);
}
}
elsif (_match($self, $tokens, '//')) {
# root
push @$loc_path, Tree::XPathEngine::Root->new();
my $optimised = _optimise_descendant_or_self($self, $tokens);
if (!$optimised) {
push @$loc_path, Tree::XPathEngine::Step->new($self, 'descendant-or-self',
Tree::XPathEngine::Step::test_nt_node);
push @$loc_path, _relative_location_path($self, $tokens);
}
else {
push @$loc_path, $optimised, _relative_location_path($self, $tokens);
}
}
else {
push @$loc_path, _relative_location_path($self, $tokens);
}
return $loc_path;
}
sub _optimise_descendant_or_self {
my ($self, $tokens) = @_;
_debug( "in _optimise_descendant_or_self\n") if( $Tree::XPathEngine::DEBUG);
my $tokpos = $self->{_tokpos};
# // must be followed by a Step.
if ($tokens->[$tokpos+1] && $tokens->[$tokpos+1] eq '[') {
# next token is a predicate
return;
}
elsif ($tokens->[$tokpos] =~ /^\.\.?$/) {
# abbreviatedStep - can't optimise.
return;
}
else {
_debug("Trying to optimise //\n") if( $Tree::XPathEngine::DEBUG);
my $step = _step($self, $tokens);
if ($step->{axis} ne 'child') {
# can't optimise axes other than child for now...
$self->{_tokpos} = $tokpos;
return;
}
$step->{axis} = 'descendant';
$step->{axis_method} = 'axis_descendant';
$self->{_tokpos}--;
$tokens->[$self->{_tokpos}] = '.';
return $step;
}
}
sub _relative_location_path {
my ($self, $tokens) = @_;
_debug( "in _relative_location_path\n") if( $Tree::XPathEngine::DEBUG);
my @steps;
push @steps,_step($self, $tokens);
while (_match($self, $tokens, '//?')) {
if ($self->{_curr_match} eq '//') {
my $optimised = _optimise_descendant_or_self($self, $tokens);
if (!$optimised) {
push @steps, Tree::XPathEngine::Step->new($self, 'descendant-or-self',
Tree::XPathEngine::Step::test_nt_node);
}
else {
push @steps, $optimised;
}
}
push @steps, _step($self, $tokens);
if (@steps > 1 &&
$steps[-1]->{axis} eq 'self' &&
$steps[-1]->{test} == Tree::XPathEngine::Step::test_nt_node) {
pop @steps;
}
}
return @steps;
}
sub _step {
my ($self, $tokens) = @_;
_debug( "in _step\n") if( $Tree::XPathEngine::DEBUG);
if (_match($self, $tokens, '\\.')) {
# self::node()
return Tree::XPathEngine::Step->new($self, 'self', Tree::XPathEngine::Step::test_nt_node);
}
elsif (_match($self, $tokens, '\\.\\.')) {
# parent::node()
return Tree::XPathEngine::Step->new($self, 'parent', Tree::XPathEngine::Step::test_nt_node);
}
else {
# AxisSpecifier NodeTest Predicate(s?)
my $token = $tokens->[$self->{_tokpos}];
_debug("p: Checking $token\n") if( $Tree::XPathEngine::DEBUG);
my $step;
if ($token =~ /^\@($self->{NAME}|$WILD)$/) {
$self->{_tokpos}++;
if ($token eq '@*') {
$step = Tree::XPathEngine::Step->new($self,
'attribute',
Tree::XPathEngine::Step::test_attr_any,
'*');
}
elsif ($token =~ /^\@($self->{NAME})$/) {
$step = Tree::XPathEngine::Step->new($self,
'attribute',
Tree::XPathEngine::Step::test_attr_name,
$1);
}
}
elsif ($token =~ /^$WILD$/) { # *
$self->{_tokpos}++;
$step = Tree::XPathEngine::Step->new($self, 'child',
Tree::XPathEngine::Step::test_any,
$token);
}
elsif ($token =~ /^$self->{NAME}$/) { # name:name
$self->{_tokpos}++;
$step = Tree::XPathEngine::Step->new($self, 'child',
Tree::XPathEngine::Step::test_name,
$token);
}
elsif ($token eq 'text()') {
$self->{_tokpos}++;
$step = Tree::XPathEngine::Step->new($self, 'child',
Tree::XPathEngine::Step::test_nt_text);
}
elsif ($token eq 'node()') {
$self->{_tokpos}++;
$step = Tree::XPathEngine::Step->new($self, 'child',
Tree::XPathEngine::Step::test_nt_node);
}
elsif ($token =~ /^($AXIS_NAME)($self->{NAME}|$WILD|$NODE_TYPE)$/) {
my $axis = substr( $1, 0, -2);
$self->{_tokpos}++;
$token = $2;
if ($token =~ /^$WILD$/) { # *
$step = Tree::XPathEngine::Step->new($self, $axis,
(($axis eq 'attribute') ?
Tree::XPathEngine::Step::test_attr_any
:
Tree::XPathEngine::Step::test_any),
$token);
}
elsif ($token =~ /^$self->{NAME}$/) { # name:name
$step = Tree::XPathEngine::Step->new($self, $axis,
(($axis eq 'attribute') ?
Tree::XPathEngine::Step::test_attr_name
:
Tree::XPathEngine::Step::test_name),
$token);
}
elsif ($token eq 'text()') {
$step = Tree::XPathEngine::Step->new($self, $axis,
Tree::XPathEngine::Step::test_nt_text);
}
elsif ($token eq 'node()') {
$step = Tree::XPathEngine::Step->new($self, $axis,
Tree::XPathEngine::Step::test_nt_node);
}
else {
die "Shouldn't get here";
}
}
else {
die "token $token doesn't match format of a 'Step'\n";
}
while (_match($self, $tokens, '\\[')) {
push @{$step->{predicates}}, _expr($self, $tokens);
_match($self, $tokens, '\\]', 1);
}
return $step;
}
}
sub _is_step {
my ($self, $tokens) = @_;
my $token = $tokens->[$self->{_tokpos}];
return unless defined $token;
_debug("p: Checking if '$token' is a step\n") if( $Tree::XPathEngine::DEBUG);
local $^W=0;
if( ($token eq 'processing-instruction')
|| ($token =~ /^\@($self->{NAME}|$WILD)$/)
|| ( ($token =~ /^($self->{NAME}|$WILD)$/ )
&& ( ($tokens->[$self->{_tokpos}+1] || '') ne '(') )
|| ($token =~ /^$NODE_TYPE$/)
|| ($token =~ /^$AXIS_NAME($self->{NAME}|$WILD|$NODE_TYPE)$/)
)
{ return 1; }
else
{ _debug("p: '$token' not a step\n") if( $Tree::XPathEngine::DEBUG);
return;
}
}
sub _debug {
my ($pkg, $file, $line, $sub) = caller(1);
$sub =~ s/^$pkg\:://;
while (@_) {
my $x = shift;
$x =~ s/\bPKG\b/$pkg/g;
$x =~ s/\bLINE\b/$line/g;
$x =~ s/\bg\b/$sub/g;
print STDERR $x;
}
}
__END__
=head1 NAME
Tree::XPathEngine - a re-usable XPath engine
=head1 DESCRIPTION
This module provides an XPath engine, that can be re-used by other
module/classes that implement trees.
It is designed to be compatible with L, ie it passes its
tests if you replace Class::XPath by Tree::XPathEngine.
This code is a more or less direct copy of the L module by
Matt Sergeant. I only removed the XML processing part (that parses an XML
document and load it as a tree in memory) to remove the dependency
on XML::Parser, applied a couple of patches, removed a whole bunch of XML
specific things (comment, processing inistructions, namespaces...),
renamed a whole lot of methods to make Pod::Coverage happy, and changed
the docs.
The article eXtending XML XPath, http://www.xmltwig.com/article/extending_xml_xpath/
should give authors who want to use this module enough background to do so.
Otherwise, my email is below ;--)
B: while the underlying code is rather solid, this module most likely
lacks docs.
As they say, "patches welcome"... but I am also interested in any experience
using this module, what were the tricky parts, and how could the code or the
docs be improved.
=head1 SYNOPSIS
use Tree::XPathEngine;
my $tree= my_tree->new( ...);
my $xp = Tree::XPathEngine->new();
my @nodeset = $xp->find('/root/kid/grankid[1]'); # find all first grankids
package tree;
# needs to provide these methods
sub xpath_get_name { ... }
sub xpath_get_next_sibling { ... }
sub xpath_get_previous_sibling { ... }
sub xpath_get_root_node { ... }
sub xpath_get_parent_node { ... }
sub xpath_get_child_nodes { ... }
sub xpath_is_element_node { return 1; }
sub xpath_cmp { ... }
sub xpath_get_attributes { ... } # only if attributes are used
sub xpath_to_literal { ... } # only if you want to use findnodes_as_string or findvalue
=head1 DETAILS
=head1 API
The API of Tree::XPathEngine itself is extremely simple to allow you to get
going almost immediately. The deeper API's are more complex, but you
shouldn't have to touch most of that.
=head2 new %options
=head3 options
=over 4
=item xpath_name_re
a regular expression used to match names (node names or attribute names)
by default it is qr/[A-Za-z_][\w.-]*/ in order to work under perl 5.6.n,
but you might want to use something like qr/\p{L}[\w.-]*/ in 5.8.n, to
accomodate letter outside of the ascii range.
=back
=head2 findnodes ($path, $context)
Returns a list of nodes found by C<$path>, in context C<$context>.
In scalar context returns an C object.
=head2 findnodes_as_string ($path, $context)
Returns the text values of the nodes
=head2 findvalue ($path, $context)
Returns either a C, a C
or a C object. If the path returns a NodeSet,
$nodeset->xpath_to_literal is called automatically for you (and thus a
C is returned). Note that
for each of the objects stringification is overloaded, so you can just
print the value found, or manipulate it in the ways you would a normal
perl value (e.g. using regular expressions).
=head2 exists ($path, $context)
Returns true if the given path exists.
=head2 matches($node, $path, $context)
Returns true if the node matches the path.
=head2 find ($path, $context)
The find function takes an XPath expression (a string) and returns either a
Tree::XPathEngine::NodeSet object containing the nodes it found (or empty if
no nodes matched the path), or one of Tree::XPathEngine::Literal (a string),
Tree::XPathEngine::Number, or Tree::XPathEngine::Boolean. It should always
return something - and you can use ->isa() to find out what it returned. If
you need to check how many nodes it found you should check $nodeset->size.
See L.
=head2 XPath variables
XPath lets you use variables in expressions (see the XPath spec:
L).
=over 4
=item set_var ($var_name, $val)
sets the variable C<$var_name> to val
=item get_var ($var_name)
get the value of the variable (there should be no need to use this method from
outside the module, but it looked silly to have C and C<_get_var>).
=back
=head1 How to use this module
The purpose of this module is to add XPah support to generic tree modules.
It works by letting you create a Tree::XPathEngine object, that will be called
to resolve XPath queries on a context. The context is a node (or a list of
nodes) in a tree.
The tree should share some characteristics with a XML tree: it is made of nodes,
there are 2 kinds of nodes, document (the whole tree, the root of the tree is
a child of this node), elements(regular nodes in the tree) and attributes.
Nodes in the tree are expected to provide methods that will be called by the
XPath engine to resolve the query. Not all of the possible methods need be
available, depending on the type of XPath queries that need to be supported:
for example if the nodes do not have a text value then there is no need for a
C method, and XPath queries cannot include the C
function (using it will trigger a B error).
Most of the expected methods are usual methods for a tree module, so it should
not be too difficult to implement them, by aliasing existing methods to the
required ones.
Just in case, here is a fast way to alias for example your own C method
to the C needed by Tree::XPathEngine:
*get_parent_node= *parent; # in the node package
The XPath engine expects the whole tree and attributes to be full blown objects,
which provide a set of methods similar to nodes. If they are not, see below for
ways to "fake" it.
=head2 Methods to be provided by the nodes
=over 4
=item xpath_get_name
returns the name of the node.
Not used for the document.
=item xpath_string_value
The text corresponding to the node, used by the C function (for
queries like C)
=item xpath_get_next_sibling
=item xpath_get_previous_sibling
=item xpath_get_root_node
returns the document object. see L below for more details.
=item xpath_get_parent_node
The parent of the root of the tree is the document node.
The parent of an attribute is its element.
=item xpath_get_child_nodes
returns a list of children.
note that the attributes are not children of an element
=item xpath_is_element_node
=item xpath_is_document_node
=item xpath_is_attribute_node
=item xpath_is_text_node
only if the tree includes textual nodes
=item xpath_to_string
returns the node as a string
=item xpath_to_number
returns the node value as a number object
sub xpath_to_number
{ return XML::XPath::Number->new( $_[0]->xpath_string_value); }
=item xpath_cmp ($node_a, $node_b)
compares 2 nodes and returns -1, 0 or 1 depending on whether C<$a_node> is
before, equal to or after C<$b_node> in the tree.
This is needed in order to return sorted results and to remove duplicates.
See L below for a ready-to-use sorting method if your
tree does not have a C method
=back
=head2 Element specific methods
=over 4
=item xpath_get_attributes
returns the list of attributes, attributes should be objects that support
the following methods:
=back
=head1 Tricky bits
=head2 Document object
The original XPath works on XML, and is roughly speaking based on the DOM
model of an XML document. As far as the XPath engine is concerned, it still
deals with a DOM tree.
One of the possibly annoying consequences is that in the DOM the document
itself is a node, that has a single element child, the root of the document
tree. If the tree you want to use this module on doesn't follow that model,
if its root element B the tree itself, then you will have to fake it.
This is how I did it in L:
# in package Tree::DAG_Node::XPath
sub xpath_get_root_node
{ my $node= shift;
# The parent of root is a Tree::DAG_Node::XPath::Root
# that helps getting the tree to mimic a DOM tree
return $node->root->xpath_get_parent_node;
}
sub xpath_get_parent_node
{ my $node= shift;
return $node->mother # normal case, any node but the root
# the root parent is a Tree::DAG_Node::XPath::Root object
# which contains the reference of the (real) root node
|| bless { root => $node }, 'Tree::DAG_Node::XPath::Root';
}
# class for the fake root for a tree
package Tree::DAG_Node::XPath::Root;
sub xpath_get_child_nodes { return ( $_[0]->{root}); }
sub address { return -1; } # the root is before all other nodes
sub xpath_get_attributes { return [] }
sub xpath_is_document_node { return 1 }
sub xpath_is_element_node { return 0 }
sub xpath_is_attribute_node { return 0 }
=head2 Attribute objects
If the attributes in the original tree are not objects, but simple fields in
a hash, you can generate objects on the fly:
# in the element package
sub xpath_get_attributes
{ my $elt= shift;
my $atts= $elt->attributes; # returns a reference to a hash of attributes
my $rank=-1; # used for sorting
my @atts= map { bless( { name => $_, value => $atts->{$_}, elt => $elt, rank => $rank -- },
'Tree::DAG_Node::XPath::Attribute')
}
sort keys %$atts;
return @atts;
}
# the attribute package
package Tree::DAG_Node::XPath::Attribute;
use Tree::XPathEngine::Number;
# not used, instead get_attributes in Tree::DAG_Node::XPath directly returns an
# object blessed in this class
#sub new
# { my( $class, $elt, $att)= @_;
# return bless { name => $att, value => $elt->att( $att), elt => $elt }, $class;
# }
sub xpath_get_value { return $_[0]->{value}; }
sub xpath_get_name { return $_[0]->{name} ; }
sub xpath_string_value { return $_[0]->{value}; }
sub xpath_to_number { return Tree::XPathEngine::Number->new( $_[0]->{value}); }
sub xpath_is_document_node { 0 }
sub xpath_is_element_node { 0 }
sub xpath_is_attribute_node { 1 }
sub to_string { return qq{$_[0]->{name}="$_[0]->{value}"}; }
# Tree::DAG_Node uses the address field to sort nodes, which simplifies things quite a bit
sub xpath_cmp { $_[0]->address cmp $_[1]->address }
sub address
{ my $att= shift;
my $elt= $att->{elt};
return $elt->address . ':' . $att->{rank};
}
=head2 Ordering nodesets
XPath query results must be sorted, and duplicates removed, so the XPath engine
needs to be able to sort nodes.
I does so by calling the C method on nodes.
One of the easiest way to write such a method, for static trees, is to have a
method of the object return its position in the tree as a number.
If that is not possible, here is a method that should work (note that it only
compares elements):
# in the tree element package
sub xpath_cmp($$)
{ my( $a, $b)= @_;
if( UNIVERSAL::isa( $b, $ELEMENT)) # $ELEMENT is the tree element class
{ # 2 elts, compare them
return $a->elt_cmp( $b);
}
elsif( UNIVERSAL::isa( $b, $ATTRIBUTE)) # $ATTRIBUTE is the attribute class
{ # 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->elt_cmp( $b->{elt}) ) || -1 ;
}
elsif( UNIVERSAL::isa( $b, $TREE)) # $TREE is the tree class
{ # elt <=> document, elt is after document
return 1;
}
else
{ die "unknown node type ", ref( $b); }
}
sub elt_cmp
{ my( $a, $b)=@_;
# easy cases
return 0 if( $a == $b);
return 1 if( $a->in($b)); # a starts after b
return -1 if( $b->in($a)); # a starts before b
# ancestors does not include the element itself
my @a_pile= ($a, $a->ancestors);
my @b_pile= ($b, $b->ancestors);
# the 2 elements are not in the same twig
return undef unless( $a_pile[-1] == $b_pile[-1]);
# find the first non common ancestors (they are siblings)
my $a_anc= pop @a_pile;
my $b_anc= pop @b_pile;
while( $a_anc == $b_anc)
{ $a_anc= pop @a_pile;
$b_anc= pop @b_pile;
}
# from there move left and right and figure out the order
my( $a_prev, $a_next, $b_prev, $b_next)= ($a_anc, $a_anc, $b_anc, $b_anc);
while()
{ $a_prev= $a_prev->_prev_sibling || return( -1);
return 1 if( $a_prev == $b_next);
$a_next= $a_next->_next_sibling || return( 1);
return -1 if( $a_next == $b_prev);
$b_prev= $b_prev->_prev_sibling || return( 1);
return -1 if( $b_prev == $a_next);
$b_next= $b_next->_next_sibling || return( -1);
return 1 if( $b_next == $a_prev);
}
}
sub in
{ my ($self, $ancestor)= @_;
while( $self= $self->xpath_get_parent_node) { return $self if( $self == $ancestor); }
}
sub ancestors
{ my( $self)= @_;
while( $self= $self->xpath_get_parent_node) { push @ancestors, $self; }
return @ancestors;
}
# in the attribute package
sub xpath_cmp($$)
{ my( $a, $b)= @_;
if( UNIVERSAL::isa( $b, $ATTRIBUTE))
{ # 2 attributes, compare their elements, then their name
return ($a->{elt}->elt_cmp( $b->{elt}) ) || ($a->{name} cmp $b->{name});
}
elsif( UNIVERSAL::isa( $b, $ELEMENT))
{ # 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}->elt_cmp( $b) ) || 1 ;
}
elsif( UNIVERSAL::isa( $b, $TREE))
{ # att <=> document, att is after document
return 1;
}
else
{ die "unknown node type ", ref( $b); }
}
=head1 XPath extension
The module supports the XPath recommendation to the same extend as XML::XPath
(that is, rather completely).
It includes a perl-specific extension: direct support for regular expressions.
You can use the usual (in Perl!) C<=~> and C operators. Regular expressions
are / delimited (no other delimiter is accepted, \ inside regexp must be
backslashed), the C modifiers can be used.
$xp->findnodes( '//@att[.=~ /^v.$/]'); # returns the list of attributes att
# whose value matches ^v.$
=head1 TODO
provide inheritable node and attribute classes for typical cases, starting with
nodes where the root IS the tree, and where attributes are a simple hash (similar
to what I did in L).
better docs (patches welcome).
=head1 SEE ALSO
L for an exemple of using this module
L for background information
L, which is probably easier to use, but at this point supports much
less of XPath that Tree::XPathEngine.
=head1 AUTHOR
Michel Rodriguez, C<< >>
This code is heavily based on the code for L by Matt Sergeant
copyright 2000 Axkit.com Ltd
=head1 BUGS
Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.
=head1 ACKNOWLEDGEMENTS
=head1 COPYRIGHT & LICENSE
XML::XPath Copyright 2000-2004 AxKit.com Ltd.
Copyright 2006 Michel Rodriguez, All Rights Reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of Tree::XPathEngine
Tree-XPathEngine-0.05/t/ 0000755 0000764 0000144 00000000000 10374646304 014532 5 ustar mrodrigu users Tree-XPathEngine-0.05/t/minitree.pm 0000644 0000764 0000144 00000007165 10374061277 016715 0 ustar mrodrigu users # $Id$
use strict;
use warnings;
package minitree;
{ my( @parent, @next_sibling, @previous_sibling, @first_child, @name, @value, @attributes, @pos);
my $last_obj=0;
sub new
{ my $class= shift;
my $att_class= shift;
my %attributes= @_;
$last_obj++;
my $id= $last_obj;
my $self= bless \$id, $class;
$self->name( $attributes{name}); delete $attributes{name};
$self->value( $attributes{value}); delete $attributes{value};
my @node_attributes= map { $att_class->new( $self, $_ => $attributes{$_}) } sort keys %attributes;
$self->attributes( \@node_attributes);
return $self;
}
BEGIN
{ foreach my $method ( qw( parent next_sibling previous_sibling first_child name value pos) )
{ no strict 'refs';
*{$method}= sub { my $self= shift;
if( @_) { ${$method}[$$self]= shift; }
return ${$method}[$$self];
};
}
}
sub attributes
{ my $self= shift;
if( @_) { $attributes[$$self]= shift; }
return $attributes[$$self] || [];
};
sub root { my $self= shift; while( $self->parent) { $self= $self->parent; } return $self; }
sub last_child
{ my $self= shift;
my $child= $self->first_child || return;
while( $child->next_sibling) { $child= $child->next_sibling; }
return $child;
}
sub children
{ my $self= shift;
my @children;
my $child= $self->first_child || return;
while( $child) { push @children, $child; $child= $child->next_sibling; }
return @children;
}
sub add_as_last_child_of
{ my( $child, $parent)= @_;
$child->parent( $parent);
if( my $previous_sibling= $parent->last_child)
{ $previous_sibling->next_sibling( $child);
$child->previous_sibling( $previous_sibling);
}
else
{ $parent->first_child( $child); }
}
sub set_pos
{ my $self= shift;
my $pos = shift || 1;
$self->pos( $pos++);
foreach my $att (@{$self->attributes})
{ $att->pos( $pos++); }
foreach my $child ($self->children)
{ $pos= $child->set_pos( $pos); }
return $pos;
}
sub dump
{ my $self= shift;
return "$$self : "
# . join ( " - ", grep { $_ } map { "$_ : " . ${$self->$_} if( $self->$_) }
# qw( parent next_sibling previous_sibling first_child)
# )
# . ' : '
. join ( " - ", map { "$_ : " . $self->$_ } qw( name value pos))
. " : " . join( " - ", map { $_->dump } @{$self->attributes})
;
}
sub dump_all
{ my $class= shift;
foreach my $id (1..$last_obj)
{ my $self= bless \$id, $class;
print $self->dump, "\n";
}
}
}
1;
package attribute;
{
my( @name, @value, @parent, @pos);
my $last_obj=0;
sub new
{ my( $class, $parent, $name, $value)= @_;
my $id= $last_obj++;
my $self= bless \$id, $class;
$self->name( $name );
$self->value( $value );
$self->parent( $parent);
return $self;
}
BEGIN
{ foreach my $method ( qw( parent name value pos) )
{ no strict 'refs';
*{$method}= sub { my $self= shift;
if( @_) { ${$method}[$$self]= shift; }
return ${$method}[$$self];
};
}
}
sub dump { my $self= shift; return $self->name . " => " . $self->value . " (" . $self->pos . ")"; }
}
1;
Tree-XPathEngine-0.05/t/04_errors.t 0000644 0000764 0000144 00000006332 10374061735 016541 0 ustar mrodrigu users #!/usr/bin/perl
# $Id: /tree-xpathengine/trunk/t/04_errors.t 21 2006-02-13T10:47:57.335542Z mrodrigu $
use strict;
use warnings;
use Test::More qw( no_plan);
use Tree::XPathEngine;
BEGIN { push @INC, './t'; }
my $tree = init_tree();
my $xp = Tree::XPathEngine->new;
{
eval { $xp->findnodes( '/foo#a/toto', $tree); };
like( $@, qr/Invalid query somewhere around here/, "invalid query");
}
{
eval { $xp->findnodes( '/foo[@position()=1]', $tree); };
like( $@, qr/Invalid token/, "invalid token");
}
{
eval { $xp->findnodes( '//@att1[. / 2 > 2]', $tree); };
like( $@, qr/doesn't match format of a 'Step'/, "invalid token");
}
{
eval { $xp->findnodes( '[. / 2 > 2]', $tree); };
like( $@, qr/Not a _primary_expr/, "not a _primary_expr");
}
{
my $path='/foo[@att]a';
eval { $xp->findnodes( $path, $tree); };
like( $@, qr/^Parse of expression \Q$path\E failed - junk after end of expression:/, "junk after end of expression");
}
{
my $path='/root[last(2)]';
eval { $xp->findnodes( $path, $tree); };
like( $@, qr/^last: function doesn't take parameters/, "param in last()");
}
{
my $path='count(1)';
eval { $xp->findnodes( $path, $tree); };
like( $@, qr/^count: Parameter must be a NodeSet/, "wrong param in count()");
}
{
my $path='/root[position("foo")=1]';
eval { $xp->findnodes( $path, $tree); };
like( $@, qr/^position: function doesn't take parameters/, "param in position()");
}
sub init_tree
{ my $tree = tree->new( 'att', name => 'tree', value => 'tree_value', id =>'t-1');
my $root = tree->new( 'att', name => 'root', value => 'vroot', att1 => '1', id => 'r-1');
$root->add_as_last_child_of( $tree);
return $tree;
}
package tree;
use base 'minitree';
sub xpath_get_name { return shift->name; }
sub xpath_string_value { return shift->value; }
sub xpath_get_root_node { return shift->root; }
sub xpath_get_parent_node { return shift->parent; }
sub xpath_get_child_nodes { return return wantarray ? shift->children : [shift->children]; }
sub xpath_get_next_sibling { return shift->next_sibling; }
sub xpath_get_previous_sibling { return shift->previous_sibling; }
sub xpath_is_element_node { return 1; }
sub get_pos { return shift->pos; }
sub xpath_get_attributes { return wantarray ? @{shift->attributes} : shift->attributes; }
sub to_string
{ my $node= shift;
my $name= $node->name;
my $value= $node->value;
my $atts= join( ' ', map { $_->to_string } $_->xpath_get_attributes);
return "[$name {$atts} $value]";
}
sub xpath_cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; }
1;
package att;
use base 'attribute';
sub xpath_get_name { return shift->name; }
sub to_string { my $att= shift; return sprintf( '%s="%s"', $att->xpath_get_name, $att->xpath_get_value) ; }
sub xpath_string_value { return shift->value; }
sub xpath_get_root_node { return shift->parent->root; }
sub xpath_get_parent_node { return shift->parent; }
sub xpath_is_attribute_node { return 1; }
sub xpath_get_child_nodes { return; }
sub xpath_cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; }
1;
Tree-XPathEngine-0.05/t/pod-coverage.t 0000644 0000764 0000144 00000000407 10374061735 017272 0 ustar mrodrigu users #!perl -T
# $Id: /tree-xpathengine/trunk/t/pod-coverage.t 21 2006-02-13T10:47:57.335542Z mrodrigu $
use Test::More;
eval "use Test::Pod::Coverage 1.04";
plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
all_pod_coverage_ok();
Tree-XPathEngine-0.05/t/00-load.t 0000644 0000764 0000144 00000000373 10374061735 016055 0 ustar mrodrigu users # $Id: /tree-xpathengine/trunk/t/00-load.t 21 2006-02-13T10:47:57.335542Z mrodrigu $
use Test::More tests => 1;
BEGIN {
use_ok( 'Tree::XPathEngine' );
}
diag( "Testing Tree::XPathEngine $Tree::XPathEngine::VERSION, Perl 5.008007, /usr/bin/perl" );
Tree-XPathEngine-0.05/t/03_xpath.t 0000644 0000764 0000144 00000030257 10374110372 016343 0 ustar mrodrigu users #!/usr/bin/perl
# $Id: /tree-xpathengine/trunk/t/03_xpath.t 22 2006-02-13T14:00:25.731780Z mrodrigu $
use strict;
use warnings;
use Test::More qw( no_plan);
use Tree::XPathEngine;
BEGIN { push @INC, './t'; }
my $tree = init_tree();
my $xp = Tree::XPathEngine->new;
is( $xp->findvalue( '/root/kid[@id="k-2" or @id="k-4"]', $tree), 'vkid-2vkid-4', "or expression");
is( $xp->findvalue( '/root/kid[@id="k-2" and @id="k-4"]', $tree), '', "and expression (no return)");
is( $xp->findvalue( '/root/kid[@id="k-2" and position()=1]', $tree), 'vkid-2', "and expression");
is( $xp->findvalue( '//@att1[.>2]', $tree), '345', ">");
is( $xp->findvalue( '//@att1[.>=2]', $tree), '2345', ">=");
is( $xp->findvalue( '//@att1[.<2]', $tree), '11', "<");
is( $xp->findvalue( '//@att1[.<=2]', $tree), '112', "<=");
is( $xp->findvalue( '//@att1[.=2]', $tree), '2', "=");
is( $xp->findvalue( '//@att1[.!=2]', $tree), '11345', "!=");
is( $xp->findvalue( '//@att2[.="vv"]', $tree), "vv"x10, "= (string)");
is( $xp->findvalue( '//@att1[.+1>2]', $tree), '2345', "> and +");
is( $xp->findvalue( '//@att1[.-1>2]', $tree), '45', "> and -");
is( $xp->findvalue( '//@att1[.*2>2]', $tree), '2345', "> and *");
is( $xp->findvalue( '//@att1[. div 2 > 2]', $tree), '5', "> and div");
is( $xp->findvalue( '//@att1[. mod 2 = 1]', $tree), '1135', "> and mod");
is( $xp->findvalue( '//@att1[ -. < -3]', $tree), '45', "> and unary -");
is( $xp->findvalue( '//root | //@att1[ . > 4] | /root/kid[@*="k-3"]' , $tree), 'vrootvkid-35', "|");
is( $xp->findvalue( '/root//gkid1[..//gkid2[@id="gk2-3"]]/@id', $tree), 'gk1-3', '// in the path');
is( $xp->findvalue( '/root//gkid1[..//gkid2[@id="gk2-3"]]/@id', $tree), 'gk1-3', '// in the path');
is( $xp->findvalue( '/root//gkid1[//gkid2[@id="gk2-3"]]/@id', $tree), 'gk1-1gk1-2gk1-3gk1-4gk1-5', '// in the predicate');
is( $xp->findvalue( '2', $tree), '2', 'constant');
is( $xp->findvalue( '2 = (1 + 1)', $tree), 'true', 'boolean constant (true)');
is( $xp->findvalue( '2 = (1 + 2)', $tree), '', 'boolean constant (false)');
is( $xp->findvalue( '"foo"', $tree), 'foo', 'literal constant');
is( $xp->findvalue( '(2 = (1 + 1)) > ( 2 = 3) ', $tree), 'true', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) >= ( 2 = 3) ', $tree), 'true', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) = ( 2 = 2) ', $tree), 'true', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) < ( 2 = 3) ', $tree), '', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) <= ( 2 = 3) ', $tree), '', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) != ( 2 = 2) ', $tree), '', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) < ( 2 = 3) ', $tree), '', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) <= ( 2 = 3) ', $tree), '', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) != ( 2 = 2) ', $tree), '', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) > ( 2 = 3) ', $tree), 'true', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) >= ( 2 = 3) ', $tree), 'true', 'boolean comparison');
is( $xp->findvalue( '(2 = (1 + 1)) = ( 2 = 2) ', $tree), 'true', 'boolean comparison');
is( $xp->findvalue( '"true" = ( 2 = 2) ', $tree), 'true', 'boolean thingies');
is( $xp->findvalue( '"" = ( 2 = 3) ', $tree), 'true', 'boolean thingies');
# string functions
is( $xp->findvalue( 'concat( "foo", "bar")', $tree), 'foobar', 'concat');
is( $xp->findvalue( 'starts_with( "foobar", "foo")', $tree), 'true', 'starts_with (true)');
is( $xp->findvalue( 'starts_with( "foobar", "bar")', $tree), '', 'starts_with (false)');
is( $xp->findvalue( 'contains( "foobar", "foo")', $tree), 'true', 'contains (true)');
is( $xp->findvalue( 'contains( "foobar", "baz")', $tree), '', 'contains (false)');
is( $xp->findvalue( 'substring-before("1999/04/01","/")', $tree), '1999', 'substring-before (success)');
is( $xp->findvalue( 'substring-before("1999/04/01",":")', $tree), '', 'substring-before (failure)');
is( $xp->findvalue( 'substring-after("1999/04/01","/")', $tree), '04/01', 'substring-after (success)');
is( $xp->findvalue( 'substring-before("1999/04/01",":")', $tree), '', 'substring-after (failure)');
is( $xp->findvalue( 'substring("1999/04/01", 1, 4)', $tree), '1999', 'substring (leading substring)');
is( $xp->findvalue( 'substring("1999/04/01", 6, 2)', $tree), '04', 'substring');
is( $xp->findvalue( 'substring("1999/04/01", 6)', $tree), '04/01', 'substring (no 3rd argument)');
is( $xp->findvalue( 'string-length("1999/04/01")', $tree), '10', 'string-length');
is( $xp->findvalue( 'string-length("")', $tree), '', 'string-length (empty string)');
is( $xp->findvalue( 'normalize-space("foo bar")', $tree), 'foo bar', 'normalize-space');
is( $xp->findvalue( 'normalize-space("foo bar ")', $tree), 'foo bar', 'normalize-space');
is( $xp->findvalue( 'normalize-space(" foo bar ")', $tree), 'foo bar', 'normalize-space');
is( $xp->findvalue( 'normalize-space(" foo bar baz")', $tree), 'foo bar baz', 'normalize-space');
is( $xp->findvalue( 'translate("bar","abc","ABC")', $tree), 'BAr', 'translate');
is( $xp->findvalue( 'translate("--aaa--","abc-","ABC")', $tree), 'AAA', 'translate (with deletion)');
is( $xp->findvalue( 'translate("--aada--","abc-","ABC")', $tree), 'AAdA', 'translate (with deletion and untouched char)');
is( $xp->findvalue( 'true()', $tree), 'true', 'true');
is( $xp->findvalue( 'false()', $tree), '', 'false');
is( $xp->findvalue( 'not(false())', $tree), 'true', 'not');
is( $xp->findvalue( 'boolean(1)', $tree), 'true', 'boolean (true)');
is( $xp->findvalue( 'boolean(0)', $tree), '', 'boolean (false)');
is( $xp->findvalue( 'number(1)', $tree), '1', 'number');
is( $xp->findvalue( '"1" = "1.0"', $tree), '', 'number equals (false)');
is( $xp->findvalue( '1 = "1.0"', $tree), 'true', 'number equals (conversion, true)');
is( $xp->findvalue( '1 = number("1.0")', $tree), 'true', 'number equals (true)');
is( $xp->findvalue( 'number( //kid[1]/@att1)', $tree), '1', 'number (node)');
is( $xp->findvalue( 'number( //kid[1]/@att1)="1.0"', $tree), 'true', 'number equals (node, true)');
is( $xp->findvalue( '//kid[1]/@att1[number(.)="1.0"]', $tree), '1', 'number equals (on (current) node)');
is( $xp->findvalue( '//kid[1]/@att1[number()="1.0"]', $tree), '1', 'number equals (on default (current) node)');
is( $xp->findvalue( ' (//kid[1]/@att1)="1.0"', $tree), '', 'number equals (node, false)');
is( $xp->findvalue( ' sum(//kid/@att1)', $tree), 15, "sum (nodes)");
is( $xp->findvalue( 'count( //gkid1)', $tree), 5, "count");
{ my $gk= ($xp->findnodes( '//gkid1', $tree))[0];
ok( $xp->matches( $gk, '//*[@att2="vv"]', $tree), 'matches');
}
is( $xp->findvalue( '//kid[@att1>2][2]', $tree), "vkid-4", "2 predicates");
is( $xp->findvalue( '//kid[@*=2]', $tree), "vkid-2", "= on a nodeset");
is( $xp->findvalue( '//kid[@*=@id][2]', $tree), "vkid-2", "= on 2 nodesets");
is( $xp->findvalue( '//kid[@*>=@id][2]', $tree), "vkid-2", ">= on 2 nodesets");
is( $xp->findvalue( '//kid[@*<(@id+1)][2]', $tree), "vkid-2", "< on 2 nodesets");
is( $xp->findvalue( '//kid[@*>(@id - 1)][2]', $tree), "vkid-2", "> on 2 nodesets");
is( $xp->findvalue( '//kid[@* != @id][2]', $tree), "", "!= on 2 nodesets (no hit)");
is( $xp->findvalue( '//kid[@* != @id * 2][2]', $tree), "", "!= on 2 nodesets (no hit)");
is( $xp->findvalue( '//kid[@*=~ m/^\d$/][2]', $tree), "vkid-2", "=~ on 2 nodesets");
is( $xp->findvalue( '//kid[@*!~ m/^\d$/][2]', $tree), "vkid-2", "!~ on 2 nodesets");
{ my $gk= ($xp->findnodes( '//gkid1', $tree))[0];
is( $xp->findvalue( '@att2="vv"', $gk), 'true','predicate only');
}
is( $xp->findvalue( '//@id[.="gk1-4"]/../ancestor::*[@att2="vv"]', $tree), 'vkid-4', 'ancestor (with wc)');
is( $xp->findvalue( '//@id[.="gk1-4"]/ancestor::*[@att2="vv"]', $tree), 'vkid-4vgkid1-4', 'ancestor (with wc, 1)');
is( $xp->findvalue( '//@id[.="gk1-4"]/../ancestor-or-self::*[@att2="vv"]', $tree), 'vkid-4vgkid1-4', 'ancestor-or-self (with wc)');
is( $xp->findvalue( '//@att2/ancestor::kid[@id="k-4"]', $tree), 'vkid-4', 'ancestor');
is( $xp->findvalue( '//@att2/ancestor-or-self::kid[@id="k-4"]', $tree), 'vkid-4', 'ancestor-or-self');
is( $xp->findvalue( '//*[string()="vgkid2-3"]', $tree), 'vgkid2-3', 'string()');
is( $xp->findvalue( '//*[string()=~ /^vgkid2-3/]', $tree), 'vgkid2-3', 'match (/ delimited) on string()');
is( $xp->findvalue( '//*[string()=~ /^vg(\/|kid)2-3/]', $tree), 'vgkid2-3', 'match (/ delimited, \/) on string()');
is( $xp->findvalue( '//*[string()=~ /^vg(\/|kid)2-3/]', $tree), 'vgkid2-3', 'match (/ delimited, \/) on string()');
is( $xp->findvalue( '//*[string()=~ /^vg(!|\/|kid)2-3/]', $tree), 'vgkid2-3', 'match (/ delimited, !,\/) on string()');
is( $xp->findvalue( '//*[string()=~ /^vgkid2-[24]/]', $tree), 'vgkid2-2vgkid2-4', 'match (/ delimited) on string() (x)');
is( $xp->findvalue( '//*[@id="k-4"]/preceding-sibling::*[1]', $tree), 'vkid-3', 'preceding-sibling (1)');
is( $xp->findvalue( '//*[@id="k-4"]/preceding-sibling::*', $tree), 'vkid-1vkid-2vkid-3', 'preceding-sibling (x)');
is( $xp->findvalue( '//*[@id="k-4"]/following-sibling::*[1]', $tree), 'vkid-5', 'preceding-sibling (1)');
is( $xp->findvalue( '//*[@id="k-3"]/following-sibling::*', $tree), 'vkid-4vkid-5', 'preceding-sibling (x)');
is( $xp->findvalue( '//*[@id="k-5"]/following-sibling::*', $tree), '', 'preceding-sibling (x)');
is( $xp->findvalue( '//*[@id="k-4"]/preceding::*[1]', $tree), 'vgkid1-1', 'preceding(1)');
is( $xp->findvalue( '//*[@id="k-4"]/following::*[1]', $tree), 'vgkid1-5', 'following(1)');
is( $xp->findvalue( '//kid[//@id="k-4"][2]', $tree), 'vkid-2', '//in predicate');
is( $xp->findvalue( '//kid[//@id="k-8"][2]', $tree), '', '//in predicate (empty result)');
{ sub init_tree
{ my $tree = tree->new( 'att', name => 'tree', value => 'vtree', id =>'t-1');
my $root = tree->new( 'att', name => 'root', value => 'vroot', att1 => '1', id => 'r-1');
$root->add_as_last_child_of( $tree);
foreach (1..5)
{ my $kid= tree->new( 'att', name => 'kid', value => "vkid-$_", att1 => "$_", att2 => "vv", id=> "k-$_");
$kid->add_as_last_child_of( $root);
my $gkid1= tree->new( 'att', name => 'gkid1', value => "vgkid1-$_", att2 => "vv", id=> "gk1-$_");
$gkid1->add_as_last_child_of( $kid);
my $gkid2= tree->new( 'att', name => 'gkid2', value => "vgkid2-$_", att2 => "vx", id=> "gk2-$_");
$gkid2->add_as_last_child_of( $kid);
}
$tree->set_pos;
#tree->dump_all;
return $tree;
}
}
package tree;
use base 'minitree';
sub xpath_get_name { return shift->name; }
sub xpath_string_value { return shift->value; }
sub xpath_get_root_node { return shift->root; }
sub xpath_get_parent_node { return shift->parent; }
sub xpath_get_child_nodes { return wantarray ? shift->children : [shift->children]; }
sub xpath_get_next_sibling { return shift->next_sibling; }
sub xpath_get_previous_sibling { return shift->previous_sibling; }
sub xpath_is_element_node { return 1; }
sub xpath_is_attribute_node { return 0; }
sub get_pos { return shift->pos; }
sub xpath_get_attributes { return wantarray ? @{shift->attributes} : shift->attributes; }
sub to_string
{ my $node= shift;
my $name= $node->name;
my $value= $node->value;
my $atts= join( ' ', map { $_->to_string } $node->xpath_get_attributes);
return "[$name {$atts} $value]";
}
sub xpath_to_number { return Tree::XPathEngine::Number->new( shift->value); }
sub xpath_cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; }
1;
package att;
use base 'attribute';
sub xpath_get_name { return shift->name; }
sub to_string { my $att= shift; return sprintf( '%s="%s"', $att->xpath_get_name, $att->xpath_get_value) ; }
sub xpath_to_number { return Tree::XPathEngine::Number->new( shift->value); }
sub xpath_to_boolean { return Tree::XPathEngine::Boolean->new( shift->value); }
sub xpath_string_value { return shift->value; }
sub xpath_get_root_node { return shift->parent->root; }
sub xpath_get_parent_node { return shift->parent; }
sub xpath_is_attribute_node { return 1; }
sub xpath_is_element_node { return 0; }
sub xpath_get_child_nodes { return wantarray ? () : []; }
sub xpath_cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; }
1;
Tree-XPathEngine-0.05/t/01_basic.t 0000644 0000764 0000144 00000012347 10374061735 016306 0 ustar mrodrigu users #!/usr/bin/perl
#$Id: /tree-xpathengine/trunk/t/01_basic.t 21 2006-02-13T10:47:57.335542Z mrodrigu $
use strict;
use warnings;
use Test::More qw( no_plan);
use Tree::XPathEngine;
BEGIN { push @INC, './t'; }
my $tree = init_tree();
my $xp = Tree::XPathEngine->new;
{
my @root_nodes= $xp->findnodes( '/root', $tree);
is( join( ':', map { $_->value } @root_nodes), 'root_value', q{findnodes( '/root', $tree)});
}
{
my @kid_nodes= $xp->findnodes( '/root/kid0', $tree);
is( scalar @kid_nodes, 2, q{findnodes( '/root/kid0', $tree)});
}
{
my $kid_nodes= $xp->findvalue( '/root/kid0', $tree);
is( $kid_nodes, 'vkid2vkid4', q{findvalue( '/root/kid0', $tree)});
}
{
is( $xp->findvalue( '//*[@att2="vv"]', $tree), 'gvkid1gvkid2gvkid3gvkid4gvkid5',
q{findvalue( '//*[@att2="vv"]', $tree)}
);
is( $xp->findvalue( '//*[@att2]', $tree), 'gvkid1gkid2 1gvkid2gkid2 2gvkid3gkid2 3gvkid4gkid2 4gvkid5gkid2 5',
q{findvalue( '//*[@att2]', $tree)}
);
}
{
is( $xp->findvalue( '//kid1/@att1[.="v1"]', $tree), 'v1', "return attribute values (1)");
is( $xp->findvalue( '//@att1[.="v1"]', $tree), 'v1'x2, "return attribute values (2)");
is( $xp->findvalue( '//@att2[.="vx"]', $tree), 'vx'x5, "return attribute values (5)");
is( $xp->findvalue( '//kid1/@att1[.=~m/v1/]', $tree), 'v1', "regxp match, return attribute values (1)");
is( $xp->findvalue( '//@att1[.=~m/v1/]', $tree), 'v1'x2, "regxp match, return attribute values (2)");
is( $xp->findvalue( '//@att2[.=~/vx/]', $tree), 'vx'x5, "regxp match, return attribute values (5)");
}
{ my $elt= ($xp->findnodes( '/root/kid1[1]/gkid2', $tree))[0];
ok( $xp->matches( $elt, '/root/kid1/gkid2', $tree), 'matches (true)');
ok( !$xp->matches( $elt, '/root/kid0/gkid2', $tree), 'matches (false)');
}
{ my @empty= $xp->findnodes( '0', $tree);
is( scalar( @empty), 0, 'findnodes, empty return in list context');
}
{ is( $xp->findnodes_as_string( '/root/kid1[1]/gkid2', $tree), '[gkid2 {att2="vx"} gkid2 1]' , 'findnode_as_string (nodeset result)');
is( $xp->findnodes_as_string( '"foo"', $tree), 'foo' , 'findnode_as_string (literal result)');
is( $xp->findnodes_as_string( '1', $tree), 1 , 'findnode_as_string (number result)');
}
{ is( $xp->findvalue( '/root/kid1[1]/gkid2', $tree), 'gkid2 1' , 'findvalue (nodeset result)');
is( $xp->findvalue( '"foo"', $tree), 'foo' , 'findvalue (literal result)');
is( $xp->findvalue( '1', $tree), 1 , 'findvalue (number result)');
is( $xp->findvalue( '//nothing', $tree), '' , 'findvalue (number result)');
}
{ is( $xp->exists( '/root/kid1[1]/gkid2', $tree), 1, 'exists (true)');
is( $xp->exists( '/nothing/kid1[1]/gkid2', $tree), 0, 'exists (false)');
}
{ $xp->set_var( var => "gkid2 1");
is( $xp->get_var( 'var'), 'gkid2 1', 'get_var');
is( $xp->findvalue( '//gkid2[string()="gkid2 1"]', $tree), 'gkid2 1', "string()");
#is( $xp->findvalue( '//gkid2[string()=$var]', $tree), 'gkid2 1', "string()"); # TODO
}
{ # to test _get_context_size
is( $xp->findvalue( '//kid0[last()]/gkid2', $tree), 'gkid2 4', "string()");
# to test _get_context_pos
is( $xp->findvalue( '//kid0[position()=2]/gkid2', $tree), 'gkid2 4', "string()");
}
sub init_tree
{ my $tree = tree->new( 'att', name => 'tree', value => 'tree');
my $root = tree->new( 'att', name => 'root', value => 'root_value', att1 => 'v1');
$root->add_as_last_child_of( $tree);
foreach (1..5)
{ my $kid= tree->new( 'att', name => 'kid' . $_ % 2, value => "vkid$_", att1 => "v$_");
$kid->add_as_last_child_of( $root);
my $gkid1= tree->new( 'att', name => 'gkid' . $_ % 2, value => "gvkid$_", att2 => "vv");
$gkid1->add_as_last_child_of( $kid);
my $gkid2= tree->new( 'att', name => 'gkid2', value => "gkid2 $_", att2 => "vx");
$gkid2->add_as_last_child_of( $kid);
}
$tree->set_pos;
#tree->dump_all;
return $tree;
}
package tree;
use base 'minitree';
sub xpath_get_name { return shift->name; }
sub xpath_string_value { return shift->value; }
sub xpath_get_root_node { return shift->root; }
sub xpath_get_parent_node { return shift->parent; }
sub xpath_get_child_nodes { return shift->children; }
sub xpath_get_next_sibling { return shift->next_sibling; }
sub xpath_get_previous_sibling { return shift->previous_sibling; }
sub xpath_is_element_node { return 1; }
sub xpath_get_attributes { return @{shift->attributes}; }
sub to_string
{ my $node= shift;
my $name= $node->name;
my $value= $node->value;
my $atts= join( ' ', map { $_->to_string } $_->xpath_get_attributes);
return "[$name {$atts} $value]";
}
sub xpath_cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; }
1;
package att;
use base 'attribute';
sub xpath_get_name { return shift->name; }
sub to_string { my $att= shift; return sprintf( '%s="%s"', $att->name, $att->value) ; }
sub xpath_string_value { return shift->value; }
sub xpath_get_root_node { return shift->parent->root; }
sub xpath_get_parent_node { return shift->parent; }
sub xpath_is_attribute_node { return 1; }
sub xpath_get_child_nodes { return; }
sub xpath_cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; }
1;
Tree-XPathEngine-0.05/t/pod.t 0000644 0000764 0000144 00000000336 10374061735 015502 0 ustar mrodrigu users #!perl -T
# $Id: /tree-xpathengine/trunk/t/pod.t 21 2006-02-13T10:47:57.335542Z mrodrigu $
use Test::More;
eval "use Test::Pod 1.14";
plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
all_pod_files_ok();
Tree-XPathEngine-0.05/t/02_altername_word_tokens.t 0000644 0000764 0000144 00000005450 10374061735 021611 0 ustar mrodrigu users #!/usr/bin/perl
# $Id: /tree-xpathengine/trunk/t/02_altername_word_tokens.t 21 2006-02-13T10:47:57.335542Z mrodrigu $
use strict;
use warnings;
use Test::More qw( no_plan);
use Tree::XPathEngine;
BEGIN { push @INC, './t'; }
foreach my $extra_char ( '#', ':')
{ my $tree = init_tree( $extra_char);
my $xp = Tree::XPathEngine->new( xpath_name_re => qr/[a-z][\w$extra_char]*/);
{ my @kid_nodes= $xp->findnodes( "/root/kid${extra_char}0", $tree);
is( scalar @kid_nodes, 2, qq{findnodes( '/root/kid${extra_char}0', \$tree)});
}
{ my $kid_nodes= $xp->findvalue( "/root/kid${extra_char}0", $tree);
is( $kid_nodes, 'vkid2vkid4', qq{findvalue( '/root/kid${extra_char}0', \$tree)});
}
}
sub init_tree
{ my( $extra_char)= @_;
my $tree = tree->new( 'att', name => 'tree', value => 'tree');
my $root = tree->new( 'att', name => 'root', value => 'root_value', att1 => 'v1');
$root->add_as_last_child_of( $tree);
foreach (1..5)
{ my $kid= tree->new( 'att', name => 'kid' . $extra_char . $_ % 2, value => "vkid$_", att1 => "v$_");
$kid->add_as_last_child_of( $root);
my $gkid1= tree->new( 'att', name => 'gkid' . $extra_char . $_ % 2, value => "gvkid$_", att2 => "vv");
$gkid1->add_as_last_child_of( $kid);
my $gkid2= tree->new( 'att', name => 'gkid2', value => "gkid2 $_", att2 => "vx");
$gkid2->add_as_last_child_of( $kid);
}
$tree->set_pos;
#tree->dump_all;
return $tree;
}
package tree;
use base 'minitree';
sub xpath_get_name { return shift->name; }
sub xpath_string_value { return shift->value; }
sub xpath_get_root_node { return shift->root; }
sub xpath_get_parent_node { return shift->parent; }
sub xpath_get_child_nodes { return return wantarray ? shift->children : [shift->children]; }
sub xpath_get_next_sibling { return shift->next_sibling; }
sub xpath_get_previous_sibling { return shift->previous_sibling; }
sub xpath_is_element_node { return 1; }
sub get_pos { return shift->pos; }
sub xpath_get_attributes { return wantarray ? @{shift->attributes} : shift->attributes; }
sub xpath_cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; }
1;
package att;
use base 'attribute';
sub xpath_get_name { return shift->name; }
sub xpath_string_value { return shift->value; }
sub to_string { return shift->value; }
sub xpath_get_root_node { return shift->parent->root; }
sub xpath_get_parent_node { return shift->parent; }
sub xpath_is_attribute_node { return 1; }
sub xpath_get_child_nodes { return; }
sub xpath_cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; }
1;
Tree-XPathEngine-0.05/Changes 0000644 0000764 0000144 00000000431 10374646276 015570 0 ustar mrodrigu users Revision history for Tree-XPathEngine
$Id: /tree-xpathengine/trunk/Changes 26 2006-02-15T15:46:06.515200Z mrodrigu $
0.05 2006-02-12
Fixed installation problems (extra includes and missing files in MANIFEST)
0.04 2006-02-12
First version, released on CPAN
Tree-XPathEngine-0.05/MANIFEST 0000644 0000764 0000144 00000001033 10374646276 015425 0 ustar mrodrigu users Changes
MANIFEST
META.yml # Will be created by "make dist"
Makefile.PL
README
lib/Tree/XPathEngine.pm
lib/Tree/XPathEngine/Boolean.pm
lib/Tree/XPathEngine/Expr.pm
lib/Tree/XPathEngine/Function.pm
lib/Tree/XPathEngine/Literal.pm
lib/Tree/XPathEngine/LocationPath.pm
lib/Tree/XPathEngine/NodeSet.pm
lib/Tree/XPathEngine/Number.pm
lib/Tree/XPathEngine/Root.pm
lib/Tree/XPathEngine/Step.pm
lib/Tree/XPathEngine/Variable.pm
t/00-load.t
t/pod-coverage.t
t/pod.t
t/01_basic.t
t/02_altername_word_tokens.t
t/03_xpath.t
t/04_errors.t
t/minitree.pm
Tree-XPathEngine-0.05/META.yml 0000644 0000764 0000144 00000000541 10374646304 015540 0 ustar mrodrigu users # http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Tree-XPathEngine
version: 0.05
version_from: lib/Tree/XPathEngine.pm
installdirs: site
requires:
Test::More: 0
distribution_type: module
generated_by: ExtUtils::MakeMaker version 6.17
Tree-XPathEngine-0.05/README 0000644 0000764 0000144 00000000553 10373565700 015151 0 ustar mrodrigu users Tree-XPathEngine
Tree::XPathEngine - a re-usable XPath engine
INSTALLATION
To install this module, run the following commands:
perl Makefile.PL
make
make test
make install
COPYRIGHT AND LICENCE
Copyright (C) 2006 Michel Rodriguez
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Tree-XPathEngine-0.05/Makefile.PL 0000644 0000764 0000144 00000000774 10370412146 016240 0 ustar mrodrigu users use strict;
use warnings;
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Tree::XPathEngine',
AUTHOR => 'Michel Rodriguez ',
VERSION_FROM => 'lib/Tree/XPathEngine.pm',
ABSTRACT_FROM => 'lib/Tree/XPathEngine.pm',
PL_FILES => {},
PREREQ_PM => {
'Test::More' => 0,
},
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
clean => { FILES => 'Tree-XPathEngine-*' },
);