File Coverage

File:	blib/lib/XML/Twig/XPath.pm
Coverage:	81.2%

line	stmt	bran	cond	sub	pod	time	code
1							# $Id: /xmltwig/trunk/Twig/XPath.pm 32 2008-01-18T13:11:52.128782Z mrodrigu $
2							package XML::Twig::XPath;
3	36 36 36			36		188 59 158	use strict;
4	36 36 36			36		387 107 525	use XML::Twig;
5
6							my $XPATH; # XPath engine (XML::XPath or XML::XPathEngine);
7							my $XPATH_NUMBER; # <$XPATH>::Number, the XPath number class
8							BEGIN
9	36			36		238	{ foreach my $xpath_engine ( qw( XML::XPathEngine XML::XPath) )
10	36 36 36	50				179 123 123	{ if( XML::Twig::_use( $xpath_engine) ) { $XPATH= $xpath_engine; last; } }
11	36 0	50				306 0	unless( $XPATH) { die "cannot use XML::Twig::XPath: neither XML::XPathEngine 0.09+ nor XML::XPath are available"; }
12	36					157	$XPATH_NUMBER= "${XPATH}::Number";
13							}
14
15
16	36 36 36			36		297 62 213	use vars qw($VERSION);
17							$VERSION="0.02";
18
19							BEGIN
20	36			36		132	{ package XML::XPath::NodeSet;
21	36 36 36			36		273 68 192	no warnings; # to avoid the "Subroutine sort redefined" message
22							# replace the native sort routine by a Twig'd one
23							sub sort
24	0			0		0	{ my $self = CORE::shift;
25	0 0					0 0	@$self = CORE::sort { $a->node_cmp( $b) } @$self;
26	0					0	return $self;
27							}
28
29							package XML::XPathEngine::NodeSet;
30	36 36 36			36		265 85 429	no warnings; # to avoid the "Subroutine sort redefined" message
31							# replace the native sort routine by a Twig'd one
32							sub sort
33	145			145		28888	{ my $self = CORE::shift;
34	145 538					445 2240	@$self = CORE::sort { $a->node_cmp( $b) } @$self;
35	145					1192	return $self;
36							}
37							}
38
39							package XML::Twig::XPath;
40
41	36 36 36			36		254 67 321	use base 'XML::Twig';
42
43	1			1	0	11	sub to_number { return $XPATH_NUMBER->new( $_[0]->root->text); }
44
45							sub new
46	61			61	1	7400	{ my $class= shift;
47	61					585	my $t= XML::Twig->new( elt_class => 'XML::Twig::XPath::Elt', @_);
48	61					459	$t->{twig_xp}= $XPATH->new();
49	61					6982	bless $t, $class;
50	61					568	return $t;
51							}
52
53
54	5 5			5	0	423 27	sub set_namespace { my $t= shift; $t->{twig_xp}->set_namespace( @_); }
55	2 2			2	0	523 11	sub set_strict_namespaces { my $t= shift; $t->{twig_xp}->set_strict_namespaces( @_); }
56
57	4	100		4	0	31	sub node_cmp($$) { return $_[1] == $_[0] ? 0 : -1; } # document is before anything but itself
58
59	14			14	1	375	sub isElementNode { 0 }
60	1			1	0	4	sub isAttributeNode { 0 }
61	1			1	1	4	sub isTextNode { 0 }
62	1			1	1	4	sub isProcessingInstructionNode { 0 }
63	1			1	1	5	sub isPINode { 0 }
64	1			1	1	4	sub isCommentNode { 0 }
65	1			1	0	3	sub isNamespaceNode { 0 }
66	2			2	0	137	sub getAttributes { [] }
67	1			1	0	5	sub getValue { return $_[0]->root->text; }
68
69	84 84			84	1	2537 563	sub findnodes { my( $t, $path)= @_; return $t->{twig_xp}->findnodes( $path, $t); }
70	1 1			1	1	5 7	sub findnodes_as_string { my( $t, $path)= @_; return $t->{twig_xp}->findnodes_as_string( $path, $t); }
71	17 17			17	1	907 107	sub findvalue { my( $t, $path)= @_; return $t->{twig_xp}->findvalue( $path, $t); }
72	1 1			1	0	5 6	sub exists { my( $t, $path)= @_; return $t->{twig_xp}->exists( $path, $t); }
73	4 4			4	0	103 29	sub find { my( $t, $path)= @_; return $t->{twig_xp}->find( $path, $t); }
74	1 1 1		50 33	1	0	5 5 6	sub matches { my( $t, $path, $node)= @_; $node \|\|= $t; return $t->{twig_xp}->matches( $node, $path, $t) \|\| 0; }
75
76							1;
77
78							# adds the appropriate methods to XML::Twig::Elt so XML::XPath can be used as the XPath engine
79							package XML::Twig::XPath::Elt;
80	36 36 36			36		300 77 217	use base 'XML::Twig::Elt';
81
82							getLocalName= XML::Twig::Elt::local_name;
83							getValue = XML::Twig::Elt::text;
84	4			4	0	17	sub isAttributeNode { 0 }
85	4			4	0	17	sub isNamespaceNode { 0 }
86
87	3			3	0	23	sub to_number { return $XPATH_NUMBER->new( $_[0]->text); }
88
89							sub getAttributes
90	126			126	0	15736	{ my $elt= shift;
91	126					567	my $atts= $elt->atts;
92							# alternate, faster but less clean, way
93	126 123					924 1392	my @atts= map { bless( { name => $_, value => $atts->{$_}, elt => $elt },
94							'XML::Twig::XPath::Attribute')
95							}
96							sort keys %$atts;
97							# my @atts= map { XML::Twig::XPath::Attribute->new( $elt, $_) } sort keys %$atts;
98	126	100				903	return wantarray ? @atts : \@atts;
99							}
100
101							sub getNamespace
102	14			14		847	{ my $elt= shift;
103	14		67			109	my $prefix= shift() \|\| $elt->ns_prefix;
104	14	50				63	if( my $expanded= $elt->namespace( $prefix))
105	14					57	{ return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
106							else
107	0					0	{ return XML::Twig::XPath::Namespace->new( $prefix, ''); }
108							}
109
110							sub node_cmp($$)
111	507			507	0	1652	{ my( $a, $b)= @_;
112	507	100 100 100				3030	if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
113							{ # 2 elts, compare them
114	471					1964	return $a->cmp( $b);
115							}
116							elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
117							{ # elt <=> att, compare the elt to the att->{elt}
118							# if the elt is the att->{elt} (cmp return 0) then -1, elt is before att
119	34		100			156	return ($a->cmp( $b->{elt}) ) \|\| -1 ;
120							}
121							elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
122							{ # elt <=> document, elt is after document
123	1					2	return 1;
124							}
125							else
126	1					3	{ die "unknown node type ", ref( $b); }
127							}
128
129							sub getParentNode
130	115		67	115		3190	{ return $_[0]->_parent
131							\|\| $_[0]->twig;
132							}
133
134	5 5			5	1	31 102	sub findnodes { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes( $path, $elt); }
135	2 2			2	1	8 10	sub findnodes_as_string { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes_as_string( $path, $elt); }
136	9 9			9	1	1178 54	sub findvalue { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findvalue( $path, $elt); }
137	1 1			1	0	4 5	sub exists { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->exists( $path, $elt); }
138	1 1			1	0	4 5	sub find { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->find( $path, $elt); }
139	7 7		100	7	0	29 35	sub matches { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->matches( $elt, $path, $elt->getParentNode) \|\| 0; }
140
141
142							1;
143
144							# this package is only used to allow XML::XPath as the XPath engine, otherwise
145							# attributes are just attached to their parent element and are not considered objects
146
147							package XML::Twig::XPath::Attribute;
148
149							sub new
150	1			1	1	6	{ my( $class, $elt, $att)= @_;
151	1					8	return bless { name => $att, value => $elt->att( $att), elt => $elt }, $class;
152							}
153
154	1			1	0	7	sub getValue { return $_[0]->{value}; }
155	97			97		3751	sub getName { return $_[0]->{name} ; }
156	31 31			31		1699 283	sub getLocalName { (my $name= $_[0]->{name}) =~ s{^.*:}{}; $name; }
157	56			56		8426	sub string_value { return $_[0]->{value}; }
158	3			3	0	344	sub to_number { return $XPATH_NUMBER->new( $_[0]->{value}); }
159	1			1	1	4	sub isElementNode { 0 }
160	1			1	0	4	sub isAttributeNode { 1 }
161	1			1	0	4	sub isNamespaceNode { 0 }
162	1			1	1	4	sub isTextNode { 0 }
163	1			1	1	3	sub isProcessingInstructionNode { 0 }
164	1			1	1	4	sub isPINode { 0 }
165	1			1	1	4	sub isCommentNode { 0 }
166	11			11		161	sub toString { return qq{$_[0]->{name}="$_[0]->{value}"}; }
167
168							sub getNamespace
169	0			0		0	{ my $att= shift;
170	0					0	my $prefix= shift();
171	0	0				0	if( ! defined( $prefix))
172	0 0	0				0 0	{ if($att->{name}=~ m{^(.*):}) { $prefix= $1; }
173	0					0	else { $prefix=''; }
174							}
175
176	0	0				0	if( my $expanded= $att->{elt}->namespace( $prefix))
177	0					0	{ return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
178							}
179
180							sub node_cmp($$)
181	40			40	0	169	{ my( $a, $b)= @_;
182	40	100 100 100				347	if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
183							{ # 2 attributes, compare their elements, then their name
184	17		100			95	return ($a->{elt}->cmp( $b->{elt}) ) \|\| ($a->{name} cmp $b->{name});
185							}
186							elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
187							{ # att <=> elt : compare the att->elt and the elt
188							# if att->elt is the elt (cmp returns 0) then 1 (elt is before att)
189	20		100			104	return ($a->{elt}->cmp( $b) ) \|\| 1 ;
190							}
191							elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
192							{ # att <=> document, att is after document
193	2					9	return 1;
194							}
195							else
196	1					3	{ die "unknown node type ", ref( $b); }
197							}
198
199							cmp=node_cmp;
200
201							1;
202
203							package XML::Twig::XPath::Namespace;
204
205							sub new
206	15			15	1	73	{ my( $class, $prefix, $expanded)= @_;
207	15					174	bless { prefix => $prefix, expanded => $expanded }, $class;
208							}
209
210	1			1	0	6	sub isNamespaceNode { 1; }
211
212	1			1		7	sub getPrefix { $_[0]->{prefix}; }
213	1			1		6	sub getExpanded { $_[0]->{expanded}; }
214	15			15	0	87	sub getValue { $_[0]->{expanded}; }
215	1			1		6	sub getData { $_[0]->{expanded}; }
216
217							1
218