File Coverage

blib/lib/Tree/XPathEngine.pm
Criterion Covered Total %
statement 372 404 92.0
branch 121 170 71.1
condition 22 32 68.7
subroutine 49 50 98.0
pod 9 9 100.0
total 573 665 86.1


line stmt bran cond sub pod time code
1             #$Id: /tree-xpathengine/trunk/lib/Tree/XPathEngine.pm 25 2006-02-15T15:34:11.453583Z mrodrigu $
2             package Tree::XPathEngine;
3              
4 5     5   167301 use warnings;
  5         17  
  5         177  
5 5     5   26 use strict;
  5         11  
  5         5021  
6              
7 5     5   42 use vars qw($VERSION $AUTOLOAD $revision);
  5         22  
  5         4435  
8              
9             $VERSION = '0.05';
10             $Tree::XPathEngine::DEBUG = 0;
11              
12 5         586 use vars qw/
13             $WILD
14             $NUMBER_RE
15             $NODE_TYPE
16             $AXIS_NAME
17             %AXES
18             $LITERAL
19             $REGEXP_RE
20             $REGEXP_MOD_RE
21 5     5   33 %CACHE/;
  5         10  
22              
23 5     5   4277 use Tree::XPathEngine::Step;
  5         14  
  5         165  
24 5     5   6276 use Tree::XPathEngine::Expr;
  5         19  
  5         171  
25 5     5   3705 use Tree::XPathEngine::Function;
  5         19  
  5         304  
26 5     5   3285 use Tree::XPathEngine::LocationPath;
  5         13  
  5         181  
27 5     5   2957 use Tree::XPathEngine::Variable;
  5         15  
  5         147  
28 5     5   40 use Tree::XPathEngine::Literal;
  5         9  
  5         113  
29 5     5   28 use Tree::XPathEngine::Number;
  5         7  
  5         120  
30 5     5   25 use Tree::XPathEngine::NodeSet;
  5         9  
  5         110  
31 5     5   2992 use Tree::XPathEngine::Root;
  5         14  
  5         34225  
32              
33             # Axis name to principal node type mapping
34             %AXES = (
35             'ancestor' => 'element',
36             'ancestor-or-self' => 'element',
37             'attribute' => 'attribute',
38             'child' => 'element',
39             'descendant' => 'element',
40             'descendant-or-self' => 'element',
41             'following' => 'element',
42             'following-sibling' => 'element',
43             'parent' => 'element',
44             'preceding' => 'element',
45             'preceding-sibling' => 'element',
46             'self' => 'element',
47             );
48              
49             $WILD = qr{\*};
50             $NODE_TYPE = qr{(?:(text|node)\(\))};
51             $AXIS_NAME = '(?:' . join('|', keys %AXES) . ')::';
52             $NUMBER_RE = qr{(?:\d+(?:\.\d*)?|\.\d+)};
53             $REGEXP_RE = qr{(?:m?/(?:\\.|[^/])*/)};
54             $REGEXP_MOD_RE = qr{(?:[imsx]+)};
55             $LITERAL = qr{(?:"[^"]*"|'[^']*')};
56              
57             sub new {
58 5     5 1 9523 my $class = shift;
59 5         15 my( %option)= @_;
60            
61 5         22 my $self = bless {}, $class;
62              
63 5   66     76 $self->{NAME}= $option{xpath_name_re} || qr/(?:[A-Za-z_][\w.-]*)/;
64 5         293 $self->{NAME}= qr/(?:$self->{NAME})/; # add parens just to make sure we have them
65            
66 5 50       32 _debug("New Parser being created.\n") if( $Tree::XPathEngine::DEBUG);
67 5         43 $self->{context_set} = Tree::XPathEngine::NodeSet->new();
68 5         14 $self->{context_pos} = undef; # 1 based position in array context
69 5         13 $self->{context_size} = 0; # total size of context
70 5         15 $self->{vars} = {};
71 5         15 $self->{direction} = 'forward';
72 5         14 $self->{cache} = {};
73            
74 5         19 return $self;
75             }
76              
77             sub find {
78 148     148 1 242 my $self = shift;
79 148         261 my( $path, $context) = @_;
80 148         753 my $parsed_path= $self->_parse( $path);
81 143         655 return $parsed_path->evaluate( $context);
82             }
83              
84              
85             sub matches {
86 3     3 1 15 my $self = shift;
87 3         7 my ($node, $path, $context) = @_;
88              
89 3         10 my @nodes = $self->findnodes( $path, $context);
90              
91 3 100       10 if (grep { "$node" eq "$_" } @nodes) { return 1; }
  15         50  
  2         18  
92 1         6 return;
93             }
94              
95             sub findnodes {
96 21     21 1 8532 my $self = shift;
97 21         46 my ($path, $context) = @_;
98            
99 21         62 my $results = $self->find( $path, $context);
100            
101 13 100       73 if ($results->isa('Tree::XPathEngine::NodeSet'))
102 12         39 { return $results->get_nodelist; }
103             else
104 1         5 { return (); }
105             }
106              
107              
108             sub findnodes_as_string {
109 3     3 1 1244 my $self = shift;
110 3         5 my ($path, $context) = @_;
111            
112 3         9 my $results = $self->find( $path, $context);
113            
114 3 100       34 if ($results->isa('Tree::XPathEngine::NodeSet')) {
    50          
115 1         5 return join('', map { $_->to_string } $results->get_nodelist);
  1         5  
116             }
117             elsif ($results->isa('Tree::XPathEngine::Node')) {
118 0         0 return $results->to_string;
119             }
120             else {
121 2         10 return $results->value; # CHECK
122             }
123             }
124              
125             sub findvalue {
126 124     124 1 5639 my $self = shift;
127 124         311 my ($path, $context) = @_;
128 124         433 my $results = $self->find( $path, $context);
129 124 100       738 return $results ? $results->xpath_to_literal : '';
130             }
131              
132             sub exists
133 2     2 1 767 { my $self = shift;
134 2         4 my ($path, $context) = @_;
135 2         9 my @nodeset = $self->findnodes( $path, $context);
136 2 100       16 return scalar( @nodeset ) ? 1 : 0;
137             }
138              
139             sub get_var {
140 1     1 1 5 my $self = shift;
141 1         2 my $var = shift;
142 1         5 $self->{vars}->{$var};
143             }
144              
145             sub set_var {
146 1     1 1 636 my $self = shift;
147 1         3 my $var = shift;
148 1         2 my $val = shift;
149 1         5 $self->{vars}->{$var} = $val;
150             }
151              
152             #sub _get_context_set { $_[0]->{context_set}; }
153 2309     2309   7758 sub _set_context_set { $_[0]->{context_set} = $_[1]; }
154 3     3   16 sub _get_context_pos { $_[0]->{context_pos}; }
155 2821     2821   15379 sub _set_context_pos { $_[0]->{context_pos} = $_[1]; }
156 2     2   6 sub _get_context_size { $_[0]->{context_set}->size; }
157             #sub _get_context_node { $_[0]->{context_set}->get_node($_[0]->{context_pos}); }
158              
159             sub _parse {
160 148     148   293 my $self = shift;
161 148         217 my $path = shift;
162 148 100       584 if ($CACHE{$path}) {
163 18         50 return $CACHE{$path};
164             }
165 130         536 my $tokens = $self->_tokenize($path);
166              
167 129         290 $self->{_tokpos} = 0;
168 129         397 my $tree = $self->_analyze($tokens);
169            
170 126 100       412 if ($self->{_tokpos} < scalar(@$tokens)) {
171             # didn't manage to parse entire expression - throw an exception
172 1         22 die "Parse of expression $path failed - junk after end of expression: $tokens->[$self->{_tokpos}]";
173             }
174            
175 125         428 $CACHE{$path} = $tree;
176            
177 125 50       281 _debug("PARSED Expr to:\n", $tree->as_string, "\n") if( $Tree::XPathEngine::DEBUG);
178            
179 125         499 return $tree;
180             }
181              
182             sub _tokenize {
183 130     130   216 my $self = shift;
184 130         219 my $path = shift;
185 130         221 study $path;
186            
187 130         207 my @tokens;
188            
189 130 50       359 _debug("Parsing: $path\n") if( $Tree::XPathEngine::DEBUG);
190            
191             # Bug: We don't allow "'@' NodeType" which is in the grammar, but I think is just plain stupid.
192              
193 130         228 my $expected=''; # used to desambiguate conflicts (for REs)
194              
195 130         412 while( length($path))
196 1318         2188 { my $token='';
197 1318 100 66     31631 if( $expected eq 'RE' && ($path=~ m{\G\s*($REGEXP_RE $REGEXP_MOD_RE?)\s*}gcxs))
    100          
198 9         25 { $token= $1; $expected=''; }
  9         18  
199             elsif($path =~ m/\G
200             \s* # ignore all whitespace
201             ( # tokens
202             $LITERAL| # literal string
203             $NUMBER_RE| # digits
204             \.\.| # parent
205             \.| # current
206             ($AXIS_NAME)?$NODE_TYPE| # node type test (probably useless in this context)
207             \@($self->{NAME}|$WILD)| # attribute
208             \$$self->{NAME}| # variable reference
209             ($AXIS_NAME)?($self->{NAME}|$WILD)| # NAME,NodeType,Axis::Test
210             \!=|<=|\-|>=|\/\/|and|or|mod|div| # multi-char seps
211             =~|\!~| # regexp matching (not in the XPath spec)
212             [,\+=\|<>\/\(\[\]\)]| # single char seps
213             (?
214             (?
215             $ # match end of query
216             )
217             \s* # ignore all whitespace
218             /gcxs)
219             {
220 1179         2072 $token = $1;
221 1179 100       2604 $expected= ($token=~ m{^[=!]~$}) ? 'RE' : '';
222             }
223             else
224 130         234 { $token=''; last; }
  130         463  
225              
226 1188 100       2812 if (length($token))
227             {
228 1059 50       2349 _debug("TOKEN: $token\n") if( $Tree::XPathEngine::DEBUG);
229 1059         4054 push @tokens, $token;
230             }
231             }
232            
233 130 100       450 if (pos($path) < length($path)) {
234 1         4 my $marker = ("." x (pos($path)-1));
235 1         4 $path = substr($path, 0, pos($path) + 8) . "...";
236 1         4 $path =~ s/\n/ /g;
237 1         2 $path =~ s/\t/ /g;
238 1         11 die "Query:\n",
239             "$path\n",
240             $marker, "^^^\n",
241             "Invalid query somewhere around here (I think)\n";
242             }
243            
244 129         502 return \@tokens;
245             }
246              
247             sub _analyze {
248 129     129   211 my $self = shift;
249 129         185 my $tokens = shift;
250             # lexical analysis
251            
252 129         449 return _expr($self, $tokens);
253             }
254              
255             sub _match {
256 6073     6073   9674 my ($self, $tokens, $match, $fatal) = @_;
257            
258 6073         9357 $self->{_curr_match} = '';
259 6073 100       18474 return 0 unless $self->{_tokpos} < @$tokens;
260              
261 4823         13766 local $^W;
262            
263             # _debug ("match: $match\n") if( $Tree::XPathEngine::DEBUG);
264            
265 4823 100       94984 if ($tokens->[$self->{_tokpos}] =~ /^$match$/) {
266 876         1916 $self->{_curr_match} = $tokens->[$self->{_tokpos}];
267 876         1290 $self->{_tokpos}++;
268 876         3394 return 1;
269             }
270             else {
271 3947 100       19505 if ($fatal) {
272 1         39 die "Invalid token: ", $tokens->[$self->{_tokpos}], "\n";
273             }
274             else {
275 3946         26672 return 0;
276             }
277             }
278             }
279              
280             sub _expr {
281 301     301   463 my ($self, $tokens) = @_;
282            
283 301 50       659 _debug( "in _exprexpr\n") if( $Tree::XPathEngine::DEBUG);
284            
285 301         757 return _or_expr($self, $tokens);
286             }
287              
288             sub _or_expr {
289 301     301   425 my ($self, $tokens) = @_;
290            
291 301 50       781 _debug( "in _or_expr\n") if( $Tree::XPathEngine::DEBUG);
292            
293 301         853 my $expr = _and_expr($self, $tokens);
294 297         616 while (_match($self, $tokens, 'or')) {
295 1         5 my $or_expr = Tree::XPathEngine::Expr->new($self);
296 1         4 $or_expr->set_lhs($expr);
297 1         3 $or_expr->set_op('or');
298              
299 1         3 my $rhs = _and_expr($self, $tokens);
300              
301 1         4 $or_expr->set_rhs($rhs);
302 1         2 $expr = $or_expr;
303             }
304            
305 297         1030 return $expr;
306             }
307              
308             sub _and_expr {
309 302     302   381 my ($self, $tokens) = @_;
310            
311 302 50       584 _debug( "in _and_expr\n") if( $Tree::XPathEngine::DEBUG);
312            
313 302         852 my $expr = _match_expr($self, $tokens);
314 298         566 while (_match($self, $tokens, 'and')) {
315 2         11 my $and_expr = Tree::XPathEngine::Expr->new($self);
316 2         8 $and_expr->set_lhs($expr);
317 2         6 $and_expr->set_op('and');
318            
319 2         5 my $rhs = _match_expr($self, $tokens);
320            
321 2         12 $and_expr->set_rhs($rhs);
322 2         6 $expr = $and_expr;
323             }
324            
325 298         583 return $expr;
326             }
327              
328             sub _match_expr {
329 304     304   404 my ($self, $tokens) = @_;
330            
331 304 50       646 _debug( "in _match_expr\n") if( $Tree::XPathEngine::DEBUG);
332            
333 304         718 my $expr = _equality_expr($self, $tokens);
334              
335 300         619 while (_match($self, $tokens, '[=!]~')) {
336 9         48 my $match_expr = Tree::XPathEngine::Expr->new($self);
337 9         38 $match_expr->set_lhs($expr);
338 9         34 $match_expr->set_op($self->{_curr_match});
339            
340 9         24 my $rhs = _equality_expr($self, $tokens);
341            
342 9         41 $match_expr->set_rhs($rhs);
343 9         22 $expr = $match_expr;
344             }
345            
346 300         677 return $expr;
347             }
348              
349             sub _equality_expr {
350 313     313   369 my ($self, $tokens) = @_;
351            
352 313 50       2309 _debug( "in _equality_expr\n") if( $Tree::XPathEngine::DEBUG);
353            
354 313         631 my $expr = _relational_expr($self, $tokens);
355 309         630 while (_match($self, $tokens, '!?=')) {
356 71         323 my $eq_expr = Tree::XPathEngine::Expr->new($self);
357 71         246 $eq_expr->set_lhs($expr);
358 71         266 $eq_expr->set_op($self->{_curr_match});
359            
360 71         148 my $rhs = _relational_expr($self, $tokens);
361            
362 71         310 $eq_expr->set_rhs($rhs);
363 71         188 $expr = $eq_expr;
364             }
365            
366 309         737 return $expr;
367             }
368              
369             sub _relational_expr {
370 384     384   510 my ($self, $tokens) = @_;
371            
372 384 50       678 _debug( "in _relational_expr\n") if( $Tree::XPathEngine::DEBUG);
373            
374 384         941 my $expr = _additive_expr($self, $tokens);
375 380         816 while (_match($self, $tokens, '(<|>|<=|>=)')) {
376 18         236 my $rel_expr = Tree::XPathEngine::Expr->new($self);
377 18         60 $rel_expr->set_lhs($expr);
378 18         68 $rel_expr->set_op($self->{_curr_match});
379            
380 18         43 my $rhs = _additive_expr($self, $tokens);
381            
382 18         182 $rel_expr->set_rhs($rhs);
383 18         60 $expr = $rel_expr;
384             }
385            
386 380         1067 return $expr;
387             }
388              
389             sub _additive_expr {
390 402     402   540 my ($self, $tokens) = @_;
391            
392 402 50       930 _debug( "in _additive_expr\n") if( $Tree::XPathEngine::DEBUG);
393            
394 402         817 my $expr = _multiplicative_expr($self, $tokens);
395 398         864 while (_match($self, $tokens, '[\\+\\-]')) {
396 12         64 my $add_expr = Tree::XPathEngine::Expr->new($self);
397 12         134 $add_expr->set_lhs($expr);
398 12         54 $add_expr->set_op($self->{_curr_match});
399            
400 12         33 my $rhs = _multiplicative_expr($self, $tokens);
401            
402 12         143 $add_expr->set_rhs($rhs);
403 12         37 $expr = $add_expr;
404             }
405            
406 398         925 return $expr;
407             }
408              
409             sub _multiplicative_expr {
410 414     414   608 my ($self, $tokens) = @_;
411            
412 414 50       956 _debug( "in _multiplicative_expr\n") if( $Tree::XPathEngine::DEBUG);
413            
414 414         1103 my $expr = _unary_expr($self, $tokens);
415 410         9365 while (_match($self, $tokens, '(\\*|div|mod)')) {
416 4         24 my $mult_expr = Tree::XPathEngine::Expr->new($self);
417 4         15 $mult_expr->set_lhs($expr);
418 4         14 $mult_expr->set_op($self->{_curr_match});
419            
420 4         11 my $rhs = _unary_expr($self, $tokens);
421            
422 4         22 $mult_expr->set_rhs($rhs);
423 4         10 $expr = $mult_expr;
424             }
425            
426 410         1055 return $expr;
427             }
428              
429             sub _unary_expr {
430 420     420   497 my ($self, $tokens) = @_;
431            
432 420 50       744 _debug( "in _unary_expr\n") if( $Tree::XPathEngine::DEBUG);
433            
434 420 100       940 if (_match($self, $tokens, '-')) {
435 2         11 my $expr = Tree::XPathEngine::Expr->new($self);
436 2         11 $expr->set_lhs(Tree::XPathEngine::Number->new(0));
437 2         8 $expr->set_op('-');
438 2         9 $expr->set_rhs(_unary_expr($self, $tokens));
439 2         7 return $expr;
440             }
441             else {
442 418         882 return _union_expr($self, $tokens);
443             }
444             }
445              
446             sub _union_expr {
447 418     418   1431 my ($self, $tokens) = @_;
448            
449 418 50       804 _debug( "in _union_expr\n") if( $Tree::XPathEngine::DEBUG);
450            
451 418         775 my $expr = _path_expr($self, $tokens);
452 414         930 while (_match($self, $tokens, '\\|')) {
453 2         10 my $un_expr = Tree::XPathEngine::Expr->new($self);
454 2         8 $un_expr->set_lhs($expr);
455 2         6 $un_expr->set_op('|');
456            
457 2         4 my $rhs = _path_expr($self, $tokens);
458            
459 2         7 $un_expr->set_rhs($rhs);
460 2         5 $expr = $un_expr;
461             }
462            
463 414         1067 return $expr;
464             }
465              
466             sub _path_expr {
467 420     420   586 my ($self, $tokens) = @_;
468              
469 420 50       801 _debug( "in _path_expr\n") if( $Tree::XPathEngine::DEBUG);
470            
471             # _path_expr is _location_path | _filter_expr | _filter_expr '//?' _relative_location_path
472            
473             # Since we are being predictive we need to find out which function to call next, then.
474            
475             # LocationPath either starts with "/", "//", ".", ".." or a proper Step.
476            
477 420         1637 my $expr = Tree::XPathEngine::Expr->new($self);
478            
479 420         1009 my $test = $tokens->[$self->{_tokpos}];
480            
481             # Test for AbsoluteLocationPath and AbbreviatedRelativeLocationPath
482 420 100       1955 if ($test =~ /^(\/\/?|\.\.?)$/) {
    100          
483             # LocationPath
484 113         395 $expr->set_lhs(_location_path($self, $tokens));
485             }
486             # Test for AxisName::...
487             elsif (_is_step($self, $tokens)) {
488 42         121 $expr->set_lhs(_location_path($self, $tokens));
489             }
490             else {
491             # Not a LocationPath
492             # Use _filter_expr instead:
493            
494 265         694 $expr = _filter_expr($self, $tokens);
495 264 50       955 if (_match($self, $tokens, '//?')) {
496 0         0 my $loc_path = Tree::XPathEngine::LocationPath->new();
497 0         0 push @$loc_path, $expr;
498 0 0       0 if ($self->{_curr_match} eq '//') {
499 0         0 push @$loc_path, Tree::XPathEngine::Step->new($self, 'descendant-or-self',
500             Tree::XPathEngine::Step::test_nt_node() );
501             }
502 0         0 push @$loc_path, _relative_location_path($self, $tokens);
503 0         0 my $new_expr = Tree::XPathEngine::Expr->new($self);
504 0         0 $new_expr->set_lhs($loc_path);
505 0         0 return $new_expr;
506             }
507             }
508            
509 416         1095 return $expr;
510             }
511              
512             sub _filter_expr {
513 265     265   399 my ($self, $tokens) = @_;
514            
515 265 50       505 _debug( "in _filter_expr\n") if( $Tree::XPathEngine::DEBUG);
516            
517 265         545 my $expr = _primary_expr($self, $tokens);
518 264         700 while (_match($self, $tokens, '\\[')) {
519             # really PredicateExpr...
520 0         0 $expr->push_predicate(_expr($self, $tokens));
521 0         0 _match($self, $tokens, '\\]', 1);
522             }
523            
524 264         683 return $expr;
525             }
526              
527             sub _primary_expr {
528 265     265   336 my ($self, $tokens) = @_;
529              
530 265 50       518 _debug( "in _primary_expr\n") if( $Tree::XPathEngine::DEBUG);
531            
532 265         845 my $expr = Tree::XPathEngine::Expr->new($self);
533            
534 265 100       761 if (_match($self, $tokens, $LITERAL)) {
    100          
    100          
    100          
    50          
    100          
535             # new Literal with $self->{_curr_match}...
536 81         436 $self->{_curr_match} =~ m/^(["'])(.*)\1$/;
537 81         886 $expr->set_lhs(Tree::XPathEngine::Literal->new($2));
538             }
539             elsif (_match($self, $tokens, "$REGEXP_RE$REGEXP_MOD_RE?")) {
540             # new Literal with $self->{_curr_match} turned into a regexp...
541 9         147 my( $regexp, $mod)= $self->{_curr_match} =~ m{($REGEXP_RE)($REGEXP_MOD_RE?)};
542 9         49 $regexp=~ s{^m?s*/}{};
543 9         37 $regexp=~ s{/$}{};
544 9 50       28 if( $mod) { $regexp=~ "(?$mod:$regexp)"; } # move the mods inside the regexp
  0         0  
545 9         55 $expr->set_lhs(Tree::XPathEngine::Literal->new($regexp));
546             }
547             elsif (_match($self, $tokens, $NUMBER_RE)) {
548             # new Number with $self->{_curr_match}...
549 103         621 $expr->set_lhs(Tree::XPathEngine::Number->new($self->{_curr_match}));
550             }
551             elsif (_match($self, $tokens, '\\(')) {
552 25         82 $expr->set_lhs(_expr($self, $tokens));
553 25         66 _match($self, $tokens, '\\)', 1);
554             }
555             elsif (_match($self, $tokens, "\\\$$self->{NAME}")) {
556             # new Variable with $self->{_curr_match}...
557 0         0 $self->{_curr_match} =~ /^\$(.*)$/;
558 0         0 $expr->set_lhs(Tree::XPathEngine::Variable->new($self, $1));
559             }
560             elsif (_match($self, $tokens, $self->{NAME})) {
561             # check match not Node_Type - done in lexer...
562             # new Function
563 46         84 my $func_name = $self->{_curr_match};
564 46         102 _match($self, $tokens, '\\(', 1);
565 46         160 $expr->set_lhs(
566             Tree::XPathEngine::Function->new(
567             $self,
568             $func_name,
569             _arguments($self, $tokens)
570             )
571             );
572 46         110 _match($self, $tokens, '\\)', 1);
573             }
574             else {
575 1         16 die "Not a _primary_expr at ", $tokens->[$self->{_tokpos}], "\n";
576             }
577            
578 264         1346 return $expr;
579             }
580              
581             sub _arguments {
582 46     46   67 my ($self, $tokens) = @_;
583            
584 46 50       398 _debug( "in _arguments\n") if( $Tree::XPathEngine::DEBUG);
585            
586 46         58 my @args;
587            
588 46 100       176 if($tokens->[$self->{_tokpos}] eq ')') {
589 13         113 return \@args;
590             }
591            
592 33         84 push @args, _expr($self, $tokens);
593 33         73 while (_match($self, $tokens, ',')) {
594 19         46 push @args, _expr($self, $tokens);
595             }
596            
597 33         272 return \@args;
598             }
599              
600             sub _location_path {
601 155     155   217 my ($self, $tokens) = @_;
602              
603 155 50       322 _debug( "in _location_path\n") if( $Tree::XPathEngine::DEBUG);
604            
605 155         729 my $loc_path = Tree::XPathEngine::LocationPath->new();
606            
607 155 100       322 if (_match($self, $tokens, '/')) {
    100          
608             # root
609 18 50       53 _debug("h: Matched root\n") if( $Tree::XPathEngine::DEBUG);
610 18         121 push @$loc_path, Tree::XPathEngine::Root->new();
611 18 50       59 if (_is_step($self, $tokens)) {
612 18 50       51 _debug("Next is step\n") if( $Tree::XPathEngine::DEBUG);
613 18         58 push @$loc_path, _relative_location_path($self, $tokens);
614             }
615             }
616             elsif (_match($self, $tokens, '//')) {
617             # root
618 69         415 push @$loc_path, Tree::XPathEngine::Root->new();
619 69         256 my $optimised = _optimise_descendant_or_self($self, $tokens);
620 69 100       160 if (!$optimised) {
621 62         362 push @$loc_path, Tree::XPathEngine::Step->new($self, 'descendant-or-self',
622             Tree::XPathEngine::Step::test_nt_node);
623 62         293 push @$loc_path, _relative_location_path($self, $tokens);
624             }
625             else {
626 7         23 push @$loc_path, $optimised, _relative_location_path($self, $tokens);
627             }
628             }
629             else {
630 68         526 push @$loc_path, _relative_location_path($self, $tokens);
631             }
632            
633 152         2527 return $loc_path;
634             }
635              
636             sub _optimise_descendant_or_self {
637 72     72   133 my ($self, $tokens) = @_;
638            
639 72 50       217 _debug( "in _optimise_descendant_or_self\n") if( $Tree::XPathEngine::DEBUG);
640            
641 72         141 my $tokpos = $self->{_tokpos};
642            
643             # // must be followed by a Step.
644 72 100 100     670 if ($tokens->[$tokpos+1] && $tokens->[$tokpos+1] eq '[') {
    50          
645             # next token is a predicate
646 61         131 return;
647             }
648             elsif ($tokens->[$tokpos] =~ /^\.\.?$/) {
649             # abbreviatedStep - can't optimise.
650 0         0 return;
651             }
652             else {
653 11 50       36 _debug("Trying to optimise //\n") if( $Tree::XPathEngine::DEBUG);
654 11         45 my $step = _step($self, $tokens);
655 11 100       77 if ($step->{axis} ne 'child') {
656             # can't optimise axes other than child for now...
657 4         9 $self->{_tokpos} = $tokpos;
658 4         27 return;
659             }
660 7         15 $step->{axis} = 'descendant';
661 7         13 $step->{axis_method} = 'axis_descendant';
662 7         12 $self->{_tokpos}--;
663 7         16 $tokens->[$self->{_tokpos}] = '.';
664 7         16 return $step;
665             }
666             }
667              
668             sub _relative_location_path {
669 155     155   251 my ($self, $tokens) = @_;
670            
671 155 50       350 _debug( "in _relative_location_path\n") if( $Tree::XPathEngine::DEBUG);
672            
673 155         182 my @steps;
674            
675 155         376 push @steps,_step($self, $tokens);
676 153         484 while (_match($self, $tokens, '//?')) {
677 45 100       162 if ($self->{_curr_match} eq '//') {
678 3         8 my $optimised = _optimise_descendant_or_self($self, $tokens);
679 3 50       10 if (!$optimised) {
680 3         13 push @steps, Tree::XPathEngine::Step->new($self, 'descendant-or-self',
681             Tree::XPathEngine::Step::test_nt_node);
682             }
683             else {
684 0         0 push @steps, $optimised;
685             }
686             }
687 45         100 push @steps, _step($self, $tokens);
688 44 50 33     423 if (@steps > 1 &&
      33        
689             $steps[-1]->{axis} eq 'self' &&
690             $steps[-1]->{test} == Tree::XPathEngine::Step::test_nt_node) {
691 0         0 pop @steps;
692             }
693             }
694            
695 152         486 return @steps;
696             }
697              
698             sub _step {
699 211     211   300 my ($self, $tokens) = @_;
700              
701 211 50       752 _debug( "in _step\n") if( $Tree::XPathEngine::DEBUG);
702            
703 211 100       350 if (_match($self, $tokens, '\\.')) {
    100          
704             # self::node()
705 32         140 return Tree::XPathEngine::Step->new($self, 'self', Tree::XPathEngine::Step::test_nt_node);
706             }
707             elsif (_match($self, $tokens, '\\.\\.')) {
708             # parent::node()
709 3         16 return Tree::XPathEngine::Step->new($self, 'parent', Tree::XPathEngine::Step::test_nt_node);
710             }
711             else {
712             # AxisSpecifier NodeTest Predicate(s?)
713 176         429 my $token = $tokens->[$self->{_tokpos}];
714            
715 176 50       372 _debug("p: Checking $token\n") if( $Tree::XPathEngine::DEBUG);
716            
717 176         196 my $step;
718 176 100       2826 if ($token =~ /^\@($self->{NAME}|$WILD)$/) {
    100          
    100          
    50          
    50          
    100          
719 82         156 $self->{_tokpos}++;
720 82 100       816 if ($token eq '@*') {
    50          
721 10         47 $step = Tree::XPathEngine::Step->new($self,
722             'attribute',
723             Tree::XPathEngine::Step::test_attr_any,
724             '*');
725             }
726             elsif ($token =~ /^\@($self->{NAME})$/) {
727 72         352 $step = Tree::XPathEngine::Step->new($self,
728             'attribute',
729             Tree::XPathEngine::Step::test_attr_name,
730             $1);
731             }
732             }
733             elsif ($token =~ /^$WILD$/) { # *
734 15         34 $self->{_tokpos}++;
735 15         64 $step = Tree::XPathEngine::Step->new($self, 'child',
736             Tree::XPathEngine::Step::test_any,
737             $token);
738             }
739             elsif ($token =~ /^$self->{NAME}$/) { # name:name
740 66         299 $self->{_tokpos}++;
741 66         310 $step = Tree::XPathEngine::Step->new($self, 'child',
742             Tree::XPathEngine::Step::test_name,
743             $token);
744             }
745             elsif ($token eq 'text()') {
746 0         0 $self->{_tokpos}++;
747 0         0 $step = Tree::XPathEngine::Step->new($self, 'child',
748             Tree::XPathEngine::Step::test_nt_text);
749             }
750             elsif ($token eq 'node()') {
751 0         0 $self->{_tokpos}++;
752 0         0 $step = Tree::XPathEngine::Step->new($self, 'child',
753             Tree::XPathEngine::Step::test_nt_node);
754             }
755             elsif ($token =~ /^($AXIS_NAME)($self->{NAME}|$WILD|$NODE_TYPE)$/) {
756 12         44 my $axis = substr( $1, 0, -2);
757 12         27 $self->{_tokpos}++;
758 12         25 $token = $2;
759 12 100       146 if ($token =~ /^$WILD$/) { # *
    50          
    0          
    0          
760 10 50       60 $step = Tree::XPathEngine::Step->new($self, $axis,
761             (($axis eq 'attribute') ?
762             Tree::XPathEngine::Step::test_attr_any
763             :
764             Tree::XPathEngine::Step::test_any),
765             $token);
766             }
767             elsif ($token =~ /^$self->{NAME}$/) { # name:name
768 2 50       14 $step = Tree::XPathEngine::Step->new($self, $axis,
769             (($axis eq 'attribute') ?
770             Tree::XPathEngine::Step::test_attr_name
771             :
772             Tree::XPathEngine::Step::test_name),
773             $token);
774             }
775             elsif ($token eq 'text()') {
776 0         0 $step = Tree::XPathEngine::Step->new($self, $axis,
777             Tree::XPathEngine::Step::test_nt_text);
778             }
779             elsif ($token eq 'node()') {
780 0         0 $step = Tree::XPathEngine::Step->new($self, $axis,
781             Tree::XPathEngine::Step::test_nt_node);
782             }
783             else {
784 0         0 die "Shouldn't get here";
785             }
786             }
787             else {
788 1         26 die "token $token doesn't match format of a 'Step'\n";
789             }
790            
791 175         425 while (_match($self, $tokens, '\\[')) {
792 95         213 push @{$step->{predicates}}, _expr($self, $tokens);
  95         444  
793 94         230 _match($self, $tokens, '\\]', 1);
794             }
795            
796 173         705 return $step;
797             }
798             }
799              
800             sub _is_step {
801 325     325   474 my ($self, $tokens) = @_;
802            
803 325         695 my $token = $tokens->[$self->{_tokpos}];
804            
805 325 50       691 return unless defined $token;
806            
807 325 50       661 _debug("p: Checking if '$token' is a step\n") if( $Tree::XPathEngine::DEBUG);
808            
809 325         738 local $^W=0;
810            
811 325 100 66     10068 if( ($token eq 'processing-instruction')
      100        
      100        
      66        
      66        
      66        
812             || ($token =~ /^\@($self->{NAME}|$WILD)$/)
813             || ( ($token =~ /^($self->{NAME}|$WILD)$/ )
814             && ( ($tokens->[$self->{_tokpos}+1] || '') ne '(') )
815             || ($token =~ /^$NODE_TYPE$/)
816             || ($token =~ /^$AXIS_NAME($self->{NAME}|$WILD|$NODE_TYPE)$/)
817             )
818 60         246 { return 1; }
819             else
820 265 50       630 { _debug("p: '$token' not a step\n") if( $Tree::XPathEngine::DEBUG);
821 265         1253 return;
822             }
823             }
824              
825             sub _debug {
826            
827 0     0     my ($pkg, $file, $line, $sub) = caller(1);
828            
829 0           $sub =~ s/^$pkg\:://;
830            
831 0           while (@_) {
832 0           my $x = shift;
833 0           $x =~ s/\bPKG\b/$pkg/g;
834 0           $x =~ s/\bLINE\b/$line/g;
835 0           $x =~ s/\bg\b/$sub/g;
836 0           print STDERR $x;
837             }
838             }
839              
840              
841             __END__