File Coverage

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

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	39 39 39			39		459137 52 1011	use strict;
4	39 39 39			39		51552 55 257	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	39			39		2591	{ foreach my $xpath_engine ( qw( XML::XPathEngine XML::XPath) )
10	40 39 39	100				99 48 67	{ if( XML::Twig::_use( $xpath_engine) ) { $XPATH= $xpath_engine; last; } }
11	39 0	50				130 0	unless( $XPATH) { die "cannot use XML::Twig::XPath: neither XML::XPathEngine 0.09+ nor XML::XPath are available"; }
12	39					679	$XPATH_NUMBER= "${XPATH}::Number";
13							}
14
15
16	39 39 39			39		126 36 1578	use vars qw($VERSION);
17							$VERSION="0.02";
18
19							BEGIN
20	39			39		524	{ package XML::XPath::NodeSet;
21	39 39 39			39		115 33 2506	no warnings; # to avoid the "Subroutine sort redefined" message
22							# replace the native sort routine by a Twig'd one
23							sub sort
24	13			13	0	259	{ my $self = CORE::shift;
25	13 32					26 31	@$self = CORE::sort { $a->node_cmp( $b) } @$self;
26	13					16	return $self;
27							}
28
29							package XML::XPathEngine::NodeSet;
30	39 39 39			39		109 36 1562	no warnings; # to avoid the "Subroutine sort redefined" message
31							# replace the native sort routine by a Twig'd one
32							sub sort
33	158			158	0	6994	{ my $self = CORE::shift;
34	158 555					296 546	@$self = CORE::sort { $a->node_cmp( $b) } @$self;
35	158					313	return $self;
36							}
37							}
38
39							package XML::Twig::XPath;
40
41	39 39 39			39		106 28 1992	use base 'XML::Twig';
42
43							my $XP; # the global xp object;
44
45	1			1	0	6	sub to_number { return $XPATH_NUMBER->new( $_[0]->root->text); }
46
47							sub new
48	69			69	1	3277691	{ my $class= shift;
49	69					236	my $t= XML::Twig->new( elt_class => 'XML::Twig::XPath::Elt', @_);
50	69					288	$t->{twig_xp}= $XPATH->new();
51	69					1384	bless $t, $class;
52	69					203	return $t;
53							}
54
55
56	6 6			6	0	48 15	sub set_namespace { my $t= shift; $t->{twig_xp}->set_namespace( @_); }
57	2 2			2	0	44 5	sub set_strict_namespaces { my $t= shift; $t->{twig_xp}->set_strict_namespaces( @_); }
58
59	4	100		4	0	16	sub node_cmp($$) { return $_[1] == $_[0] ? 0 : -1; } # document is before anything but itself
60
61	14			14	1	77	sub isElementNode { 0 }
62	1			1	0	2	sub isAttributeNode { 0 }
63	1			1	1	1	sub isTextNode { 0 }
64	1			1	1	2	sub isProcessingInstructionNode { 0 }
65	1			1	1	2	sub isPINode { 0 }
66	1			1	1	1	sub isCommentNode { 0 }
67	1			1	0	1	sub isNamespaceNode { 0 }
68	2			2	0	60	sub getAttributes { [] }
69	1			1	0	477	sub getValue { return $_[0]->root->text; }
70
71	98 98			98	1	2921 324	sub findnodes { my( $t, $path)= @_; return $t->{twig_xp}->findnodes( $path, $t); }
72	1 1			1	1	4 4	sub findnodes_as_string { my( $t, $path)= @_; return $t->{twig_xp}->findnodes_as_string( $path, $t); }
73	20 20			20	1	566 47	sub findvalue { my( $t, $path)= @_; return $t->{twig_xp}->findvalue( $path, $t); }
74	1 1			1	0	22 3	sub exists { my( $t, $path)= @_; return $t->{twig_xp}->exists( $path, $t); }
75	8 8			8	0	691 17	sub find { my( $t, $path)= @_; return $t->{twig_xp}->find( $path, $t); }
76	1 1 1		50 33	1	0	2 2 3	sub matches { my( $t, $path, $node)= @_; $node \|\|= $t; return $t->{twig_xp}->matches( $node, $path, $t) \|\| 0; }
77
78							#TODO: it would be nice to be able to pass in any object in this
79							#distribution and cast it to the proper $XPATH class to use as a
80							#variable (via 'nodes' argument or something)
81							sub set_var {
82	10			10	0	941	my ($t, $name, $value) = @_;
83	10 6	100				18 11	if( ! ref $value) { $value= $t->findnodes( qq{"$value"}); }
84	10					1037	$t->{twig_xp}->set_var($name, $value);
85							}
86
87							1;
88
89							# adds the appropriate methods to XML::Twig::Elt so XML::XPath can be used as the XPath engine
90							package XML::Twig::XPath::Elt;
91	39 39 39			39		14627 41 1904	use base 'XML::Twig::Elt';
92
93							getLocalName= XML::Twig::Elt::local_name;
94							getValue = XML::Twig::Elt::text;
95	4			4		6	sub isAttributeNode { 0 }
96	4			4		8	sub isNamespaceNode { 0 }
97
98	3			3		86	sub to_number { return $XPATH_NUMBER->new( $_[0]->text); }
99
100							sub getAttributes
101	189			189		14360	{ my $elt= shift;
102	189					289	my $atts= $elt->atts;
103							# alternate, faster but less clean, way
104	189 249					388 915	my @atts= map { bless( { name => $_, value => $atts->{$_}, elt => $elt },
105							'XML::Twig::XPath::Attribute')
106							}
107							sort keys %$atts;
108							# my @atts= map { XML::Twig::XPath::Attribute->new( $elt, $_) } sort keys %$atts;
109	189	100				525	return wantarray ? @atts : \@atts;
110							}
111
112							sub getNamespace
113	14			14		179	{ my $elt= shift;
114	14		67			30	my $prefix= shift() \|\| $elt->ns_prefix;
115	14	50				20	if( my $expanded= $elt->namespace( $prefix))
116	14					17	{ return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
117							else
118	0					0	{ return XML::Twig::XPath::Namespace->new( $prefix, ''); }
119							}
120
121							sub node_cmp($$)
122	556			556		361	{ my( $a, $b)= @_;
123	556	100 100 100				810	if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
124							{ # 2 elts, compare them
125	514					686	return $a->cmp( $b);
126							}
127							elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
128							{ # elt <=> att, compare the elt to the att->{elt}
129							# if the elt is the att->{elt} (cmp return 0) then -1, elt is before att
130	34		100			37	return ($a->cmp( $b->{elt}) ) \|\| -1 ;
131							}
132							elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
133							{ # elt <=> document, elt is after document
134	7					10	return 1;
135							}
136							else
137	1					12	{ die "unknown node type ", ref( $b); }
138							}
139
140							sub getParentNode
141	115		67	115		2125	{ return $_[0]->_parent
142							\|\| $_[0]->twig;
143							}
144
145	5 5			5		130 18	sub findnodes { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes( $path, $elt); }
146	2 2			2		2 3	sub findnodes_as_string { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes_as_string( $path, $elt); }
147	9 9			9		228 18	sub findvalue { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findvalue( $path, $elt); }
148	1 1			1		1 2	sub exists { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->exists( $path, $elt); }
149	1 1			1		1 2	sub find { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->find( $path, $elt); }
150	7 7		100	7		14 12	sub matches { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->matches( $elt, $path, $elt->getParentNode) \|\| 0; }
151
152
153							1;
154
155							# this package is only used to allow XML::XPath as the XPath engine, otherwise
156							# attributes are just attached to their parent element and are not considered objects
157
158							package XML::Twig::XPath::Attribute;
159
160							sub new
161	1			1		7	{ my( $class, $elt, $att)= @_;
162	1					4	return bless { name => $att, value => $elt->att( $att), elt => $elt }, $class;
163							}
164
165	1			1		3	sub getValue { return $_[0]->{value}; }
166	215			215		1654	sub getName { return $_[0]->{name} ; }
167	39 39			39		482 68	sub getLocalName { (my $name= $_[0]->{name}) =~ s{^.*:}{}; $name; }
168	76			76		2776	sub string_value { return $_[0]->{value}; }
169	21			21		682	sub to_number { return $XPATH_NUMBER->new( $_[0]->{value}); }
170	1			1		2	sub isElementNode { 0 }
171	1			1		1	sub isAttributeNode { 1 }
172	1			1		2	sub isNamespaceNode { 0 }
173	1			1		2	sub isTextNode { 0 }
174	1			1		1	sub isProcessingInstructionNode { 0 }
175	1			1		2	sub isPINode { 0 }
176	1			1		2	sub isCommentNode { 0 }
177	11			11		46	sub toString { return qq{$_[0]->{name}="$_[0]->{value}"}; }
178
179							sub getNamespace
180	4			4		53	{ my $att= shift;
181	4					3	my $prefix= shift();
182	4	50				5	if( ! defined( $prefix))
183	4 4	50				9 5	{ if($att->{name}=~ m{^(.*):}) { $prefix= $1; }
184	0					0	else { $prefix=''; }
185							}
186
187	4	50				5	if( my $expanded= $att->{elt}->namespace( $prefix))
188	4					6	{ return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
189							}
190
191							sub node_cmp($$)
192	40			40		34	{ my( $a, $b)= @_;
193	40	100 100 100				99	if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
194							{ # 2 attributes, compare their elements, then their name
195	17		100			30	return ($a->{elt}->cmp( $b->{elt}) ) \|\| ($a->{name} cmp $b->{name});
196							}
197							elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
198							{ # att <=> elt : compare the att->elt and the elt
199							# if att->elt is the elt (cmp returns 0) then 1 (elt is before att)
200	20		100			24	return ($a->{elt}->cmp( $b) ) \|\| 1 ;
201							}
202							elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
203							{ # att <=> document, att is after document
204	2					7	return 1;
205							}
206							else
207	1					10	{ die "unknown node type ", ref( $b); }
208							}
209
210							cmp=node_cmp;
211
212							1;
213
214							package XML::Twig::XPath::Namespace;
215
216							sub new
217	19			19		28	{ my( $class, $prefix, $expanded)= @_;
218	19					58	bless { prefix => $prefix, expanded => $expanded }, $class;
219							}
220
221	1			1		4	sub isNamespaceNode { 1; }
222
223	1			1		5	sub getPrefix { $_[0]->{prefix}; }
224	1			1		7	sub getExpanded { $_[0]->{expanded}; }
225	19			19		34	sub getValue { $_[0]->{expanded}; }
226	1			1		3	sub getData { $_[0]->{expanded}; }
227
228							1
229