File Coverage

lib/XML/Parser/Lite/Tree/XPath/Token.pm
Criterion Covered Total %
statement 416 467 89.0
branch 236 344 68.6
condition 37 48 77.0
subroutine 40 40 100.0
pod 0 34 0.0
total 729 933 78.1


line stmt bran cond sub pod time code
1             package XML::Parser::Lite::Tree::XPath::Token;
2            
3 32     32   27402 use strict;
  32         63  
  32         1163  
4 32     32   18409 use XML::Parser::Lite::Tree::XPath::Result;
  32         90  
  32         1166  
5 32     32   27025 use XML::Parser::Lite::Tree::XPath::Axis;
  32         88  
  32         1040  
6 32     32   263 use Data::Dumper;
  32         71  
  32         218601  
7            
8             sub new {
9 2470     2470 0 4091 my $class = shift;
10 2470         7505 my $self = bless {}, $class;
11 2470         6273 return $self;
12             }
13            
14             sub match {
15 55524     55524 0 72516 my ($self, $type, $content) = @_;
16            
17 55524 100       258001 return 0 unless $self->{type} eq $type;
18            
19 7371 100 100     33473 return 0 if (defined($content) && ($self->{content} ne $content));
20            
21 4386         15072 return 1;
22             }
23            
24             sub is_expression {
25 12     12 0 50 my ($self) = @_;
26            
27 12 100       53 return 1 if $self->{type} eq 'Number';
28 6 100       22 return 1 if $self->{type} eq 'Literal';
29 5 100       27 return 0 if $self->{type} eq 'Operator';
30            
31 1         13 warn "Not sure if $self->{type} is an expression";
32            
33 1         9 return 0;
34             }
35            
36             sub dump {
37 279     279 0 372 my ($self) = @_;
38            
39 279         450 my $ret = $self->{type};
40 279 100       612 $ret .= ':absolute' if $self->{absolute};
41 279 100       715 $ret .= ':'.$self->{content} if defined $self->{content};
42 279 100       636 $ret .= '::'.$self->{axis} if defined $self->{axis};
43            
44 279         855 return $ret;
45             }
46            
47             sub ret {
48 1090     1090 0 1685 my ($self, $a, $b) = @_;
49 1090         3018 return XML::Parser::Lite::Tree::XPath::Result->new($a, $b);
50             }
51            
52             sub eval {
53 1696     1696 0 2210 my ($self, $context) = @_;
54            
55 1696 100       4421 return $context if $context->is_error;
56 1695         2955 $self->{context} = $context;
57            
58 1695 100 100     10008 if ($self->{type} eq 'LocationPath'){
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
59            
60             # a LocationPath should just be a list of Steps, so eval them in order
61            
62 154         204 my $ret;
63            
64 154 100       449 if ($self->{absolute}){
65 92         188 $ret = $self->{root};
66             }else{
67 62         170 $ret = $context->get_nodeset;
68 62 50       152 return $ret if $ret->is_error;
69             }
70            
71            
72 154         192 for my $step(@{$self->{tokens}}){
  154         314  
73            
74 279 50       771 unless ($step->match('Step')){
75 0         0 return $self->ret('Error', "Found a non-Step token ('$step->{type}') in a LocationPath");
76             }
77            
78 279         1146 $ret = $step->eval($ret);
79            
80 279 50       674 return $ret if $ret->is_error;
81            
82 279         763 $ret->normalize();
83             }
84            
85 154         509 return $ret;
86            
87             }elsif ($self->{type} eq 'Step'){
88            
89             # for a step, loop through it's children
90            
91             # my $axis = defined($self->{axis}) ? $self->{axis} : 'child';
92             # my $ret = $self->filter_axis($axis, $context);
93            
94 279         837 my $ret = XML::Parser::Lite::Tree::XPath::Axis::instance->filter($self, $context);
95            
96 279         375 for my $step(@{$self->{tokens}}){
  279         591  
97            
98 310 50 66     704 unless ($step->match('AxisSpecifier') || $step->match('NameTest') || $step->match('Predicate') || $step->match('NodeTypeTest')){
      100        
      66        
99            
100 0         0 return $self->ret('Error', "Found an unexpected token ('$step->{type}') in a Step");
101             }
102            
103 310         1117 $ret = $step->eval($ret);
104            
105 310 50       969 return $ret if $ret->is_error;
106             }
107            
108 279         626 return $ret;
109            
110            
111             }elsif ($self->{type} eq 'NameTest'){
112            
113 221 100       607 return $context if $self->{content} eq '*';
114            
115 134 50       510 if ($self->{content} =~ m!\:\*$!){
116 0         0 return $self->ret('Error', "Can't do NCName:* NameTests");
117             }
118            
119 134 50       335 if ($context->{type} eq 'nodeset'){
120 134         396 my $out = $self->ret('nodeset', []);
121            
122 134         199 for my $tag(@{$context->{value}}){
  134         282  
123            
124 608 100 100     2740 if (($tag->{'type'} eq 'element') && ($tag->{'name'} eq $self->{content})){
125 188         231 push @{$out->{value}}, $tag;
  188         366  
126             }
127            
128 608 100 100     1646 if (($tag->{'type'} eq 'attribute') && ($tag->{'name'} eq $self->{content})){
129 12         13 push @{$out->{value}}, $tag;
  12         35  
130             }
131             }
132            
133 134         315 return $out;
134             }
135            
136 0         0 return $self->ret('Error', "filter by name $self->{content} on context $context->{type}");
137            
138            
139             }elsif ($self->{type} eq 'NodeTypeTest'){
140            
141 58 50       188 if ($self->{content} eq 'node'){
142 58 50       164 if ($context->{type} eq 'nodeset'){
143 58         136 return $context;
144             }else{
145 0         0 return $self->ret('Error', "can't filter node() on a non-nodeset value.");
146             }
147             }
148            
149 0         0 return $self->ret('Error', "NodeTypeTest with an unknown filter ($self->{content})");
150            
151            
152             }elsif ($self->{type} eq 'Predicate'){
153            
154 31         80 my $expr = $self->{tokens}->[0];
155            
156 31         105 my $out = $self->ret('nodeset', []);
157 31         54 my $i = 1;
158 31         44 my $c = scalar @{$context->{value}};
  31         70  
159            
160 31         54 for my $child(@{$context->{value}}){
  31         74  
161            
162 171         301 $child->{proximity_position} = $i;
163 171         257 $child->{context_size} = $c;
164 171         187 $i++;
165            
166 171         346 my $ret = $expr->eval($self->ret('node', $child));
167            
168 171 100       458 if ($ret->{type} eq 'boolean'){
    100          
    50          
    0          
169            
170 133 100       298 if ($ret->{value}){
171 45         52 push @{$out->{value}}, $child;
  45         108  
172             }
173            
174             }elsif ($ret->{type} eq 'number'){
175            
176 26 100       179 if ($ret->{value} == $child->{proximity_position}){
177 8         15 push @{$out->{value}}, $child;
  8         22  
178             }
179            
180             }elsif ($ret->{type} eq 'nodeset'){
181            
182 12 100       13 if (scalar @{$ret->{value}}){
  12         35  
183 6         7 push @{$out->{value}}, $child;
  6         13  
184             }
185            
186             }elsif ($ret->{type} eq 'Error'){
187            
188 0         0 return $ret;
189            
190             }else{
191 0         0 return $self->ret('Error', "unexpected predicate result type ($ret->{type})");
192             }
193            
194 171         300 delete $child->{proximity_position};
195 171         478 delete $child->{context_size};
196             }
197            
198 31         91 return $out;
199            
200             }elsif ($self->{type} eq 'Number'){
201            
202 173         388 return $self->ret('number', $self->{content});
203            
204             }elsif ($self->{type} eq 'FunctionCall'){
205            
206 280         669 my $handler = $self->get_function_handler($self->{content});
207            
208 280 50 33     1247 if ((!defined $handler) || (!defined $handler->[0])){
209 0         0 return $self->ret('Error', "No handler for function call '$self->{content}'");
210             }
211            
212            
213             #
214             # evaluate each of the supplied args first
215             #
216            
217 280         350 my @in_args;
218 280         313 for my $source (@{$self->{tokens}}){
  280         630  
219 196         497 my $out = $source->eval($context);
220 196 50       543 return $out if $out->is_error;
221 196         532 push @in_args, $out;
222             }
223            
224            
225             #
226             # now check them against the function signature
227             #
228            
229 280         447 my $func = $handler->[0];
230 280         364 my $sig = $handler->[1];
231 280         809 my @sig = split /,/, $sig;
232 280         312 my @out_args;
233            
234 280         324 my $position = 0;
235            
236 280         394 for my $sig(@sig){
237            
238 261         318 my $repeat = 0;
239 261         269 my $optional = 0;
240            
241 261 100       666 if ($sig =~ m/\+$/){ $repeat = 1; }
  5         6  
242 261 100       736 if ($sig =~ m/\?$/){ $optional = 1; }
  107         142  
243 261         713 $sig =~ s/[?+]$//;
244            
245             #
246             # repeating args are somewhat tricky
247             #
248            
249 261 100       510 if ($repeat){
250            
251 5         6 my $count = 0;
252            
253 5         5 while (1){
254 10         10 $count++;
255            
256 10 100       22 unless (defined $in_args[$position]){
257 5 100       10 if ($count == 1){
258 1         8 return $self->ret('Error', "Argument $position to function $self->{content} is required (type $sig)");
259             }
260 4         12 last;
261             }
262            
263 5         12 my $value = $self->coerce($in_args[$position], $sig);
264 5         7 $position++;
265 5 50       10 if (defined $value){
266 5 50       11 return $value if $value->is_error;
267 5         8 push @out_args, $value;
268            
269             }else{
270 0 0       0 if ($count == 1){
271 0         0 return $self->ret('Error', "Can't coerce argument $position to a $sig in function $self->{content}");
272             }
273 0         0 last;
274             }
275             }
276            
277             }else{
278            
279 256 100       544 unless (defined $in_args[$position]){
280 65 50       107 if ($optional){
281 65         163 next;
282             }else{
283 0         0 return $self->ret('Error', "Argument $position to function $self->{content} is required (type $sig)");
284             }
285             }
286            
287 191         454 my $value = $self->coerce($in_args[$position], $sig);
288 191         224 $position++;
289            
290 191 50       343 if (defined $value){
291            
292 191 50       461 return $value if $value->is_error;
293 191         508 push @out_args, $value;
294             }else{
295 0         0 return $self->ret('Error', "Can't coerce argument $position to a $sig in function $self->{content}");
296             }
297             }
298             }
299            
300 279         428 return &{$func}($self, \@out_args);
  279         610  
301            
302             }elsif ($self->{type} eq 'FunctionArg'){
303            
304             # a FunctionArg should have a single child
305            
306 196 50       233 return $self->ret('Error', 'FunctionArg should have 1 token') unless 1 == scalar @{$self->{tokens}};
  196         491  
307            
308 196         574 return $self->{tokens}->[0]->eval($context);
309            
310             }elsif (($self->{type} eq 'EqualityExpr') || ($self->{type} eq 'RelationalExpr')){
311            
312 120         360 my $v1 = $self->{tokens}->[0]->eval($context);
313 120         328 my $v2 = $self->{tokens}->[1]->eval($context);
314 120         314 my $t = "$v1->{type}/$v2->{type}";
315            
316 120 50       286 return $v1 if $v1->is_error;
317 120 50       309 return $v2 if $v2->is_error;
318            
319 120 50       306 if ($v1->{type} gt $v2->{type}){
320 0         0 $t = "$v2->{type}/$v1->{type}";
321 0         0 ($v1, $v2) = ($v2, $v1);
322             }
323            
324 120 100       213 if ($t eq 'nodeset/string'){
325            
326 6         8 for my $node(@{$v1->{value}}){;
  6         15  
327            
328 5         12 my $v1_s = $self->ret('node', $node)->get_string;
329 5 50       28 return $v1_s if $v1_s->is_error;
330            
331 5         20 my $ok = $self->compare_op($self->{content}, $v1_s, $v2);
332 5 50       16 return $ok if $ok->is_error;
333            
334 5 100       31 return $ok if $ok->{value};
335             }
336            
337 4         13 return $self->ret('boolean', 0);
338             }
339            
340 114 100       204 if ($t eq 'string/string'){
341            
342 22         63 return $self->compare_op($self->{content}, $v1, $v2);
343             }
344            
345 92 50       173 if ($t eq 'number/number'){
346            
347 92         229 return $self->compare_op($self->{content}, $v1, $v2);
348             }
349            
350 0         0 return $self->ret('Error', "can't do an EqualityExpr on $t");
351            
352             }elsif ($self->{type} eq 'Literal'){
353            
354 93         243 return $self->ret('string', $self->{content});
355            
356            
357             }elsif ($self->{type} eq 'UnionExpr'){
358            
359 9         39 my $a1 = $self->get_child_arg(0, 'nodeset');
360 9         23 my $a2 = $self->get_child_arg(1, 'nodeset');
361            
362 9 50       25 return $a1 if $a1->is_error;
363 9 50       22 return $a2 if $a2->is_error;
364            
365 9         23 my $out = $self->ret('nodeset', []);
366            
367 9         12 map{ push @{$out->{value}}, $_ } @{$a1->{value}};
  49         45  
  49         85  
  9         19  
368 9         10 map{ push @{$out->{value}}, $_ } @{$a2->{value}};
  17         17  
  17         32  
  9         14  
369            
370 9         22 $out->normalize();
371            
372 9         60 return $out;
373            
374             }elsif ($self->{type} eq 'MultiplicativeExpr'){
375            
376 36         85 my $a1 = $self->get_child_arg(0, 'number');
377 36         74 my $a2 = $self->get_child_arg(1, 'number');
378            
379 36 50       87 return $a1 if $a1->is_error;
380 36 50       79 return $a2 if $a2->is_error;
381            
382 36         77 my $result = 0;
383 36 100       80 $result = $a1->{value} * $a2->{value} if $self->{content} eq '*';
384 36 100       144 $result = $self->op_mod($a1->{value}, $a2->{value}) if $self->{content} eq 'mod';
385 36 100       113 $result = $self->op_div($a1->{value}, $a2->{value}) if $self->{content} eq 'div';
386            
387 36         99 return $self->ret('number', $result);
388            
389             }elsif (($self->{type} eq 'OrExpr') || ($self->{type} eq 'AndExpr')){
390            
391 11         24 my $a1 = $self->get_child_arg(0, 'boolean');
392 11         20 my $a2 = $self->get_child_arg(1, 'boolean');
393            
394 11 50       26 return $a1 if $a1->is_error;
395 11 50       26 return $a2 if $a2->is_error;
396            
397 11 50 100     65 return $self->ret('boolean', $a1->{value} || $a2->{value}) if $self->{type} eq 'OrExpr';
398 0 0 0     0 return $self->ret('boolean', $a1->{value} && $a2->{value}) if $self->{type} eq 'AndExpr';
399            
400             }elsif ($self->{type} eq 'AdditiveExpr'){
401            
402 27         58 my $a1 = $self->get_child_arg(0, 'number');
403 27         56 my $a2 = $self->get_child_arg(1, 'number');
404            
405 27 50       63 return $a1 if $a1->is_error;
406 27 50       54 return $a2 if $a2->is_error;
407            
408 27         33 my $result = 0;
409 27 100       82 $result = $a1->{value} + $a2->{value} if $self->{content} eq '+';
410 27 100       59 $result = $a1->{value} - $a2->{value} if $self->{content} eq '-';
411            
412 27         48 return $self->ret('number', $result);
413            
414             }elsif ($self->{type} eq 'UnaryExpr'){
415            
416 6         19 my $a1 = $self->get_child_arg(0, 'number');
417            
418 6 50       16 return $a1 if $a1->is_error;
419            
420 6         16 $a1->{value} = - $a1->{value};
421            
422 6         12 return $a1;
423            
424             }else{
425 1         7 return $self->ret('Error', "Don't know how to eval a '$self->{type}' node.");
426             }
427             }
428            
429             sub coerce {
430 196     196 0 290 my ($self, $arg, $type) = @_;
431            
432 196         245 my $value = undef;
433            
434 196 100       579 $value = $arg->get_string if $type eq 'string';
435 196 100       422 $value = $arg->get_number if $type eq 'number';
436 196 100       717 $value = $arg->get_nodeset if $type eq 'nodeset';
437 196 100       400 $value = $arg->get_boolean if $type eq 'boolean';
438 196 100       354 $value = $arg if $type eq 'any';
439            
440 196         323 return $value;
441             }
442            
443             sub get_child_arg {
444 172     172 0 238 my ($self, $pos, $type) = @_;
445            
446 172         258 my $token = $self->{tokens}->[$pos];
447 172 50       309 return $self->ret('Error', "Required child token {1+$pos} for $self->{type} token wasn't found.") unless defined $token;
448            
449 172         534 my $out = $token->eval($self->{context});
450 172 50       391 return $out if $out->is_error;
451            
452 172         438 return $out->get_type($type);
453             }
454            
455            
456             sub get_function_handler {
457 280     280 0 432 my ($self, $function) = @_;
458            
459 280         8456 my $function_map = {
460            
461             # nodeset functions
462             'last' => [\&function_last, '' ],
463             'position' => [\&function_position, '' ],
464             'count' => [\&function_count, 'nodeset' ],
465             'id' => [\&function_id, 'any' ],
466             'local-name' => [\&function_local_name, 'nodeset?' ],
467             'namespace-uri' => [\&function_namespace_uri, 'nodeset?' ],
468             'name' => [\&function_name, 'nodeset?' ],
469            
470             # string functions
471             'string' => [\&function_string, 'any?' ],
472             'concat' => [\&function_concat, 'string,string+' ],
473             'starts-with' => [\&function_starts_with, 'string,string' ],
474             'contains' => [\&function_contains, 'string,string' ],
475             'substring-before' => [\&function_substring_befor, 'string,string' ],
476             'substring-after' => [\&function_substring_after, 'string,string' ],
477             'substring' => [undef, 'string,number,number?' ],
478             'string-length' => [\&function_string_length, 'string?' ],
479             'normalize-space' => [\&function_normalize_space, 'string?' ],
480             'translate' => [undef, 'string,string,string' ],
481            
482             # boolean functions
483             'boolean' => [undef, 'any' ],
484             'not' => [\&function_not, 'boolean' ],
485             'true' => [undef, '' ],
486             'false' => [undef, '' ],
487             'lang' => [undef, 'string' ],
488            
489             # number functions
490             'number' => [undef, 'any?' ],
491             'sum' => [undef, 'nodeset' ],
492             'floor' => [\&function_floor, 'number' ],
493             'ceiling' => [\&function_ceiling, 'number' ],
494             'round' => [undef, 'number' ],
495            
496             };
497            
498 280 50       3520 return $function_map->{$function} if defined $function_map->{$function};
499            
500 0         0 return undef;
501             }
502            
503             sub function_last {
504 29     29 0 35 my ($self, $args) = @_;
505            
506 29         80 return $self->ret('number', $self->{context}->{value}->{context_size});
507             }
508            
509             sub function_not {
510 4     4 0 4 my ($self, $args) = @_;
511            
512 4         6 my $out = $args->[0];
513 4         8 $out->{value} = !$out->{value};
514            
515 4         15 return $out
516             }
517            
518             sub function_normalize_space {
519 3     3 0 5 my ($self, $args) = @_;
520            
521 3         4 my $value = $args->[0];
522            
523 3 50       7 unless (defined $value){
524 0         0 $value = $self->{context}->get_string;
525 0 0       0 return $value if $value->get_error;
526             }
527            
528 3         8 $value = $value->{value};
529 3         10 $value =~ s!^[\x20\x09\x0d\x0a]+!!;
530 3         8 $value =~ s![\x20\x09\x0d\x0a]+$!!;
531 3         5 $value =~ s![\x20\x09\x0d\x0a]+! !g;
532            
533 3         7 return $self->ret('string', $value);
534             }
535            
536             sub function_count {
537 38     38 0 44 my ($self, $args) = @_;
538            
539 38         50 my $subject = $args->[0];
540            
541 38 50       86 return $self->ret('number', scalar(@{$subject->{value}})) if $subject->{type} eq 'nodeset';
  38         91  
542            
543 0         0 die("can't perform count() on $subject->{type}");
544             }
545            
546             sub function_starts_with {
547 14     14 0 21 my ($self, $args) = @_;
548            
549 14         33 my $s1 = $args->[0]->{value};
550 14         25 my $s2 = $args->[1]->{value};
551            
552 14         47 return $self->ret('boolean', (substr($s1, 0, length $s2) eq $s2));
553             }
554            
555             sub function_contains {
556 18     18 0 27 my ($self, $args) = @_;
557            
558 18         38 my $s1 = $args->[0]->{value};
559 18         41 my $s2 = quotemeta $args->[1]->{value};
560            
561 18         190 return $self->ret('boolean', ($s1 =~ /$s2/));
562             }
563            
564             sub function_string_length {
565 21     21 0 27 my ($self, $args) = @_;
566            
567 21         26 my $value = $args->[0];
568            
569 21 50       32 unless (defined $value){
570 0         0 $value = $self->{context}->get_string;
571 0 0       0 return $value if $value->is_error;
572             }
573            
574 21         50 return $self->ret('number', length $value->{value});
575             }
576            
577             sub function_position {
578 33     33 0 45 my ($self, $args) = @_;
579            
580 33         95 my $node = $self->{context}->get_nodeset;
581 33 50       81 return $node if $node->is_error;
582            
583 33         56 $node = $node->{value}->[0];
584 33 50       112 return $self->ret('Error', "No node in context nodeset o_O") unless defined $node;
585            
586 33         324 return $self->ret('number', $node->{proximity_position});
587             }
588            
589             sub function_floor {
590 11     11 0 14 my ($self, $args) = @_;
591            
592 11         19 my $val = $args->[0]->{value};
593 11         26 my $ret = $self->simple_floor($val);
594            
595 11 50       32 $ret = - $self->simple_ceiling(-$val) if $val < 0;
596            
597 11         20 return $self->ret('number', $ret);
598             }
599            
600             sub function_ceiling {
601 11     11 0 13 my ($self, $args) = @_;
602            
603 11         18 my $val = $args->[0]->{value};
604 11         21 my $ret = $self->simple_ceiling($val);
605            
606 11 50       18 $ret = - $self->simple_floor(-$val) if $val < 0;
607            
608 11         23 return $self->ret('number', $ret);
609             }
610            
611             sub function_id {
612 4     4 0 8 my ($self, $args) = @_;
613            
614 4 50 33     27 unless ($self->{context}->{type} eq 'node' || $self->{context}->{type} eq 'nodeset'){
615            
616 0         0 return $self->ret('Error', "Can only call id() in a node or nodeset context - not $self->{context}->{type}");
617             }
618            
619 4         7 my $obj = $args->[0];
620 4         8 my $ids = '';
621            
622 4 100       11 if ($obj->{type} eq 'nodeset'){
623            
624 2         3 for my $node(@{$obj->{value}}){
  2         5  
625            
626 8         20 $ids .= ' ' . $self->get_string_value($node);
627             }
628             }else{
629 2         10 $ids = $obj->get_string->{value};
630             }
631            
632 4         44 $ids =~ s!^\s*(.*?)\s*$!$1!;
633            
634 4 50       14 $self->ret('nodeset', []) unless length $ids;
635            
636 4         18 my @ids = split /[ \t\r\n]+/, $ids;
637            
638            
639             #
640             # we have a list of IDs to search for - now traverse the whole document,
641             # checking every element node
642             #
643            
644 4         9 my $root = {};
645            
646 4 50       15 if ($self->{context}->{type} eq 'nodeset'){
647 4         8 $root = $self->{context}->{value}->[0];
648             }
649 4 50       12 if ($self->{context}->{type} eq 'node'){
650 0         0 $root = $self->{context}->{value};
651             }
652            
653 4         11 $root = $root->{parent} while defined $root->{parent};
654            
655 4         16 my $out = $self->_recurse_find_id($root, \@ids);
656            
657 4         12 return $self->ret('nodeset', $out);
658             }
659            
660             sub _recurse_find_id {
661 32     32   35 my ($self, $node, $ids) = @_;
662            
663 32         36 my $out = [];
664            
665             #
666             # is it a match?
667             #
668            
669 32 100 100     110 if ($node->{type} eq 'element' && length $node->{uid}){
670            
671 12         12 for my $id (@{$ids}){
  12         18  
672 22 100       47 if ($id eq $node->{uid}){
673 6         7 push @{$out}, $node;
  6         11  
674 6         9 last;
675             }
676             }
677             }
678            
679            
680             #
681             # do we need to recurse?
682             #
683            
684 32 100 100     97 if ($node->{type} eq 'element' || $node->{type} eq 'root'){
685            
686 24         24 for my $child (@{$node->{children}}){
  24         42  
687            
688 28         50 my $more = $self->_recurse_find_id($child, $ids);
689            
690 28         28 for my $match (@{$more}){
  28         50  
691            
692 12         12 push @{$out}, $match;
  12         30  
693             }
694             }
695             }
696            
697 32         52 return $out;
698             }
699            
700             sub function_local_name {
701 9     9 0 13 my ($self, $args) = @_;
702            
703 9         24 my $node = $self->_get_first_node_by_doc_order($args);
704            
705 9 50       23 return $node if $node->{type} eq 'Error';
706 9 50       18 return $self->ret('string', '') unless defined $node;
707            
708 9         30 my $name = $self->get_expanded_name($node);
709            
710 9 100       36 return return $self->ret('string', $name->{local}) if defined $name;
711 1         4 return $self->ret('string', '');
712             }
713            
714             sub function_namespace_uri {
715 7     7 0 11 my ($self, $args) = @_;
716            
717 7         23 my $node = $self->_get_first_node_by_doc_order($args);
718            
719 7 50       18 return $node if $node->{type} eq 'Error';
720 7 50       19 return $self->ret('string', '') unless defined $node;
721            
722 7         23 my $name = $self->get_expanded_name($node);
723            
724 7 50       33 return return $self->ret('string', $name->{ns}) if defined $name;
725 0         0 return $self->ret('string', '');
726             }
727            
728             sub function_name {
729 57     57 0 82 my ($self, $args) = @_;
730            
731 57         118 my $node = $self->_get_first_node_by_doc_order($args);
732            
733 57 50       150 return $node if $node->{type} eq 'Error';
734 57 50       115 return $self->ret('string', '') unless defined $node;
735            
736 57         125 my $name = $self->get_expanded_name($node);
737            
738 57 100       207 return return $self->ret('string', $name->{qname}) if defined $name;
739 1         4 return $self->ret('string', '');
740             }
741            
742             sub _get_first_node_by_doc_order {
743 75     75   192 my ($self, $args) = @_;
744            
745            
746             #
747             # for no args, take the first node in the context nodeset
748             #
749            
750 75 100       191 unless (defined $args->[0]){
751            
752 64 100       265 return $self->{context}->{value} if $self->{context}->{type} eq 'node';
753 2 50       13 return $self->{context}->{value}->[0] if $self->{context}->{type} eq 'nodeset';
754            
755 0         0 return $self->ret('Error', "If argument is ommitted, context must be node or nodeset - not $self->{context}->{type}");
756             }
757            
758            
759             #
760             # we have a nodeset arg - return the node with the lowest doc order
761             #
762            
763 11 50       40 return $args->[0]->{value} if $args->[0]->{type} eq 'node';
764            
765 11 50       40 if ($args->[0]->{type} eq 'nodeset'){
766            
767 11         31 my $min = $self->{max_order} + 1;
768 11         11 my $low = undef;
769            
770 11         13 for my $node (@{$args->[0]->{value}}){
  11         28  
771            
772 15 100       41 if ($node->{order} < $min){
773            
774 11         16 $min = $node->{order};
775 11         20 $low = $node;
776             }
777             }
778            
779 11         25 return $low;
780             }
781            
782 0         0 return $self->ret('Error', "Argument to fucntion isn't expected node/nodeset");
783             }
784            
785             sub function_string {
786 10     10 0 16 my ($self, $args) = @_;
787            
788            
789             #
790             # for no args, use the context node
791             #
792            
793 10 100       19 unless (defined $args->[0]){
794            
795 1 50       3 return $self->ret('string', $self->get_string_value($self->{context}->{value})) if $self->{context}->{type} eq 'node';
796 1 50       8 return $self->ret('string', $self->get_string_value($self->{context}->{value}->[0])) if $self->{context}->{type} eq 'nodeset';
797            
798 0         0 return $self->ret('Error', "If argument to string() is ommitted, context must be node or nodeset - not $self->{context}->{type}");
799             }
800            
801 9 100       26 if ($args->[0]->{type} eq 'number'){
802            
803 4         10 return $self->ret('string', $args->[0]->{value});
804             }
805            
806 5 100       13 if ($args->[0]->{type} eq 'string'){
807            
808 1         4 return $self->ret('string', $args->[0]->{value});
809             }
810            
811 4 100 66     24 if ($args->[0]->{type} eq 'node' || $args->[0]->{type} eq 'nodeset'){
812            
813 2         7 my $node = $self->_get_first_node_by_doc_order($args);
814 2 50       5 return $node if $node->{type} eq 'Error';
815            
816 2 50       6 if ($node->{type} eq 'element'){
817 2         6 return $self->ret('string', $self->get_string_value($node));
818             }else{
819 0         0 return $self->ret('string', '');
820             }
821             }
822            
823 2 50       7 if ($args->[0]->{type} eq 'boolean'){
824            
825 2 100       6 return $self->ret('string', $args->[0]->{value} ? 'true' : 'false');
826             }
827            
828 0         0 return $self->ret('Error', "Don't know how to perform string() on a $args->[0]->{type}");
829             }
830            
831             sub function_concat {
832 4     4 0 4 my ($self, $args) = @_;
833            
834 4         5 my $out = '';
835 4         8 $out .= $_->{value} for @{$args};
  4         18  
836            
837 4         10 return $self->ret('string', $out);
838             }
839            
840             sub function_substring_befor {
841 3     3 0 7 my ($self, $args) = @_;
842            
843 3         11 my $idx = index $args->[0]->{value}, $args->[1]->{value};
844            
845 3 100       9 if ($idx == -1){
846 1         3 return $self->ret('string', '');
847             }
848            
849 2         9 return $self->ret('string', substr $args->[0]->{value}, 0, $idx);
850             }
851            
852             sub function_substring_after {
853 3     3 0 6 my ($self, $args) = @_;
854            
855 3         12 my $idx = index $args->[0]->{value}, $args->[1]->{value};
856            
857 3 100       8 if ($idx == -1){
858 1         3 return $self->ret('string', '');
859             }
860            
861 2         10 return $self->ret('string', substr $args->[0]->{value}, $idx + length $args->[1]->{value});
862             }
863            
864             sub simple_floor {
865 11     11 0 14 my ($self, $value) = @_;
866 11         19 return int $value;
867             }
868            
869             sub simple_ceiling {
870 11     11 0 18 my ($self, $value) = @_;
871 11         11 my $t = int $value;
872 11 100       23 return $t if $t == $value;
873 8         13 return $t+1;
874             }
875            
876             sub compare_op {
877 119     119 0 199 my ($self, $op, $a1, $a2) = @_;
878            
879 119 100       289 if ($a1->{type} eq 'string'){
880 27 100       54 if ($op eq '=' ){ return $self->ret('boolean', ($a1->{value} eq $a2->{value}) ? 1 : 0); }
  27 50       97  
881 0 0       0 if ($op eq '!='){ return $self->ret('boolean', ($a1->{value} ne $a2->{value}) ? 1 : 0); }
  0 0       0  
882 0 0       0 if ($op eq '>='){ return $self->ret('boolean', ($a1->{value} ge $a2->{value}) ? 1 : 0); }
  0 0       0  
883 0 0       0 if ($op eq '<='){ return $self->ret('boolean', ($a1->{value} le $a2->{value}) ? 1 : 0); }
  0 0       0  
884 0 0       0 if ($op eq '>' ){ return $self->ret('boolean', ($a1->{value} gt $a2->{value}) ? 1 : 0); }
  0 0       0  
885 0 0       0 if ($op eq '<' ){ return $self->ret('boolean', ($a1->{value} lt $a2->{value}) ? 1 : 0); }
  0 0       0  
886             }
887            
888 92 50       187 if ($a1->{type} eq 'number'){
889 92 100       162 if ($op eq '=' ){ return $self->ret('boolean', ($a1->{value} == $a2->{value}) ? 1 : 0); }
  77 100       262  
890 15 50       29 if ($op eq '!='){ return $self->ret('boolean', ($a1->{value} != $a2->{value}) ? 1 : 0); }
  1 100       7  
891 14 0       26 if ($op eq '>='){ return $self->ret('boolean', ($a1->{value} >= $a2->{value}) ? 1 : 0); }
  0 50       0  
892 14 0       25 if ($op eq '<='){ return $self->ret('boolean', ($a1->{value} <= $a2->{value}) ? 1 : 0); }
  0 50       0  
893 14 100       23 if ($op eq '>' ){ return $self->ret('boolean', ($a1->{value} > $a2->{value}) ? 1 : 0); }
  7 100       25  
894 7 100       14 if ($op eq '<' ){ return $self->ret('boolean', ($a1->{value} < $a2->{value}) ? 1 : 0); }
  7 50       25  
895             }
896            
897 0         0 return $self->ret('Error', "Don't know how to compare $op on type $a1->{type}");
898             }
899            
900             sub op_mod {
901 12     12 0 19 my ($self, $n1, $n2) = @_;
902            
903 12         33 my $r = int ($n1 / $n2);
904 12         26 return $n1 - ($r * $n2);
905             }
906            
907             sub op_div {
908 23     23 0 36 my ($self, $n1, $n2) = @_;
909            
910 23         59 return $n1 / $n2;
911             }
912            
913             sub get_string_value {
914 32     32 0 39 my ($self, $node) = @_;
915            
916            
917 32 100 100     108 if ($node->{type} eq 'element' || $node->{type} eq 'root'){
918            
919             #
920             # The string-value of an element node is the concatenation of the string-values
921             # of all text node descendants of the element node in document order.
922             #
923            
924 20         22 my $value = '';
925 20         21 for my $child (@{$node->{children}}){
  20         30  
926 21 100       47 if ($child->{type} eq 'element'){
927 11         29 $value .= $self->get_string_value($child);
928             }
929 21 100       48 if ($child->{type} eq 'text'){
930 10         29 $value .= $self->get_string_value($child);
931             }
932             }
933 20         58 return $value;
934             }
935            
936 12 50       26 if ($node->{type} eq 'attribute'){
937            
938             #
939             # An attribute node has a string-value. The string-value is the normalized value
940             # as specified by the XML Recommendation [XML]. An attribute whose normalized value
941             # is a zero-length string is not treated specially: it results in an attribute node
942             # whose string-value is a zero-length string.
943             #
944             }
945            
946 12 50       26 if ($node->{type} eq 'namespace'){
947            
948             #
949             # The string-value of a namespace node is the namespace URI that is being bound to
950             # the namespace prefix; if it is relative, it must be resolved just like a namespace
951             # URI in an expanded-name.
952             #
953             }
954            
955             #
956             # The string-value of a processing instruction node is the part of the processing
957             # instruction following the target and any whitespace. It does not include the
958             # terminating ?>.
959             #
960            
961             #
962             # The string-value of comment is the content of the comment not including the
963             # opening .
964             #
965            
966 12 50       22 if ($node->{type} eq 'text'){
967            
968             #
969             # The string-value of a text node is the character data. A text node always has
970             # at least one character of data.
971             #
972            
973 12         41 return $node->{content};
974             }
975            
976 0         0 print "# we can't find a string-value for this node!\n";
977 0         0 print Dumper $node;
978            
979 0         0 return '';
980             }
981            
982             sub get_expanded_name {
983 73     73 0 104 my ($self, $node) = @_;
984            
985 73 100       185 if ($node->{type} eq 'element'){
986            
987             return {
988 71 50       441 'ns' => $node->{ns},
989             'qname' => $node->{name},
990             'local' => defined $node->{local_name} ? $node->{local_name} : $node->{name},
991             };
992             }
993            
994 2 50       8 if ($node->{type} eq 'root'){
995            
996 2         22 return undef;
997             }
998            
999 0           print "# we can't find an expanded name for this node!\n";
1000 0           print Dumper $node;
1001            
1002 0           return undef;
1003             }
1004            
1005             1;