source: trunk/gsdl/perllib/cpan/XML/XPath/Node.pm@ 7909

Last change on this file since 7909 was 7909, checked in by mdewsnip, 17 years ago

CPAN module for processing XPath expressions.

  • Property svn:keywords set to Author Date Id Revision
File size: 12.5 KB
Line 
1# $Id: Node.pm 7909 2004-08-06 05:11:55Z mdewsnip $
2
3package XML::XPath::Node;
4
5use strict;
6use vars qw(@ISA @EXPORT $AUTOLOAD %EXPORT_TAGS @EXPORT_OK);
7use Exporter;
8use Carp;
9@ISA = ('Exporter');
10
11sub UNKNOWN_NODE () {0;}
12sub ELEMENT_NODE () {1;}
13sub ATTRIBUTE_NODE () {2;}
14sub TEXT_NODE () {3;}
15sub CDATA_SECTION_NODE () {4;}
16sub ENTITY_REFERENCE_NODE () {5;}
17sub ENTITY_NODE () {6;}
18sub PROCESSING_INSTRUCTION_NODE () {7;}
19sub COMMENT_NODE () {8;}
20sub DOCUMENT_NODE () {9;}
21sub DOCUMENT_TYPE_NODE () {10;}
22sub DOCUMENT_FRAGMENT_NODE () {11;}
23sub NOTATION_NODE () {12;}
24
25# Non core DOM stuff
26sub ELEMENT_DECL_NODE () {13;}
27sub ATT_DEF_NODE () {14;}
28sub XML_DECL_NODE () {15;}
29sub ATTLIST_DECL_NODE () {16;}
30sub NAMESPACE_NODE () {17;}
31
32# per-node constants
33
34# All
35sub node_parent () { 0; }
36sub node_pos () { 1; }
37sub node_global_pos () { 2; }
38
39# Element
40sub node_prefix () { 3; }
41sub node_children () { 4; }
42sub node_name () { 5; }
43sub node_attribs () { 6; }
44sub node_namespaces () { 7; }
45sub node_ids () { 8; }
46
47# Char
48sub node_text () { 3; }
49
50# PI
51sub node_target () { 3; }
52sub node_data () { 4; }
53
54# Comment
55sub node_comment () { 3; }
56
57# Attribute
58# sub node_prefix () { 3; }
59sub node_key () { 4; }
60sub node_value () { 5; }
61
62# Namespaces
63# sub node_prefix () { 3; }
64sub node_expanded () { 4; }
65
66@EXPORT = qw(
67 UNKNOWN_NODE
68 ELEMENT_NODE
69 ATTRIBUTE_NODE
70 TEXT_NODE
71 CDATA_SECTION_NODE
72 ENTITY_REFERENCE_NODE
73 ENTITY_NODE
74 PROCESSING_INSTRUCTION_NODE
75 COMMENT_NODE
76 DOCUMENT_NODE
77 DOCUMENT_TYPE_NODE
78 DOCUMENT_FRAGMENT_NODE
79 NOTATION_NODE
80 ELEMENT_DECL_NODE
81 ATT_DEF_NODE
82 XML_DECL_NODE
83 ATTLIST_DECL_NODE
84 NAMESPACE_NODE
85 );
86
87@EXPORT_OK = qw(
88 node_parent
89 node_pos
90 node_global_pos
91 node_prefix
92 node_children
93 node_name
94 node_attribs
95 node_namespaces
96 node_text
97 node_target
98 node_data
99 node_comment
100 node_key
101 node_value
102 node_expanded
103 node_ids
104 );
105
106%EXPORT_TAGS = (
107 'node_keys' => [
108 qw(
109 node_parent
110 node_pos
111 node_global_pos
112 node_prefix
113 node_children
114 node_name
115 node_attribs
116 node_namespaces
117 node_text
118 node_target
119 node_data
120 node_comment
121 node_key
122 node_value
123 node_expanded
124 node_ids
125 ), @EXPORT,
126 ],
127);
128
129
130my $global_pos = 0;
131
132sub nextPos {
133 my $class = shift;
134 return $global_pos += 5;
135}
136
137sub resetPos {
138 $global_pos = 0;
139}
140
141my %DecodeDefaultEntity =
142(
143 '"' => """,
144 ">" => ">",
145 "<" => "&lt;",
146 "'" => "&apos;",
147 "&" => "&amp;"
148);
149
150sub XMLescape {
151 my ($str, $default) = @_;
152 return undef unless defined $str;
153 $default ||= '';
154
155 if ($XML::XPath::EncodeUtf8AsEntity) {
156 $str =~ s/([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)|([$default])|(]]>)/
157 defined($1) ? XmlUtf8Decode ($1) :
158 defined ($2) ? $DecodeDefaultEntity{$2} : "]]&gt;" /egsx;
159 }
160 else {
161 $str =~ s/([$default])|(]]>)/
162 defined ($1) ? $DecodeDefaultEntity{$1} : ']]&gt;' /gsex;
163 }
164
165#?? could there be references that should not be expanded?
166# e.g. should not replace &#nn; &#xAF; and &abc;
167# $str =~ s/&(?!($ReName|#[0-9]+|#x[0-9a-fA-F]+);)/&amp;/go;
168
169 $str;
170}
171
172#
173# Opposite of XmlUtf8Decode plus it adds prefix "&#" or "&#x" and suffix ";"
174# The 2nd parameter ($hex) indicates whether the result is hex encoded or not.
175#
176sub XmlUtf8Decode
177{
178 my ($str, $hex) = @_;
179 my $len = length ($str);
180 my $n;
181
182 if ($len == 2) {
183 my @n = unpack "C2", $str;
184 $n = (($n[0] & 0x3f) << 6) + ($n[1] & 0x3f);
185 }
186 elsif ($len == 3) {
187 my @n = unpack "C3", $str;
188 $n = (($n[0] & 0x1f) << 12) + (($n[1] & 0x3f) << 6) +
189 ($n[2] & 0x3f);
190 }
191 elsif ($len == 4) {
192 my @n = unpack "C4", $str;
193 $n = (($n[0] & 0x0f) << 18) + (($n[1] & 0x3f) << 12) +
194 (($n[2] & 0x3f) << 6) + ($n[3] & 0x3f);
195 }
196 elsif ($len == 1) { # just to be complete...
197 $n = ord ($str);
198 }
199 else {
200 die "bad value [$str] for XmlUtf8Decode";
201 }
202 $hex ? sprintf ("&#x%x;", $n) : "&#$n;";
203}
204
205sub new {
206 my $class = shift;
207 no strict 'refs';
208 my $impl = $class . "Impl";
209 my $this = $impl->new(@_);
210 if ($XML::XPath::SafeMode) {
211 return $this;
212 }
213 my $self = \$this;
214 return bless $self, $class;
215}
216
217sub AUTOLOAD {
218 my $method = $AUTOLOAD;
219 $method =~ s/.*:://;
220# warn "AUTOLOAD $method!\n";
221 no strict 'refs';
222 *{$AUTOLOAD} = sub {
223 my $self = shift;
224 my $olderror = $@; # store previous exceptions
225 my $obj = eval { $$self };
226 if ($@) {
227 if ($@ =~ /Not a SCALAR reference/) {
228 croak("No such method $method in " . ref($self));
229 }
230 croak $@;
231 }
232 if ($obj) {
233 # make sure $@ propogates if this method call was the result
234 # of losing scope because of a die().
235 if ($method =~ /^(DESTROY|del_parent_link)$/) {
236 $obj->$method(@_);
237 $@ = $olderror if $olderror;
238 return;
239 }
240 return $obj->$method(@_);
241 }
242 };
243 goto &$AUTOLOAD;
244}
245
246package XML::XPath::NodeImpl;
247
248use vars qw/@ISA $AUTOLOAD/;
249@ISA = ('XML::XPath::Node');
250
251sub new {
252 die "Virtual base method";
253}
254
255sub getNodeType {
256 my $self = shift;
257 return XML::XPath::Node::UNKNOWN_NODE;
258}
259
260sub isElementNode {}
261sub isAttributeNode {}
262sub isNamespaceNode {}
263sub isTextNode {}
264sub isProcessingInstructionNode {}
265sub isPINode {}
266sub isCommentNode {}
267
268sub getNodeValue {
269 return;
270}
271
272sub getValue {
273 shift->getNodeValue(@_);
274}
275
276sub setNodeValue {
277 return;
278}
279
280sub setValue {
281 shift->setNodeValue(@_);
282}
283
284sub getParentNode {
285 my $self = shift;
286 return $self->[XML::XPath::Node::node_parent];
287}
288
289sub getRootNode {
290 my $self = shift;
291 while (my $parent = $self->getParentNode) {
292 $self = $parent;
293 }
294 return $self;
295}
296
297sub getElementById {
298 my $self = shift;
299 my ($id) = @_;
300# warn "getElementById: $id\n";
301 my $root = $self->getRootNode;
302 my $node = $root->[XML::XPath::Node::node_ids]{$id};
303# warn "returning node: ", $node->getName, "\n";
304 return $node;
305}
306
307sub getName { }
308sub getData { }
309
310sub getChildNodes {
311 return wantarray ? () : [];
312}
313
314sub getChildNode {
315 return;
316}
317
318sub getAttribute {
319 return;
320}
321
322sub getAttributes {
323 return wantarray ? () : [];
324}
325
326sub getAttributeNodes {
327 shift->getAttributes(@_);
328}
329
330sub getNamespaceNodes {
331 return wantarray ? () : [];
332}
333
334sub getNamespace {
335 return;
336}
337
338sub getLocalName {
339 return;
340}
341
342sub string_value { return; }
343
344sub get_pos {
345 my $self = shift;
346 return $self->[XML::XPath::Node::node_pos];
347}
348
349sub set_pos {
350 my $self = shift;
351 $self->[XML::XPath::Node::node_pos] = shift;
352}
353
354sub get_global_pos {
355 my $self = shift;
356 return $self->[XML::XPath::Node::node_global_pos];
357}
358
359sub set_global_pos {
360 my $self = shift;
361 $self->[XML::XPath::Node::node_global_pos] = shift;
362}
363
364sub renumber {
365 my $self = shift;
366 my $search = shift;
367 my $diff = shift;
368
369 foreach my $node ($self->findnodes($search)) {
370 $node->set_global_pos(
371 $node->get_global_pos + $diff
372 );
373 }
374}
375
376sub insertAfter {
377 my $self = shift;
378 my $newnode = shift;
379 my $posnode = shift;
380
381 my $pos_number = eval { $posnode->[XML::XPath::Node::node_children][-1]->get_global_pos() + 1; };
382 if (!defined $pos_number) {
383 $pos_number = $posnode->get_global_pos() + 1;
384 }
385
386 eval {
387 if ($pos_number ==
388 $posnode->findnodes(
389 'following::node()'
390 )->get_node(1)->get_global_pos()) {
391 $posnode->renumber('following::node()', +5);
392 }
393 };
394
395 my $pos = $posnode->get_pos;
396
397 $newnode->setParentNode($self);
398 splice @{$self->[XML::XPath::Node::node_children]}, $pos + 1, 0, $newnode;
399
400 for (my $i = $pos + 1; $i < @{$self->[XML::XPath::Node::node_children]}; $i++) {
401 $self->[XML::XPath::Node::node_children][$i]->set_pos($i);
402 }
403
404 $newnode->set_global_pos($pos_number);
405}
406
407sub insertBefore {
408 my $self = shift;
409 my $newnode = shift;
410 my $posnode = shift;
411
412 my $pos_number = ($posnode->getPreviousSibling() || $posnode->getParentNode)->get_global_pos();
413 if ($pos_number == $posnode->get_global_pos()) {
414 $posnode->renumber('self::node() | descendant::node() | following::node()', +5);
415 }
416
417 my $pos = $posnode->get_pos;
418
419 $newnode->setParentNode($self);
420 splice @{$self->[XML::XPath::Node::node_children]}, $pos, 0, $newnode;
421
422 for (my $i = $pos; $i < @{$self->[XML::XPath::Node::node_children]}; $i++) {
423 $self->[XML::XPath::Node::node_children][$i]->set_pos($i);
424 }
425
426 $newnode->set_global_pos($pos_number);
427}
428
429sub getPreviousSibling {
430 my $self = shift;
431 my $pos = $self->[XML::XPath::Node::node_pos];
432 return unless $self->[XML::XPath::Node::node_parent];
433 return $self->[XML::XPath::Node::node_parent]->getChildNode($pos);
434}
435
436sub getNextSibling {
437 my $self = shift;
438 my $pos = $self->[XML::XPath::Node::node_pos];
439 return unless $self->[XML::XPath::Node::node_parent];
440 return $self->[XML::XPath::Node::node_parent]->getChildNode($pos + 2);
441}
442
443sub setParentNode {
444 my $self = shift;
445 my $parent = shift;
446# warn "SetParent of ", ref($self), " to ", $parent->[XML::XPath::Node::node_name], "\n";
447 $self->[XML::XPath::Node::node_parent] = $parent;
448}
449
450sub del_parent_link {
451 my $self = shift;
452 $self->[XML::XPath::Node::node_parent] = undef;
453}
454
455sub dispose {
456 my $self = shift;
457 foreach my $kid ($self->getChildNodes) {
458 $kid->dispose;
459 }
460 foreach my $kid ($self->getAttributeNodes) {
461 $kid->dispose;
462 }
463 foreach my $kid ($self->getNamespaceNodes) {
464 $kid->dispose;
465 }
466 $self->[XML::XPath::Node::node_parent] = undef;
467}
468
469sub to_number {
470 my $num = shift->string_value;
471 return XML::XPath::Number->new($num);
472}
473
474sub find {
475 my $node = shift;
476 my ($path) = @_;
477 my $xp = XML::XPath->new(); # new is v. lightweight
478 return $xp->find($path, $node);
479}
480
481sub findvalue {
482 my $node = shift;
483 my ($path) = @_;
484 my $xp = XML::XPath->new();
485 return $xp->findvalue($path, $node);
486}
487
488sub findnodes {
489 my $node = shift;
490 my ($path) = @_;
491 my $xp = XML::XPath->new();
492 return $xp->findnodes($path, $node);
493}
494
495sub matches {
496 my $node = shift;
497 my ($path, $context) = @_;
498 my $xp = XML::XPath->new();
499 return $xp->matches($node, $path, $context);
500}
501
502sub to_sax {
503 my $self = shift;
504 unshift @_, 'Handler' if @_ == 1;
505 my %handlers = @_;
506
507 my $doch = $handlers{DocumentHandler} || $handlers{Handler};
508 my $dtdh = $handlers{DTDHandler} || $handlers{Handler};
509 my $enth = $handlers{EntityResolver} || $handlers{Handler};
510
511 $self->_to_sax ($doch, $dtdh, $enth);
512}
513
514sub DESTROY {}
515
516use Carp;
517
518sub _to_sax {
519 carp "_to_sax not implemented in ", ref($_[0]);
520}
521
5221;
523__END__
524
525=head1 NAME
526
527XML::XPath::Node - internal representation of a node
528
529=head1 API
530
531The Node API aims to emulate DOM to some extent, however the API
532isn't quite compatible with DOM. This is to ease transition from
533XML::DOM programming to XML::XPath. Compatibility with DOM may
534arise once XML::DOM gets namespace support.
535
536=head2 new
537
538Creates a new node. See the sub-classes for parameters to pass to new().
539
540=head2 getNodeType
541
542Returns one of ELEMENT_NODE, TEXT_NODE, COMMENT_NODE, ATTRIBUTE_NODE,
543PROCESSING_INSTRUCTION_NODE or NAMESPACE_NODE. UNKNOWN_NODE is returned
544if the sub-class doesn't implement getNodeType - but that means
545something is broken! The constants are exported by default from
546XML::XPath::Node. The constants have the same numeric value as the
547XML::DOM versions.
548
549=head2 getParentNode
550
551Returns the parent of this node, or undef if this is the root node. Note
552that the root node is the root node in terms of XPath - not the root
553element node.
554
555=head2 to_sax ( $handler | %handlers )
556
557Generates sax calls to the handler or handlers. See the PerlSAX docs for
558details (not yet implemented correctly).
559
560=head1 MORE INFO
561
562See the sub-classes for the meaning of the rest of the API:
563
564=over 4
565
566=item *
567
568L<XML::XPath::Node::Element>
569
570=item *
571
572L<XML::XPath::Node::Attribute>
573
574=item *
575
576L<XML::XPath::Node::Namespace>
577
578=item *
579
580L<XML::XPath::Node::Text>
581
582=item *
583
584L<XML::XPath::Node::Comment>
585
586=item *
587
588L<XML::XPath::Node::PI>
589
590=back
591
592=cut
Note: See TracBrowser for help on using the repository browser.