XML-XPathEngine-0.14/0000755000175000017500000000000012144117367014516 5ustar mrodrigumrodriguXML-XPathEngine-0.14/MANIFEST0000644000175000017500000000107112144117367015646 0ustar mrodrigumrodriguChanges MANIFEST META.yml # Will be created by "make dist" Makefile.PL README lib/XML/XPathEngine.pm lib/XML/XPathEngine/Function.pm lib/XML/XPathEngine/LocationPath.pm lib/XML/XPathEngine/Variable.pm lib/XML/XPathEngine/Number.pm lib/XML/XPathEngine/Step.pm lib/XML/XPathEngine/Literal.pm lib/XML/XPathEngine/Expr.pm lib/XML/XPathEngine/Boolean.pm lib/XML/XPathEngine/NodeSet.pm lib/XML/XPathEngine/Root.pm t/pod-coverage.t t/pod.t t/00-load.t t/01_basic.t t/minidom.pm t/minitree.pm META.json Module JSON meta-data (added by MakeMaker) XML-XPathEngine-0.14/lib/0000755000175000017500000000000012144117367015264 5ustar mrodrigumrodriguXML-XPathEngine-0.14/lib/XML/0000755000175000017500000000000012144117367015724 5ustar mrodrigumrodriguXML-XPathEngine-0.14/lib/XML/XPathEngine.pm0000644000175000017500000011075612144117274020443 0ustar mrodrigumrodrigupackage XML::XPathEngine; use warnings; use strict; use vars qw($VERSION $AUTOLOAD $revision); $VERSION = '0.14'; $XML::XPathEngine::Namespaces = 0; $XML::XPathEngine::DEBUG = 0; use vars qw/ $NCName $QName $NCWild $QNWild $NUMBER_RE $NODE_TYPE $AXIS_NAME %AXES $LITERAL $REGEXP_RE $REGEXP_MOD_RE %CACHE/; use XML::XPathEngine::Step; use XML::XPathEngine::Expr; use XML::XPathEngine::Function; use XML::XPathEngine::LocationPath; use XML::XPathEngine::Variable; use XML::XPathEngine::Literal; use XML::XPathEngine::Number; use XML::XPathEngine::NodeSet; use XML::XPathEngine::Root; # Axis name to principal node type mapping %AXES = ( 'ancestor' => 'element', 'ancestor-or-self' => 'element', 'attribute' => 'attribute', 'namespace' => 'namespace', 'child' => 'element', 'descendant' => 'element', 'descendant-or-self' => 'element', 'following' => 'element', 'following-sibling' => 'element', 'parent' => 'element', 'preceding' => 'element', 'preceding-sibling' => 'element', 'self' => 'element', ); $NCName = '([A-Za-z_][\w\\.\\-]*)'; $QName = "($NCName:)?$NCName"; $NCWild = "${NCName}:\\*"; $QNWild = "\\*"; $NODE_TYPE = '((text|comment|processing-instruction|node)\\(\\))'; $AXIS_NAME = '(' . join('|', keys %AXES) . ')::'; $NUMBER_RE = '\d+(\\.\d*)?|\\.\d+'; $LITERAL = '\\"[^\\"]*\\"|\\\'[^\\\']*\\\''; $REGEXP_RE = qr{(?:m?/(?:\\.|[^/])*/)}; $REGEXP_MOD_RE = qr{(?:[imsx]+)}; sub new { my $class = shift; my $self = bless {}, $class; _debug("New Parser being created.\n") if( $XML::XPathEngine::DEBUG); $self->{context_set} = XML::XPathEngine::NodeSet->new(); $self->{context_pos} = undef; # 1 based position in array context $self->{context_size} = 0; # total size of context $self->clear_namespaces(); $self->{vars} = {}; $self->{direction} = 'forward'; $self->{cache} = {}; return $self; } sub find { my $self = shift; my( $path, $context) = @_; my $parsed_path= $self->_parse( $path); my $results= $parsed_path->evaluate( $context); if( $results->isa( 'XML::XPathEngine::NodeSet')) { return $results->sort->remove_duplicates; } else { return $results; } } 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('XML::XPathEngine::NodeSet')) { return wantarray ? $results->get_nodelist : $results; } else { return wantarray ? XML::XPathEngine::NodeSet->new($results) : $results; } # result should be SCALAR #{ return wantarray ? ($results) : $results; } # result should be SCALAR #{ return wantarray ? () : XML::XPathEngine::NodeSet->new(); } } sub findnodes_as_string { my $self = shift; my ($path, $context) = @_; my $results = $self->find( $path, $context); if ($results->isa('XML::XPathEngine::NodeSet')) { return join '', map { $_->toString } $results->get_nodelist; } elsif ($results->isa('XML::XPathEngine::Boolean')) { return ''; # to behave like XML::LibXML } elsif ($results->isa('XML::XPathEngine::Node')) { return $results->toString; } else { return _xml_escape_text($results->value); } } sub findnodes_as_strings { my $self = shift; my ($path, $context) = @_; my $results = $self->find( $path, $context); if ($results->isa('XML::XPathEngine::NodeSet')) { return map { $_->getValue } $results->get_nodelist; } elsif ($results->isa('XML::XPathEngine::Boolean')) { return (); # to behave like XML::LibXML } elsif ($results->isa('XML::XPathEngine::Node')) { return $results->getValue; } else { return _xml_escape_text($results->value); } } sub findvalue { my $self = shift; my ($path, $context) = @_; my $results = $self->find( $path, $context); if ($results->isa('XML::XPathEngine::NodeSet')) { return $results->to_final_value; } #{ return $results->to_literal; } return $results->value; } sub findvalues { my $self = shift; my ($path, $context) = @_; my $results = $self->find( $path, $context); if ($results->isa('XML::XPathEngine::NodeSet')) { return $results->string_values; } return ($results->string_value); } sub exists { my $self = shift; my ($path, $context) = @_; $self = '/' if (!defined $self); 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 set_namespace { my $self = shift; my ($prefix, $expanded) = @_; $self->{uses_namespaces}=1; $self->{namespaces}{$prefix} = $expanded; } sub clear_namespaces { my $self = shift; $self->{uses_namespaces}=0; $self->{namespaces} = {}; } sub get_namespace { my $self = shift; my ($prefix, $node) = @_; my $ns= $node ? $node->getNamespace($prefix) : $self->{uses_namespaces} ? $self->{namespaces}->{$prefix} : $prefix; return $ns; } sub set_strict_namespaces { my( $self, $strict) = @_; $self->{strict_namespaces}= $strict; } 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; my $context= join( '&&', $path, map { "$_=>$self->{namespaces}->{$_}" } sort keys %{$self->{namespaces}}); #warn "context: $context\n"; if ($CACHE{$context}) { return $CACHE{$context}; } 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}]"; } $tree->{uses_namespaces}= $self->{uses_namespaces}; $tree->{strict_namespaces}= $self->{strict_namespaces}; $CACHE{$context} = $tree; _debug("PARSED Expr to:\n", $tree->as_string, "\n") if( $XML::XPathEngine::DEBUG); return $tree; } sub _tokenize { my $self = shift; my $path = shift; study $path; my @tokens; _debug("Parsing: $path\n") if( $XML::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*}gcxso)) { # special case: regexp expected after =~ or !~, regular parsing rules do not apply # ( the / is now the regexp delimiter) $token= $1; $expected=''; } elsif($path =~ m/\G \s* # ignore all whitespace ( # tokens $LITERAL| $NUMBER_RE| # digits \.\.| # parent \.| # current ($AXIS_NAME)?$NODE_TYPE| # tests processing-instruction| \@($NCWild|$QName|$QNWild)| # attrib \$$QName| # variable reference ($AXIS_NAME)?($NCWild|$QName|$QNWild)| # NCName,NodeType,Axis::Test \!=|<=|\-|>=|\/\/|and|or|mod|div| # multi-char seps =~|\!~| # regexp (not in the XPath spec) [,\+=\|<>\/\(\[\]\)]| # single char seps (?{_curr_match} = ''; return 0 unless $self->{_tokpos} < @$tokens; local $^W; # _debug ("match: $match\n") if( $XML::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( $XML::XPathEngine::DEBUG); return _or_expr($self, $tokens); } sub _or_expr { my ($self, $tokens) = @_; _debug( "in _or_expr\n") if( $XML::XPathEngine::DEBUG); my $expr = _and_expr($self, $tokens); while (_match($self, $tokens, 'or')) { my $or_expr = XML::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( $XML::XPathEngine::DEBUG); my $expr = _match_expr($self, $tokens); while (_match($self, $tokens, 'and')) { my $and_expr = XML::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( $XML::XPathEngine::DEBUG); my $expr = _equality_expr($self, $tokens); while (_match($self, $tokens, '[=!]~')) { my $match_expr = XML::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( $XML::XPathEngine::DEBUG); my $expr = _relational_expr($self, $tokens); while (_match($self, $tokens, '!?=')) { my $eq_expr = XML::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( $XML::XPathEngine::DEBUG); my $expr = _additive_expr($self, $tokens); while (_match($self, $tokens, '(<|>|<=|>=)')) { my $rel_expr = XML::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( $XML::XPathEngine::DEBUG); my $expr = _multiplicative_expr($self, $tokens); while (_match($self, $tokens, '[\\+\\-]')) { my $add_expr = XML::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( $XML::XPathEngine::DEBUG); my $expr = _unary_expr($self, $tokens); while (_match($self, $tokens, '(\\*|div|mod)')) { my $mult_expr = XML::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( $XML::XPathEngine::DEBUG); if (_match($self, $tokens, '-')) { my $expr = XML::XPathEngine::Expr->new($self); $expr->set_lhs(XML::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( $XML::XPathEngine::DEBUG); my $expr = _path_expr($self, $tokens); while (_match($self, $tokens, '\\|')) { my $un_expr = XML::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( $XML::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 = XML::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 = XML::XPathEngine::LocationPath->new(); push @$loc_path, $expr; if ($self->{_curr_match} eq '//') { push @$loc_path, XML::XPathEngine::Step->new($self, 'descendant-or-self', XML::XPathEngine::Step::test_nt_node() ); } push @$loc_path, _relative_location_path($self, $tokens); my $new_expr = XML::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( $XML::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( $XML::XPathEngine::DEBUG); my $expr = XML::XPathEngine::Expr->new($self); if (_match($self, $tokens, $LITERAL)) { # new Literal with $self->{_curr_match}... $self->{_curr_match} =~ m/^(["'])(.*)\1$/; $expr->set_lhs(XML::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(XML::XPathEngine::Literal->new($regexp)); } elsif (_match($self, $tokens, $NUMBER_RE)) { # new Number with $self->{_curr_match}... $expr->set_lhs(XML::XPathEngine::Number->new($self->{_curr_match})); } elsif (_match($self, $tokens, '\\(')) { $expr->set_lhs(_expr($self, $tokens)); _match($self, $tokens, '\\)', 1); } elsif (_match($self, $tokens, "\\\$$QName")) { # new Variable with $self->{_curr_match}... $self->{_curr_match} =~ /^\$(.*)$/; $expr->set_lhs(XML::XPathEngine::Variable->new($self, $1)); } elsif (_match($self, $tokens, $QName)) { # check match not Node_Type - done in lexer... # new Function my $func_name = $self->{_curr_match}; _match($self, $tokens, '\\(', 1); $expr->set_lhs( XML::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( $XML::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( $XML::XPathEngine::DEBUG); my $loc_path = XML::XPathEngine::LocationPath->new(); if (_match($self, $tokens, '/')) { # root _debug("h: Matched root\n") if( $XML::XPathEngine::DEBUG); push @$loc_path, XML::XPathEngine::Root->new(); if (_is_step($self, $tokens)) { _debug("Next is step\n") if( $XML::XPathEngine::DEBUG); push @$loc_path, _relative_location_path($self, $tokens); } } elsif (_match($self, $tokens, '//')) { # root push @$loc_path, XML::XPathEngine::Root->new(); my $optimised = _optimise_descendant_or_self($self, $tokens); if (!$optimised) { push @$loc_path, XML::XPathEngine::Step->new($self, 'descendant-or-self', XML::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( $XML::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( $XML::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( $XML::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, XML::XPathEngine::Step->new($self, 'descendant-or-self', XML::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} == XML::XPathEngine::Step::test_nt_node) { pop @steps; } } return @steps; } sub _step { my ($self, $tokens) = @_; _debug( "in _step\n") if( $XML::XPathEngine::DEBUG); if (_match($self, $tokens, '\\.')) { # self::node() return XML::XPathEngine::Step->new($self, 'self', XML::XPathEngine::Step::test_nt_node); } elsif (_match($self, $tokens, '\\.\\.')) { # parent::node() return XML::XPathEngine::Step->new($self, 'parent', XML::XPathEngine::Step::test_nt_node); } else { # AxisSpecifier NodeTest Predicate(s?) my $token = $tokens->[$self->{_tokpos}]; _debug("p: Checking $token\n") if( $XML::XPathEngine::DEBUG); my $step; if ($token eq 'processing-instruction') { $self->{_tokpos}++; _match($self, $tokens, '\\(', 1); _match($self, $tokens, $LITERAL); $self->{_curr_match} =~ /^["'](.*)["']$/; $step = XML::XPathEngine::Step->new($self, 'child', XML::XPathEngine::Step::test_nt_pi, XML::XPathEngine::Literal->new($1)); _match($self, $tokens, '\\)', 1); } elsif ($token =~ /^\@($NCWild|$QName|$QNWild)$/o) { $self->{_tokpos}++; if ($token eq '@*') { $step = XML::XPathEngine::Step->new($self, 'attribute', XML::XPathEngine::Step::test_attr_any, '*'); } elsif ($token =~ /^\@($NCName):\*$/o) { $step = XML::XPathEngine::Step->new($self, 'attribute', XML::XPathEngine::Step::test_attr_ncwild, $1); } elsif ($token =~ /^\@($QName)$/o) { $step = XML::XPathEngine::Step->new($self, 'attribute', XML::XPathEngine::Step::test_attr_qname, $1); } } elsif ($token =~ /^($NCName):\*$/o) { # ns:* $self->{_tokpos}++; $step = XML::XPathEngine::Step->new($self, 'child', XML::XPathEngine::Step::test_ncwild, $1); } elsif ($token =~ /^$QNWild$/o) { # * $self->{_tokpos}++; $step = XML::XPathEngine::Step->new($self, 'child', XML::XPathEngine::Step::test_any, $token); } elsif ($token =~ /^$QName$/o) { # name:name $self->{_tokpos}++; $step = XML::XPathEngine::Step->new($self, 'child', XML::XPathEngine::Step::test_qname, $token); } elsif ($token eq 'comment()') { $self->{_tokpos}++; $step = XML::XPathEngine::Step->new($self, 'child', XML::XPathEngine::Step::test_nt_comment); } elsif ($token eq 'text()') { $self->{_tokpos}++; $step = XML::XPathEngine::Step->new($self, 'child', XML::XPathEngine::Step::test_nt_text); } elsif ($token eq 'node()') { $self->{_tokpos}++; $step = XML::XPathEngine::Step->new($self, 'child', XML::XPathEngine::Step::test_nt_node); } elsif ($token eq 'processing-instruction()') { $self->{_tokpos}++; $step = XML::XPathEngine::Step->new($self, 'child', XML::XPathEngine::Step::test_nt_pi); } elsif ($token =~ /^$AXIS_NAME($NCWild|$QName|$QNWild|$NODE_TYPE)$/o) { my $axis = $1; $self->{_tokpos}++; $token = $2; if ($token eq 'processing-instruction') { _match($self, $tokens, '\\(', 1); _match($self, $tokens, $LITERAL); $self->{_curr_match} =~ /^["'](.*)["']$/; $step = XML::XPathEngine::Step->new($self, $axis, XML::XPathEngine::Step::test_nt_pi, XML::XPathEngine::Literal->new($1)); _match($self, $tokens, '\\)', 1); } elsif ($token =~ /^($NCName):\*$/o) { # ns:* $step = XML::XPathEngine::Step->new($self, $axis, (($axis eq 'attribute') ? XML::XPathEngine::Step::test_attr_ncwild : XML::XPathEngine::Step::test_ncwild), $1); } elsif ($token =~ /^$QNWild$/o) { # * $step = XML::XPathEngine::Step->new($self, $axis, (($axis eq 'attribute') ? XML::XPathEngine::Step::test_attr_any : XML::XPathEngine::Step::test_any), $token); } elsif ($token =~ /^$QName$/o) { # name:name $step = XML::XPathEngine::Step->new($self, $axis, (($axis eq 'attribute') ? XML::XPathEngine::Step::test_attr_qname : XML::XPathEngine::Step::test_qname), $token); } elsif ($token eq 'comment()') { $step = XML::XPathEngine::Step->new($self, $axis, XML::XPathEngine::Step::test_nt_comment); } elsif ($token eq 'text()') { $step = XML::XPathEngine::Step->new($self, $axis, XML::XPathEngine::Step::test_nt_text); } elsif ($token eq 'node()') { $step = XML::XPathEngine::Step->new($self, $axis, XML::XPathEngine::Step::test_nt_node); } elsif ($token eq 'processing-instruction()') { $step = XML::XPathEngine::Step->new($self, $axis, XML::XPathEngine::Step::test_nt_pi); } 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( $XML::XPathEngine::DEBUG); local $^W=0; if( ($token eq 'processing-instruction') || ($token =~ /^\@($NCWild|$QName|$QNWild)$/o) || ( ($token =~ /^($NCWild|$QName|$QNWild)$/o ) && ( ($tokens->[$self->{_tokpos}+1] || '') ne '(') ) || ($token =~ /^$NODE_TYPE$/o) || ($token =~ /^$AXIS_NAME($NCWild|$QName|$QNWild|$NODE_TYPE)$/o) ) { return 1; } else { _debug("p: '$token' not a step\n") if( $XML::XPathEngine::DEBUG); return; } } { my %ENT; BEGIN { %ENT= ( '&' => '&', '<' => '<', '>' => '>', '"' => '"e;'); } sub _xml_escape_text { my( $text)= @_; $text=~ s{([&<>])}{$ENT{$1}}g; return $text; } } 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 XML::XPathEngine - a re-usable XPath engine for DOM-like trees =head1 DESCRIPTION This module provides an XPath engine, that can be re-used by other module/classes that implement trees. In order to use the XPath engine, nodes in the user module need to mimick DOM nodes. The degree of similitude between the user tree and a DOM dictates how much of the XPath features can be used. A module implementing all of the DOM should be able to use this module very easily (you might need to add the cmp method on nodes in order to get ordered result sets). This code is a more or less direct copy of the L module by Matt Sergeant. I only removed the XML processing part to remove the dependency on XML::Parser, applied a couple of patches, 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 mostly lacks docs. As they say, "patches welcome"... =head1 SYNOPSIS use XML::XPathEngine; my $tree= my_tree->new( ...); my $xp = XML::XPathEngine->new(); my @nodeset = $xp->find('/root/kid/grandkid[1]', $tree); # find all first grankids package XML::MyTree; # needs to provide DOM methods =head1 DETAILS =head1 API XML::XPathEngine will provide the following methods: =head2 new =head2 findnodes ($path, $context) Returns a list of nodes found by $path, optionally in context $context. In scalar context returns an XML::XPathEngine::NodeSet object. =head2 findnodes_as_string ($path, $context) Returns the nodes found as a single string. The result is not guaranteed to be valid XML though (it could for example be just text if the query returns attribute values). =head2 findnodes_as_strings ($path, $context) Returns the nodes found as a list of strings, one per node found. =head2 findvalue ($path, $context) Returns the result as a string (the concatenation of the values of the result nodes). =head2 findvalues($path, $context) Returns the values of the result nodes as a list of strings. =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 XML::XPathEngine::NodeSet object containing the nodes it found (or empty if no nodes matched the path), or one of XML::XPathEngine::Literal (a string), XML::XPathEngine::Number, or XML::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 getNodeText ($path) Returns the text string for a particular node. Returns a string, or undef if the node doesn't exist. =head2 set_namespace ($prefix, $uri) Sets the namespace prefix mapping to the uri. Normally in XML::XPathEngine the prefixes in XPath node tests take their context from the current node. This means that foo:bar will always match an element regardless of the namespace that the prefix foo is mapped to (which might even change within the document, resulting in unexpected results). In order to make prefixes in XPath node tests actually map to a real URI, you need to enable that via a call to the set_namespace method of your XML::XPathEngine object. =head2 clear_namespaces () Clears all previously set namespace mappings. =head2 get_namespace ($prefix, $node) Returns the uri associated to the prefix for the node (mostly for internal usage) =head2 set_strict_namespaces ($strict) By default, for historical as well as convenience reasons, XML::XPathEngine has a slightly non-standard way of dealing with the default namespace. If you search for C it will return elements C. As far as I understand it, if the document has a default namespace, this should not return anything. You would have to first do a C, and then search using the namespace. Passing a true value to C will activate this behaviour, passing a false value will return it to its default behaviour. =head2 set_var ($var. $val) Sets an XPath variable (that can be used in queries as C<$var>) =head2 get_var ($var) Returns the value of the XPath variable (mostly for internal usage) =head2 $XML::XPathEngine::Namespaces Set this to 0 if you I want namespace processing to occur. This will make everything a little (tiny) bit faster, but you'll suffer for it, probably. =head1 Node Object Model Nodes need to provide the same API as nodes in XML::XPath (at least the access API, not the tree manipulation one). =head1 Example Please see the test files in t/ for examples on how to use XPath. =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 SEE ALSO L L, L for exemples of using this module L for a similar module for non-XML trees. L for background information. The last section of the article summarizes how to reuse XML::XPath. As XML::XPathEngine offers the same API it should help you =head1 AUTHOR Michel Rodriguez, C<< >> Most code comes directly from XML::XPath, by Matt Sergeant. =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 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 XML::XPathEngine XML-XPathEngine-0.14/lib/XML/XPathEngine/0000755000175000017500000000000012144117367020076 5ustar mrodrigumrodriguXML-XPathEngine-0.14/lib/XML/XPathEngine/NodeSet.pm0000644000175000017500000001007711444214037021774 0ustar mrodrigumrodrigu# $Id: NodeSet.pm,v 1.17 2002/04/24 13:06:08 matt Exp $ package XML::XPathEngine::NodeSet; use strict; use XML::XPathEngine::Boolean; use overload '""' => \&to_literal, 'bool' => \&to_boolean, ; sub new { my $class = shift; bless [], $class; } sub sort { my $self = CORE::shift; @$self = CORE::sort { $a->cmp( $b) } @$self; return $self; } sub reverse { my $self = CORE::shift; @$self = reverse @$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 getRootNode { my $self = CORE::shift; return $self->[0]->getRootNode; } sub get_nodelist { my $self = CORE::shift; @$self; } sub getChildNodes { my $self = CORE::shift; return map { $_->getChildNodes } @$self; } sub getElementById { my $self = CORE::shift; return map { $_->getElementById } @$self; } sub to_boolean { my $self = CORE::shift; return (@$self > 0) ? XML::XPathEngine::Boolean->True : XML::XPathEngine::Boolean->False; } sub string_value { my $self = CORE::shift; return '' unless @$self; return $self->[0]->string_value; } sub to_literal { my $self = CORE::shift; return XML::XPathEngine::Literal->new( join('', map { $_->string_value } @$self) ); } sub to_number { my $self = CORE::shift; return XML::XPathEngine::Number->new( $self->to_literal ); } sub to_final_value { my $self = CORE::shift; return join('', map { $_->string_value } @$self); } sub string_values { my $self = CORE::shift; return map { $_->string_value } @$self; } 1; __END__ =head1 NAME XML::XPathEngine::NodeSet - a list of XML document nodes =head1 DESCRIPTION An XML::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('XML::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 string_value() Returns the string-value of the first node in the list. See the XPath specification for what "string-value" means. =head2 string_values() Returns a list of the string-values of all the nodes in the list. =head2 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. =cut XML-XPathEngine-0.14/lib/XML/XPathEngine/Step.pm0000644000175000017500000003425111444214037021346 0ustar mrodrigumrodrigu# $Id: Step.pm,v 1.35 2001/04/01 16:56:40 matt Exp $ package XML::XPathEngine::Step; use XML::XPathEngine; use strict; # the beginnings of using XS for this file... # require DynaLoader; # use vars qw/$VERSION @ISA/; # $VERSION = '1.0'; # @ISA = qw(DynaLoader); # # bootstrap XML::XPathEngine::Step $VERSION; sub test_qname () { 0; } # Full name sub test_ncwild () { 1; } # NCName:* sub test_any () { 2; } # * sub test_attr_qname () { 3; } # @ns:attrib sub test_attr_ncwild () { 4; } # @nc:* sub test_attr_any () { 5; } # @* sub test_nt_comment () { 6; } # comment() sub test_nt_text () { 7; } # text() sub test_nt_pi () { 8; } # processing-instruction() sub test_nt_node () { 9; } # node() sub new { my $class = shift; my ($pp, $axis, $test, $literal) = @_; my $axis_method = "axis_$axis"; $axis_method =~ tr/-/_/; my $self = { pp => $pp, # the XML::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_pi) { $string .= 'processing-instruction('; if ($self->{literal}->value) { $string .= $self->{literal}->as_string; } $string .= ")"; } elsif ($test == test_nt_comment) { $string .= 'comment()'; } elsif ($test == test_nt_text) { $string .= 'text()'; } elsif ($test == test_nt_node) { $string .= 'node()'; } elsif ($test == test_ncwild || $test == test_attr_ncwild) { $string .= $self->{literal} . ':*'; } else { $string .= $self->{literal}; } foreach (@{$self->{predicates}}) { next unless defined $_; $string .= "[" . $_->as_string . "]"; } return $string; } sub as_xml { my $self = shift; my $string = "\n"; $string .= "" . $self->{axis} . "\n"; my $test = $self->{test}; $string .= ""; if ($test == test_nt_pi) { $string .= '{literal}->value) { $string .= '>'; $string .= $self->{literal}->as_string; $string .= ''; } else { $string .= '/>'; } } elsif ($test == test_nt_comment) { $string .= ''; } elsif ($test == test_nt_text) { $string .= ''; } elsif ($test == test_nt_node) { $string .= ''; } elsif ($test == test_ncwild || $test == test_attr_ncwild) { $string .= '' . $self->{literal} . ''; } else { $string .= '' . $self->{literal} . ''; } $string .= "\n"; foreach (@{$self->{predicates}}) { next unless defined $_; $string .= "\n" . $_->as_xml() . "\n"; } $string .= "\n"; return $string; } sub evaluate { my $self = shift; my $from = shift; # context nodeset if( $from && !$from->isa( 'XML::XPathEngine::NodeSet')) { my $from_nodeset= XML::XPathEngine::NodeSet->new(); $from_nodeset->push( $from); $from= $from_nodeset; } #warn "Step::evaluate called with ", $from->size, " length nodeset\n"; my $saved_context = $self->{pp}->_get_context_set; my $saved_pos = $self->{pp}->_get_context_pos; $self->{pp}->_set_context_set($from); my $initial_nodeset = XML::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($saved_context); $self->{pp}->_set_context_pos($saved_pos); 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 = XML::XPathEngine::NodeSet->new(); no strict 'refs'; eval { $method->($self, $context, $results); }; if ($@) { die "axis $method not implemented [$@]\n"; } # warn("results: ", join('><', map {$_->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->getParentNode; START: return $results unless $parent; if (node_test($self, $parent)) { $results->push($parent); } $parent = $parent->getParentNode; goto START; } 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->getParentNode; goto START; } sub axis_attribute { my $self = shift; my ($context, $results) = @_; foreach my $attrib (@{$context->getAttributes}) { if ($self->test_attribute($attrib)) { $results->push($attrib); } } } sub axis_child { my $self = shift; my ($context, $results) = @_; foreach my $node (@{$context->getChildNodes}) { if (node_test($self, $node)) { $results->push($node); } } } sub axis_descendant { my $self = shift; my ($context, $results) = @_; my @stack = $context->getChildNodes; while (@stack) { my $node = shift @stack; if (node_test($self, $node)) { $results->push($node); } unshift @stack, $node->getChildNodes; } } sub axis_descendant_or_self { my $self = shift; my ($context, $results) = @_; my @stack = ($context); while (@stack) { my $node = shift @stack; if (node_test($self, $node)) { $results->push($node); } #warn "node is a ", ref( $node); unshift @stack, $node->getChildNodes; } } sub axis_following { my $self = shift; my ($context, $results) = @_; my $elt= $context->getNextSibling || _next_sibling_of_an_ancestor_of( $context); while( $elt) { if (node_test($self, $elt)) { $results->push( $elt); } $elt= $elt->getFirstChild || $elt->getNextSibling || _next_sibling_of_an_ancestor_of( $elt); } } sub _next_sibling_of_an_ancestor_of { my $elt= shift; $elt= $elt->getParentNode || return; my $next_elt; while( !($next_elt= $elt->getNextSibling)) { $elt= $elt->getParentNode; return unless( $elt && $elt->can( 'getNextSibling')); } return $next_elt; } sub axis_following_sibling { my $self = shift; my ($context, $results) = @_; #warn "in axis_following_sibling"; while ($context = $context->getNextSibling) { if (node_test($self, $context)) { $results->push($context); } } } sub axis_namespace { my $self = shift; my ($context, $results) = @_; return $results unless $context->isElementNode; foreach my $ns (@{$context->getNamespaces}) { if ($self->test_namespace($ns)) { $results->push($ns); } } } sub axis_parent { my $self = shift; my ($context, $results) = @_; my $parent = $context->getParentNode; return $results unless $parent; if (node_test($self, $parent)) { $results->push($parent); } } sub axis_preceding { my $self = shift; my ($context, $results) = @_; my $elt= $context->getPreviousSibling || _previous_sibling_of_an_ancestor_of( $context); while( $elt) { if (node_test($self, $elt)) { $results->push( $elt); } $elt= $elt->getLastChild || $elt->getPreviousSibling || _previous_sibling_of_an_ancestor_of( $elt); } } sub _previous_sibling_of_an_ancestor_of { my $elt= shift; $elt= $elt->getParentNode || return; my $next_elt; while( !($next_elt= $elt->getPreviousSibling)) { $elt= $elt->getParentNode; return unless $elt->getParentNode; # so we don't have to write a getPreviousSibling } return $next_elt; } sub axis_preceding_sibling { my $self = shift; my ($context, $results) = @_; while ($context = $context->getPreviousSibling) { 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->isElementNode && defined $node->getName; } local $^W; if ($test == test_ncwild) { return unless $node->isElementNode; return _match_ns( $self, $node); } elsif ($test == test_qname) { return unless $node->isElementNode; if ($self->{literal} =~ /:/ || $self->{pp}->{strict_namespaces}) { my ($prefix, $name) = _name2prefix_and_local_name( $self->{literal}); return 1 if( ($name eq $node->getLocalName) && _match_ns( $self, $node)); } else { return 1 if $node->getName eq $self->{literal}; } } elsif ($test == test_nt_text) { return 1 if $node->isTextNode; } elsif ($test == test_nt_comment) { return 1 if $node->isCommentNode; } elsif ($test == test_nt_pi && !$self->{literal}) { return 1 if $node->isPINode; } elsif ($test == test_nt_pi) { return unless $node->isPINode; if (my $val = $self->{literal}->value) { return 1 if $node->getTarget eq $val; } else { return 1; } } return; # fallthrough returns false } sub _name2prefix_and_local_name { my $name= shift; return $name =~ /:/ ? split(':', $name, 2) : ( '', $name); } sub _name2prefix { my $name= shift; if( $name=~ m{^(.*?):}) { return $1; } else { return ''; } } sub _match_ns { my( $self, $node)= @_; my $pp= $self->{pp}; my $prefix= _name2prefix( $self->{literal}); my( $match_ns, $node_ns); if( $pp->{uses_namespaces} || $pp->{strict_namespaces}) { $match_ns = $pp->get_namespace($prefix); if( $match_ns || $pp->{strict_namespaces}) { $node_ns= $node->getNamespace->getValue; } else { # non-standard behaviour: if the query prefix is not declared # compare the 2 prefixes $match_ns = $prefix; $node_ns = _name2prefix( $node->getName); } } else { $match_ns = $prefix; $node_ns = _name2prefix( $node->getName); } return $match_ns eq $node_ns; } sub test_attribute { my $self = shift; my $node = shift; my $test = $self->{test}; return 1 if ($test == test_attr_any) || ($test == test_nt_node); if ($test == test_attr_ncwild) { return 1 if _match_ns( $self, $node); } elsif ($test == test_attr_qname) { if ($self->{literal} =~ /:/) { my ($prefix, $name) = _name2prefix_and_local_name( $self->{literal}); return 1 if ( ($name eq $node->getLocalName) && ( _match_ns( $self, $node)) ); } else { return 1 if $node->getName eq $self->{literal}; } } return; # fallthrough returns false } sub test_namespace { my $self = shift; my $node = shift; # Not sure if this is correct. The spec seems very unclear on what # constitutes a namespace test... bah! my $test = $self->{test}; return 1 if $test == test_any; # True for all nodes of principal type if ($test == test_any) { return 1; } elsif ($self->{literal} eq $node->getExpanded) { return 1; } 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 = XML::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('XML::XPathEngine::Boolean')) { if ($result->value) { $newset->push($nodeset->get_node($i)); } } elsif ($result->isa('XML::XPathEngine::Number')) { if ($result->value == $i) { $newset->push($nodeset->get_node($i)); last; } } else { if ($result->to_boolean->value) { $newset->push($nodeset->get_node($i)); } } } return $newset; } 1; XML-XPathEngine-0.14/lib/XML/XPathEngine/Root.pm0000644000175000017500000000117211444214037021352 0ustar mrodrigumrodrigu# $Id: Root.pm,v 1.6 2001/03/16 11:10:08 matt Exp $ package XML::XPathEngine::Root; use strict; use XML::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 = XML::XPathEngine::NodeSet->new(); $newset->push($nodeset->get_node(1)->getRootNode()); return $newset; } 1; XML-XPathEngine-0.14/lib/XML/XPathEngine/Variable.pm0000644000175000017500000000152211444214037022153 0ustar mrodrigumrodrigu# $Id: Variable.pm,v 1.5 2001/03/16 11:10:08 matt Exp $ package XML::XPathEngine::Variable; use strict; # This class does NOT contain 1 instance of a variable # see the XML::XPathEngine::Parser 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 get_value { my $self = shift; $self->{path_parser}->get_var($self->{name}); } sub set_value { my $self = shift; my ($val) = @_; $self->{path_parser}->set_var($self->{name}, $val); } sub evaluate { my $self = shift; my $val = $self->get_value; return $val; } 1; XML-XPathEngine-0.14/lib/XML/XPathEngine/Expr.pm0000644000175000017500000004716011444214037021354 0ustar mrodrigumrodrigu# $Id: Expr.pm,v 1.20 2003/01/26 19:33:24 matt Exp $ package XML::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 as_xml { my $self = shift; local $^W; # Use of uninitialized value! grrr my $string; if (defined $self->{op}) { $string .= $self->op_xml(); } else { $string .= $self->{lhs}->as_xml(); } foreach my $predicate (@{$self->{predicates}}) { $string .= "\n" . $predicate->as_xml() . "\n"; } return $string; } sub op_xml { my $self = shift; my $op = $self->{op}; my $tag; for ($op) { /^or$/ && do { $tag = "Or"; }; /^and$/ && do { $tag = "And"; }; /^=$/ && do { $tag = "Equals"; }; /^!=$/ && do { $tag = "NotEquals"; }; /^<=$/ && do { $tag = "LessThanOrEquals"; }; /^>=$/ && do { $tag = "GreaterThanOrEquals"; }; /^>$/ && do { $tag = "GreaterThan"; }; /^<$/ && do { $tag = "LessThan"; }; /^\+$/ && do { $tag = "Plus"; }; /^-$/ && do { $tag = "Minus"; }; /^div$/ && do { $tag = "Div"; }; /^mod$/ && do { $tag = "Mod"; }; /^\*$/ && do { $tag = "Multiply"; }; /^\|$/ && do { $tag = "Union"; }; } return "<$tag>\n" . $self->{lhs}->as_xml() . $self->{rhs}->as_xml() . "\n"; } 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('XML::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 XML::XPathEngine::Boolean; sub op_or { my ($node, $lhs, $rhs) = @_; if($lhs->evaluate($node)->to_boolean->value) { return XML::XPathEngine::Boolean->True; } else { return $rhs->evaluate($node)->to_boolean; } } sub op_and { my ($node, $lhs, $rhs) = @_; if( ! $lhs->evaluate($node)->to_boolean->value ) { return XML::XPathEngine::Boolean->False; } else { return $rhs->evaluate($node)->to_boolean; } } sub op_match { my ($node, $lhs, $rhs) = @_; my $lh_results = $lhs->evaluate($node); my $rh_results = $rhs->evaluate($node); my $rh_value = $rh_results->string_value; if ($lh_results->isa('XML::XPathEngine::NodeSet') ) { foreach my $lhnode ($lh_results->get_nodelist) { if ($lhnode->string_value=~ m/$rh_value/) # / is important here, regexp is / delimited { return XML::XPathEngine::Boolean->True; } } return XML::XPathEngine::Boolean->False; } else { return $lh_results->string_value =~ m/$rh_value/ ? XML::XPathEngine::Boolean->True : XML::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->string_value; if ($lh_results->isa('XML::XPathEngine::NodeSet') ) { foreach my $lhnode ($lh_results->get_nodelist) { if ($lhnode->string_value!~ m/$rh_value/) { return XML::XPathEngine::Boolean->True; } } return XML::XPathEngine::Boolean->False; } else { return $lh_results->string_value !~ m/$rh_value/ ? XML::XPathEngine::Boolean->True : XML::XPathEngine::Boolean->False; } } sub op_equals { my ($node, $lhs, $rhs) = @_; my $lh_results = $lhs->evaluate($node); my $rh_results = $rhs->evaluate($node); if ($lh_results->isa('XML::XPathEngine::NodeSet') && $rh_results->isa('XML::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->string_value eq $rhnode->string_value) { return XML::XPathEngine::Boolean->True; } } } return XML::XPathEngine::Boolean->False; } elsif (($lh_results->isa('XML::XPathEngine::NodeSet') || $rh_results->isa('XML::XPathEngine::NodeSet')) && (!$lh_results->isa('XML::XPathEngine::NodeSet') || !$rh_results->isa('XML::XPathEngine::NodeSet'))) { # (that says: one is a nodeset, and one is not a nodeset) my ($nodeset, $other); if ($lh_results->isa('XML::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('XML::XPathEngine::Number')) { foreach my $node ($nodeset->get_nodelist) { if ($node->string_value == $other->value) { return XML::XPathEngine::Boolean->True; } } } elsif ($other->isa('XML::XPathEngine::Literal')) { foreach my $node ($nodeset->get_nodelist) { if ($node->string_value eq $other->value) { return XML::XPathEngine::Boolean->True; } } } elsif ($other->isa('XML::XPathEngine::Boolean')) { if ($nodeset->to_boolean->value == $other->value) { return XML::XPathEngine::Boolean->True; } } return XML::XPathEngine::Boolean->False; } else { # Neither is a nodeset if ($lh_results->isa('XML::XPathEngine::Boolean') || $rh_results->isa('XML::XPathEngine::Boolean')) { # if either is a boolean if ($lh_results->to_boolean->value == $rh_results->to_boolean->value) { return XML::XPathEngine::Boolean->True; } return XML::XPathEngine::Boolean->False; } elsif ($lh_results->isa('XML::XPathEngine::Number') || $rh_results->isa('XML::XPathEngine::Number')) { # if either is a number local $^W; # 'number' might result in undef if ($lh_results->to_number->value == $rh_results->to_number->value) { return XML::XPathEngine::Boolean->True; } return XML::XPathEngine::Boolean->False; } else { if ($lh_results->to_literal->value eq $rh_results->to_literal->value) { return XML::XPathEngine::Boolean->True; } return XML::XPathEngine::Boolean->False; } } } sub op_nequals { my ($node, $lhs, $rhs) = @_; if (op_equals($node, $lhs, $rhs)->value) { return XML::XPathEngine::Boolean->False; } return XML::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('XML::XPathEngine::NodeSet') && $rh_results->isa('XML::XPathEngine::NodeSet')) { foreach my $lhnode ($lh_results->get_nodelist) { foreach my $rhnode ($rh_results->get_nodelist) { my $lhNum = XML::XPathEngine::Number->new($lhnode->string_value); my $rhNum = XML::XPathEngine::Number->new($rhnode->string_value); if ($lhNum->value >= $rhNum->value) { return XML::XPathEngine::Boolean->True; } } } return XML::XPathEngine::Boolean->False; } elsif (($lh_results->isa('XML::XPathEngine::NodeSet') || $rh_results->isa('XML::XPathEngine::NodeSet')) && (!$lh_results->isa('XML::XPathEngine::NodeSet') || !$rh_results->isa('XML::XPathEngine::NodeSet'))) { # (that says: one is a nodeset, and one is not a nodeset) if ($lh_results->isa('XML::XPathEngine::NodeSet')) { foreach my $node ($lh_results->get_nodelist) { if ($node->to_number->value >= $rh_results->to_number->value) { return XML::XPathEngine::Boolean->True; } } } else { foreach my $node ($rh_results->get_nodelist) { if ( $lh_results->to_number->value >= $node->to_number->value) { return XML::XPathEngine::Boolean->True; } } } return XML::XPathEngine::Boolean->False; } else { # Neither is a nodeset if ($lh_results->isa('XML::XPathEngine::Boolean') || $rh_results->isa('XML::XPathEngine::Boolean')) { # if either is a boolean if ($lh_results->to_boolean->to_number->value >= $rh_results->to_boolean->to_number->value) { return XML::XPathEngine::Boolean->True; } } else { if ($lh_results->to_number->value >= $rh_results->to_number->value) { return XML::XPathEngine::Boolean->True; } } return XML::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('XML::XPathEngine::NodeSet') && $rh_results->isa('XML::XPathEngine::NodeSet')) { foreach my $lhnode ($lh_results->get_nodelist) { foreach my $rhnode ($rh_results->get_nodelist) { my $lhNum = XML::XPathEngine::Number->new($lhnode->string_value); my $rhNum = XML::XPathEngine::Number->new($rhnode->string_value); if ($lhNum->value > $rhNum->value) { return XML::XPathEngine::Boolean->True; } } } return XML::XPathEngine::Boolean->False; } elsif (($lh_results->isa('XML::XPathEngine::NodeSet') || $rh_results->isa('XML::XPathEngine::NodeSet')) && (!$lh_results->isa('XML::XPathEngine::NodeSet') || !$rh_results->isa('XML::XPathEngine::NodeSet'))) { # (that says: one is a nodeset, and one is not a nodeset) if ($lh_results->isa('XML::XPathEngine::NodeSet')) { foreach my $node ($lh_results->get_nodelist) { if ($node->to_number->value > $rh_results->to_number->value) { return XML::XPathEngine::Boolean->True; } } } else { foreach my $node ($rh_results->get_nodelist) { if ( $lh_results->to_number->value > $node->to_number->value) { return XML::XPathEngine::Boolean->True; } } } return XML::XPathEngine::Boolean->False; } else { # Neither is a nodeset if ($lh_results->isa('XML::XPathEngine::Boolean') || $rh_results->isa('XML::XPathEngine::Boolean')) { # if either is a boolean if ($lh_results->to_boolean->value > $rh_results->to_boolean->value) { return XML::XPathEngine::Boolean->True; } } else { if ($lh_results->to_number->value > $rh_results->to_number->value) { return XML::XPathEngine::Boolean->True; } } return XML::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); my $result = $lh_results->to_number->value + $rh_results->to_number->value ; return XML::XPathEngine::Number->new($result); } sub op_minus { my ($node, $lhs, $rhs) = @_; my $lh_results = $lhs->evaluate($node); my $rh_results = $rhs->evaluate($node); my $result = $lh_results->to_number->value - $rh_results->to_number->value ; return XML::XPathEngine::Number->new($result); } sub op_div { my ($node, $lhs, $rhs) = @_; my $lh_results = $lhs->evaluate($node); my $rh_results = $rhs->evaluate($node); my $result = eval { $lh_results->to_number->value / $rh_results->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 XML::XPathEngine::Literal->new('Infinity'); } return XML::XPathEngine::Number->new($result); } sub op_mod { my ($node, $lhs, $rhs) = @_; my $lh_results = $lhs->evaluate($node); my $rh_results = $rhs->evaluate($node); my $result = $lh_results->to_number->value % $rh_results->to_number->value ; return XML::XPathEngine::Number->new($result); } sub op_mult { my ($node, $lhs, $rhs) = @_; my $lh_results = $lhs->evaluate($node); my $rh_results = $rhs->evaluate($node); my $result = $lh_results->to_number->value * $rh_results->to_number->value ; return XML::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('XML::XPathEngine::NodeSet') && $rh_result->isa('XML::XPathEngine::NodeSet')) { my %found; my $results = XML::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 = XML::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('XML::XPathEngine::Boolean')) { if ($result->value) { $newset->push($nodeset->get_node($i)); } } elsif ($result->isa('XML::XPathEngine::Number')) { if ($result->value == $i) { $newset->push($nodeset->get_node($i)); } } else { if ($result->to_boolean->value) { $newset->push($nodeset->get_node($i)); } } } return $newset; } 1; XML-XPathEngine-0.14/lib/XML/XPathEngine/Function.pm0000644000175000017500000002546311444214037022225 0ustar mrodrigumrodrigu# $Id: Function.pm,v 1.26 2002/12/26 17:24:50 matt Exp $ package XML::XPathEngine::Function; use XML::XPathEngine::Number; use XML::XPathEngine::Literal; use XML::XPathEngine::Boolean; use XML::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 as_xml { my $self = shift; my $string = "{name}\""; my $params = ""; foreach (@{$self->{params}}) { $params .= "" . $_->as_xml . "\n"; } if ($params) { $string .= ">\n$params\n"; } else { $string .= " />\n"; } return $string; } sub evaluate { my $self = shift; my $node = shift; while ($node->isa('XML::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: # XML::XPathEngine::Number # XML::XPathEngine::Literal (string) # XML::XPathEngine::NodeSet # XML::XPathEngine::Boolean ### NODESET FUNCTIONS ### sub last { my $self = shift; my ($node, @params) = @_; die "last: function doesn't take parameters\n" if (@params); return XML::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 XML::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('XML::XPathEngine::NodeSet'); return XML::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 = XML::XPathEngine::NodeSet->new(); if ($params[0]->isa('XML::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->string_value; $results->append($self->id($node, XML::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 $_ if ($node->isAttributeNode) { warn "calling \($node->getParentNode->getRootNode->getChildNodes)->[0] on attribute node\n"; $node = ($node->getParentNode->getRootNode->getChildNodes)->[0]; } foreach my $id (@ids) { if (my $found = $node->getElementById($id)) { $results->push($found); } } } return $results; } sub local_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 XML::XPathEngine::Literal->new($node->getLocalName); } sub namespace_uri { my $self = shift; my ($node, @params) = @_; die "namespace-uri: Function not supported\n"; } 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 XML::XPathEngine::Literal->new($node->getName); } ### STRING FUNCTIONS ### sub string { my $self = shift; my ($node, @params) = @_; die "string: Too many parameters\n" if @params > 1; if (@params) { return XML::XPathEngine::Literal->new($params[0]->string_value); } # TODO - this MUST be wrong! - not sure now. -matt return XML::XPathEngine::Literal->new($node->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 {$_->string_value} @params); return XML::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]->string_value, $params[1]->string_value); if (substr($string1, 0, length($string2)) eq $string2) { return XML::XPathEngine::Boolean->True; } return XML::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]->string_value; if ($params[0]->string_value =~ /(.*?)\Q$value\E(.*)/) { return XML::XPathEngine::Boolean->True; } return XML::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]->string_value; my $short= $params[1]->string_value; if( $long=~ m{^(.*?)\Q$short}) { return XML::XPathEngine::Literal->new($1); } else { return XML::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]->string_value; my $short= $params[1]->string_value; if( $long=~ m{\Q$short\E(.*)$}) { return XML::XPathEngine::Literal->new($1); } else { return XML::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]->string_value; $offset = $params[1]->value; $offset--; # uses 1 based offsets if (@params == 3) { $len = $params[2]->value; return XML::XPathEngine::Literal->new(substr($str, $offset, $len)); } else { return XML::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 XML::XPathEngine::Number->new(length($params[0]->string_value)); } else { return XML::XPathEngine::Number->new( length($node->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]->string_value; } else { $str = $node->string_value; } $str =~ s/^\s*//; $str =~ s/\s*$//; $str =~ s/\s+/ /g; return XML::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]->string_value; my $find = $params[1]->string_value; my $repl = $params[2]->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 XML::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]->to_boolean; } sub not { my $self = shift; my ($node, @params) = @_; $params[0] = $params[0]->to_boolean unless $params[0]->isa('XML::XPathEngine::Boolean'); $params[0]->value ? XML::XPathEngine::Boolean->False : XML::XPathEngine::Boolean->True; } sub true { my $self = shift; my ($node, @params) = @_; die "true: function takes no parameters\n" if @params > 0; XML::XPathEngine::Boolean->True; } sub false { my $self = shift; my ($node, @params) = @_; die "true: function takes no parameters\n" if @params > 0; XML::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)[1]'); my $lclang = lc($params[0]->string_value); # warn("Looking for lang($lclang) in $lang\n"); if (substr(lc($lang), 0, length($lclang)) eq $lclang) { return XML::XPathEngine::Boolean->True; } else { return XML::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('XML::XPathEngine::Node')) { return XML::XPathEngine::Number->new( $params[0]->string_value ); } return $params[0]->to_number; } return XML::XPathEngine::Number->new( $node->string_value ); } sub sum { my $self = shift; my ($node, @params) = @_; die "sum: Parameter must be a NodeSet\n" unless $params[0]->isa('XML::XPathEngine::NodeSet'); my $sum = 0; foreach my $node ($params[0]->get_nodelist) { $sum += $self->number($node)->value; } return XML::XPathEngine::Number->new($sum); } sub floor { my $self = shift; my ($node, @params) = @_; require POSIX; my $num = $self->number($node, @params); return XML::XPathEngine::Number->new( POSIX::floor($num->value)); } sub ceiling { my $self = shift; my ($node, @params) = @_; require POSIX; my $num = $self->number($node, @params); return XML::XPathEngine::Number->new( POSIX::ceil($num->value)); } sub round { my $self = shift; my ($node, @params) = @_; my $num = $self->number($node, @params); require POSIX; return XML::XPathEngine::Number->new( POSIX::floor($num->value + 0.5)); # Yes, I know the spec says don't do this... } 1; XML-XPathEngine-0.14/lib/XML/XPathEngine/Number.pm0000644000175000017500000000341311444214037021657 0ustar mrodrigumrodrigu# $Id: Number.pm,v 1.14 2002/12/26 17:57:09 matt Exp $ package XML::XPathEngine::Number; use XML::XPathEngine::Boolean; use XML::XPathEngine::Literal; use strict; use overload '""' => \&value, '<=>' => \&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 cmp { my $self = shift; my ($other, $swap) = @_; if ($swap) { return $other <=> $$self; } return $$self <=> $other; } sub evaluate { my $self = shift; $self; } sub to_boolean { my $self = shift; return $$self ? XML::XPathEngine::Boolean->True : XML::XPathEngine::Boolean->False; } sub to_literal { XML::XPathEngine::Literal->new($_[0]->as_string); } sub to_number { $_[0]; } sub string_value { return $_[0]->value } sub getChildNodes { return wantarray ? () : []; } sub getAttributes { return wantarray ? () : []; } 1; __END__ =head1 NAME XML::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 XML::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. =cut XML-XPathEngine-0.14/lib/XML/XPathEngine/Boolean.pm0000644000175000017500000000247111444214037022011 0ustar mrodrigumrodrigu# $Id: Boolean.pm,v 1.7 2000/07/03 08:54:47 matt Exp $ package XML::XPathEngine::Boolean; use XML::XPathEngine::Number; use XML::XPathEngine::Literal; use strict; use overload '""' => \&value, '<=>' => \&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 cmp { my $self = shift; my ($other, $swap) = @_; if ($swap) { return $other <=> $$self; } return $$self <=> $other; } sub to_number { XML::XPathEngine::Number->new($_[0]->value); } sub to_boolean { $_[0]; } sub to_literal { XML::XPathEngine::Literal->new($_[0]->value ? "true" : "false"); } sub string_value { return $_[0]->to_literal->value; } sub getChildNodes { return wantarray ? () : []; } sub getAttributes { return wantarray ? () : []; } 1; __END__ =head1 NAME XML::XPathEngine::Boolean - Boolean true/false values =head1 DESCRIPTION XML::XPathEngine::Boolean objects implement simple boolean true/false objects. =head1 API =head2 XML::XPathEngine::Boolean->True Creates a new Boolean object with a true value. =head2 XML::XPathEngine::Boolean->False Creates a new Boolean object with a false value. =head2 value() Returns true or false. =head2 to_literal() Returns the string "true" or "false". =cut XML-XPathEngine-0.14/lib/XML/XPathEngine/LocationPath.pm0000644000175000017500000000215011444214037023011 0ustar mrodrigumrodrigu# $Id: LocationPath.pm,v 1.8 2001/03/16 11:10:08 matt Exp $ package XML::XPathEngine::LocationPath; use XML::XPathEngine::Root; 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 set_root { my $self = shift; unshift @$self, XML::XPathEngine::Root->new(); } 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 = XML::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; } 1; XML-XPathEngine-0.14/lib/XML/XPathEngine/Literal.pm0000644000175000017500000000426111646004023022021 0ustar mrodrigumrodrigu# $Id: Literal.pm,v 1.11 2001/03/16 11:10:08 matt Exp $ package XML::XPathEngine::Literal; use XML::XPathEngine::Boolean; use XML::XPathEngine::Number; use strict; use Carp; use overload '""' => \&value, 'cmp' => \&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 value_as_number { my $self = shift; warn "numifying '", $$self, "' to '", +$$self, "'\n"; +$$self; } sub cmp { my $self = shift; my ($cmp, $swap) = @_; if ($swap) { return $cmp cmp $$self; } return $$self cmp $cmp; } sub evaluate { my $self = shift; $self; } sub to_boolean { my $self = shift; return (length($$self) > 0) ? XML::XPathEngine::Boolean->True : XML::XPathEngine::Boolean->False; } sub to_number { return XML::XPathEngine::Number->new($_[0]->value); } sub to_literal { return $_[0]; } sub string_value { return $_[0]->value; } sub getChildNodes { croak "cannot get child nodes of a literal"; } sub getAttributes { croak "cannot get attributes of a literal"; } sub getParentNode { croak "cannot get parent node of a literal"; } 1; __END__ =head1 NAME XML::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 cmp($literal) Returns the equivalent of perl's cmp operator against the given $literal. =cut XML-XPathEngine-0.14/t/0000755000175000017500000000000012144117367014761 5ustar mrodrigumrodriguXML-XPathEngine-0.14/t/00-load.t0000644000175000017500000000023411444214037016273 0ustar mrodrigumrodriguuse Test::More tests => 1; BEGIN { use_ok( 'XML::XPathEngine' ); } diag( "Testing XML::XPathEngine $XML::XPathEngine::VERSION, Perl $], /usr/bin/perl" ); XML-XPathEngine-0.14/t/pod.t0000644000175000017500000000021411444214037015717 0ustar mrodrigumrodrigu#!perl -T 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(); XML-XPathEngine-0.14/t/minitree.pm0000644000175000017500000000664711444214037017142 0ustar mrodrigumrodriguuse 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; my @fields= qw( name value pos); return "$$self : " . join ( " - ", map { "$_ : " . $self->$_ } @fields ) . " : " . 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; XML-XPathEngine-0.14/t/minidom.pm0000644000175000017500000001021311444214037016742 0ustar mrodrigumrodrigu#!/usr/bin/perl -w use strict; use warnings; my $dom= minidom::document->new( ' vgkid1-1 vgkid2-1 vgkid1-2 vgkid2-2 vgkid1-3 vgkid2-3 vgkid1-4 vgkid2-4 vg kid1-5 vgkid2-5 '); use Data::Dumper; print Dumper $dom; package minidom::node; my $parent=0; my $pos=1; my $rank=2; sub isElementNode {} sub isAttributeNode {} sub isNamespaceNode {} sub isTextNode {} sub isProcessingInstructionNode {} sub isPINode {} sub isCommentNode {} sub getParentNode { return $_[0]->[$parent]; } sub pos { return $_[0]->[$pos]; } sub getRootNode { my $self = shift; while (my $parent = $self->getParentNode) { $self = $parent; } return $self; } sub getChildNodes { return wantarray ? () : []; } sub getAttributes { return wantarray ? () : []; } sub getPreviousSibling { my $self = shift; my $rank = $self->[$rank]; return unless $self->[$parent]; return $rank ? $self->[$parent]->getChildNode($rank-1) : undef; } sub getNextSibling { my $self = shift; my $rank = $self->[$rank]; return unless $self->[$parent]; return $self->[$parent]->getChildNode($rank+1); } sub getChildNode { return } 1; package minidom::document; use base 'minidom::node'; sub new { my( $class, $string)= @_; ( my $base_class= $class)=~ s{::[^:]*$}{}; my $i=0; $string=~ s{}{[[ bless( [ '$1'], '${base_class}::comment') ]]}sg; $string=~ s{<\?(\w+)(.*?)\?>}{[[ bless( [ '$1', '$2'], '${base_class}::pi') ]]}sg; while( $string=~ m{^<}) { $string=~ s{<([^/>]*)>([^<]*)]*)>} { parse_elt( $base_class, $1, $2, $3); }eg; } $string=~ s{\[\[}{\[}g; # remove marker before root $string=~ s{\]\]}{\],}g; # after my $data= eval( $string); my $self= bless $data, $class; $self->add_pos_parent(); return $self; } { my $pos; sub add_pos_parent { my( $self)= @_; unless( $pos) { unshift @$self, undef, ++$pos, 0; } my @children= @$self; shift @children; shift @children; shift @children; my $rank=1; foreach my $child (@children) { if( UNIVERSAL::isa( $child, 'ARRAY')) { warn "adding pos ($pos) and parent for $child->[0] (", ref($child), ")\n"; unshift @$child, $self, ++$pos, $rank++; add_pos_parent( $child) } } } } sub parse_elt { my( $base_class, $start_tag, $content, $end_tag)= @_; $start_tag=~ s{^}{'}; $start_tag=~ s{ }{', [}; # after the first space, start the atts $start_tag=~ s{([\w:-]+)\s*=\s*("[^"]*"|'[^']')}{bless( [ "$1", $2 ], '${base_class}::attribute'), }g; $start_tag=~ s{, $}{]}; # end the atts, ready for content my @content= split /(\[\[.*?\]\])/s, $content; foreach (@content) { if( m{^\[\[}) # embedded elements { s{^\[\[}{}; s{\]\]}{}; } # remove '[[' else { s{^}{bless( ['}s, s{$}{'], '${base_class}::text')}s; } # text, quote it } $content= join( ', ', @content); return "[[ bless( [ $start_tag, $content ], '${base_class}::element') ]]"; } 1; package minidom::element; use base 'minidom::node'; my $attributes=3; my $content=4; sub getChildNode { my( $self, $rank)= @_; return $self->[$rank+$content]; } sub getChildNodes { my( $self, $rank)= @_; my @content= @$self; foreach( 1..$content) { shift @content; } return wantarray ? @content : \@content; } 1; XML-XPathEngine-0.14/t/pod-coverage.t0000644000175000017500000000030711444214037017513 0ustar mrodrigumrodrigu#!perl -T use Test::More; eval "use Test::Pod::Coverage"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; plan tests => 1; pod_coverage_ok( "XML::XPathEngine"); XML-XPathEngine-0.14/t/01_basic.t0000644000175000017500000001617411646010626016534 0ustar mrodrigumrodrigu#!/usr/bin/perl use strict; use warnings; use Test::More; use XML::XPathEngine; BEGIN { push @INC, './t'; } my $tree = init_tree(); my $xp = XML::XPathEngine->new; #warn $tree->as_xml, "\n\n"; { 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=~/v[345]/]', $tree), 'vkid3vkid5', "match on attributes"); is( $xp->findvalue( '//@*', $tree), 'i1v1i2v1i3vvi4vx1i5v2i6vvi7vx0i8v3i9vvi10vx1i11v4i12vvi13vx0i14v5i15vvi16vx1i17', 'match all attributes'); is( $xp->findvalue( '//@*[parent::*/@att1=~/v[345]/]', $tree), 'v3i9v4i12v5i15', 'match all attributes with a test'); is( $xp->findvalue( '//kid1[@att1="v3"]/following::gkid2[1]', $tree), 'gkid2 4', "following axis[1]"); is( $xp->findvalue( '//kid1[@att1="v3"]/following::gkid2[2]', $tree), 'gkid2 5', "following axis[2]"); is( $xp->findvalue( '//kid1[@att1="v3"]/following::kid1/*', $tree), 'gvkid5gkid2 5', "following axis"); is( $xp->findvalue( '//kid1[@att1="v3"]/preceding::gkid2[1]', $tree), 'gkid2 2', "preceding axis[1]"); is( $xp->findvalue( '//kid1[@att1="v3"]/preceding::gkid2[2]', $tree), 'gkid2 1', "preceding axis[1]"); is( $xp->findvalue( '//kid1[@att1="v3"]/preceding::gkid2', $tree), 'gkid2 1gkid2 2', "preceding axis"); is( $xp->findvalue( 'count(//kid1)', $tree), '3', 'count( //gkid1)'); is( $xp->findvalue( 'count(//gkid2)', $tree), '5', 'count( //gkid2)'); is( $xp->findvalue( 'count(/root[count(.//kid1)=count(.//gkid1)])', $tree), 1, 'count() in expression (count(//kid1)=count(//gkid1))'); is( $xp->findvalue( 'count(/root[count(.//kid1)>count(.//gkid1)])', $tree), 0, 'count() in expression (returns 0)'); is( $xp->findvalue( 'count(/root[count(.//kid1)=count(.//gkid2)])', $tree), 0, 'count() in expression (returns 1)'); is( $xp->findvalue( 'count( root/*[count( ./gkid0) = 1])', $tree), 2, 'count() in expression (root/*[count( ./gkid0) = 1])'); is( $xp->findvalue( 'count(//gkid2[@att2="vx" and @att3=1])', $tree), 3, 'count with and'); is( $xp->findvalue( 'count(//gkid2[@att2="vx" and @att3])', $tree), 5, 'count with and'); is( $xp->findvalue( 'count(//gkid2[@att2="vx" or @att3])', $tree), 5, 'count with or'); #warn $xp->findvalue( './/*/@id', $tree); is( $xp->findvalue( '(.//*)[2]/@id', $tree), 'i3', '(descendant::*)[2]'); is( $xp->findvalue( '//kid1[@att1="v3"]/following::gkid2[1]', $tree), 'gkid2 4', "following axis[1]"); is( $xp->findvalue( '//kid1[@att1="v3"]/following::gkid2[2]', $tree), 'gkid2 5', "following axis[2]"); is( $xp->findvalue( 'id("i2")/@att1', $tree), 'v1', 'id()'); is( $xp->findvalue( 'substring-after(//kid1[1]/@att1, "v")', $tree), '1', 'substring-after'); is( $xp->findvalue( 'id("i3")//*[1]/@att2', $tree), 'vv', 'id descendants attribute'); is( $xp->findvalue( '(id("i3")//*)[1]/@att2', $tree), 'vv', 'grouped id descendants attribute'); is( $xp->findvalue( 'substring-after((id("i2")//*[1])/@att2, "v")', $tree), 'v', 'substring-after(id())'); is( join( '|', $xp->findvalues( '//kid1[@att1=~/v[345]/]', $tree)), 'vkid3|vkid5', "findvalues match on attributes"); is( join( '|', $xp->findvalues( '//kid1[@att1=~/v[345]/]/@id', $tree)), 'i9|i15', "findvalues on attributes"); is( $xp->findvalue( '2', $tree), 2, 'findvalues on a litteral'); is( $xp->findvalue( '//gkid1="gvkid1"', $tree), 1, 'findvalues on a litteral'); eval { $xp->findvalues( '//gkid1="gvkid1"/ggkid', $tree); }; like( $@, qr/cannot get child nodes of a literal/, 'children axis from a litteral'); eval { $xp->findvalues( '//gkid1="gvkid1"/../gkid1', $tree); }; like( $@, qr/cannot get parent node of a literal/, 'parent axis from a litteral'); eval { $xp->findvalues( '//gkid1="gvkid1"/@att', $tree); }; like( $@, qr/cannot get attributes of a literal/, 'attribute axis from a litteral'); done_testing(); sub init_tree { my $id=0; my $tree = tree->new( 'att', name => 'tree', value => 'tree', id => "i" . ++$id); my $root = tree->new( 'att', name => 'root', value => 'root_value', att1 => 'v1', id => "i" . ++$id); $root->add_as_last_child_of( $tree); foreach (1..5) { my $kid= tree->new( 'att', name => 'kid' . $_ % 2, value => "vkid$_", att1 => "v$_", id => "i" . ++$id); $kid->add_as_last_child_of( $root); my $gkid1= tree->new( 'att', name => 'gkid' . $_ % 2, value => "gvkid$_", att2 => "vv", id => "i" . ++$id); $gkid1->add_as_last_child_of( $kid); my $gkid2= tree->new( 'att', name => 'gkid2', value => "gkid2 $_", att2 => "vx", att3 => $_ % 2, id => "i" . ++$id); $gkid2->add_as_last_child_of( $kid); } $tree->set_pos; return $tree; } package tree; use base 'minitree'; sub getName { return shift->name; } sub getValue { return shift->value; } sub string_value { return shift->value; } sub getRootNode { return shift->root; } sub getParentNode { return shift->parent; } sub getChildNodes { return wantarray ? shift->children : [shift->children]; } sub getFirstChild { return shift->first_child; } sub getLastChild { return shift->last_child; } sub getNextSibling { return shift->next_sibling; } sub getPreviousSibling { return shift->previous_sibling; } sub isElementNode { return 1; } sub isAttributeNode { return 0; } sub get_pos { return shift->pos; } sub getAttributes { return wantarray ? @{shift->attributes} : shift->attributes; } sub as_xml { my $elt= shift; return "<" . $elt->getName . join( "", map { " " . $_->getName . '="' . $_->getValue . '"' } $elt->getAttributes) . '>' . (join( "\n", map { $_->as_xml } $elt->getChildNodes) || $elt->getValue) . "getName . ">" ; } sub cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; } sub getElementById { my $elt = shift; my $id = shift; foreach ( @{$elt->attributes} ) { $_->getName eq 'id' and $_->getValue eq $id and return $elt; } foreach ( $elt->getChildNodes ) { return $_->getElementById($id); } } 1; package att; use base 'attribute'; sub getName { return shift->name; } sub getValue { return shift->value; } sub string_value { return shift->value; } sub getRootNode { return shift->parent->root; } sub getParentNode { return shift->parent; } sub isAttributeNode { return 1; } sub getChildNodes { return ; } sub cmp { my( $a, $b)= @_; return $a->pos <=> $b->pos; } sub getElementById { return shift->getParentNode->getElementById( @_); } 1; XML-XPathEngine-0.14/Makefile.PL0000644000175000017500000000131011444214037016455 0ustar mrodrigumrodriguuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'XML::XPathEngine', AUTHOR => 'Michel Rodriguez ', VERSION_FROM => 'lib/XML/XPathEngine.pm', ABSTRACT_FROM => 'lib/XML/XPathEngine.pm', PL_FILES => {}, PREREQ_PM => { 'Test::More' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'XML-XPathEngine-*' }, ); # add the license bit in META.yaml unless( `$^X -n -e'print if( m{license\\s*:\\s*perl})' Makefile`) { system $^X . q{ -p -i -e's{^((.*)distribution_type: module(.*))}{$1\n$2license: perl$3}m' Makefile}; } XML-XPathEngine-0.14/Changes0000644000175000017500000000706712144117276016022 0ustar mrodrigumrodriguRevision history for XML::XPathEngine version 0.14 fixed POD error version 0.13 added: error, with (hopefully!) proper error message when trying to follow XML axes from a litteral, see http://stackoverflow.com/questions/7761509/xpath-expression-to-access-parent-or-sibling-using-htmltreebuilderxpath-modul version 0.12 added: findvalues method which returns the results as a list of strings version 0.11 fix: axis_descendant returns descendants in incorrect order. found and patched by Kumagai Kentaro http://rt.cpan.org/Ticket/Display.html?id=35049 fix: calling id() function in some situations causes an error found and patched by Kumagai Kentaro http://rt.cpan.org/Ticket/Display.html?id=35049 version 0.10 fix: overloading did not quite work (literals returned by findvalue woult cause an exception when used as numbers). the fix is to return a real string in findvalue, instead of an XML::XPath::Engine::Literal object that then needs to be overloaded while this theoretically could break code that would rely on the return being an object, I doubt this is the case in Real Code. let me know if this causes any problem Bug found by Niko Tyni and reported on Debian http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=460297 reported on RT: http://rt.cpan.org/Public/Bug/Display.html?id=34908 bug tested in the XML::DOM::XPath 0.14 test suite fix: predicates using the position and/or other conditions would fail, as the position would not be saved in Step.pm Reported by Stephane Bortzmeyer, patched by Niko Tyni http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=460281 http://rt.cpan.org/Ticket/Display.html?id=34907 bug tested in the XML::DOM::XPath 0.14 test suite version: 0.09 fix: namespace processing was a bit dodgy, it's been cleaned up now. Tested through XML::Twig::XPath and XML::DOM::XPath fix: count did not work (RT #34854), found and patched by Yasuhiro Matsumoto http://rt.cpan.org/Ticket/Display.html?id=34854 added: XML::XPathEngine set_strict_namespaces method, which makes namespace processing more standard compliant, and probably often more of a pain. Tested through XML::Twig::XPath Thanks to Timothy Appnel for his input in that matter added: XML::XPathEngine findnodes_as_strings method, which returns an array of strings (the getValue of the nodes). fixed: findnodes_as_string now returns the empty string if the result of the XPath query is a boolean (XML::XPathEngine::Boolean), as when querying //@id="foo" for example. This makes the behaviour similar to XML::LibXML's. version:0.08 fix: Fixed bug in XML::XPathEngine::Step::axis_preceding (same bug as with axis_following) version: 0.07 fix: Fixed bug in the previous bug fix version: 0.06 fix: Fixed bug in XML::XPathEngine::Step::axis_following that messed up queries using the 'following' axis (tested by HTML::TreeBuilder::XPath 0.07) version: 0.05 fix: Fixed bug in XML::XPathEngine::Function::as_xml as per RT #21951 (spotted by BJOERN) see http://rt.cpan.org/Ticket/Display.html?id=21951 version: 0.04 fix: Fixed bug in Step.pm version: 0.03 fix: Bug fixes for queries involving elt="text" (tested through XML::Twig::XPath), the lang() function version: 0.02 released: First version on CPAN version: 0.01 created: First version, released on an unsuspecting world. XML-XPathEngine-0.14/README0000644000175000017500000000064111444214037015371 0ustar mrodrigumrodriguXML-XPathEngine This module is used to add XPath support to XML modules. 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 Most code copyright (C) 2000 AxKit.com Ltd This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. XML-XPathEngine-0.14/META.yml0000664000175000017500000000077612144117367016003 0ustar mrodrigumrodrigu--- abstract: 'a re-usable XPath engine for DOM-like trees' author: - 'Michel Rodriguez ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: XML-XPathEngine no_index: directory: - t - inc requires: Test::More: 0 version: 0.14 XML-XPathEngine-0.14/META.json0000664000175000017500000000160012144117367016136 0ustar mrodrigumrodrigu{ "abstract" : "a re-usable XPath engine for DOM-like trees", "author" : [ "Michel Rodriguez " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-XPathEngine", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Test::More" : "0" } } }, "release_status" : "stable", "version" : "0.14" }