File Coverage

File:	lib/XML/Parser/Lite/Tree/XPath/Token.pm
Coverage:	81.1%

line	stmt	bran	cond	sub	time	code
1						package XML::Parser::Lite::Tree::XPath::Token;
2
3	32 32 32			32	113 49 119	use strict;
4	32 32 32			32	193 65 270	use XML::Parser::Lite::Tree::XPath::Result;
5	32 32 32			32	211 67 270	use XML::Parser::Lite::Tree::XPath::Axis;
6	32 32 32			32	161 47 154	use Data::Dumper;
7
8						sub new {
9	2470			2470	6118	my $class = shift;
10	2470				9182	my $self = bless {}, $class;
11	2470				7399	return $self;
12						}
13
14						sub match {
15	55524			55524	157826	my ($self, $type, $content) = @_;
16
17	55524	100			342328	return 0 unless $self->{type} eq $type;
18
19	7371	100	100		53677	return 0 if (defined($content) && ($self->{content} ne $content));
20
21	4386				19405	return 1;
22						}
23
24						sub is_expression {
25	12			12	84	my ($self) = @_;
26
27	12	100			74	return 1 if $self->{type} eq 'Number';
28	6	100			24	return 1 if $self->{type} eq 'Literal';
29	5	100			35	return 0 if $self->{type} eq 'Operator';
30
31	1				1	warn "Not sure if $self->{type} is an expression";
32
33	1				10	return 0;
34						}
35
36						sub dump {
37	279			279	706	my ($self) = @_;
38
39	279				694	my $ret = $self->{type};
40	279	100			920	$ret .= ':absolute' if $self->{absolute};
41	279	100			1201	$ret .= ':'.$self->{content} if defined $self->{content};
42	279	100			889	$ret .= '::'.$self->{axis} if defined $self->{axis};
43
44	279				870	return $ret;
45						}
46
47						sub ret {
48	1090			1090	3268	my ($self, $a, $b) = @_;
49	1090				3877	return XML::Parser::Lite::Tree::XPath::Result->new($a, $b);
50						}
51
52						sub eval {
53	1696			1696	4699	my ($self, $context) = @_;
54
55	1696	100			4893	return $context if $context->is_error;
56	1695				4601	$self->{context} = $context;
57
58	1695	100 100 100 100 100 100 100 100 100 100 100 100 100 100 100	67 100		21834	if ($self->{type} eq 'LocationPath'){
59
60						# a LocationPath should just be a list of Steps, so eval them in order
61
62	154				242	my $ret;
63
64	154	100			496	if ($self->{absolute}){
65	92				264	$ret = $self->{root};
66						}else{
67	62				191	$ret = $context->get_nodeset;
68	62	50			233	return $ret if $ret->is_error;
69						}
70
71
72	154 154				265 570	for my $step(@{$self->{tokens}}){
73
74	279	50			825	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				1587	$ret = $step->eval($ret);
79
80	279	50			910	return $ret if $ret->is_error;
81
82	279				910	$ret->normalize();
83						}
84
85	154				544	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				888	my $ret = XML::Parser::Lite::Tree::XPath::Axis::instance->filter($self, $context);
95
96	279 279				503 980	for my $step(@{$self->{tokens}}){
97
98	310	50	60		891	unless ($step->match('AxisSpecifier') \|\| $step->match('NameTest') \|\| $step->match('Predicate') \|\| $step->match('NodeTypeTest')){
99
100	0				0	return $self->ret('Error', "Found an unexpected token ('$step->{type}') in a Step");
101						}
102
103	310				1523	$ret = $step->eval($ret);
104
105	310	50			917	return $ret if $ret->is_error;
106						}
107
108	279				770	return $ret;
109
110
111						}elsif ($self->{type} eq 'NameTest'){
112
113	221	100			965	return $context if $self->{content} eq '*';
114
115	134	50			541	if ($self->{content} =~ m!\:\*$!){
116	0				0	return $self->ret('Error', "Can't do NCName:* NameTests");
117						}
118
119	134	50			630	if ($context->{type} eq 'nodeset'){
120	134				544	my $out = $self->ret('nodeset', []);
121
122	134 134				256 460	for my $tag(@{$context->{value}}){
123
124	608	100	100		5221	if (($tag->{'type'} eq 'element') && ($tag->{'name'} eq $self->{content})){
125	188 188				323 682	push @{$out->{value}}, $tag;
126						}
127
128	608	100	100		3446	if (($tag->{'type'} eq 'attribute') && ($tag->{'name'} eq $self->{content})){
129	12 12				23 52	push @{$out->{value}}, $tag;
130						}
131						}
132
133	134				404	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			260	if ($self->{content} eq 'node'){
142	58	50			213	if ($context->{type} eq 'nodeset'){
143	58				160	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				114	my $expr = $self->{tokens}->[0];
155
156	31				119	my $out = $self->ret('nodeset', []);
157	31				67	my $i = 1;
158	31 31				53 103	my $c = scalar @{$context->{value}};
159
160	31 31				54 112	for my $child(@{$context->{value}}){
161
162	171				528	$child->{proximity_position} = $i;
163	171				446	$child->{context_size} = $c;
164	171				275	$i++;
165
166	171				566	my $ret = $expr->eval($self->ret('node', $child));
167
168	171	100 100 50 0			723	if ($ret->{type} eq 'boolean'){
169
170	133	100			459	if ($ret->{value}){
171	45 45				75 166	push @{$out->{value}}, $child;
172						}
173
174						}elsif ($ret->{type} eq 'number'){
175
176	26	100			124	if ($ret->{value} == $child->{proximity_position}){
177	8 8				16 30	push @{$out->{value}}, $child;
178						}
179
180						}elsif ($ret->{type} eq 'nodeset'){
181
182	12 12	100			20 48	if (scalar @{$ret->{value}}){
183	6 6				12 19	push @{$out->{value}}, $child;
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				428	delete $child->{proximity_position};
195	171				611	delete $child->{context_size};
196						}
197
198	31				142	return $out;
199
200						}elsif ($self->{type} eq 'Number'){
201
202	173				672	return $self->ret('number', $self->{content});
203
204						}elsif ($self->{type} eq 'FunctionCall'){
205
206	280				975	my $handler = $self->get_function_handler($self->{content});
207
208	280	50	33		2248	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				413	my @in_args;
218	280 280				474 1041	for my $source (@{$self->{tokens}}){
219	196				761	my $out = $source->eval($context);
220	196	50			580	return $out if $out->is_error;
221	196				682	push @in_args, $out;
222						}
223
224
225						#
226						# now check them against the function signature
227						#
228
229	280				740	my $func = $handler->[0];
230	280				682	my $sig = $handler->[1];
231	280				983	my @sig = split /,/, $sig;
232	280				487	my @out_args;
233
234	280				496	my $position = 0;
235
236	280				705	for my $sig(@sig){
237
238	261				462	my $repeat = 0;
239	261				470	my $optional = 0;
240
241	261 5	100			806 11	if ($sig =~ m/\+$/){ $repeat = 1; }
242	261 107	100			745 217	if ($sig =~ m/\?$/){ $optional = 1; }
243	261				757	$sig =~ s/[?+]$//;
244
245						#
246						# repeating args are somewhat tricky
247						#
248
249	261	100			624	if ($repeat){
250
251	5				9	my $count = 0;
252
253	5				10	while (1){
254	10				17	$count++;
255
256	10	100			34	unless (defined $in_args[$position]){
257	5	100			14	if ($count == 1){
258	1				10	return $self->ret('Error', "Argument $position to function $self->{content} is required (type $sig)");
259						}
260	4				14	last;
261						}
262
263	5				16	my $value = $self->coerce($in_args[$position], $sig);
264	5				9	$position++;
265	5	50			14	if (defined $value){
266	5	50			15	return $value if $value->is_error;
267	5				15	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			823	unless (defined $in_args[$position]){
280	65	50			153	if ($optional){
281	65				198	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				694	my $value = $self->coerce($in_args[$position], $sig);
288	191				370	$position++;
289
290	191	50			496	if (defined $value){
291
292	191	50			529	return $value if $value->is_error;
293	191				723	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 279				767 789	return &{$func}($self, \@out_args);
301
302						}elsif ($self->{type} eq 'FunctionArg'){
303
304						# a FunctionArg should have a single child
305
306	196 196	50			385 795	return $self->ret('Error', 'FunctionArg should have 1 token') unless 1 == scalar @{$self->{tokens}};
307
308	196				957	return $self->{tokens}->[0]->eval($context);
309
310						}elsif (($self->{type} eq 'EqualityExpr') \|\| ($self->{type} eq 'RelationalExpr')){
311
312	120				608	my $v1 = $self->{tokens}->[0]->eval($context);
313	120				623	my $v2 = $self->{tokens}->[1]->eval($context);
314	120				514	my $t = "$v1->{type}/$v2->{type}";
315
316	120	50			326	return $v1 if $v1->is_error;
317	120	50			331	return $v2 if $v2->is_error;
318
319	120	50			514	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			357	if ($t eq 'nodeset/string'){
325
326	6 6				12 20	for my $node(@{$v1->{value}}){;
327
328	5				16	my $v1_s = $self->ret('node', $node)->get_string;
329	5	50			24	return $v1_s if $v1_s->is_error;
330
331	5				21	my $ok = $self->compare_op($self->{content}, $v1_s, $v2);
332	5	50			16	return $ok if $ok->is_error;
333
334	5	100			29	return $ok if $ok->{value};
335						}
336
337	4				14	return $self->ret('boolean', 0);
338						}
339
340	114	100			343	if ($t eq 'string/string'){
341
342	22				91	return $self->compare_op($self->{content}, $v1, $v2);
343						}
344
345	92	50			292	if ($t eq 'number/number'){
346
347	92				382	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				365	return $self->ret('string', $self->{content});
355
356
357						}elsif ($self->{type} eq 'UnionExpr'){
358
359	9				41	my $a1 = $self->get_child_arg(0, 'nodeset');
360	9				80	my $a2 = $self->get_child_arg(1, 'nodeset');
361
362	9	50			26	return $a1 if $a1->is_error;
363	9	50			25	return $a2 if $a2->is_error;
364
365	9				33	my $out = $self->ret('nodeset', []);
366
367	9 49 49 9				16 87 170 30	map{ push @{$out->{value}}, $_ } @{$a1->{value}};
368	9 17 17 9				18 29 60 28	map{ push @{$out->{value}}, $_ } @{$a2->{value}};
369
370	9				27	$out->normalize();
371
372	9				54	return $out;
373
374						}elsif ($self->{type} eq 'MultiplicativeExpr'){
375
376	36				109	my $a1 = $self->get_child_arg(0, 'number');
377	36				112	my $a2 = $self->get_child_arg(1, 'number');
378
379	36	50			108	return $a1 if $a1->is_error;
380	36	50			102	return $a2 if $a2->is_error;
381
382	36				72	my $result = 0;
383	36	100			131	$result = $a1->{value} * $a2->{value} if $self->{content} eq '*';
384	36	100			171	$result = $self->op_mod($a1->{value}, $a2->{value}) if $self->{content} eq 'mod';
385	36	100			194	$result = $self->op_div($a1->{value}, $a2->{value}) if $self->{content} eq 'div';
386
387	36				115	return $self->ret('number', $result);
388
389						}elsif (($self->{type} eq 'OrExpr') \|\| ($self->{type} eq 'AndExpr')){
390
391	11				34	my $a1 = $self->get_child_arg(0, 'boolean');
392	11				34	my $a2 = $self->get_child_arg(1, 'boolean');
393
394	11	50			32	return $a1 if $a1->is_error;
395	11	50			30	return $a2 if $a2->is_error;
396
397	11	50	100		113	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				86	my $a1 = $self->get_child_arg(0, 'number');
403	27				83	my $a2 = $self->get_child_arg(1, 'number');
404
405	27	50			78	return $a1 if $a1->is_error;
406	27	50			77	return $a2 if $a2->is_error;
407
408	27				52	my $result = 0;
409	27	100			155	$result = $a1->{value} + $a2->{value} if $self->{content} eq '+';
410	27	100			98	$result = $a1->{value} - $a2->{value} if $self->{content} eq '-';
411
412	27				82	return $self->ret('number', $result);
413
414						}elsif ($self->{type} eq 'UnaryExpr'){
415
416	6				23	my $a1 = $self->get_child_arg(0, 'number');
417
418	6	50			17	return $a1 if $a1->is_error;
419
420	6				27	$a1->{value} = - $a1->{value};
421
422	6				16	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	569	my ($self, $arg, $type) = @_;
431
432	196				354	my $value = undef;
433
434	196	100			777	$value = $arg->get_string if $type eq 'string';
435	196	100			608	$value = $arg->get_number if $type eq 'number';
436	196	100			694	$value = $arg->get_nodeset if $type eq 'nodeset';
437	196	100			585	$value = $arg->get_boolean if $type eq 'boolean';
438	196	100			589	$value = $arg if $type eq 'any';
439
440	196				473	return $value;
441						}
442
443						sub get_child_arg {
444	172			172	494	my ($self, $pos, $type) = @_;
445
446	172				519	my $token = $self->{tokens}->[$pos];
447	172	50			462	return $self->ret('Error', "Required child token {1+$pos} for $self->{type} token wasn't found.") unless defined $token;
448
449	172				734	my $out = $token->eval($self->{context});
450	172	50			498	return $out if $out->is_error;
451
452	172				562	return $out->get_type($type);
453						}
454
455
456						sub get_function_handler {
457	280			280	823	my ($self, $function) = @_;
458
459	280				14166	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			3674	return $function_map->{$function} if defined $function_map->{$function};
499
500	0				0	return undef;
501						}
502
503						sub function_last {
504	29			29	77	my ($self, $args) = @_;
505
506	29				156	return $self->ret('number', $self->{context}->{value}->{context_size});
507						}
508
509						sub function_not {
510	4			4	12	my ($self, $args) = @_;
511
512	4				10	my $out = $args->[0];
513	4				16	$out->{value} = !$out->{value};
514
515	4				13	return $out
516						}
517
518						sub function_normalize_space {
519	3			3	8	my ($self, $args) = @_;
520
521	3				10	my $value = $args->[0];
522
523	3	50			9	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				9	$value = $value->{value};
529	3				7	$value =~ s!^[\x20\x09\x0d\x0a]+!!;
530	3				8	$value =~ s![\x20\x09\x0d\x0a]+$!!;
531	3				6	$value =~ s![\x20\x09\x0d\x0a]+! !g;
532
533	3				10	return $self->ret('string', $value);
534						}
535
536						sub function_count {
537	38			38	105	my ($self, $args) = @_;
538
539	38				91	my $subject = $args->[0];
540
541	38 38	50			169 139	return $self->ret('number', scalar(@{$subject->{value}})) if $subject->{type} eq 'nodeset';
542
543	0				0	die("can't perform count() on $subject->{type}");
544						}
545
546						sub function_starts_with {
547	14			14	39	my ($self, $args) = @_;
548
549	14				45	my $s1 = $args->[0]->{value};
550	14				44	my $s2 = $args->[1]->{value};
551
552	14				65	return $self->ret('boolean', (substr($s1, 0, length $s2) eq $s2));
553						}
554
555						sub function_contains {
556	18			18	50	my ($self, $args) = @_;
557
558	18				58	my $s1 = $args->[0]->{value};
559	18				65	my $s2 = quotemeta $args->[1]->{value};
560
561	18				121	return $self->ret('boolean', ($s1 =~ /$s2/));
562						}
563
564						sub function_string_length {
565	21			21	56	my ($self, $args) = @_;
566
567	21				51	my $value = $args->[0];
568
569	21	50			54	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				82	return $self->ret('number', length $value->{value});
575						}
576
577						sub function_position {
578	33			33	91	my ($self, $args) = @_;
579
580	33				125	my $node = $self->{context}->get_nodeset;
581	33	50			96	return $node if $node->is_error;
582
583	33				107	$node = $node->{value}->[0];
584	33	50			115	return $self->ret('Error', "No node in context nodeset o_O") unless defined $node;
585
586	33				129	return $self->ret('number', $node->{proximity_position});
587						}
588
589						sub function_floor {
590	11			11	31	my ($self, $args) = @_;
591
592	11				34	my $val = $args->[0]->{value};
593	11				33	my $ret = $self->simple_floor($val);
594
595	11	50			36	$ret = - $self->simple_ceiling(-$val) if $val < 0;
596
597	11				36	return $self->ret('number', $ret);
598						}
599
600						sub function_ceiling {
601	11			11	28	my ($self, $args) = @_;
602
603	11				36	my $val = $args->[0]->{value};
604	11				34	my $ret = $self->simple_ceiling($val);
605
606	11	50			34	$ret = - $self->simple_floor(-$val) if $val < 0;
607
608	11				34	return $self->ret('number', $ret);
609						}
610
611						sub function_id {
612	4			4	12	my ($self, $args) = @_;
613
614	4	50	33		40	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				11	my $obj = $args->[0];
620	4				10	my $ids = '';
621
622	4	100			15	if ($obj->{type} eq 'nodeset'){
623
624	2 2				4 8	for my $node(@{$obj->{value}}){
625
626	8				26	$ids .= ' ' . $self->get_string_value($node);
627						}
628						}else{
629	2				8	$ids = $obj->get_string->{value};
630						}
631
632	4				31	$ids =~ s!^\s(.?)\s*$!$1!;
633
634	4	50			13	$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				12	my $root = {};
645
646	4	50			20	if ($self->{context}->{type} eq 'nodeset'){
647	4				17	$root = $self->{context}->{value}->[0];
648						}
649	4	50			18	if ($self->{context}->{type} eq 'node'){
650	0				0	$root = $self->{context}->{value};
651						}
652
653	4				16	$root = $root->{parent} while defined $root->{parent};
654
655	4				17	my $out = $self->_recurse_find_id($root, \@ids);
656
657	4				15	return $self->ret('nodeset', $out);
658						}
659
660						sub _recurse_find_id {
661	32			32	89	my ($self, $node, $ids) = @_;
662
663	32				66	my $out = [];
664
665						#
666						# is it a match?
667						#
668
669	32	100	100		209	if ($node->{type} eq 'element' && length $node->{uid}){
670
671	12 12				18 36	for my $id (@{$ids}){
672	22	100			95	if ($id eq $node->{uid}){
673	6 6				10 16	push @{$out}, $node;
674	6				12	last;
675						}
676						}
677						}
678
679
680						#
681						# do we need to recurse?
682						#
683
684	32	100	100		188	if ($node->{type} eq 'element' \|\| $node->{type} eq 'root'){
685
686	24 24				40 81	for my $child (@{$node->{children}}){
687
688	28				86	my $more = $self->_recurse_find_id($child, $ids);
689
690	28 28				45 102	for my $match (@{$more}){
691
692	12 12				20 53	push @{$out}, $match;
693						}
694						}
695						}
696
697	32				83	return $out;
698						}
699
700						sub function_local_name {
701	9			9	23	my ($self, $args) = @_;
702
703	9				31	my $node = $self->_get_first_node_by_doc_order($args);
704
705	9	50			36	return $node if $node->{type} eq 'Error';
706	9	50			26	return $self->ret('string', '') unless defined $node;
707
708	9				26	my $name = $self->get_expanded_name($node);
709
710	9	100			49	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	24	my ($self, $args) = @_;
716
717	7				21	my $node = $self->_get_first_node_by_doc_order($args);
718
719	7	50			29	return $node if $node->{type} eq 'Error';
720	7	50			21	return $self->ret('string', '') unless defined $node;
721
722	7				20	my $name = $self->get_expanded_name($node);
723
724	7	50			41	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	155	my ($self, $args) = @_;
730
731	57				174	my $node = $self->_get_first_node_by_doc_order($args);
732
733	57	50			206	return $node if $node->{type} eq 'Error';
734	57	50			156	return $self->ret('string', '') unless defined $node;
735
736	57				164	my $name = $self->get_expanded_name($node);
737
738	57	100			309	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	245	my ($self, $args) = @_;
744
745
746						#
747						# for no args, take the first node in the context nodeset
748						#
749
750	75	100			269	unless (defined $args->[0]){
751
752	64	100			507	return $self->{context}->{value} if $self->{context}->{type} eq 'node';
753	2	50			17	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			48	return $args->[0]->{value} if $args->[0]->{type} eq 'node';
764
765	11	50			51	if ($args->[0]->{type} eq 'nodeset'){
766
767	11				35	my $min = $self->{max_order} + 1;
768	11				21	my $low = undef;
769
770	11 11				19 46	for my $node (@{$args->[0]->{value}}){
771
772	15	100			62	if ($node->{order} < $min){
773
774	11				27	$min = $node->{order};
775	11				34	$low = $node;
776						}
777						}
778
779	11				35	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	31	my ($self, $args) = @_;
787
788
789						#
790						# for no args, use the context node
791						#
792
793	10	100			34	unless (defined $args->[0]){
794
795	1	50			6	return $self->ret('string', $self->get_string_value($self->{context}->{value})) if $self->{context}->{type} eq 'node';
796	1	50			11	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			43	if ($args->[0]->{type} eq 'number'){
802
803	4				18	return $self->ret('string', $args->[0]->{value});
804						}
805
806	5	100			22	if ($args->[0]->{type} eq 'string'){
807
808	1				5	return $self->ret('string', $args->[0]->{value});
809						}
810
811	4	100	67		42	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			7	return $node if $node->{type} eq 'Error';
815
816	2	50			9	if ($node->{type} eq 'element'){
817	2				7	return $self->ret('string', $self->get_string_value($node));
818						}else{
819	0				0	return $self->ret('string', '');
820						}
821						}
822
823	2	50			11	if ($args->[0]->{type} eq 'boolean'){
824
825	2	100			14	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	11	my ($self, $args) = @_;
833
834	4				8	my $out = '';
835	4 4 4				5 8 33	$out .= $_->{value} for @{$args};
836
837	4				15	return $self->ret('string', $out);
838						}
839
840						sub function_substring_befor {
841	3			3	10	my ($self, $args) = @_;
842
843	3				17	my $idx = index $args->[0]->{value}, $args->[1]->{value};
844
845	3	100			11	if ($idx == -1){
846	1				5	return $self->ret('string', '');
847						}
848
849	2				12	return $self->ret('string', substr $args->[0]->{value}, 0, $idx);
850						}
851
852						sub function_substring_after {
853	3			3	9	my ($self, $args) = @_;
854
855	3				17	my $idx = index $args->[0]->{value}, $args->[1]->{value};
856
857	3	100			13	if ($idx == -1){
858	1				5	return $self->ret('string', '');
859						}
860
861	2				18	return $self->ret('string', substr $args->[0]->{value}, $idx + length $args->[1]->{value});
862						}
863
864						sub simple_floor {
865	11			11	32	my ($self, $value) = @_;
866	11				33	return int $value;
867						}
868
869						sub simple_ceiling {
870	11			11	31	my ($self, $value) = @_;
871	11				24	my $t = int $value;
872	11	100			40	return $t if $t == $value;
873	8				24	return $t+1;
874						}
875
876						sub compare_op {
877	119			119	369	my ($self, $op, $a1, $a2) = @_;
878
879	119	100			417	if ($a1->{type} eq 'string'){
880	27 27	100 50			87 155	if ($op eq '=' ){ return $self->ret('boolean', ($a1->{value} eq $a2->{value}) ? 1 : 0); }
881	0 0	0 0			0 0	if ($op eq '!='){ return $self->ret('boolean', ($a1->{value} ne $a2->{value}) ? 1 : 0); }
882	0 0	0 0			0 0	if ($op eq '>='){ return $self->ret('boolean', ($a1->{value} ge $a2->{value}) ? 1 : 0); }
883	0 0	0 0			0 0	if ($op eq '<='){ return $self->ret('boolean', ($a1->{value} le $a2->{value}) ? 1 : 0); }
884	0 0	0 0			0 0	if ($op eq '>' ){ return $self->ret('boolean', ($a1->{value} gt $a2->{value}) ? 1 : 0); }
885	0 0	0 0			0 0	if ($op eq '<' ){ return $self->ret('boolean', ($a1->{value} lt $a2->{value}) ? 1 : 0); }
886						}
887
888	92	50			351	if ($a1->{type} eq 'number'){
889	92 77	100 100			278 544	if ($op eq '=' ){ return $self->ret('boolean', ($a1->{value} == $a2->{value}) ? 1 : 0); }
890	15 1	50 100			48 8	if ($op eq '!='){ return $self->ret('boolean', ($a1->{value} != $a2->{value}) ? 1 : 0); }
891	14 0	0 50			40 0	if ($op eq '>='){ return $self->ret('boolean', ($a1->{value} >= $a2->{value}) ? 1 : 0); }
892	14 0	0 50			41 0	if ($op eq '<='){ return $self->ret('boolean', ($a1->{value} <= $a2->{value}) ? 1 : 0); }
893	14 7	100 100			43 45	if ($op eq '>' ){ return $self->ret('boolean', ($a1->{value} > $a2->{value}) ? 1 : 0); }
894	7 7	100 50			24 42	if ($op eq '<' ){ return $self->ret('boolean', ($a1->{value} < $a2->{value}) ? 1 : 0); }
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	36	my ($self, $n1, $n2) = @_;
902
903	12				42	my $r = int ($n1 / $n2);
904	12				41	return $n1 - ($r * $n2);
905						}
906
907						sub op_div {
908	23			23	72	my ($self, $n1, $n2) = @_;
909
910	23				88	return $n1 / $n2;
911						}
912
913						sub get_string_value {
914	32			32	86	my ($self, $node) = @_;
915
916
917	32	100	100		201	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				34	my $value = '';
925	20 20				34 68	for my $child (@{$node->{children}}){
926	21	100			75	if ($child->{type} eq 'element'){
927	11				38	$value .= $self->get_string_value($child);
928						}
929	21	100			88	if ($child->{type} eq 'text'){
930	10				34	$value .= $self->get_string_value($child);
931						}
932						}
933	20				67	return $value;
934						}
935
936	12	50			44	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			39	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 <!-- or the closing -->.
964						#
965
966	12	50			46	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				53	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	201	my ($self, $node) = @_;
984
985	73	100			270	if ($node->{type} eq 'element'){
986
987						return {
988	71	50			745	'ns' => $node->{ns},
989						'qname' => $node->{name},
990						'local' => defined $node->{local_name} ? $node->{local_name} : $node->{name},
991						};
992						}
993
994	2	50			10	if ($node->{type} eq 'root'){
995
996	2				6	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;