1 ################################################################################ |
|
2 # |
|
3 # Perl module: XML::DOM |
|
4 # |
|
5 # By Enno Derksen <enno@att.com> |
|
6 # |
|
7 ################################################################################ |
|
8 # |
|
9 # To do: |
|
10 # |
|
11 # * optimize Attr if it only contains 1 Text node to hold the value |
|
12 # * fix setDocType! |
|
13 # |
|
14 # * BUG: setOwnerDocument - does not process default attr values correctly, |
|
15 # they still point to the old doc. |
|
16 # * change Exception mechanism |
|
17 # * maybe: more checking of sysId etc. |
|
18 # * NoExpand mode (don't know what else is useful) |
|
19 # * various odds and ends: see comments starting with "??" |
|
20 # * normalize(1) could also expand CDataSections and EntityReferences |
|
21 # * parse a DocumentFragment? |
|
22 # * encoding support |
|
23 # |
|
24 ###################################################################### |
|
25 |
|
26 ###################################################################### |
|
27 package XML::DOM; |
|
28 ###################################################################### |
|
29 |
|
30 use strict; |
|
31 use vars qw( $VERSION @ISA @EXPORT |
|
32 $IgnoreReadOnly $SafeMode $TagStyle |
|
33 %DefaultEntities %DecodeDefaultEntity |
|
34 ); |
|
35 use Carp; |
|
36 use XML::RegExp; |
|
37 |
|
38 BEGIN |
|
39 { |
|
40 require XML::Parser; |
|
41 $VERSION = '1.27'; |
|
42 |
|
43 my $needVersion = '2.23'; |
|
44 die "need at least XML::Parser version $needVersion (current=${XML::Parser::VERSION})" |
|
45 unless $XML::Parser::VERSION >= $needVersion; |
|
46 |
|
47 @ISA = qw( Exporter ); |
|
48 |
|
49 # Constants for XML::DOM Node types |
|
50 @EXPORT = qw( |
|
51 UNKNOWN_NODE |
|
52 ELEMENT_NODE |
|
53 ATTRIBUTE_NODE |
|
54 TEXT_NODE |
|
55 CDATA_SECTION_NODE |
|
56 ENTITY_REFERENCE_NODE |
|
57 ENTITY_NODE |
|
58 PROCESSING_INSTRUCTION_NODE |
|
59 COMMENT_NODE |
|
60 DOCUMENT_NODE |
|
61 DOCUMENT_TYPE_NODE |
|
62 DOCUMENT_FRAGMENT_NODE |
|
63 NOTATION_NODE |
|
64 ELEMENT_DECL_NODE |
|
65 ATT_DEF_NODE |
|
66 XML_DECL_NODE |
|
67 ATTLIST_DECL_NODE |
|
68 ); |
|
69 } |
|
70 |
|
71 #---- Constant definitions |
|
72 |
|
73 # Node types |
|
74 |
|
75 sub UNKNOWN_NODE () { 0 } # not in the DOM Spec |
|
76 |
|
77 sub ELEMENT_NODE () { 1 } |
|
78 sub ATTRIBUTE_NODE () { 2 } |
|
79 sub TEXT_NODE () { 3 } |
|
80 sub CDATA_SECTION_NODE () { 4 } |
|
81 sub ENTITY_REFERENCE_NODE () { 5 } |
|
82 sub ENTITY_NODE () { 6 } |
|
83 sub PROCESSING_INSTRUCTION_NODE () { 7 } |
|
84 sub COMMENT_NODE () { 8 } |
|
85 sub DOCUMENT_NODE () { 9 } |
|
86 sub DOCUMENT_TYPE_NODE () { 10} |
|
87 sub DOCUMENT_FRAGMENT_NODE () { 11} |
|
88 sub NOTATION_NODE () { 12} |
|
89 |
|
90 sub ELEMENT_DECL_NODE () { 13 } # not in the DOM Spec |
|
91 sub ATT_DEF_NODE () { 14 } # not in the DOM Spec |
|
92 sub XML_DECL_NODE () { 15 } # not in the DOM Spec |
|
93 sub ATTLIST_DECL_NODE () { 16 } # not in the DOM Spec |
|
94 |
|
95 %DefaultEntities = |
|
96 ( |
|
97 "quot" => '"', |
|
98 "gt" => ">", |
|
99 "lt" => "<", |
|
100 "apos" => "'", |
|
101 "amp" => "&" |
|
102 ); |
|
103 |
|
104 %DecodeDefaultEntity = |
|
105 ( |
|
106 '"' => """, |
|
107 ">" => ">", |
|
108 "<" => "<", |
|
109 "'" => "'", |
|
110 "&" => "&" |
|
111 ); |
|
112 |
|
113 # |
|
114 # If you don't want DOM warnings to use 'warn', override this method like this: |
|
115 # |
|
116 # { # start block scope |
|
117 # local *XML::DOM::warning = \&my_warn; |
|
118 # ... your code here ... |
|
119 # } # end block scope (old XML::DOM::warning takes effect again) |
|
120 # |
|
121 sub warning # static |
|
122 { |
|
123 warn @_; |
|
124 } |
|
125 |
|
126 # |
|
127 # This method defines several things in the caller's package, so you can use named constants to |
|
128 # access the array that holds the member data, i.e. $self->[_Data]. It assumes the caller's package |
|
129 # defines a class that is implemented as a blessed array reference. |
|
130 # Note that this is very similar to using 'use fields' and 'use base'. |
|
131 # |
|
132 # E.g. if $fields eq "Name Model", $parent eq "XML::DOM::Node" and |
|
133 # XML::DOM::Node had "A B C" as fields and it was called from package "XML::DOM::ElementDecl", |
|
134 # then this code would basically do the following: |
|
135 # |
|
136 # package XML::DOM::ElementDecl; |
|
137 # |
|
138 # sub _Name () { 3 } # Note that parent class had three fields |
|
139 # sub _Model () { 4 } |
|
140 # |
|
141 # # Maps constant names (without '_') to constant (int) value |
|
142 # %HFIELDS = ( %XML::DOM::Node::HFIELDS, Name => _Name, Model => _Model ); |
|
143 # |
|
144 # # Define XML:DOM::ElementDecl as a subclass of XML::DOM::Node |
|
145 # @ISA = qw{ XML::DOM::Node }; |
|
146 # |
|
147 # # The following function names can be exported into the user's namespace. |
|
148 # @EXPORT_OK = qw{ _Name _Model }; |
|
149 # |
|
150 # # The following function names can be exported into the user's namespace |
|
151 # # with: import XML::DOM::ElementDecl qw( :Fields ); |
|
152 # %EXPORT_TAGS = ( Fields => qw{ _Name _Model } ); |
|
153 # |
|
154 sub def_fields # static |
|
155 { |
|
156 my ($fields, $parent) = @_; |
|
157 |
|
158 my ($pkg) = caller; |
|
159 |
|
160 no strict 'refs'; |
|
161 |
|
162 my @f = split (/\s+/, $fields); |
|
163 my $n = 0; |
|
164 |
|
165 my %hfields; |
|
166 if (defined $parent) |
|
167 { |
|
168 my %pf = %{"$parent\::HFIELDS"}; |
|
169 %hfields = %pf; |
|
170 |
|
171 $n = scalar (keys %pf); |
|
172 @{"$pkg\::ISA"} = ( $parent ); |
|
173 } |
|
174 |
|
175 my $i = $n; |
|
176 for (@f) |
|
177 { |
|
178 eval "sub $pkg\::_$_ () { $i }"; |
|
179 $hfields{$_} = $i; |
|
180 $i++; |
|
181 } |
|
182 %{"$pkg\::HFIELDS"} = %hfields; |
|
183 @{"$pkg\::EXPORT_OK"} = map { "_$_" } @f; |
|
184 |
|
185 ${"$pkg\::EXPORT_TAGS"}{Fields} = [ map { "_$_" } @f ]; |
|
186 } |
|
187 |
|
188 # sub blesh |
|
189 # { |
|
190 # my $hashref = shift; |
|
191 # my $class = shift; |
|
192 # no strict 'refs'; |
|
193 # my $self = bless [\%{"$class\::FIELDS"}], $class; |
|
194 # if (defined $hashref) |
|
195 # { |
|
196 # for (keys %$hashref) |
|
197 # { |
|
198 # $self->{$_} = $hashref->{$_}; |
|
199 # } |
|
200 # } |
|
201 # $self; |
|
202 # } |
|
203 |
|
204 # sub blesh2 |
|
205 # { |
|
206 # my $hashref = shift; |
|
207 # my $class = shift; |
|
208 # no strict 'refs'; |
|
209 # my $self = bless [\%{"$class\::FIELDS"}], $class; |
|
210 # if (defined $hashref) |
|
211 # { |
|
212 # for (keys %$hashref) |
|
213 # { |
|
214 # eval { $self->{$_} = $hashref->{$_}; }; |
|
215 # croak "ERROR in field [$_] $@" if $@; |
|
216 # } |
|
217 # } |
|
218 # $self; |
|
219 #} |
|
220 |
|
221 # |
|
222 # CDATA section may not contain "]]>" |
|
223 # |
|
224 sub encodeCDATA |
|
225 { |
|
226 my ($str) = shift; |
|
227 $str =~ s/]]>/]]>/go; |
|
228 $str; |
|
229 } |
|
230 |
|
231 # |
|
232 # PI may not contain "?>" |
|
233 # |
|
234 sub encodeProcessingInstruction |
|
235 { |
|
236 my ($str) = shift; |
|
237 $str =~ s/\?>/?>/go; |
|
238 $str; |
|
239 } |
|
240 |
|
241 # |
|
242 #?? Not sure if this is right - must prevent double minus somehow... |
|
243 # |
|
244 sub encodeComment |
|
245 { |
|
246 my ($str) = shift; |
|
247 return undef unless defined $str; |
|
248 |
|
249 $str =~ s/--/--/go; |
|
250 $str; |
|
251 } |
|
252 |
|
253 # |
|
254 # For debugging |
|
255 # |
|
256 sub toHex |
|
257 { |
|
258 my $str = shift; |
|
259 my $len = length($str); |
|
260 my @a = unpack ("C$len", $str); |
|
261 my $s = ""; |
|
262 for (@a) |
|
263 { |
|
264 $s .= sprintf ("%02x", $_); |
|
265 } |
|
266 $s; |
|
267 } |
|
268 |
|
269 # |
|
270 # 2nd parameter $default: list of Default Entity characters that need to be |
|
271 # converted (e.g. "&<" for conversion to "&" and "<" resp.) |
|
272 # |
|
273 sub encodeText |
|
274 { |
|
275 my ($str, $default) = @_; |
|
276 return undef unless defined $str; |
|
277 |
|
278 $str =~ s/([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)|([$default])|(]]>)/ |
|
279 defined($1) ? XmlUtf8Decode ($1) : |
|
280 defined ($2) ? $DecodeDefaultEntity{$2} : "]]>" /egs; |
|
281 |
|
282 #?? could there be references that should not be expanded? |
|
283 # e.g. should not replace &#nn; ¯ and &abc; |
|
284 # $str =~ s/&(?!($ReName|#[0-9]+|#x[0-9a-fA-F]+);)/&/go; |
|
285 |
|
286 $str; |
|
287 } |
|
288 |
|
289 # |
|
290 # Used by AttDef - default value |
|
291 # |
|
292 sub encodeAttrValue |
|
293 { |
|
294 encodeText (shift, '"&<'); |
|
295 } |
|
296 |
|
297 # |
|
298 # Converts an integer (Unicode - ISO/IEC 10646) to a UTF-8 encoded character |
|
299 # sequence. |
|
300 # Used when converting e.g. { or Ͽ to a string value. |
|
301 # |
|
302 # Algorithm borrowed from expat/xmltok.c/XmlUtf8Encode() |
|
303 # |
|
304 # not checking for bad characters: < 0, x00-x08, x0B-x0C, x0E-x1F, xFFFE-xFFFF |
|
305 # |
|
306 sub XmlUtf8Encode |
|
307 { |
|
308 my $n = shift; |
|
309 if ($n < 0x80) |
|
310 { |
|
311 return chr ($n); |
|
312 } |
|
313 elsif ($n < 0x800) |
|
314 { |
|
315 return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80)); |
|
316 } |
|
317 elsif ($n < 0x10000) |
|
318 { |
|
319 return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80), |
|
320 (($n & 0x3f) | 0x80)); |
|
321 } |
|
322 elsif ($n < 0x110000) |
|
323 { |
|
324 return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80), |
|
325 ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80)); |
|
326 } |
|
327 croak "number is too large for Unicode [$n] in &XmlUtf8Encode"; |
|
328 } |
|
329 |
|
330 # |
|
331 # Opposite of XmlUtf8Decode plus it adds prefix "&#" or "&#x" and suffix ";" |
|
332 # The 2nd parameter ($hex) indicates whether the result is hex encoded or not. |
|
333 # |
|
334 sub XmlUtf8Decode |
|
335 { |
|
336 my ($str, $hex) = @_; |
|
337 my $len = length ($str); |
|
338 my $n; |
|
339 |
|
340 if ($len == 2) |
|
341 { |
|
342 my @n = unpack "C2", $str; |
|
343 $n = (($n[0] & 0x3f) << 6) + ($n[1] & 0x3f); |
|
344 } |
|
345 elsif ($len == 3) |
|
346 { |
|
347 my @n = unpack "C3", $str; |
|
348 $n = (($n[0] & 0x1f) << 12) + (($n[1] & 0x3f) << 6) + |
|
349 ($n[2] & 0x3f); |
|
350 } |
|
351 elsif ($len == 4) |
|
352 { |
|
353 my @n = unpack "C4", $str; |
|
354 $n = (($n[0] & 0x0f) << 18) + (($n[1] & 0x3f) << 12) + |
|
355 (($n[2] & 0x3f) << 6) + ($n[3] & 0x3f); |
|
356 } |
|
357 elsif ($len == 1) # just to be complete... |
|
358 { |
|
359 $n = ord ($str); |
|
360 } |
|
361 else |
|
362 { |
|
363 croak "bad value [$str] for XmlUtf8Decode"; |
|
364 } |
|
365 $hex ? sprintf ("&#x%x;", $n) : "&#$n;"; |
|
366 } |
|
367 |
|
368 $IgnoreReadOnly = 0; |
|
369 $SafeMode = 1; |
|
370 |
|
371 sub getIgnoreReadOnly |
|
372 { |
|
373 $IgnoreReadOnly; |
|
374 } |
|
375 |
|
376 # |
|
377 # The global flag $IgnoreReadOnly is set to the specified value and the old |
|
378 # value of $IgnoreReadOnly is returned. |
|
379 # |
|
380 # To temporarily disable read-only related exceptions (i.e. when parsing |
|
381 # XML or temporarily), do the following: |
|
382 # |
|
383 # my $oldIgnore = XML::DOM::ignoreReadOnly (1); |
|
384 # ... do whatever you want ... |
|
385 # XML::DOM::ignoreReadOnly ($oldIgnore); |
|
386 # |
|
387 sub ignoreReadOnly |
|
388 { |
|
389 my $i = $IgnoreReadOnly; |
|
390 $IgnoreReadOnly = $_[0]; |
|
391 return $i; |
|
392 } |
|
393 |
|
394 # |
|
395 # XML spec seems to break its own rules... (see ENTITY xmlpio) |
|
396 # |
|
397 sub forgiving_isValidName |
|
398 { |
|
399 $_[0] =~ /^$XML::RegExp::Name$/o; |
|
400 } |
|
401 |
|
402 # |
|
403 # Don't allow names starting with xml (either case) |
|
404 # |
|
405 sub picky_isValidName |
|
406 { |
|
407 $_[0] =~ /^$XML::RegExp::Name$/o and $_[0] !~ /^xml/i; |
|
408 } |
|
409 |
|
410 # Be forgiving by default, |
|
411 *isValidName = \&forgiving_isValidName; |
|
412 |
|
413 sub allowReservedNames # static |
|
414 { |
|
415 *isValidName = ($_[0] ? \&forgiving_isValidName : \&picky_isValidName); |
|
416 } |
|
417 |
|
418 sub getAllowReservedNames # static |
|
419 { |
|
420 *isValidName == \&forgiving_isValidName; |
|
421 } |
|
422 |
|
423 # |
|
424 # Always compress empty tags by default |
|
425 # This is used by Element::print. |
|
426 # |
|
427 $TagStyle = sub { 0 }; |
|
428 |
|
429 sub setTagCompression |
|
430 { |
|
431 $TagStyle = shift; |
|
432 } |
|
433 |
|
434 ###################################################################### |
|
435 package XML::DOM::PrintToFileHandle; |
|
436 ###################################################################### |
|
437 |
|
438 # |
|
439 # Used by XML::DOM::Node::printToFileHandle |
|
440 # |
|
441 |
|
442 sub new |
|
443 { |
|
444 my($class, $fn) = @_; |
|
445 bless $fn, $class; |
|
446 } |
|
447 |
|
448 sub print |
|
449 { |
|
450 my ($self, $str) = @_; |
|
451 print $self $str; |
|
452 } |
|
453 |
|
454 ###################################################################### |
|
455 package XML::DOM::PrintToString; |
|
456 ###################################################################### |
|
457 |
|
458 use vars qw{ $Singleton }; |
|
459 |
|
460 # |
|
461 # Used by XML::DOM::Node::toString to concatenate strings |
|
462 # |
|
463 |
|
464 sub new |
|
465 { |
|
466 my($class) = @_; |
|
467 my $str = ""; |
|
468 bless \$str, $class; |
|
469 } |
|
470 |
|
471 sub print |
|
472 { |
|
473 my ($self, $str) = @_; |
|
474 $$self .= $str; |
|
475 } |
|
476 |
|
477 sub toString |
|
478 { |
|
479 my $self = shift; |
|
480 $$self; |
|
481 } |
|
482 |
|
483 sub reset |
|
484 { |
|
485 ${$_[0]} = ""; |
|
486 } |
|
487 |
|
488 $Singleton = new XML::DOM::PrintToString; |
|
489 |
|
490 ###################################################################### |
|
491 package XML::DOM::DOMImplementation; |
|
492 ###################################################################### |
|
493 |
|
494 $XML::DOM::DOMImplementation::Singleton = |
|
495 bless \$XML::DOM::DOMImplementation::Singleton, 'XML::DOM::DOMImplementation'; |
|
496 |
|
497 sub hasFeature |
|
498 { |
|
499 my ($self, $feature, $version) = @_; |
|
500 |
|
501 $feature eq 'XML' and $version eq '1.0'; |
|
502 } |
|
503 |
|
504 |
|
505 ###################################################################### |
|
506 package XML::XQL::Node; # forward declaration |
|
507 ###################################################################### |
|
508 |
|
509 ###################################################################### |
|
510 package XML::DOM::Node; |
|
511 ###################################################################### |
|
512 |
|
513 use vars qw( @NodeNames @EXPORT @ISA %HFIELDS @EXPORT_OK @EXPORT_TAGS ); |
|
514 |
|
515 BEGIN |
|
516 { |
|
517 use XML::DOM::DOMException; |
|
518 import Carp; |
|
519 |
|
520 require FileHandle; |
|
521 |
|
522 @ISA = qw( Exporter XML::XQL::Node ); |
|
523 |
|
524 # NOTE: SortKey is used in XML::XQL::Node. |
|
525 # UserData is reserved for users (Hang your data here!) |
|
526 XML::DOM::def_fields ("C A Doc Parent ReadOnly UsedIn Hidden SortKey UserData"); |
|
527 |
|
528 push (@EXPORT, qw( |
|
529 UNKNOWN_NODE |
|
530 ELEMENT_NODE |
|
531 ATTRIBUTE_NODE |
|
532 TEXT_NODE |
|
533 CDATA_SECTION_NODE |
|
534 ENTITY_REFERENCE_NODE |
|
535 ENTITY_NODE |
|
536 PROCESSING_INSTRUCTION_NODE |
|
537 COMMENT_NODE |
|
538 DOCUMENT_NODE |
|
539 DOCUMENT_TYPE_NODE |
|
540 DOCUMENT_FRAGMENT_NODE |
|
541 NOTATION_NODE |
|
542 ELEMENT_DECL_NODE |
|
543 ATT_DEF_NODE |
|
544 XML_DECL_NODE |
|
545 ATTLIST_DECL_NODE |
|
546 )); |
|
547 } |
|
548 |
|
549 #---- Constant definitions |
|
550 |
|
551 # Node types |
|
552 |
|
553 sub UNKNOWN_NODE () {0;} # not in the DOM Spec |
|
554 |
|
555 sub ELEMENT_NODE () {1;} |
|
556 sub ATTRIBUTE_NODE () {2;} |
|
557 sub TEXT_NODE () {3;} |
|
558 sub CDATA_SECTION_NODE () {4;} |
|
559 sub ENTITY_REFERENCE_NODE () {5;} |
|
560 sub ENTITY_NODE () {6;} |
|
561 sub PROCESSING_INSTRUCTION_NODE () {7;} |
|
562 sub COMMENT_NODE () {8;} |
|
563 sub DOCUMENT_NODE () {9;} |
|
564 sub DOCUMENT_TYPE_NODE () {10;} |
|
565 sub DOCUMENT_FRAGMENT_NODE () {11;} |
|
566 sub NOTATION_NODE () {12;} |
|
567 |
|
568 sub ELEMENT_DECL_NODE () {13;} # not in the DOM Spec |
|
569 sub ATT_DEF_NODE () {14;} # not in the DOM Spec |
|
570 sub XML_DECL_NODE () {15;} # not in the DOM Spec |
|
571 sub ATTLIST_DECL_NODE () {16;} # not in the DOM Spec |
|
572 |
|
573 @NodeNames = ( |
|
574 "UNKNOWN_NODE", # not in the DOM Spec! |
|
575 |
|
576 "ELEMENT_NODE", |
|
577 "ATTRIBUTE_NODE", |
|
578 "TEXT_NODE", |
|
579 "CDATA_SECTION_NODE", |
|
580 "ENTITY_REFERENCE_NODE", |
|
581 "ENTITY_NODE", |
|
582 "PROCESSING_INSTRUCTION_NODE", |
|
583 "COMMENT_NODE", |
|
584 "DOCUMENT_NODE", |
|
585 "DOCUMENT_TYPE_NODE", |
|
586 "DOCUMENT_FRAGMENT_NODE", |
|
587 "NOTATION_NODE", |
|
588 |
|
589 "ELEMENT_DECL_NODE", |
|
590 "ATT_DEF_NODE", |
|
591 "XML_DECL_NODE", |
|
592 "ATTLIST_DECL_NODE" |
|
593 ); |
|
594 |
|
595 sub decoupleUsedIn |
|
596 { |
|
597 my $self = shift; |
|
598 undef $self->[_UsedIn]; # was delete |
|
599 } |
|
600 |
|
601 sub getParentNode |
|
602 { |
|
603 $_[0]->[_Parent]; |
|
604 } |
|
605 |
|
606 sub appendChild |
|
607 { |
|
608 my ($self, $node) = @_; |
|
609 |
|
610 # REC 7473 |
|
611 if ($XML::DOM::SafeMode) |
|
612 { |
|
613 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
614 "node is ReadOnly") |
|
615 if $self->isReadOnly; |
|
616 } |
|
617 |
|
618 my $doc = $self->[_Doc]; |
|
619 |
|
620 if ($node->isDocumentFragmentNode) |
|
621 { |
|
622 if ($XML::DOM::SafeMode) |
|
623 { |
|
624 for my $n (@{$node->[_C]}) |
|
625 { |
|
626 croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR, |
|
627 "nodes belong to different documents") |
|
628 if $doc != $n->[_Doc]; |
|
629 |
|
630 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
631 "node is ancestor of parent node") |
|
632 if $n->isAncestor ($self); |
|
633 |
|
634 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
635 "bad node type") |
|
636 if $self->rejectChild ($n); |
|
637 } |
|
638 } |
|
639 |
|
640 my @list = @{$node->[_C]}; # don't try to compress this |
|
641 for my $n (@list) |
|
642 { |
|
643 $n->setParentNode ($self); |
|
644 } |
|
645 push @{$self->[_C]}, @list; |
|
646 } |
|
647 else |
|
648 { |
|
649 if ($XML::DOM::SafeMode) |
|
650 { |
|
651 croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR, |
|
652 "nodes belong to different documents") |
|
653 if $doc != $node->[_Doc]; |
|
654 |
|
655 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
656 "node is ancestor of parent node") |
|
657 if $node->isAncestor ($self); |
|
658 |
|
659 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
660 "bad node type") |
|
661 if $self->rejectChild ($node); |
|
662 } |
|
663 $node->setParentNode ($self); |
|
664 push @{$self->[_C]}, $node; |
|
665 } |
|
666 $node; |
|
667 } |
|
668 |
|
669 sub getChildNodes |
|
670 { |
|
671 # NOTE: if node can't have children, $self->[_C] is undef. |
|
672 my $kids = $_[0]->[_C]; |
|
673 |
|
674 # Return a list if called in list context. |
|
675 wantarray ? (defined ($kids) ? @{ $kids } : ()) : |
|
676 (defined ($kids) ? $kids : $XML::DOM::NodeList::EMPTY); |
|
677 } |
|
678 |
|
679 sub hasChildNodes |
|
680 { |
|
681 my $kids = $_[0]->[_C]; |
|
682 defined ($kids) && @$kids > 0; |
|
683 } |
|
684 |
|
685 # This method is overriden in Document |
|
686 sub getOwnerDocument |
|
687 { |
|
688 $_[0]->[_Doc]; |
|
689 } |
|
690 |
|
691 sub getFirstChild |
|
692 { |
|
693 my $kids = $_[0]->[_C]; |
|
694 defined $kids ? $kids->[0] : undef; |
|
695 } |
|
696 |
|
697 sub getLastChild |
|
698 { |
|
699 my $kids = $_[0]->[_C]; |
|
700 defined $kids ? $kids->[-1] : undef; |
|
701 } |
|
702 |
|
703 sub getPreviousSibling |
|
704 { |
|
705 my $self = shift; |
|
706 |
|
707 my $pa = $self->[_Parent]; |
|
708 return undef unless $pa; |
|
709 my $index = $pa->getChildIndex ($self); |
|
710 return undef unless $index; |
|
711 |
|
712 $pa->getChildAtIndex ($index - 1); |
|
713 } |
|
714 |
|
715 sub getNextSibling |
|
716 { |
|
717 my $self = shift; |
|
718 |
|
719 my $pa = $self->[_Parent]; |
|
720 return undef unless $pa; |
|
721 |
|
722 $pa->getChildAtIndex ($pa->getChildIndex ($self) + 1); |
|
723 } |
|
724 |
|
725 sub insertBefore |
|
726 { |
|
727 my ($self, $node, $refNode) = @_; |
|
728 |
|
729 return $self->appendChild ($node) unless $refNode; # append at the end |
|
730 |
|
731 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
732 "node is ReadOnly") |
|
733 if $self->isReadOnly; |
|
734 |
|
735 my @nodes = ($node); |
|
736 @nodes = @{$node->[_C]} |
|
737 if $node->getNodeType == DOCUMENT_FRAGMENT_NODE; |
|
738 |
|
739 my $doc = $self->[_Doc]; |
|
740 |
|
741 for my $n (@nodes) |
|
742 { |
|
743 croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR, |
|
744 "nodes belong to different documents") |
|
745 if $doc != $n->[_Doc]; |
|
746 |
|
747 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
748 "node is ancestor of parent node") |
|
749 if $n->isAncestor ($self); |
|
750 |
|
751 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
752 "bad node type") |
|
753 if $self->rejectChild ($n); |
|
754 } |
|
755 my $index = $self->getChildIndex ($refNode); |
|
756 |
|
757 croak new XML::DOM::DOMException (NOT_FOUND_ERR, |
|
758 "reference node not found") |
|
759 if $index == -1; |
|
760 |
|
761 for my $n (@nodes) |
|
762 { |
|
763 $n->setParentNode ($self); |
|
764 } |
|
765 |
|
766 splice (@{$self->[_C]}, $index, 0, @nodes); |
|
767 $node; |
|
768 } |
|
769 |
|
770 sub replaceChild |
|
771 { |
|
772 my ($self, $node, $refNode) = @_; |
|
773 |
|
774 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
775 "node is ReadOnly") |
|
776 if $self->isReadOnly; |
|
777 |
|
778 my @nodes = ($node); |
|
779 @nodes = @{$node->[_C]} |
|
780 if $node->getNodeType == DOCUMENT_FRAGMENT_NODE; |
|
781 |
|
782 for my $n (@nodes) |
|
783 { |
|
784 croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR, |
|
785 "nodes belong to different documents") |
|
786 if $self->[_Doc] != $n->[_Doc]; |
|
787 |
|
788 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
789 "node is ancestor of parent node") |
|
790 if $n->isAncestor ($self); |
|
791 |
|
792 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
793 "bad node type") |
|
794 if $self->rejectChild ($n); |
|
795 } |
|
796 |
|
797 my $index = $self->getChildIndex ($refNode); |
|
798 croak new XML::DOM::DOMException (NOT_FOUND_ERR, |
|
799 "reference node not found") |
|
800 if $index == -1; |
|
801 |
|
802 for my $n (@nodes) |
|
803 { |
|
804 $n->setParentNode ($self); |
|
805 } |
|
806 splice (@{$self->[_C]}, $index, 1, @nodes); |
|
807 |
|
808 $refNode->removeChildHoodMemories; |
|
809 $refNode; |
|
810 } |
|
811 |
|
812 sub removeChild |
|
813 { |
|
814 my ($self, $node) = @_; |
|
815 |
|
816 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
817 "node is ReadOnly") |
|
818 if $self->isReadOnly; |
|
819 |
|
820 my $index = $self->getChildIndex ($node); |
|
821 |
|
822 croak new XML::DOM::DOMException (NOT_FOUND_ERR, |
|
823 "reference node not found") |
|
824 if $index == -1; |
|
825 |
|
826 splice (@{$self->[_C]}, $index, 1, ()); |
|
827 |
|
828 $node->removeChildHoodMemories; |
|
829 $node; |
|
830 } |
|
831 |
|
832 # Merge all subsequent Text nodes in this subtree |
|
833 sub normalize |
|
834 { |
|
835 my ($self) = shift; |
|
836 my $prev = undef; # previous Text node |
|
837 |
|
838 return unless defined $self->[_C]; |
|
839 |
|
840 my @nodes = @{$self->[_C]}; |
|
841 my $i = 0; |
|
842 my $n = @nodes; |
|
843 while ($i < $n) |
|
844 { |
|
845 my $node = $self->getChildAtIndex($i); |
|
846 my $type = $node->getNodeType; |
|
847 |
|
848 if (defined $prev) |
|
849 { |
|
850 # It should not merge CDATASections. Dom Spec says: |
|
851 # Adjacent CDATASections nodes are not merged by use |
|
852 # of the Element.normalize() method. |
|
853 if ($type == TEXT_NODE) |
|
854 { |
|
855 $prev->appendData ($node->getData); |
|
856 $self->removeChild ($node); |
|
857 $i--; |
|
858 $n--; |
|
859 } |
|
860 else |
|
861 { |
|
862 $prev = undef; |
|
863 if ($type == ELEMENT_NODE) |
|
864 { |
|
865 $node->normalize; |
|
866 if (defined $node->[_A]) |
|
867 { |
|
868 for my $attr (@{$node->[_A]->getValues}) |
|
869 { |
|
870 $attr->normalize; |
|
871 } |
|
872 } |
|
873 } |
|
874 } |
|
875 } |
|
876 else |
|
877 { |
|
878 if ($type == TEXT_NODE) |
|
879 { |
|
880 $prev = $node; |
|
881 } |
|
882 elsif ($type == ELEMENT_NODE) |
|
883 { |
|
884 $node->normalize; |
|
885 if (defined $node->[_A]) |
|
886 { |
|
887 for my $attr (@{$node->[_A]->getValues}) |
|
888 { |
|
889 $attr->normalize; |
|
890 } |
|
891 } |
|
892 } |
|
893 } |
|
894 $i++; |
|
895 } |
|
896 } |
|
897 |
|
898 # |
|
899 # Return all Element nodes in the subtree that have the specified tagName. |
|
900 # If tagName is "*", all Element nodes are returned. |
|
901 # NOTE: the DOM Spec does not specify a 3rd or 4th parameter |
|
902 # |
|
903 sub getElementsByTagName |
|
904 { |
|
905 my ($self, $tagName, $recurse, $list) = @_; |
|
906 $recurse = 1 unless defined $recurse; |
|
907 $list = (wantarray ? [] : new XML::DOM::NodeList) unless defined $list; |
|
908 |
|
909 return unless defined $self->[_C]; |
|
910 |
|
911 # preorder traversal: check parent node first |
|
912 for my $kid (@{$self->[_C]}) |
|
913 { |
|
914 if ($kid->isElementNode) |
|
915 { |
|
916 if ($tagName eq "*" || $tagName eq $kid->getTagName) |
|
917 { |
|
918 push @{$list}, $kid; |
|
919 } |
|
920 $kid->getElementsByTagName ($tagName, $recurse, $list) if $recurse; |
|
921 } |
|
922 } |
|
923 wantarray ? @{ $list } : $list; |
|
924 } |
|
925 |
|
926 sub getNodeValue |
|
927 { |
|
928 undef; |
|
929 } |
|
930 |
|
931 sub setNodeValue |
|
932 { |
|
933 # no-op |
|
934 } |
|
935 |
|
936 # |
|
937 # Redefined by XML::DOM::Element |
|
938 # |
|
939 sub getAttributes |
|
940 { |
|
941 undef; |
|
942 } |
|
943 |
|
944 #------------------------------------------------------------ |
|
945 # Extra method implementations |
|
946 |
|
947 sub setOwnerDocument |
|
948 { |
|
949 my ($self, $doc) = @_; |
|
950 $self->[_Doc] = $doc; |
|
951 |
|
952 return unless defined $self->[_C]; |
|
953 |
|
954 for my $kid (@{$self->[_C]}) |
|
955 { |
|
956 $kid->setOwnerDocument ($doc); |
|
957 } |
|
958 } |
|
959 |
|
960 sub cloneChildren |
|
961 { |
|
962 my ($self, $node, $deep) = @_; |
|
963 return unless $deep; |
|
964 |
|
965 return unless defined $self->[_C]; |
|
966 |
|
967 local $XML::DOM::IgnoreReadOnly = 1; |
|
968 |
|
969 for my $kid (@{$node->[_C]}) |
|
970 { |
|
971 my $newNode = $kid->cloneNode ($deep); |
|
972 push @{$self->[_C]}, $newNode; |
|
973 $newNode->setParentNode ($self); |
|
974 } |
|
975 } |
|
976 |
|
977 # |
|
978 # For internal use only! |
|
979 # |
|
980 sub removeChildHoodMemories |
|
981 { |
|
982 my ($self) = @_; |
|
983 |
|
984 undef $self->[_Parent]; # was delete |
|
985 } |
|
986 |
|
987 # |
|
988 # Remove circular dependencies. The Node and its children should |
|
989 # not be used afterwards. |
|
990 # |
|
991 sub dispose |
|
992 { |
|
993 my $self = shift; |
|
994 |
|
995 $self->removeChildHoodMemories; |
|
996 |
|
997 if (defined $self->[_C]) |
|
998 { |
|
999 $self->[_C]->dispose; |
|
1000 undef $self->[_C]; # was delete |
|
1001 } |
|
1002 undef $self->[_Doc]; # was delete |
|
1003 } |
|
1004 |
|
1005 # |
|
1006 # For internal use only! |
|
1007 # |
|
1008 sub setParentNode |
|
1009 { |
|
1010 my ($self, $parent) = @_; |
|
1011 |
|
1012 # REC 7473 |
|
1013 my $oldParent = $self->[_Parent]; |
|
1014 if (defined $oldParent) |
|
1015 { |
|
1016 # remove from current parent |
|
1017 my $index = $oldParent->getChildIndex ($self); |
|
1018 |
|
1019 # NOTE: we don't have to check if [_C] is defined, |
|
1020 # because were removing a child here! |
|
1021 splice (@{$oldParent->[_C]}, $index, 1, ()); |
|
1022 |
|
1023 $self->removeChildHoodMemories; |
|
1024 } |
|
1025 $self->[_Parent] = $parent; |
|
1026 } |
|
1027 |
|
1028 # |
|
1029 # This function can return 3 values: |
|
1030 # 1: always readOnly |
|
1031 # 0: never readOnly |
|
1032 # undef: depends on parent node |
|
1033 # |
|
1034 # Returns 1 for DocumentType, Notation, Entity, EntityReference, Attlist, |
|
1035 # ElementDecl, AttDef. |
|
1036 # The first 4 are readOnly according to the DOM Spec, the others are always |
|
1037 # children of DocumentType. (Naturally, children of a readOnly node have to be |
|
1038 # readOnly as well...) |
|
1039 # These nodes are always readOnly regardless of who their ancestors are. |
|
1040 # Other nodes, e.g. Comment, are readOnly only if their parent is readOnly, |
|
1041 # which basically means that one of its ancestors has to be one of the |
|
1042 # aforementioned node types. |
|
1043 # Document and DocumentFragment return 0 for obvious reasons. |
|
1044 # Attr, Element, CDATASection, Text return 0. The DOM spec says that they can |
|
1045 # be children of an Entity, but I don't think that that's possible |
|
1046 # with the current XML::Parser. |
|
1047 # Attr uses a {ReadOnly} property, which is only set if it's part of a AttDef. |
|
1048 # Always returns 0 if ignoreReadOnly is set. |
|
1049 # |
|
1050 sub isReadOnly |
|
1051 { |
|
1052 # default implementation for Nodes that are always readOnly |
|
1053 ! $XML::DOM::IgnoreReadOnly; |
|
1054 } |
|
1055 |
|
1056 sub rejectChild |
|
1057 { |
|
1058 1; |
|
1059 } |
|
1060 |
|
1061 sub getNodeTypeName |
|
1062 { |
|
1063 $NodeNames[$_[0]->getNodeType]; |
|
1064 } |
|
1065 |
|
1066 sub getChildIndex |
|
1067 { |
|
1068 my ($self, $node) = @_; |
|
1069 my $i = 0; |
|
1070 |
|
1071 return -1 unless defined $self->[_C]; |
|
1072 |
|
1073 for my $kid (@{$self->[_C]}) |
|
1074 { |
|
1075 return $i if $kid == $node; |
|
1076 $i++; |
|
1077 } |
|
1078 -1; |
|
1079 } |
|
1080 |
|
1081 sub getChildAtIndex |
|
1082 { |
|
1083 my $kids = $_[0]->[_C]; |
|
1084 defined ($kids) ? $kids->[$_[1]] : undef; |
|
1085 } |
|
1086 |
|
1087 sub isAncestor |
|
1088 { |
|
1089 my ($self, $node) = @_; |
|
1090 |
|
1091 do |
|
1092 { |
|
1093 return 1 if $self == $node; |
|
1094 $node = $node->[_Parent]; |
|
1095 } |
|
1096 while (defined $node); |
|
1097 |
|
1098 0; |
|
1099 } |
|
1100 |
|
1101 # |
|
1102 # Added for optimization. Overriden in XML::DOM::Text |
|
1103 # |
|
1104 sub isTextNode |
|
1105 { |
|
1106 0; |
|
1107 } |
|
1108 |
|
1109 # |
|
1110 # Added for optimization. Overriden in XML::DOM::DocumentFragment |
|
1111 # |
|
1112 sub isDocumentFragmentNode |
|
1113 { |
|
1114 0; |
|
1115 } |
|
1116 |
|
1117 # |
|
1118 # Added for optimization. Overriden in XML::DOM::Element |
|
1119 # |
|
1120 sub isElementNode |
|
1121 { |
|
1122 0; |
|
1123 } |
|
1124 |
|
1125 # |
|
1126 # Add a Text node with the specified value or append the text to the |
|
1127 # previous Node if it is a Text node. |
|
1128 # |
|
1129 sub addText |
|
1130 { |
|
1131 # REC 9456 (if it was called) |
|
1132 my ($self, $str) = @_; |
|
1133 |
|
1134 my $node = ${$self->[_C]}[-1]; # $self->getLastChild |
|
1135 |
|
1136 if (defined ($node) && $node->isTextNode) |
|
1137 { |
|
1138 # REC 5475 (if it was called) |
|
1139 $node->appendData ($str); |
|
1140 } |
|
1141 else |
|
1142 { |
|
1143 $node = $self->[_Doc]->createTextNode ($str); |
|
1144 $self->appendChild ($node); |
|
1145 } |
|
1146 $node; |
|
1147 } |
|
1148 |
|
1149 # |
|
1150 # Add a CDATASection node with the specified value or append the text to the |
|
1151 # previous Node if it is a CDATASection node. |
|
1152 # |
|
1153 sub addCDATA |
|
1154 { |
|
1155 my ($self, $str) = @_; |
|
1156 |
|
1157 my $node = ${$self->[_C]}[-1]; # $self->getLastChild |
|
1158 |
|
1159 if (defined ($node) && $node->getNodeType == CDATA_SECTION_NODE) |
|
1160 { |
|
1161 $node->appendData ($str); |
|
1162 } |
|
1163 else |
|
1164 { |
|
1165 $node = $self->[_Doc]->createCDATASection ($str); |
|
1166 $self->appendChild ($node); |
|
1167 } |
|
1168 $node; |
|
1169 } |
|
1170 |
|
1171 sub removeChildNodes |
|
1172 { |
|
1173 my $self = shift; |
|
1174 |
|
1175 my $cref = $self->[_C]; |
|
1176 return unless defined $cref; |
|
1177 |
|
1178 my $kid; |
|
1179 while ($kid = pop @{$cref}) |
|
1180 { |
|
1181 undef $kid->[_Parent]; # was delete |
|
1182 } |
|
1183 } |
|
1184 |
|
1185 sub toString |
|
1186 { |
|
1187 my $self = shift; |
|
1188 my $pr = $XML::DOM::PrintToString::Singleton; |
|
1189 $pr->reset; |
|
1190 $self->print ($pr); |
|
1191 $pr->toString; |
|
1192 } |
|
1193 |
|
1194 sub to_sax |
|
1195 { |
|
1196 my $self = shift; |
|
1197 unshift @_, 'Handler' if (@_ == 1); |
|
1198 my %h = @_; |
|
1199 |
|
1200 my $doch = exists ($h{DocumentHandler}) ? $h{DocumentHandler} |
|
1201 : $h{Handler}; |
|
1202 my $dtdh = exists ($h{DTDHandler}) ? $h{DTDHandler} |
|
1203 : $h{Handler}; |
|
1204 my $enth = exists ($h{EntityResolver}) ? $h{EntityResolver} |
|
1205 : $h{Handler}; |
|
1206 |
|
1207 $self->_to_sax ($doch, $dtdh, $enth); |
|
1208 } |
|
1209 |
|
1210 sub printToFile |
|
1211 { |
|
1212 my ($self, $fileName) = @_; |
|
1213 my $fh = new FileHandle ($fileName, "w") || |
|
1214 croak "printToFile - can't open output file $fileName"; |
|
1215 |
|
1216 $self->print ($fh); |
|
1217 $fh->close; |
|
1218 } |
|
1219 |
|
1220 # |
|
1221 # Use print to print to a FileHandle object (see printToFile code) |
|
1222 # |
|
1223 sub printToFileHandle |
|
1224 { |
|
1225 my ($self, $FH) = @_; |
|
1226 my $pr = new XML::DOM::PrintToFileHandle ($FH); |
|
1227 $self->print ($pr); |
|
1228 } |
|
1229 |
|
1230 # |
|
1231 # Used by AttDef::setDefault to convert unexpanded default attribute value |
|
1232 # |
|
1233 sub expandEntityRefs |
|
1234 { |
|
1235 my ($self, $str) = @_; |
|
1236 my $doctype = $self->[_Doc]->getDoctype; |
|
1237 |
|
1238 $str =~ s/&($XML::RegExp::Name|(#([0-9]+)|#x([0-9a-fA-F]+)));/ |
|
1239 defined($2) ? XML::DOM::XmlUtf8Encode ($3 || hex ($4)) |
|
1240 : expandEntityRef ($1, $doctype)/ego; |
|
1241 $str; |
|
1242 } |
|
1243 |
|
1244 sub expandEntityRef |
|
1245 { |
|
1246 my ($entity, $doctype) = @_; |
|
1247 |
|
1248 my $expanded = $XML::DOM::DefaultEntities{$entity}; |
|
1249 return $expanded if defined $expanded; |
|
1250 |
|
1251 $expanded = $doctype->getEntity ($entity); |
|
1252 return $expanded->getValue if (defined $expanded); |
|
1253 |
|
1254 #?? is this an error? |
|
1255 croak "Could not expand entity reference of [$entity]\n"; |
|
1256 # return "&$entity;"; # entity not found |
|
1257 } |
|
1258 |
|
1259 sub isHidden |
|
1260 { |
|
1261 $_[0]->[_Hidden]; |
|
1262 } |
|
1263 |
|
1264 ###################################################################### |
|
1265 package XML::DOM::Attr; |
|
1266 ###################################################################### |
|
1267 |
|
1268 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
1269 |
|
1270 BEGIN |
|
1271 { |
|
1272 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
1273 XML::DOM::def_fields ("Name Specified", "XML::DOM::Node"); |
|
1274 } |
|
1275 |
|
1276 use XML::DOM::DOMException; |
|
1277 use Carp; |
|
1278 |
|
1279 sub new |
|
1280 { |
|
1281 my ($class, $doc, $name, $value, $specified) = @_; |
|
1282 |
|
1283 if ($XML::DOM::SafeMode) |
|
1284 { |
|
1285 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
1286 "bad Attr name [$name]") |
|
1287 unless XML::DOM::isValidName ($name); |
|
1288 } |
|
1289 |
|
1290 my $self = bless [], $class; |
|
1291 |
|
1292 $self->[_Doc] = $doc; |
|
1293 $self->[_C] = new XML::DOM::NodeList; |
|
1294 $self->[_Name] = $name; |
|
1295 |
|
1296 if (defined $value) |
|
1297 { |
|
1298 $self->setValue ($value); |
|
1299 $self->[_Specified] = (defined $specified) ? $specified : 1; |
|
1300 } |
|
1301 else |
|
1302 { |
|
1303 $self->[_Specified] = 0; |
|
1304 } |
|
1305 $self; |
|
1306 } |
|
1307 |
|
1308 sub getNodeType |
|
1309 { |
|
1310 ATTRIBUTE_NODE; |
|
1311 } |
|
1312 |
|
1313 sub isSpecified |
|
1314 { |
|
1315 $_[0]->[_Specified]; |
|
1316 } |
|
1317 |
|
1318 sub getName |
|
1319 { |
|
1320 $_[0]->[_Name]; |
|
1321 } |
|
1322 |
|
1323 sub getValue |
|
1324 { |
|
1325 my $self = shift; |
|
1326 my $value = ""; |
|
1327 |
|
1328 for my $kid (@{$self->[_C]}) |
|
1329 { |
|
1330 $value .= $kid->getData; |
|
1331 } |
|
1332 $value; |
|
1333 } |
|
1334 |
|
1335 sub setValue |
|
1336 { |
|
1337 my ($self, $value) = @_; |
|
1338 |
|
1339 # REC 1147 |
|
1340 $self->removeChildNodes; |
|
1341 $self->appendChild ($self->[_Doc]->createTextNode ($value)); |
|
1342 $self->[_Specified] = 1; |
|
1343 } |
|
1344 |
|
1345 sub getNodeName |
|
1346 { |
|
1347 $_[0]->getName; |
|
1348 } |
|
1349 |
|
1350 sub getNodeValue |
|
1351 { |
|
1352 $_[0]->getValue; |
|
1353 } |
|
1354 |
|
1355 sub setNodeValue |
|
1356 { |
|
1357 $_[0]->setValue ($_[1]); |
|
1358 } |
|
1359 |
|
1360 sub cloneNode |
|
1361 { |
|
1362 my ($self) = @_; # parameter deep is ignored |
|
1363 |
|
1364 my $node = $self->[_Doc]->createAttribute ($self->getName); |
|
1365 $node->[_Specified] = $self->[_Specified]; |
|
1366 $node->[_ReadOnly] = 1 if $self->[_ReadOnly]; |
|
1367 |
|
1368 $node->cloneChildren ($self, 1); |
|
1369 $node; |
|
1370 } |
|
1371 |
|
1372 #------------------------------------------------------------ |
|
1373 # Extra method implementations |
|
1374 # |
|
1375 |
|
1376 sub isReadOnly |
|
1377 { |
|
1378 # ReadOnly property is set if it's part of a AttDef |
|
1379 ! $XML::DOM::IgnoreReadOnly && defined ($_[0]->[_ReadOnly]); |
|
1380 } |
|
1381 |
|
1382 sub print |
|
1383 { |
|
1384 my ($self, $FILE) = @_; |
|
1385 |
|
1386 my $name = $self->[_Name]; |
|
1387 |
|
1388 $FILE->print ("$name=\""); |
|
1389 for my $kid (@{$self->[_C]}) |
|
1390 { |
|
1391 if ($kid->getNodeType == TEXT_NODE) |
|
1392 { |
|
1393 $FILE->print (XML::DOM::encodeAttrValue ($kid->getData)); |
|
1394 } |
|
1395 else # ENTITY_REFERENCE_NODE |
|
1396 { |
|
1397 $kid->print ($FILE); |
|
1398 } |
|
1399 } |
|
1400 $FILE->print ("\""); |
|
1401 } |
|
1402 |
|
1403 sub rejectChild |
|
1404 { |
|
1405 my $t = $_[1]->getNodeType; |
|
1406 |
|
1407 $t != TEXT_NODE |
|
1408 && $t != ENTITY_REFERENCE_NODE; |
|
1409 } |
|
1410 |
|
1411 ###################################################################### |
|
1412 package XML::DOM::ProcessingInstruction; |
|
1413 ###################################################################### |
|
1414 |
|
1415 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
1416 BEGIN |
|
1417 { |
|
1418 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
1419 XML::DOM::def_fields ("Target Data", "XML::DOM::Node"); |
|
1420 } |
|
1421 |
|
1422 use XML::DOM::DOMException; |
|
1423 use Carp; |
|
1424 |
|
1425 sub new |
|
1426 { |
|
1427 my ($class, $doc, $target, $data, $hidden) = @_; |
|
1428 |
|
1429 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
1430 "bad ProcessingInstruction Target [$target]") |
|
1431 unless (XML::DOM::isValidName ($target) && $target !~ /^xml$/io); |
|
1432 |
|
1433 my $self = bless [], $class; |
|
1434 |
|
1435 $self->[_Doc] = $doc; |
|
1436 $self->[_Target] = $target; |
|
1437 $self->[_Data] = $data; |
|
1438 $self->[_Hidden] = $hidden; |
|
1439 $self; |
|
1440 } |
|
1441 |
|
1442 sub getNodeType |
|
1443 { |
|
1444 PROCESSING_INSTRUCTION_NODE; |
|
1445 } |
|
1446 |
|
1447 sub getTarget |
|
1448 { |
|
1449 $_[0]->[_Target]; |
|
1450 } |
|
1451 |
|
1452 sub getData |
|
1453 { |
|
1454 $_[0]->[_Data]; |
|
1455 } |
|
1456 |
|
1457 sub setData |
|
1458 { |
|
1459 my ($self, $data) = @_; |
|
1460 |
|
1461 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
1462 "node is ReadOnly") |
|
1463 if $self->isReadOnly; |
|
1464 |
|
1465 $self->[_Data] = $data; |
|
1466 } |
|
1467 |
|
1468 sub getNodeName |
|
1469 { |
|
1470 $_[0]->[_Target]; |
|
1471 } |
|
1472 |
|
1473 # |
|
1474 # Same as getData |
|
1475 # |
|
1476 sub getNodeValue |
|
1477 { |
|
1478 $_[0]->[_Data]; |
|
1479 } |
|
1480 |
|
1481 sub setNodeValue |
|
1482 { |
|
1483 $_[0]->setData ($_[1]); |
|
1484 } |
|
1485 |
|
1486 sub cloneNode |
|
1487 { |
|
1488 my $self = shift; |
|
1489 $self->[_Doc]->createProcessingInstruction ($self->getTarget, |
|
1490 $self->getData, |
|
1491 $self->isHidden); |
|
1492 } |
|
1493 |
|
1494 #------------------------------------------------------------ |
|
1495 # Extra method implementations |
|
1496 |
|
1497 sub isReadOnly |
|
1498 { |
|
1499 return 0 if $XML::DOM::IgnoreReadOnly; |
|
1500 |
|
1501 my $pa = $_[0]->[_Parent]; |
|
1502 defined ($pa) ? $pa->isReadOnly : 0; |
|
1503 } |
|
1504 |
|
1505 sub print |
|
1506 { |
|
1507 my ($self, $FILE) = @_; |
|
1508 |
|
1509 $FILE->print ("<?"); |
|
1510 $FILE->print ($self->[_Target]); |
|
1511 $FILE->print (" "); |
|
1512 $FILE->print (XML::DOM::encodeProcessingInstruction ($self->[_Data])); |
|
1513 $FILE->print ("?>"); |
|
1514 } |
|
1515 |
|
1516 ###################################################################### |
|
1517 package XML::DOM::Notation; |
|
1518 ###################################################################### |
|
1519 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
1520 |
|
1521 BEGIN |
|
1522 { |
|
1523 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
1524 XML::DOM::def_fields ("Name Base SysId PubId", "XML::DOM::Node"); |
|
1525 } |
|
1526 |
|
1527 use XML::DOM::DOMException; |
|
1528 use Carp; |
|
1529 |
|
1530 sub new |
|
1531 { |
|
1532 my ($class, $doc, $name, $base, $sysId, $pubId, $hidden) = @_; |
|
1533 |
|
1534 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
1535 "bad Notation Name [$name]") |
|
1536 unless XML::DOM::isValidName ($name); |
|
1537 |
|
1538 my $self = bless [], $class; |
|
1539 |
|
1540 $self->[_Doc] = $doc; |
|
1541 $self->[_Name] = $name; |
|
1542 $self->[_Base] = $base; |
|
1543 $self->[_SysId] = $sysId; |
|
1544 $self->[_PubId] = $pubId; |
|
1545 $self->[_Hidden] = $hidden; |
|
1546 $self; |
|
1547 } |
|
1548 |
|
1549 sub getNodeType |
|
1550 { |
|
1551 NOTATION_NODE; |
|
1552 } |
|
1553 |
|
1554 sub getPubId |
|
1555 { |
|
1556 $_[0]->[_PubId]; |
|
1557 } |
|
1558 |
|
1559 sub setPubId |
|
1560 { |
|
1561 $_[0]->[_PubId] = $_[1]; |
|
1562 } |
|
1563 |
|
1564 sub getSysId |
|
1565 { |
|
1566 $_[0]->[_SysId]; |
|
1567 } |
|
1568 |
|
1569 sub setSysId |
|
1570 { |
|
1571 $_[0]->[_SysId] = $_[1]; |
|
1572 } |
|
1573 |
|
1574 sub getName |
|
1575 { |
|
1576 $_[0]->[_Name]; |
|
1577 } |
|
1578 |
|
1579 sub setName |
|
1580 { |
|
1581 $_[0]->[_Name] = $_[1]; |
|
1582 } |
|
1583 |
|
1584 sub getBase |
|
1585 { |
|
1586 $_[0]->[_Base]; |
|
1587 } |
|
1588 |
|
1589 sub getNodeName |
|
1590 { |
|
1591 $_[0]->[_Name]; |
|
1592 } |
|
1593 |
|
1594 sub print |
|
1595 { |
|
1596 my ($self, $FILE) = @_; |
|
1597 |
|
1598 my $name = $self->[_Name]; |
|
1599 my $sysId = $self->[_SysId]; |
|
1600 my $pubId = $self->[_PubId]; |
|
1601 |
|
1602 $FILE->print ("<!NOTATION $name "); |
|
1603 |
|
1604 if (defined $pubId) |
|
1605 { |
|
1606 $FILE->print (" PUBLIC \"$pubId\""); |
|
1607 } |
|
1608 if (defined $sysId) |
|
1609 { |
|
1610 $FILE->print (" SYSTEM \"$sysId\""); |
|
1611 } |
|
1612 $FILE->print (">"); |
|
1613 } |
|
1614 |
|
1615 sub cloneNode |
|
1616 { |
|
1617 my ($self) = @_; |
|
1618 $self->[_Doc]->createNotation ($self->[_Name], $self->[_Base], |
|
1619 $self->[_SysId], $self->[_PubId], |
|
1620 $self->[_Hidden]); |
|
1621 } |
|
1622 |
|
1623 sub to_expat |
|
1624 { |
|
1625 my ($self, $iter) = @_; |
|
1626 $iter->Notation ($self->getName, $self->getBase, |
|
1627 $self->getSysId, $self->getPubId); |
|
1628 } |
|
1629 |
|
1630 sub _to_sax |
|
1631 { |
|
1632 my ($self, $doch, $dtdh, $enth) = @_; |
|
1633 $dtdh->notation_decl ( { Name => $self->getName, |
|
1634 Base => $self->getBase, |
|
1635 SystemId => $self->getSysId, |
|
1636 PublicId => $self->getPubId }); |
|
1637 } |
|
1638 |
|
1639 ###################################################################### |
|
1640 package XML::DOM::Entity; |
|
1641 ###################################################################### |
|
1642 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
1643 |
|
1644 BEGIN |
|
1645 { |
|
1646 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
1647 XML::DOM::def_fields ("NotationName Parameter Value Ndata SysId PubId", "XML::DOM::Node"); |
|
1648 } |
|
1649 |
|
1650 use XML::DOM::DOMException; |
|
1651 use Carp; |
|
1652 |
|
1653 sub new |
|
1654 { |
|
1655 my ($class, $doc, $par, $notationName, $value, $sysId, $pubId, $ndata, $hidden) = @_; |
|
1656 |
|
1657 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
1658 "bad Entity Name [$notationName]") |
|
1659 unless XML::DOM::isValidName ($notationName); |
|
1660 |
|
1661 my $self = bless [], $class; |
|
1662 |
|
1663 $self->[_Doc] = $doc; |
|
1664 $self->[_NotationName] = $notationName; |
|
1665 $self->[_Parameter] = $par; |
|
1666 $self->[_Value] = $value; |
|
1667 $self->[_Ndata] = $ndata; |
|
1668 $self->[_SysId] = $sysId; |
|
1669 $self->[_PubId] = $pubId; |
|
1670 $self->[_Hidden] = $hidden; |
|
1671 $self; |
|
1672 #?? maybe Value should be a Text node |
|
1673 } |
|
1674 |
|
1675 sub getNodeType |
|
1676 { |
|
1677 ENTITY_NODE; |
|
1678 } |
|
1679 |
|
1680 sub getPubId |
|
1681 { |
|
1682 $_[0]->[_PubId]; |
|
1683 } |
|
1684 |
|
1685 sub getSysId |
|
1686 { |
|
1687 $_[0]->[_SysId]; |
|
1688 } |
|
1689 |
|
1690 # Dom Spec says: |
|
1691 # For unparsed entities, the name of the notation for the |
|
1692 # entity. For parsed entities, this is null. |
|
1693 |
|
1694 #?? do we have unparsed entities? |
|
1695 sub getNotationName |
|
1696 { |
|
1697 $_[0]->[_NotationName]; |
|
1698 } |
|
1699 |
|
1700 sub getNodeName |
|
1701 { |
|
1702 $_[0]->[_NotationName]; |
|
1703 } |
|
1704 |
|
1705 sub cloneNode |
|
1706 { |
|
1707 my $self = shift; |
|
1708 $self->[_Doc]->createEntity ($self->[_Parameter], |
|
1709 $self->[_NotationName], $self->[_Value], |
|
1710 $self->[_SysId], $self->[_PubId], |
|
1711 $self->[_Ndata], $self->[_Hidden]); |
|
1712 } |
|
1713 |
|
1714 sub rejectChild |
|
1715 { |
|
1716 return 1; |
|
1717 #?? if value is split over subnodes, recode this section |
|
1718 # also add: C => new XML::DOM::NodeList, |
|
1719 |
|
1720 my $t = $_[1]; |
|
1721 |
|
1722 return $t == TEXT_NODE |
|
1723 || $t == ENTITY_REFERENCE_NODE |
|
1724 || $t == PROCESSING_INSTRUCTION_NODE |
|
1725 || $t == COMMENT_NODE |
|
1726 || $t == CDATA_SECTION_NODE |
|
1727 || $t == ELEMENT_NODE; |
|
1728 } |
|
1729 |
|
1730 sub getValue |
|
1731 { |
|
1732 $_[0]->[_Value]; |
|
1733 } |
|
1734 |
|
1735 sub isParameterEntity |
|
1736 { |
|
1737 $_[0]->[_Parameter]; |
|
1738 } |
|
1739 |
|
1740 sub getNdata |
|
1741 { |
|
1742 $_[0]->[_Ndata]; |
|
1743 } |
|
1744 |
|
1745 sub print |
|
1746 { |
|
1747 my ($self, $FILE) = @_; |
|
1748 |
|
1749 my $name = $self->[_NotationName]; |
|
1750 |
|
1751 my $par = $self->isParameterEntity ? "% " : ""; |
|
1752 |
|
1753 $FILE->print ("<!ENTITY $par$name"); |
|
1754 |
|
1755 my $value = $self->[_Value]; |
|
1756 my $sysId = $self->[_SysId]; |
|
1757 my $pubId = $self->[_PubId]; |
|
1758 my $ndata = $self->[_Ndata]; |
|
1759 |
|
1760 if (defined $value) |
|
1761 { |
|
1762 #?? Not sure what to do if it contains both single and double quote |
|
1763 $value = ($value =~ /\"/) ? "'$value'" : "\"$value\""; |
|
1764 $FILE->print (" $value"); |
|
1765 } |
|
1766 if (defined $pubId) |
|
1767 { |
|
1768 $FILE->print (" PUBLIC \"$pubId\""); |
|
1769 } |
|
1770 elsif (defined $sysId) |
|
1771 { |
|
1772 $FILE->print (" SYSTEM"); |
|
1773 } |
|
1774 |
|
1775 if (defined $sysId) |
|
1776 { |
|
1777 $FILE->print (" \"$sysId\""); |
|
1778 } |
|
1779 $FILE->print (" NDATA $ndata") if defined $ndata; |
|
1780 $FILE->print (">"); |
|
1781 } |
|
1782 |
|
1783 sub to_expat |
|
1784 { |
|
1785 my ($self, $iter) = @_; |
|
1786 my $name = ($self->isParameterEntity ? '%' : "") . $self->getNotationName; |
|
1787 $iter->Entity ($name, |
|
1788 $self->getValue, $self->getSysId, $self->getPubId, |
|
1789 $self->getNdata); |
|
1790 } |
|
1791 |
|
1792 sub _to_sax |
|
1793 { |
|
1794 my ($self, $doch, $dtdh, $enth) = @_; |
|
1795 my $name = ($self->isParameterEntity ? '%' : "") . $self->getNotationName; |
|
1796 $dtdh->entity_decl ( { Name => $name, |
|
1797 Value => $self->getValue, |
|
1798 SystemId => $self->getSysId, |
|
1799 PublicId => $self->getPubId, |
|
1800 Notation => $self->getNdata } ); |
|
1801 } |
|
1802 |
|
1803 ###################################################################### |
|
1804 package XML::DOM::EntityReference; |
|
1805 ###################################################################### |
|
1806 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
1807 |
|
1808 BEGIN |
|
1809 { |
|
1810 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
1811 XML::DOM::def_fields ("EntityName Parameter", "XML::DOM::Node"); |
|
1812 } |
|
1813 |
|
1814 use XML::DOM::DOMException; |
|
1815 use Carp; |
|
1816 |
|
1817 sub new |
|
1818 { |
|
1819 my ($class, $doc, $name, $parameter) = @_; |
|
1820 |
|
1821 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
1822 "bad Entity Name [$name] in EntityReference") |
|
1823 unless XML::DOM::isValidName ($name); |
|
1824 |
|
1825 my $self = bless [], $class; |
|
1826 |
|
1827 $self->[_Doc] = $doc; |
|
1828 $self->[_EntityName] = $name; |
|
1829 $self->[_Parameter] = ($parameter || 0); |
|
1830 $self; |
|
1831 } |
|
1832 |
|
1833 sub getNodeType |
|
1834 { |
|
1835 ENTITY_REFERENCE_NODE; |
|
1836 } |
|
1837 |
|
1838 sub getNodeName |
|
1839 { |
|
1840 $_[0]->[_EntityName]; |
|
1841 } |
|
1842 |
|
1843 #------------------------------------------------------------ |
|
1844 # Extra method implementations |
|
1845 |
|
1846 sub getEntityName |
|
1847 { |
|
1848 $_[0]->[_EntityName]; |
|
1849 } |
|
1850 |
|
1851 sub isParameterEntity |
|
1852 { |
|
1853 $_[0]->[_Parameter]; |
|
1854 } |
|
1855 |
|
1856 sub getData |
|
1857 { |
|
1858 my $self = shift; |
|
1859 my $name = $self->[_EntityName]; |
|
1860 my $parameter = $self->[_Parameter]; |
|
1861 |
|
1862 my $data = $self->[_Doc]->expandEntity ($name, $parameter); |
|
1863 |
|
1864 unless (defined $data) |
|
1865 { |
|
1866 #?? this is probably an error |
|
1867 my $pc = $parameter ? "%" : "&"; |
|
1868 $data = "$pc$name;"; |
|
1869 } |
|
1870 $data; |
|
1871 } |
|
1872 |
|
1873 sub print |
|
1874 { |
|
1875 my ($self, $FILE) = @_; |
|
1876 |
|
1877 my $name = $self->[_EntityName]; |
|
1878 |
|
1879 #?? or do we expand the entities? |
|
1880 |
|
1881 my $pc = $self->[_Parameter] ? "%" : "&"; |
|
1882 $FILE->print ("$pc$name;"); |
|
1883 } |
|
1884 |
|
1885 # Dom Spec says: |
|
1886 # [...] but if such an Entity exists, then |
|
1887 # the child list of the EntityReference node is the same as that of the |
|
1888 # Entity node. |
|
1889 # |
|
1890 # The resolution of the children of the EntityReference (the replacement |
|
1891 # value of the referenced Entity) may be lazily evaluated; actions by the |
|
1892 # user (such as calling the childNodes method on the EntityReference |
|
1893 # node) are assumed to trigger the evaluation. |
|
1894 sub getChildNodes |
|
1895 { |
|
1896 my $self = shift; |
|
1897 my $entity = $self->[_Doc]->getEntity ($self->[_EntityName]); |
|
1898 defined ($entity) ? $entity->getChildNodes : new XML::DOM::NodeList; |
|
1899 } |
|
1900 |
|
1901 sub cloneNode |
|
1902 { |
|
1903 my $self = shift; |
|
1904 $self->[_Doc]->createEntityReference ($self->[_EntityName], |
|
1905 $self->[_Parameter]); |
|
1906 } |
|
1907 |
|
1908 sub to_expat |
|
1909 { |
|
1910 my ($self, $iter) = @_; |
|
1911 $iter->EntityRef ($self->getEntityName, $self->isParameterEntity); |
|
1912 } |
|
1913 |
|
1914 sub _to_sax |
|
1915 { |
|
1916 my ($self, $doch, $dtdh, $enth) = @_; |
|
1917 my @par = $self->isParameterEntity ? (Parameter => 1) : (); |
|
1918 #?? not supported by PerlSAX: $self->isParameterEntity |
|
1919 |
|
1920 $doch->entity_reference ( { Name => $self->getEntityName, @par } ); |
|
1921 } |
|
1922 |
|
1923 # NOTE: an EntityReference can't really have children, so rejectChild |
|
1924 # is not reimplemented (i.e. it always returns 0.) |
|
1925 |
|
1926 ###################################################################### |
|
1927 package XML::DOM::AttDef; |
|
1928 ###################################################################### |
|
1929 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
1930 |
|
1931 BEGIN |
|
1932 { |
|
1933 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
1934 XML::DOM::def_fields ("Name Type Fixed Default Required Implied Quote", "XML::DOM::Node"); |
|
1935 } |
|
1936 |
|
1937 use XML::DOM::DOMException; |
|
1938 use Carp; |
|
1939 |
|
1940 #------------------------------------------------------------ |
|
1941 # Extra method implementations |
|
1942 |
|
1943 # AttDef is not part of DOM Spec |
|
1944 sub new |
|
1945 { |
|
1946 my ($class, $doc, $name, $attrType, $default, $fixed, $hidden) = @_; |
|
1947 |
|
1948 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
1949 "bad Attr name in AttDef [$name]") |
|
1950 unless XML::DOM::isValidName ($name); |
|
1951 |
|
1952 my $self = bless [], $class; |
|
1953 |
|
1954 $self->[_Doc] = $doc; |
|
1955 $self->[_Name] = $name; |
|
1956 $self->[_Type] = $attrType; |
|
1957 |
|
1958 if (defined $default) |
|
1959 { |
|
1960 if ($default eq "#REQUIRED") |
|
1961 { |
|
1962 $self->[_Required] = 1; |
|
1963 } |
|
1964 elsif ($default eq "#IMPLIED") |
|
1965 { |
|
1966 $self->[_Implied] = 1; |
|
1967 } |
|
1968 else |
|
1969 { |
|
1970 # strip off quotes - see Attlist handler in XML::Parser |
|
1971 $default =~ m#^(["'])(.*)['"]$#; |
|
1972 |
|
1973 $self->[_Quote] = $1; # keep track of the quote character |
|
1974 $self->[_Default] = $self->setDefault ($2); |
|
1975 |
|
1976 #?? should default value be decoded - what if it contains e.g. "&" |
|
1977 } |
|
1978 } |
|
1979 $self->[_Fixed] = $fixed if defined $fixed; |
|
1980 $self->[_Hidden] = $hidden if defined $hidden; |
|
1981 |
|
1982 $self; |
|
1983 } |
|
1984 |
|
1985 sub getNodeType |
|
1986 { |
|
1987 ATT_DEF_NODE; |
|
1988 } |
|
1989 |
|
1990 sub getName |
|
1991 { |
|
1992 $_[0]->[_Name]; |
|
1993 } |
|
1994 |
|
1995 # So it can be added to a NamedNodeMap |
|
1996 sub getNodeName |
|
1997 { |
|
1998 $_[0]->[_Name]; |
|
1999 } |
|
2000 |
|
2001 sub getType |
|
2002 { |
|
2003 $_[0]->[_Type]; |
|
2004 } |
|
2005 |
|
2006 sub setType |
|
2007 { |
|
2008 $_[0]->[_Type] = $_[1]; |
|
2009 } |
|
2010 |
|
2011 sub getDefault |
|
2012 { |
|
2013 $_[0]->[_Default]; |
|
2014 } |
|
2015 |
|
2016 sub setDefault |
|
2017 { |
|
2018 my ($self, $value) = @_; |
|
2019 |
|
2020 # specified=0, it's the default ! |
|
2021 my $attr = $self->[_Doc]->createAttribute ($self->[_Name], undef, 0); |
|
2022 $attr->[_ReadOnly] = 1; |
|
2023 |
|
2024 #?? this should be split over Text and EntityReference nodes, just like other |
|
2025 # Attr nodes - just expand the text for now |
|
2026 $value = $self->expandEntityRefs ($value); |
|
2027 $attr->addText ($value); |
|
2028 #?? reimplement in NoExpand mode! |
|
2029 |
|
2030 $attr; |
|
2031 } |
|
2032 |
|
2033 sub isFixed |
|
2034 { |
|
2035 $_[0]->[_Fixed] || 0; |
|
2036 } |
|
2037 |
|
2038 sub isRequired |
|
2039 { |
|
2040 $_[0]->[_Required] || 0; |
|
2041 } |
|
2042 |
|
2043 sub isImplied |
|
2044 { |
|
2045 $_[0]->[_Implied] || 0; |
|
2046 } |
|
2047 |
|
2048 sub print |
|
2049 { |
|
2050 my ($self, $FILE) = @_; |
|
2051 |
|
2052 my $name = $self->[_Name]; |
|
2053 my $type = $self->[_Type]; |
|
2054 my $fixed = $self->[_Fixed]; |
|
2055 my $default = $self->[_Default]; |
|
2056 |
|
2057 $FILE->print ("$name $type"); |
|
2058 $FILE->print (" #FIXED") if defined $fixed; |
|
2059 |
|
2060 if ($self->[_Required]) |
|
2061 { |
|
2062 $FILE->print (" #REQUIRED"); |
|
2063 } |
|
2064 elsif ($self->[_Implied]) |
|
2065 { |
|
2066 $FILE->print (" #IMPLIED"); |
|
2067 } |
|
2068 elsif (defined ($default)) |
|
2069 { |
|
2070 my $quote = $self->[_Quote]; |
|
2071 $FILE->print (" $quote"); |
|
2072 for my $kid (@{$default->[_C]}) |
|
2073 { |
|
2074 $kid->print ($FILE); |
|
2075 } |
|
2076 $FILE->print ($quote); |
|
2077 } |
|
2078 } |
|
2079 |
|
2080 sub getDefaultString |
|
2081 { |
|
2082 my $self = shift; |
|
2083 my $default; |
|
2084 |
|
2085 if ($self->[_Required]) |
|
2086 { |
|
2087 return "#REQUIRED"; |
|
2088 } |
|
2089 elsif ($self->[_Implied]) |
|
2090 { |
|
2091 return "#IMPLIED"; |
|
2092 } |
|
2093 elsif (defined ($default = $self->[_Default])) |
|
2094 { |
|
2095 my $quote = $self->[_Quote]; |
|
2096 $default = $default->toString; |
|
2097 return "$quote$default$quote"; |
|
2098 } |
|
2099 undef; |
|
2100 } |
|
2101 |
|
2102 sub cloneNode |
|
2103 { |
|
2104 my $self = shift; |
|
2105 my $node = new XML::DOM::AttDef ($self->[_Doc], $self->[_Name], $self->[_Type], |
|
2106 undef, $self->[_Fixed]); |
|
2107 |
|
2108 $node->[_Required] = 1 if $self->[_Required]; |
|
2109 $node->[_Implied] = 1 if $self->[_Implied]; |
|
2110 $node->[_Fixed] = $self->[_Fixed] if defined $self->[_Fixed]; |
|
2111 $node->[_Hidden] = $self->[_Hidden] if defined $self->[_Hidden]; |
|
2112 |
|
2113 if (defined $self->[_Default]) |
|
2114 { |
|
2115 $node->[_Default] = $self->[_Default]->cloneNode(1); |
|
2116 } |
|
2117 $node->[_Quote] = $self->[_Quote]; |
|
2118 |
|
2119 $node; |
|
2120 } |
|
2121 |
|
2122 sub setOwnerDocument |
|
2123 { |
|
2124 my ($self, $doc) = @_; |
|
2125 $self->SUPER::setOwnerDocument ($doc); |
|
2126 |
|
2127 if (defined $self->[_Default]) |
|
2128 { |
|
2129 $self->[_Default]->setOwnerDocument ($doc); |
|
2130 } |
|
2131 } |
|
2132 |
|
2133 ###################################################################### |
|
2134 package XML::DOM::AttlistDecl; |
|
2135 ###################################################################### |
|
2136 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
2137 |
|
2138 BEGIN |
|
2139 { |
|
2140 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
2141 import XML::DOM::AttDef qw{ :Fields }; |
|
2142 |
|
2143 XML::DOM::def_fields ("ElementName", "XML::DOM::Node"); |
|
2144 } |
|
2145 |
|
2146 use XML::DOM::DOMException; |
|
2147 use Carp; |
|
2148 |
|
2149 #------------------------------------------------------------ |
|
2150 # Extra method implementations |
|
2151 |
|
2152 # AttlistDecl is not part of the DOM Spec |
|
2153 sub new |
|
2154 { |
|
2155 my ($class, $doc, $name) = @_; |
|
2156 |
|
2157 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
2158 "bad Element TagName [$name] in AttlistDecl") |
|
2159 unless XML::DOM::isValidName ($name); |
|
2160 |
|
2161 my $self = bless [], $class; |
|
2162 |
|
2163 $self->[_Doc] = $doc; |
|
2164 $self->[_C] = new XML::DOM::NodeList; |
|
2165 $self->[_ReadOnly] = 1; |
|
2166 $self->[_ElementName] = $name; |
|
2167 |
|
2168 $self->[_A] = new XML::DOM::NamedNodeMap (Doc => $doc, |
|
2169 ReadOnly => 1, |
|
2170 Parent => $self); |
|
2171 |
|
2172 $self; |
|
2173 } |
|
2174 |
|
2175 sub getNodeType |
|
2176 { |
|
2177 ATTLIST_DECL_NODE; |
|
2178 } |
|
2179 |
|
2180 sub getName |
|
2181 { |
|
2182 $_[0]->[_ElementName]; |
|
2183 } |
|
2184 |
|
2185 sub getNodeName |
|
2186 { |
|
2187 $_[0]->[_ElementName]; |
|
2188 } |
|
2189 |
|
2190 sub getAttDef |
|
2191 { |
|
2192 my ($self, $attrName) = @_; |
|
2193 $self->[_A]->getNamedItem ($attrName); |
|
2194 } |
|
2195 |
|
2196 sub addAttDef |
|
2197 { |
|
2198 my ($self, $attrName, $type, $default, $fixed, $hidden) = @_; |
|
2199 my $node = $self->getAttDef ($attrName); |
|
2200 |
|
2201 if (defined $node) |
|
2202 { |
|
2203 # data will be ignored if already defined |
|
2204 my $elemName = $self->getName; |
|
2205 XML::DOM::warning ("multiple definitions of attribute $attrName for element $elemName, only first one is recognized"); |
|
2206 } |
|
2207 else |
|
2208 { |
|
2209 $node = new XML::DOM::AttDef ($self->[_Doc], $attrName, $type, |
|
2210 $default, $fixed, $hidden); |
|
2211 $self->[_A]->setNamedItem ($node); |
|
2212 } |
|
2213 $node; |
|
2214 } |
|
2215 |
|
2216 sub getDefaultAttrValue |
|
2217 { |
|
2218 my ($self, $attr) = @_; |
|
2219 my $attrNode = $self->getAttDef ($attr); |
|
2220 (defined $attrNode) ? $attrNode->getDefault : undef; |
|
2221 } |
|
2222 |
|
2223 sub cloneNode |
|
2224 { |
|
2225 my ($self, $deep) = @_; |
|
2226 my $node = $self->[_Doc]->createAttlistDecl ($self->[_ElementName]); |
|
2227 |
|
2228 $node->[_A] = $self->[_A]->cloneNode ($deep); |
|
2229 $node; |
|
2230 } |
|
2231 |
|
2232 sub setOwnerDocument |
|
2233 { |
|
2234 my ($self, $doc) = @_; |
|
2235 $self->SUPER::setOwnerDocument ($doc); |
|
2236 |
|
2237 $self->[_A]->setOwnerDocument ($doc); |
|
2238 } |
|
2239 |
|
2240 sub print |
|
2241 { |
|
2242 my ($self, $FILE) = @_; |
|
2243 |
|
2244 my $name = $self->getName; |
|
2245 my @attlist = @{$self->[_A]->getValues}; |
|
2246 |
|
2247 my $hidden = 1; |
|
2248 for my $att (@attlist) |
|
2249 { |
|
2250 unless ($att->[_Hidden]) |
|
2251 { |
|
2252 $hidden = 0; |
|
2253 last; |
|
2254 } |
|
2255 } |
|
2256 |
|
2257 unless ($hidden) |
|
2258 { |
|
2259 $FILE->print ("<!ATTLIST $name"); |
|
2260 |
|
2261 if (@attlist == 1) |
|
2262 { |
|
2263 $FILE->print (" "); |
|
2264 $attlist[0]->print ($FILE); |
|
2265 } |
|
2266 else |
|
2267 { |
|
2268 for my $attr (@attlist) |
|
2269 { |
|
2270 next if $attr->[_Hidden]; |
|
2271 |
|
2272 $FILE->print ("\x0A "); |
|
2273 $attr->print ($FILE); |
|
2274 } |
|
2275 } |
|
2276 $FILE->print (">"); |
|
2277 } |
|
2278 } |
|
2279 |
|
2280 sub to_expat |
|
2281 { |
|
2282 my ($self, $iter) = @_; |
|
2283 my $tag = $self->getName; |
|
2284 for my $a ($self->[_A]->getValues) |
|
2285 { |
|
2286 my $default = $a->isImplied ? '#IMPLIED' : |
|
2287 ($a->isRequired ? '#REQUIRED' : |
|
2288 ($a->[_Quote] . $a->getDefault->getValue . $a->[_Quote])); |
|
2289 |
|
2290 $iter->Attlist ($tag, $a->getName, $a->getType, $default, $a->isFixed); |
|
2291 } |
|
2292 } |
|
2293 |
|
2294 sub _to_sax |
|
2295 { |
|
2296 my ($self, $doch, $dtdh, $enth) = @_; |
|
2297 my $tag = $self->getName; |
|
2298 for my $a ($self->[_A]->getValues) |
|
2299 { |
|
2300 my $default = $a->isImplied ? '#IMPLIED' : |
|
2301 ($a->isRequired ? '#REQUIRED' : |
|
2302 ($a->[_Quote] . $a->getDefault->getValue . $a->[_Quote])); |
|
2303 |
|
2304 $dtdh->attlist_decl ({ ElementName => $tag, |
|
2305 AttributeName => $a->getName, |
|
2306 Type => $a->[_Type], |
|
2307 Default => $default, |
|
2308 Fixed => $a->isFixed }); |
|
2309 } |
|
2310 } |
|
2311 |
|
2312 ###################################################################### |
|
2313 package XML::DOM::ElementDecl; |
|
2314 ###################################################################### |
|
2315 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
2316 |
|
2317 BEGIN |
|
2318 { |
|
2319 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
2320 XML::DOM::def_fields ("Name Model", "XML::DOM::Node"); |
|
2321 } |
|
2322 |
|
2323 use XML::DOM::DOMException; |
|
2324 use Carp; |
|
2325 |
|
2326 |
|
2327 #------------------------------------------------------------ |
|
2328 # Extra method implementations |
|
2329 |
|
2330 # ElementDecl is not part of the DOM Spec |
|
2331 sub new |
|
2332 { |
|
2333 my ($class, $doc, $name, $model, $hidden) = @_; |
|
2334 |
|
2335 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
2336 "bad Element TagName [$name] in ElementDecl") |
|
2337 unless XML::DOM::isValidName ($name); |
|
2338 |
|
2339 my $self = bless [], $class; |
|
2340 |
|
2341 $self->[_Doc] = $doc; |
|
2342 $self->[_Name] = $name; |
|
2343 $self->[_ReadOnly] = 1; |
|
2344 $self->[_Model] = $model; |
|
2345 $self->[_Hidden] = $hidden; |
|
2346 $self; |
|
2347 } |
|
2348 |
|
2349 sub getNodeType |
|
2350 { |
|
2351 ELEMENT_DECL_NODE; |
|
2352 } |
|
2353 |
|
2354 sub getName |
|
2355 { |
|
2356 $_[0]->[_Name]; |
|
2357 } |
|
2358 |
|
2359 sub getNodeName |
|
2360 { |
|
2361 $_[0]->[_Name]; |
|
2362 } |
|
2363 |
|
2364 sub getModel |
|
2365 { |
|
2366 $_[0]->[_Model]; |
|
2367 } |
|
2368 |
|
2369 sub setModel |
|
2370 { |
|
2371 my ($self, $model) = @_; |
|
2372 |
|
2373 $self->[_Model] = $model; |
|
2374 } |
|
2375 |
|
2376 sub print |
|
2377 { |
|
2378 my ($self, $FILE) = @_; |
|
2379 |
|
2380 my $name = $self->[_Name]; |
|
2381 my $model = $self->[_Model]; |
|
2382 |
|
2383 $FILE->print ("<!ELEMENT $name $model>") |
|
2384 unless $self->[_Hidden]; |
|
2385 } |
|
2386 |
|
2387 sub cloneNode |
|
2388 { |
|
2389 my $self = shift; |
|
2390 $self->[_Doc]->createElementDecl ($self->[_Name], $self->[_Model], |
|
2391 $self->[_Hidden]); |
|
2392 } |
|
2393 |
|
2394 sub to_expat |
|
2395 { |
|
2396 #?? add support for Hidden?? (allover, also in _to_sax!!) |
|
2397 |
|
2398 my ($self, $iter) = @_; |
|
2399 $iter->Element ($self->getName, $self->getModel); |
|
2400 } |
|
2401 |
|
2402 sub _to_sax |
|
2403 { |
|
2404 my ($self, $doch, $dtdh, $enth) = @_; |
|
2405 $dtdh->element_decl ( { Name => $self->getName, |
|
2406 Model => $self->getModel } ); |
|
2407 } |
|
2408 |
|
2409 ###################################################################### |
|
2410 package XML::DOM::Element; |
|
2411 ###################################################################### |
|
2412 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
2413 |
|
2414 BEGIN |
|
2415 { |
|
2416 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
2417 XML::DOM::def_fields ("TagName", "XML::DOM::Node"); |
|
2418 } |
|
2419 |
|
2420 use XML::DOM::DOMException; |
|
2421 use XML::DOM::NamedNodeMap; |
|
2422 use Carp; |
|
2423 |
|
2424 sub new |
|
2425 { |
|
2426 my ($class, $doc, $tagName) = @_; |
|
2427 |
|
2428 if ($XML::DOM::SafeMode) |
|
2429 { |
|
2430 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
2431 "bad Element TagName [$tagName]") |
|
2432 unless XML::DOM::isValidName ($tagName); |
|
2433 } |
|
2434 |
|
2435 my $self = bless [], $class; |
|
2436 |
|
2437 $self->[_Doc] = $doc; |
|
2438 $self->[_C] = new XML::DOM::NodeList; |
|
2439 $self->[_TagName] = $tagName; |
|
2440 |
|
2441 # Now we're creating the NamedNodeMap only when needed (REC 2313 => 1147) |
|
2442 # $self->[_A] = new XML::DOM::NamedNodeMap (Doc => $doc, |
|
2443 # Parent => $self); |
|
2444 |
|
2445 $self; |
|
2446 } |
|
2447 |
|
2448 sub getNodeType |
|
2449 { |
|
2450 ELEMENT_NODE; |
|
2451 } |
|
2452 |
|
2453 sub getTagName |
|
2454 { |
|
2455 $_[0]->[_TagName]; |
|
2456 } |
|
2457 |
|
2458 sub getNodeName |
|
2459 { |
|
2460 $_[0]->[_TagName]; |
|
2461 } |
|
2462 |
|
2463 sub getAttributeNode |
|
2464 { |
|
2465 my ($self, $name) = @_; |
|
2466 return undef unless defined $self->[_A]; |
|
2467 |
|
2468 $self->getAttributes->{$name}; |
|
2469 } |
|
2470 |
|
2471 sub getAttribute |
|
2472 { |
|
2473 my ($self, $name) = @_; |
|
2474 my $attr = $self->getAttributeNode ($name); |
|
2475 (defined $attr) ? $attr->getValue : ""; |
|
2476 } |
|
2477 |
|
2478 sub setAttribute |
|
2479 { |
|
2480 my ($self, $name, $val) = @_; |
|
2481 |
|
2482 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
2483 "bad Attr Name [$name]") |
|
2484 unless XML::DOM::isValidName ($name); |
|
2485 |
|
2486 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
2487 "node is ReadOnly") |
|
2488 if $self->isReadOnly; |
|
2489 |
|
2490 my $node = $self->getAttributes->{$name}; |
|
2491 if (defined $node) |
|
2492 { |
|
2493 $node->setValue ($val); |
|
2494 } |
|
2495 else |
|
2496 { |
|
2497 $node = $self->[_Doc]->createAttribute ($name, $val); |
|
2498 $self->[_A]->setNamedItem ($node); |
|
2499 } |
|
2500 } |
|
2501 |
|
2502 sub setAttributeNode |
|
2503 { |
|
2504 my ($self, $node) = @_; |
|
2505 my $attr = $self->getAttributes; |
|
2506 my $name = $node->getNodeName; |
|
2507 |
|
2508 # REC 1147 |
|
2509 if ($XML::DOM::SafeMode) |
|
2510 { |
|
2511 croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR, |
|
2512 "nodes belong to different documents") |
|
2513 if $self->[_Doc] != $node->[_Doc]; |
|
2514 |
|
2515 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
2516 "node is ReadOnly") |
|
2517 if $self->isReadOnly; |
|
2518 |
|
2519 my $attrParent = $node->[_UsedIn]; |
|
2520 croak new XML::DOM::DOMException (INUSE_ATTRIBUTE_ERR, |
|
2521 "Attr is already used by another Element") |
|
2522 if (defined ($attrParent) && $attrParent != $attr); |
|
2523 } |
|
2524 |
|
2525 my $other = $attr->{$name}; |
|
2526 $attr->removeNamedItem ($name) if defined $other; |
|
2527 |
|
2528 $attr->setNamedItem ($node); |
|
2529 |
|
2530 $other; |
|
2531 } |
|
2532 |
|
2533 sub removeAttributeNode |
|
2534 { |
|
2535 my ($self, $node) = @_; |
|
2536 |
|
2537 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
2538 "node is ReadOnly") |
|
2539 if $self->isReadOnly; |
|
2540 |
|
2541 my $attr = $self->[_A]; |
|
2542 unless (defined $attr) |
|
2543 { |
|
2544 croak new XML::DOM::DOMException (NOT_FOUND_ERR); |
|
2545 return undef; |
|
2546 } |
|
2547 |
|
2548 my $name = $node->getNodeName; |
|
2549 my $attrNode = $attr->getNamedItem ($name); |
|
2550 |
|
2551 #?? should it croak if it's the default value? |
|
2552 croak new XML::DOM::DOMException (NOT_FOUND_ERR) |
|
2553 unless $node == $attrNode; |
|
2554 |
|
2555 # Not removing anything if it's the default value already |
|
2556 return undef unless $node->isSpecified; |
|
2557 |
|
2558 $attr->removeNamedItem ($name); |
|
2559 |
|
2560 # Substitute with default value if it's defined |
|
2561 my $default = $self->getDefaultAttrValue ($name); |
|
2562 if (defined $default) |
|
2563 { |
|
2564 local $XML::DOM::IgnoreReadOnly = 1; |
|
2565 |
|
2566 $default = $default->cloneNode (1); |
|
2567 $attr->setNamedItem ($default); |
|
2568 } |
|
2569 $node; |
|
2570 } |
|
2571 |
|
2572 sub removeAttribute |
|
2573 { |
|
2574 my ($self, $name) = @_; |
|
2575 my $attr = $self->[_A]; |
|
2576 unless (defined $attr) |
|
2577 { |
|
2578 croak new XML::DOM::DOMException (NOT_FOUND_ERR); |
|
2579 return; |
|
2580 } |
|
2581 |
|
2582 my $node = $attr->getNamedItem ($name); |
|
2583 if (defined $node) |
|
2584 { |
|
2585 #?? could use dispose() to remove circular references for gc, but what if |
|
2586 #?? somebody is referencing it? |
|
2587 $self->removeAttributeNode ($node); |
|
2588 } |
|
2589 } |
|
2590 |
|
2591 sub cloneNode |
|
2592 { |
|
2593 my ($self, $deep) = @_; |
|
2594 my $node = $self->[_Doc]->createElement ($self->getTagName); |
|
2595 |
|
2596 # Always clone the Attr nodes, even if $deep == 0 |
|
2597 if (defined $self->[_A]) |
|
2598 { |
|
2599 $node->[_A] = $self->[_A]->cloneNode (1); # deep=1 |
|
2600 $node->[_A]->setParentNode ($node); |
|
2601 } |
|
2602 |
|
2603 $node->cloneChildren ($self, $deep); |
|
2604 $node; |
|
2605 } |
|
2606 |
|
2607 sub getAttributes |
|
2608 { |
|
2609 $_[0]->[_A] ||= XML::DOM::NamedNodeMap->new (Doc => $_[0]->[_Doc], |
|
2610 Parent => $_[0]); |
|
2611 } |
|
2612 |
|
2613 #------------------------------------------------------------ |
|
2614 # Extra method implementations |
|
2615 |
|
2616 # Added for convenience |
|
2617 sub setTagName |
|
2618 { |
|
2619 my ($self, $tagName) = @_; |
|
2620 |
|
2621 croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR, |
|
2622 "bad Element TagName [$tagName]") |
|
2623 unless XML::DOM::isValidName ($tagName); |
|
2624 |
|
2625 $self->[_TagName] = $tagName; |
|
2626 } |
|
2627 |
|
2628 sub isReadOnly |
|
2629 { |
|
2630 0; |
|
2631 } |
|
2632 |
|
2633 # Added for optimization. |
|
2634 sub isElementNode |
|
2635 { |
|
2636 1; |
|
2637 } |
|
2638 |
|
2639 sub rejectChild |
|
2640 { |
|
2641 my $t = $_[1]->getNodeType; |
|
2642 |
|
2643 $t != TEXT_NODE |
|
2644 && $t != ENTITY_REFERENCE_NODE |
|
2645 && $t != PROCESSING_INSTRUCTION_NODE |
|
2646 && $t != COMMENT_NODE |
|
2647 && $t != CDATA_SECTION_NODE |
|
2648 && $t != ELEMENT_NODE; |
|
2649 } |
|
2650 |
|
2651 sub getDefaultAttrValue |
|
2652 { |
|
2653 my ($self, $attr) = @_; |
|
2654 $self->[_Doc]->getDefaultAttrValue ($self->[_TagName], $attr); |
|
2655 } |
|
2656 |
|
2657 sub dispose |
|
2658 { |
|
2659 my $self = shift; |
|
2660 |
|
2661 $self->[_A]->dispose if defined $self->[_A]; |
|
2662 $self->SUPER::dispose; |
|
2663 } |
|
2664 |
|
2665 sub setOwnerDocument |
|
2666 { |
|
2667 my ($self, $doc) = @_; |
|
2668 $self->SUPER::setOwnerDocument ($doc); |
|
2669 |
|
2670 $self->[_A]->setOwnerDocument ($doc) if defined $self->[_A]; |
|
2671 } |
|
2672 |
|
2673 sub print |
|
2674 { |
|
2675 my ($self, $FILE) = @_; |
|
2676 |
|
2677 my $name = $self->[_TagName]; |
|
2678 |
|
2679 $FILE->print ("<$name"); |
|
2680 |
|
2681 if (defined $self->[_A]) |
|
2682 { |
|
2683 for my $att (@{$self->[_A]->getValues}) |
|
2684 { |
|
2685 # skip un-specified (default) Attr nodes |
|
2686 if ($att->isSpecified) |
|
2687 { |
|
2688 $FILE->print (" "); |
|
2689 $att->print ($FILE); |
|
2690 } |
|
2691 } |
|
2692 } |
|
2693 |
|
2694 my @kids = @{$self->[_C]}; |
|
2695 if (@kids > 0) |
|
2696 { |
|
2697 $FILE->print (">"); |
|
2698 for my $kid (@kids) |
|
2699 { |
|
2700 $kid->print ($FILE); |
|
2701 } |
|
2702 $FILE->print ("</$name>"); |
|
2703 } |
|
2704 else |
|
2705 { |
|
2706 my $style = &$XML::DOM::TagStyle ($name, $self); |
|
2707 if ($style == 0) |
|
2708 { |
|
2709 $FILE->print ("/>"); |
|
2710 } |
|
2711 elsif ($style == 1) |
|
2712 { |
|
2713 $FILE->print ("></$name>"); |
|
2714 } |
|
2715 else |
|
2716 { |
|
2717 $FILE->print (" />"); |
|
2718 } |
|
2719 } |
|
2720 } |
|
2721 |
|
2722 sub check |
|
2723 { |
|
2724 my ($self, $checker) = @_; |
|
2725 die "Usage: \$xml_dom_elem->check (\$checker)" unless $checker; |
|
2726 |
|
2727 $checker->InitDomElem; |
|
2728 $self->to_expat ($checker); |
|
2729 $checker->FinalDomElem; |
|
2730 } |
|
2731 |
|
2732 sub to_expat |
|
2733 { |
|
2734 my ($self, $iter) = @_; |
|
2735 |
|
2736 my $tag = $self->getTagName; |
|
2737 $iter->Start ($tag); |
|
2738 |
|
2739 if (defined $self->[_A]) |
|
2740 { |
|
2741 for my $attr ($self->[_A]->getValues) |
|
2742 { |
|
2743 $iter->Attr ($tag, $attr->getName, $attr->getValue, $attr->isSpecified); |
|
2744 } |
|
2745 } |
|
2746 |
|
2747 $iter->EndAttr; |
|
2748 |
|
2749 for my $kid ($self->getChildNodes) |
|
2750 { |
|
2751 $kid->to_expat ($iter); |
|
2752 } |
|
2753 |
|
2754 $iter->End; |
|
2755 } |
|
2756 |
|
2757 sub _to_sax |
|
2758 { |
|
2759 my ($self, $doch, $dtdh, $enth) = @_; |
|
2760 |
|
2761 my $tag = $self->getTagName; |
|
2762 |
|
2763 my @attr = (); |
|
2764 my $attrOrder; |
|
2765 my $attrDefaulted; |
|
2766 |
|
2767 if (defined $self->[_A]) |
|
2768 { |
|
2769 my @spec = (); # names of specified attributes |
|
2770 my @unspec = (); # names of defaulted attributes |
|
2771 |
|
2772 for my $attr ($self->[_A]->getValues) |
|
2773 { |
|
2774 my $attrName = $attr->getName; |
|
2775 push @attr, $attrName, $attr->getValue; |
|
2776 if ($attr->isSpecified) |
|
2777 { |
|
2778 push @spec, $attrName; |
|
2779 } |
|
2780 else |
|
2781 { |
|
2782 push @unspec, $attrName; |
|
2783 } |
|
2784 } |
|
2785 $attrOrder = [ @spec, @unspec ]; |
|
2786 $attrDefaulted = @spec; |
|
2787 } |
|
2788 $doch->start_element (defined $attrOrder ? |
|
2789 { Name => $tag, |
|
2790 Attributes => { @attr }, |
|
2791 AttributeOrder => $attrOrder, |
|
2792 Defaulted => $attrDefaulted |
|
2793 } : |
|
2794 { Name => $tag, |
|
2795 Attributes => { @attr } |
|
2796 } |
|
2797 ); |
|
2798 |
|
2799 for my $kid ($self->getChildNodes) |
|
2800 { |
|
2801 $kid->_to_sax ($doch, $dtdh, $enth); |
|
2802 } |
|
2803 |
|
2804 $doch->end_element ( { Name => $tag } ); |
|
2805 } |
|
2806 |
|
2807 ###################################################################### |
|
2808 package XML::DOM::CharacterData; |
|
2809 ###################################################################### |
|
2810 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
2811 |
|
2812 BEGIN |
|
2813 { |
|
2814 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
2815 XML::DOM::def_fields ("Data", "XML::DOM::Node"); |
|
2816 } |
|
2817 |
|
2818 use XML::DOM::DOMException; |
|
2819 use Carp; |
|
2820 |
|
2821 |
|
2822 # |
|
2823 # CharacterData nodes should never be created directly, only subclassed! |
|
2824 # |
|
2825 sub new |
|
2826 { |
|
2827 my ($class, $doc, $data) = @_; |
|
2828 my $self = bless [], $class; |
|
2829 |
|
2830 $self->[_Doc] = $doc; |
|
2831 $self->[_Data] = $data; |
|
2832 $self; |
|
2833 } |
|
2834 |
|
2835 sub appendData |
|
2836 { |
|
2837 my ($self, $data) = @_; |
|
2838 |
|
2839 if ($XML::DOM::SafeMode) |
|
2840 { |
|
2841 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
2842 "node is ReadOnly") |
|
2843 if $self->isReadOnly; |
|
2844 } |
|
2845 $self->[_Data] .= $data; |
|
2846 } |
|
2847 |
|
2848 sub deleteData |
|
2849 { |
|
2850 my ($self, $offset, $count) = @_; |
|
2851 |
|
2852 croak new XML::DOM::DOMException (INDEX_SIZE_ERR, |
|
2853 "bad offset [$offset]") |
|
2854 if ($offset < 0 || $offset >= length ($self->[_Data])); |
|
2855 #?? DOM Spec says >, but >= makes more sense! |
|
2856 |
|
2857 croak new XML::DOM::DOMException (INDEX_SIZE_ERR, |
|
2858 "negative count [$count]") |
|
2859 if $count < 0; |
|
2860 |
|
2861 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
2862 "node is ReadOnly") |
|
2863 if $self->isReadOnly; |
|
2864 |
|
2865 substr ($self->[_Data], $offset, $count) = ""; |
|
2866 } |
|
2867 |
|
2868 sub getData |
|
2869 { |
|
2870 $_[0]->[_Data]; |
|
2871 } |
|
2872 |
|
2873 sub getLength |
|
2874 { |
|
2875 length $_[0]->[_Data]; |
|
2876 } |
|
2877 |
|
2878 sub insertData |
|
2879 { |
|
2880 my ($self, $offset, $data) = @_; |
|
2881 |
|
2882 croak new XML::DOM::DOMException (INDEX_SIZE_ERR, |
|
2883 "bad offset [$offset]") |
|
2884 if ($offset < 0 || $offset >= length ($self->[_Data])); |
|
2885 #?? DOM Spec says >, but >= makes more sense! |
|
2886 |
|
2887 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
2888 "node is ReadOnly") |
|
2889 if $self->isReadOnly; |
|
2890 |
|
2891 substr ($self->[_Data], $offset, 0) = $data; |
|
2892 } |
|
2893 |
|
2894 sub replaceData |
|
2895 { |
|
2896 my ($self, $offset, $count, $data) = @_; |
|
2897 |
|
2898 croak new XML::DOM::DOMException (INDEX_SIZE_ERR, |
|
2899 "bad offset [$offset]") |
|
2900 if ($offset < 0 || $offset >= length ($self->[_Data])); |
|
2901 #?? DOM Spec says >, but >= makes more sense! |
|
2902 |
|
2903 croak new XML::DOM::DOMException (INDEX_SIZE_ERR, |
|
2904 "negative count [$count]") |
|
2905 if $count < 0; |
|
2906 |
|
2907 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
2908 "node is ReadOnly") |
|
2909 if $self->isReadOnly; |
|
2910 |
|
2911 substr ($self->[_Data], $offset, $count) = $data; |
|
2912 } |
|
2913 |
|
2914 sub setData |
|
2915 { |
|
2916 my ($self, $data) = @_; |
|
2917 |
|
2918 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
2919 "node is ReadOnly") |
|
2920 if $self->isReadOnly; |
|
2921 |
|
2922 $self->[_Data] = $data; |
|
2923 } |
|
2924 |
|
2925 sub substringData |
|
2926 { |
|
2927 my ($self, $offset, $count) = @_; |
|
2928 my $data = $self->[_Data]; |
|
2929 |
|
2930 croak new XML::DOM::DOMException (INDEX_SIZE_ERR, |
|
2931 "bad offset [$offset]") |
|
2932 if ($offset < 0 || $offset >= length ($data)); |
|
2933 #?? DOM Spec says >, but >= makes more sense! |
|
2934 |
|
2935 croak new XML::DOM::DOMException (INDEX_SIZE_ERR, |
|
2936 "negative count [$count]") |
|
2937 if $count < 0; |
|
2938 |
|
2939 substr ($data, $offset, $count); |
|
2940 } |
|
2941 |
|
2942 sub getNodeValue |
|
2943 { |
|
2944 $_[0]->getData; |
|
2945 } |
|
2946 |
|
2947 sub setNodeValue |
|
2948 { |
|
2949 $_[0]->setData ($_[1]); |
|
2950 } |
|
2951 |
|
2952 ###################################################################### |
|
2953 package XML::DOM::CDATASection; |
|
2954 ###################################################################### |
|
2955 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
2956 |
|
2957 BEGIN |
|
2958 { |
|
2959 import XML::DOM::CharacterData qw( :DEFAULT :Fields ); |
|
2960 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
2961 XML::DOM::def_fields ("", "XML::DOM::CharacterData"); |
|
2962 } |
|
2963 |
|
2964 use XML::DOM::DOMException; |
|
2965 |
|
2966 sub getNodeName |
|
2967 { |
|
2968 "#cdata-section"; |
|
2969 } |
|
2970 |
|
2971 sub getNodeType |
|
2972 { |
|
2973 CDATA_SECTION_NODE; |
|
2974 } |
|
2975 |
|
2976 sub cloneNode |
|
2977 { |
|
2978 my $self = shift; |
|
2979 $self->[_Doc]->createCDATASection ($self->getData); |
|
2980 } |
|
2981 |
|
2982 #------------------------------------------------------------ |
|
2983 # Extra method implementations |
|
2984 |
|
2985 sub isReadOnly |
|
2986 { |
|
2987 0; |
|
2988 } |
|
2989 |
|
2990 sub print |
|
2991 { |
|
2992 my ($self, $FILE) = @_; |
|
2993 $FILE->print ("<![CDATA["); |
|
2994 $FILE->print (XML::DOM::encodeCDATA ($self->getData)); |
|
2995 $FILE->print ("]]>"); |
|
2996 } |
|
2997 |
|
2998 sub to_expat |
|
2999 { |
|
3000 my ($self, $iter) = @_; |
|
3001 $iter->CData ($self->getData); |
|
3002 } |
|
3003 |
|
3004 sub _to_sax |
|
3005 { |
|
3006 my ($self, $doch, $dtdh, $enth) = @_; |
|
3007 $doch->start_cdata; |
|
3008 $doch->characters ( { Data => $self->getData } ); |
|
3009 $doch->end_cdata; |
|
3010 } |
|
3011 |
|
3012 ###################################################################### |
|
3013 package XML::DOM::Comment; |
|
3014 ###################################################################### |
|
3015 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
3016 |
|
3017 BEGIN |
|
3018 { |
|
3019 import XML::DOM::CharacterData qw( :DEFAULT :Fields ); |
|
3020 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
3021 XML::DOM::def_fields ("", "XML::DOM::CharacterData"); |
|
3022 } |
|
3023 |
|
3024 use XML::DOM::DOMException; |
|
3025 use Carp; |
|
3026 |
|
3027 #?? setData - could check comment for double minus |
|
3028 |
|
3029 sub getNodeType |
|
3030 { |
|
3031 COMMENT_NODE; |
|
3032 } |
|
3033 |
|
3034 sub getNodeName |
|
3035 { |
|
3036 "#comment"; |
|
3037 } |
|
3038 |
|
3039 sub cloneNode |
|
3040 { |
|
3041 my $self = shift; |
|
3042 $self->[_Doc]->createComment ($self->getData); |
|
3043 } |
|
3044 |
|
3045 #------------------------------------------------------------ |
|
3046 # Extra method implementations |
|
3047 |
|
3048 sub isReadOnly |
|
3049 { |
|
3050 return 0 if $XML::DOM::IgnoreReadOnly; |
|
3051 |
|
3052 my $pa = $_[0]->[_Parent]; |
|
3053 defined ($pa) ? $pa->isReadOnly : 0; |
|
3054 } |
|
3055 |
|
3056 sub print |
|
3057 { |
|
3058 my ($self, $FILE) = @_; |
|
3059 my $comment = XML::DOM::encodeComment ($self->[_Data]); |
|
3060 |
|
3061 $FILE->print ("<!--$comment-->"); |
|
3062 } |
|
3063 |
|
3064 sub to_expat |
|
3065 { |
|
3066 my ($self, $iter) = @_; |
|
3067 $iter->Comment ($self->getData); |
|
3068 } |
|
3069 |
|
3070 sub _to_sax |
|
3071 { |
|
3072 my ($self, $doch, $dtdh, $enth) = @_; |
|
3073 $doch->Comment ( { Data => $self->getData }); |
|
3074 } |
|
3075 |
|
3076 ###################################################################### |
|
3077 package XML::DOM::Text; |
|
3078 ###################################################################### |
|
3079 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
3080 |
|
3081 BEGIN |
|
3082 { |
|
3083 import XML::DOM::CharacterData qw( :DEFAULT :Fields ); |
|
3084 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
3085 XML::DOM::def_fields ("", "XML::DOM::CharacterData"); |
|
3086 } |
|
3087 |
|
3088 use XML::DOM::DOMException; |
|
3089 use Carp; |
|
3090 |
|
3091 sub getNodeType |
|
3092 { |
|
3093 TEXT_NODE; |
|
3094 } |
|
3095 |
|
3096 sub getNodeName |
|
3097 { |
|
3098 "#text"; |
|
3099 } |
|
3100 |
|
3101 sub splitText |
|
3102 { |
|
3103 my ($self, $offset) = @_; |
|
3104 |
|
3105 my $data = $self->getData; |
|
3106 croak new XML::DOM::DOMException (INDEX_SIZE_ERR, |
|
3107 "bad offset [$offset]") |
|
3108 if ($offset < 0 || $offset >= length ($data)); |
|
3109 #?? DOM Spec says >, but >= makes more sense! |
|
3110 |
|
3111 croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR, |
|
3112 "node is ReadOnly") |
|
3113 if $self->isReadOnly; |
|
3114 |
|
3115 my $rest = substring ($data, $offset); |
|
3116 |
|
3117 $self->setData (substring ($data, 0, $offset)); |
|
3118 my $node = $self->[_Doc]->createTextNode ($rest); |
|
3119 |
|
3120 # insert new node after this node |
|
3121 $self->[_Parent]->insertAfter ($node, $self); |
|
3122 |
|
3123 $node; |
|
3124 } |
|
3125 |
|
3126 sub cloneNode |
|
3127 { |
|
3128 my $self = shift; |
|
3129 $self->[_Doc]->createTextNode ($self->getData); |
|
3130 } |
|
3131 |
|
3132 #------------------------------------------------------------ |
|
3133 # Extra method implementations |
|
3134 |
|
3135 sub isReadOnly |
|
3136 { |
|
3137 0; |
|
3138 } |
|
3139 |
|
3140 sub print |
|
3141 { |
|
3142 my ($self, $FILE) = @_; |
|
3143 $FILE->print (XML::DOM::encodeText ($self->getData, "<&")); |
|
3144 } |
|
3145 |
|
3146 sub isTextNode |
|
3147 { |
|
3148 1; |
|
3149 } |
|
3150 |
|
3151 sub to_expat |
|
3152 { |
|
3153 my ($self, $iter) = @_; |
|
3154 $iter->Char ($self->getData); |
|
3155 } |
|
3156 |
|
3157 sub _to_sax |
|
3158 { |
|
3159 my ($self, $doch, $dtdh, $enth) = @_; |
|
3160 $doch->characters ( { Data => $self->getData } ); |
|
3161 } |
|
3162 |
|
3163 ###################################################################### |
|
3164 package XML::DOM::XMLDecl; |
|
3165 ###################################################################### |
|
3166 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
3167 |
|
3168 BEGIN |
|
3169 { |
|
3170 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
3171 XML::DOM::def_fields ("Version Encoding Standalone", "XML::DOM::Node"); |
|
3172 } |
|
3173 |
|
3174 use XML::DOM::DOMException; |
|
3175 |
|
3176 |
|
3177 #------------------------------------------------------------ |
|
3178 # Extra method implementations |
|
3179 |
|
3180 # XMLDecl is not part of the DOM Spec |
|
3181 sub new |
|
3182 { |
|
3183 my ($class, $doc, $version, $encoding, $standalone) = @_; |
|
3184 |
|
3185 my $self = bless [], $class; |
|
3186 |
|
3187 $self->[_Doc] = $doc; |
|
3188 $self->[_Version] = $version if defined $version; |
|
3189 $self->[_Encoding] = $encoding if defined $encoding; |
|
3190 $self->[_Standalone] = $standalone if defined $standalone; |
|
3191 |
|
3192 $self; |
|
3193 } |
|
3194 |
|
3195 sub setVersion |
|
3196 { |
|
3197 if (defined $_[1]) |
|
3198 { |
|
3199 $_[0]->[_Version] = $_[1]; |
|
3200 } |
|
3201 else |
|
3202 { |
|
3203 undef $_[0]->[_Version]; # was delete |
|
3204 } |
|
3205 } |
|
3206 |
|
3207 sub getVersion |
|
3208 { |
|
3209 $_[0]->[_Version]; |
|
3210 } |
|
3211 |
|
3212 sub setEncoding |
|
3213 { |
|
3214 if (defined $_[1]) |
|
3215 { |
|
3216 $_[0]->[_Encoding] = $_[1]; |
|
3217 } |
|
3218 else |
|
3219 { |
|
3220 undef $_[0]->[_Encoding]; # was delete |
|
3221 } |
|
3222 } |
|
3223 |
|
3224 sub getEncoding |
|
3225 { |
|
3226 $_[0]->[_Encoding]; |
|
3227 } |
|
3228 |
|
3229 sub setStandalone |
|
3230 { |
|
3231 if (defined $_[1]) |
|
3232 { |
|
3233 $_[0]->[_Standalone] = $_[1]; |
|
3234 } |
|
3235 else |
|
3236 { |
|
3237 undef $_[0]->[_Standalone]; # was delete |
|
3238 } |
|
3239 } |
|
3240 |
|
3241 sub getStandalone |
|
3242 { |
|
3243 $_[0]->[_Standalone]; |
|
3244 } |
|
3245 |
|
3246 sub getNodeType |
|
3247 { |
|
3248 XML_DECL_NODE; |
|
3249 } |
|
3250 |
|
3251 sub cloneNode |
|
3252 { |
|
3253 my $self = shift; |
|
3254 |
|
3255 new XML::DOM::XMLDecl ($self->[_Doc], $self->[_Version], |
|
3256 $self->[_Encoding], $self->[_Standalone]); |
|
3257 } |
|
3258 |
|
3259 sub print |
|
3260 { |
|
3261 my ($self, $FILE) = @_; |
|
3262 |
|
3263 my $version = $self->[_Version]; |
|
3264 my $encoding = $self->[_Encoding]; |
|
3265 my $standalone = $self->[_Standalone]; |
|
3266 $standalone = ($standalone ? "yes" : "no") if defined $standalone; |
|
3267 |
|
3268 $FILE->print ("<?xml"); |
|
3269 $FILE->print (" version=\"$version\"") if defined $version; |
|
3270 $FILE->print (" encoding=\"$encoding\"") if defined $encoding; |
|
3271 $FILE->print (" standalone=\"$standalone\"") if defined $standalone; |
|
3272 $FILE->print ("?>"); |
|
3273 } |
|
3274 |
|
3275 sub to_expat |
|
3276 { |
|
3277 my ($self, $iter) = @_; |
|
3278 $iter->XMLDecl ($self->getVersion, $self->getEncoding, $self->getStandalone); |
|
3279 } |
|
3280 |
|
3281 sub _to_sax |
|
3282 { |
|
3283 my ($self, $doch, $dtdh, $enth) = @_; |
|
3284 $dtdh->xml_decl ( { Version => $self->getVersion, |
|
3285 Encoding => $self->getEncoding, |
|
3286 Standalone => $self->getStandalone } ); |
|
3287 } |
|
3288 |
|
3289 ###################################################################### |
|
3290 package XML::DOM::DocumentFragment; |
|
3291 ###################################################################### |
|
3292 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
3293 |
|
3294 BEGIN |
|
3295 { |
|
3296 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
3297 XML::DOM::def_fields ("", "XML::DOM::Node"); |
|
3298 } |
|
3299 |
|
3300 use XML::DOM::DOMException; |
|
3301 |
|
3302 sub new |
|
3303 { |
|
3304 my ($class, $doc) = @_; |
|
3305 my $self = bless [], $class; |
|
3306 |
|
3307 $self->[_Doc] = $doc; |
|
3308 $self->[_C] = new XML::DOM::NodeList; |
|
3309 $self; |
|
3310 } |
|
3311 |
|
3312 sub getNodeType |
|
3313 { |
|
3314 DOCUMENT_FRAGMENT_NODE; |
|
3315 } |
|
3316 |
|
3317 sub getNodeName |
|
3318 { |
|
3319 "#document-fragment"; |
|
3320 } |
|
3321 |
|
3322 sub cloneNode |
|
3323 { |
|
3324 my ($self, $deep) = @_; |
|
3325 my $node = $self->[_Doc]->createDocumentFragment; |
|
3326 |
|
3327 $node->cloneChildren ($self, $deep); |
|
3328 $node; |
|
3329 } |
|
3330 |
|
3331 #------------------------------------------------------------ |
|
3332 # Extra method implementations |
|
3333 |
|
3334 sub isReadOnly |
|
3335 { |
|
3336 0; |
|
3337 } |
|
3338 |
|
3339 sub print |
|
3340 { |
|
3341 my ($self, $FILE) = @_; |
|
3342 |
|
3343 for my $node (@{$self->[_C]}) |
|
3344 { |
|
3345 $node->print ($FILE); |
|
3346 } |
|
3347 } |
|
3348 |
|
3349 sub rejectChild |
|
3350 { |
|
3351 my $t = $_[1]->getNodeType; |
|
3352 |
|
3353 $t != TEXT_NODE |
|
3354 && $t != ENTITY_REFERENCE_NODE |
|
3355 && $t != PROCESSING_INSTRUCTION_NODE |
|
3356 && $t != COMMENT_NODE |
|
3357 && $t != CDATA_SECTION_NODE |
|
3358 && $t != ELEMENT_NODE; |
|
3359 } |
|
3360 |
|
3361 sub isDocumentFragmentNode |
|
3362 { |
|
3363 1; |
|
3364 } |
|
3365 |
|
3366 ###################################################################### |
|
3367 package XML::DOM::Document; |
|
3368 ###################################################################### |
|
3369 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
3370 |
|
3371 BEGIN |
|
3372 { |
|
3373 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
3374 XML::DOM::def_fields ("Doctype XmlDecl", "XML::DOM::Node"); |
|
3375 } |
|
3376 |
|
3377 use Carp; |
|
3378 use XML::DOM::NodeList; |
|
3379 use XML::DOM::DOMException; |
|
3380 |
|
3381 sub new |
|
3382 { |
|
3383 my ($class) = @_; |
|
3384 my $self = bless [], $class; |
|
3385 |
|
3386 # keep Doc pointer, even though getOwnerDocument returns undef |
|
3387 $self->[_Doc] = $self; |
|
3388 $self->[_C] = new XML::DOM::NodeList; |
|
3389 $self; |
|
3390 } |
|
3391 |
|
3392 sub getNodeType |
|
3393 { |
|
3394 DOCUMENT_NODE; |
|
3395 } |
|
3396 |
|
3397 sub getNodeName |
|
3398 { |
|
3399 "#document"; |
|
3400 } |
|
3401 |
|
3402 #?? not sure about keeping a fixed order of these nodes.... |
|
3403 sub getDoctype |
|
3404 { |
|
3405 $_[0]->[_Doctype]; |
|
3406 } |
|
3407 |
|
3408 sub getDocumentElement |
|
3409 { |
|
3410 my ($self) = @_; |
|
3411 for my $kid (@{$self->[_C]}) |
|
3412 { |
|
3413 return $kid if $kid->isElementNode; |
|
3414 } |
|
3415 undef; |
|
3416 } |
|
3417 |
|
3418 sub getOwnerDocument |
|
3419 { |
|
3420 undef; |
|
3421 } |
|
3422 |
|
3423 sub getImplementation |
|
3424 { |
|
3425 $XML::DOM::DOMImplementation::Singleton; |
|
3426 } |
|
3427 |
|
3428 # |
|
3429 # Added extra parameters ($val, $specified) that are passed straight to the |
|
3430 # Attr constructor |
|
3431 # |
|
3432 sub createAttribute |
|
3433 { |
|
3434 new XML::DOM::Attr (@_); |
|
3435 } |
|
3436 |
|
3437 sub createCDATASection |
|
3438 { |
|
3439 new XML::DOM::CDATASection (@_); |
|
3440 } |
|
3441 |
|
3442 sub createComment |
|
3443 { |
|
3444 new XML::DOM::Comment (@_); |
|
3445 |
|
3446 } |
|
3447 |
|
3448 sub createElement |
|
3449 { |
|
3450 new XML::DOM::Element (@_); |
|
3451 } |
|
3452 |
|
3453 sub createTextNode |
|
3454 { |
|
3455 new XML::DOM::Text (@_); |
|
3456 } |
|
3457 |
|
3458 sub createProcessingInstruction |
|
3459 { |
|
3460 new XML::DOM::ProcessingInstruction (@_); |
|
3461 } |
|
3462 |
|
3463 sub createEntityReference |
|
3464 { |
|
3465 new XML::DOM::EntityReference (@_); |
|
3466 } |
|
3467 |
|
3468 sub createDocumentFragment |
|
3469 { |
|
3470 new XML::DOM::DocumentFragment (@_); |
|
3471 } |
|
3472 |
|
3473 sub createDocumentType |
|
3474 { |
|
3475 new XML::DOM::DocumentType (@_); |
|
3476 } |
|
3477 |
|
3478 sub cloneNode |
|
3479 { |
|
3480 my ($self, $deep) = @_; |
|
3481 my $node = new XML::DOM::Document; |
|
3482 |
|
3483 $node->cloneChildren ($self, $deep); |
|
3484 |
|
3485 my $xmlDecl = $self->[_XmlDecl]; |
|
3486 $node->[_XmlDecl] = $xmlDecl->cloneNode ($deep) if defined $xmlDecl; |
|
3487 |
|
3488 $node; |
|
3489 } |
|
3490 |
|
3491 sub appendChild |
|
3492 { |
|
3493 my ($self, $node) = @_; |
|
3494 |
|
3495 # Extra check: make sure we don't end up with more than one Element. |
|
3496 # Don't worry about multiple DocType nodes, because DocumentFragment |
|
3497 # can't contain DocType nodes. |
|
3498 |
|
3499 my @nodes = ($node); |
|
3500 @nodes = @{$node->[_C]} |
|
3501 if $node->getNodeType == DOCUMENT_FRAGMENT_NODE; |
|
3502 |
|
3503 my $elem = 0; |
|
3504 for my $n (@nodes) |
|
3505 { |
|
3506 $elem++ if $n->isElementNode; |
|
3507 } |
|
3508 |
|
3509 if ($elem > 0 && defined ($self->getDocumentElement)) |
|
3510 { |
|
3511 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
3512 "document can have only one Element"); |
|
3513 } |
|
3514 $self->SUPER::appendChild ($node); |
|
3515 } |
|
3516 |
|
3517 sub insertBefore |
|
3518 { |
|
3519 my ($self, $node, $refNode) = @_; |
|
3520 |
|
3521 # Extra check: make sure sure we don't end up with more than 1 Elements. |
|
3522 # Don't worry about multiple DocType nodes, because DocumentFragment |
|
3523 # can't contain DocType nodes. |
|
3524 |
|
3525 my @nodes = ($node); |
|
3526 @nodes = @{$node->[_C]} |
|
3527 if $node->getNodeType == DOCUMENT_FRAGMENT_NODE; |
|
3528 |
|
3529 my $elem = 0; |
|
3530 for my $n (@nodes) |
|
3531 { |
|
3532 $elem++ if $n->isElementNode; |
|
3533 } |
|
3534 |
|
3535 if ($elem > 0 && defined ($self->getDocumentElement)) |
|
3536 { |
|
3537 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
3538 "document can have only one Element"); |
|
3539 } |
|
3540 $self->SUPER::insertBefore ($node, $refNode); |
|
3541 } |
|
3542 |
|
3543 sub replaceChild |
|
3544 { |
|
3545 my ($self, $node, $refNode) = @_; |
|
3546 |
|
3547 # Extra check: make sure sure we don't end up with more than 1 Elements. |
|
3548 # Don't worry about multiple DocType nodes, because DocumentFragment |
|
3549 # can't contain DocType nodes. |
|
3550 |
|
3551 my @nodes = ($node); |
|
3552 @nodes = @{$node->[_C]} |
|
3553 if $node->getNodeType == DOCUMENT_FRAGMENT_NODE; |
|
3554 |
|
3555 my $elem = 0; |
|
3556 $elem-- if $refNode->isElementNode; |
|
3557 |
|
3558 for my $n (@nodes) |
|
3559 { |
|
3560 $elem++ if $n->isElementNode; |
|
3561 } |
|
3562 |
|
3563 if ($elem > 0 && defined ($self->getDocumentElement)) |
|
3564 { |
|
3565 croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR, |
|
3566 "document can have only one Element"); |
|
3567 } |
|
3568 $self->SUPER::appendChild ($node, $refNode); |
|
3569 } |
|
3570 |
|
3571 #------------------------------------------------------------ |
|
3572 # Extra method implementations |
|
3573 |
|
3574 sub isReadOnly |
|
3575 { |
|
3576 0; |
|
3577 } |
|
3578 |
|
3579 sub print |
|
3580 { |
|
3581 my ($self, $FILE) = @_; |
|
3582 |
|
3583 my $xmlDecl = $self->getXMLDecl; |
|
3584 if (defined $xmlDecl) |
|
3585 { |
|
3586 $xmlDecl->print ($FILE); |
|
3587 $FILE->print ("\x0A"); |
|
3588 } |
|
3589 |
|
3590 for my $node (@{$self->[_C]}) |
|
3591 { |
|
3592 $node->print ($FILE); |
|
3593 $FILE->print ("\x0A"); |
|
3594 } |
|
3595 } |
|
3596 |
|
3597 sub setDoctype |
|
3598 { |
|
3599 my ($self, $doctype) = @_; |
|
3600 my $oldDoctype = $self->[_Doctype]; |
|
3601 if (defined $oldDoctype) |
|
3602 { |
|
3603 $self->replaceChild ($doctype, $oldDoctype); |
|
3604 } |
|
3605 else |
|
3606 { |
|
3607 #?? before root element, but after XmlDecl ! |
|
3608 $self->appendChild ($doctype); |
|
3609 } |
|
3610 $_[0]->[_Doctype] = $_[1]; |
|
3611 } |
|
3612 |
|
3613 sub removeDoctype |
|
3614 { |
|
3615 my $self = shift; |
|
3616 my $doctype = $self->removeChild ($self->[_Doctype]); |
|
3617 |
|
3618 undef $self->[_Doctype]; # was delete |
|
3619 $doctype; |
|
3620 } |
|
3621 |
|
3622 sub rejectChild |
|
3623 { |
|
3624 my $t = $_[1]->getNodeType; |
|
3625 $t != ELEMENT_NODE |
|
3626 && $t != PROCESSING_INSTRUCTION_NODE |
|
3627 && $t != COMMENT_NODE |
|
3628 && $t != DOCUMENT_TYPE_NODE; |
|
3629 } |
|
3630 |
|
3631 sub expandEntity |
|
3632 { |
|
3633 my ($self, $ent, $param) = @_; |
|
3634 my $doctype = $self->getDoctype; |
|
3635 |
|
3636 (defined $doctype) ? $doctype->expandEntity ($ent, $param) : undef; |
|
3637 } |
|
3638 |
|
3639 sub getDefaultAttrValue |
|
3640 { |
|
3641 my ($self, $elem, $attr) = @_; |
|
3642 |
|
3643 my $doctype = $self->getDoctype; |
|
3644 |
|
3645 (defined $doctype) ? $doctype->getDefaultAttrValue ($elem, $attr) : undef; |
|
3646 } |
|
3647 |
|
3648 sub getEntity |
|
3649 { |
|
3650 my ($self, $entity) = @_; |
|
3651 |
|
3652 my $doctype = $self->getDoctype; |
|
3653 |
|
3654 (defined $doctype) ? $doctype->getEntity ($entity) : undef; |
|
3655 } |
|
3656 |
|
3657 sub dispose |
|
3658 { |
|
3659 my $self = shift; |
|
3660 |
|
3661 $self->[_XmlDecl]->dispose if defined $self->[_XmlDecl]; |
|
3662 undef $self->[_XmlDecl]; # was delete |
|
3663 undef $self->[_Doctype]; # was delete |
|
3664 $self->SUPER::dispose; |
|
3665 } |
|
3666 |
|
3667 sub setOwnerDocument |
|
3668 { |
|
3669 # Do nothing, you can't change the owner document! |
|
3670 #?? could throw exception... |
|
3671 } |
|
3672 |
|
3673 sub getXMLDecl |
|
3674 { |
|
3675 $_[0]->[_XmlDecl]; |
|
3676 } |
|
3677 |
|
3678 sub setXMLDecl |
|
3679 { |
|
3680 $_[0]->[_XmlDecl] = $_[1]; |
|
3681 } |
|
3682 |
|
3683 sub createXMLDecl |
|
3684 { |
|
3685 new XML::DOM::XMLDecl (@_); |
|
3686 } |
|
3687 |
|
3688 sub createNotation |
|
3689 { |
|
3690 new XML::DOM::Notation (@_); |
|
3691 } |
|
3692 |
|
3693 sub createElementDecl |
|
3694 { |
|
3695 new XML::DOM::ElementDecl (@_); |
|
3696 } |
|
3697 |
|
3698 sub createAttlistDecl |
|
3699 { |
|
3700 new XML::DOM::AttlistDecl (@_); |
|
3701 } |
|
3702 |
|
3703 sub createEntity |
|
3704 { |
|
3705 new XML::DOM::Entity (@_); |
|
3706 } |
|
3707 |
|
3708 sub createChecker |
|
3709 { |
|
3710 my $self = shift; |
|
3711 my $checker = XML::Checker->new; |
|
3712 |
|
3713 $checker->Init; |
|
3714 my $doctype = $self->getDoctype; |
|
3715 $doctype->to_expat ($checker) if $doctype; |
|
3716 $checker->Final; |
|
3717 |
|
3718 $checker; |
|
3719 } |
|
3720 |
|
3721 sub check |
|
3722 { |
|
3723 my ($self, $checker) = @_; |
|
3724 $checker ||= XML::Checker->new; |
|
3725 |
|
3726 $self->to_expat ($checker); |
|
3727 } |
|
3728 |
|
3729 sub to_expat |
|
3730 { |
|
3731 my ($self, $iter) = @_; |
|
3732 |
|
3733 $iter->Init; |
|
3734 |
|
3735 for my $kid ($self->getChildNodes) |
|
3736 { |
|
3737 $kid->to_expat ($iter); |
|
3738 } |
|
3739 $iter->Final; |
|
3740 } |
|
3741 |
|
3742 sub check_sax |
|
3743 { |
|
3744 my ($self, $checker) = @_; |
|
3745 $checker ||= XML::Checker->new; |
|
3746 |
|
3747 $self->to_sax (Handler => $checker); |
|
3748 } |
|
3749 |
|
3750 sub _to_sax |
|
3751 { |
|
3752 my ($self, $doch, $dtdh, $enth) = @_; |
|
3753 |
|
3754 $doch->start_document; |
|
3755 |
|
3756 for my $kid ($self->getChildNodes) |
|
3757 { |
|
3758 $kid->_to_sax ($doch, $dtdh, $enth); |
|
3759 } |
|
3760 $doch->end_document; |
|
3761 } |
|
3762 |
|
3763 ###################################################################### |
|
3764 package XML::DOM::DocumentType; |
|
3765 ###################################################################### |
|
3766 use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS }; |
|
3767 |
|
3768 BEGIN |
|
3769 { |
|
3770 import XML::DOM::Node qw( :DEFAULT :Fields ); |
|
3771 import XML::DOM::Document qw( :Fields ); |
|
3772 XML::DOM::def_fields ("Entities Notations Name SysId PubId Internal", "XML::DOM::Node"); |
|
3773 } |
|
3774 |
|
3775 use XML::DOM::DOMException; |
|
3776 use XML::DOM::NamedNodeMap; |
|
3777 |
|
3778 sub new |
|
3779 { |
|
3780 my $class = shift; |
|
3781 my $doc = shift; |
|
3782 |
|
3783 my $self = bless [], $class; |
|
3784 |
|
3785 $self->[_Doc] = $doc; |
|
3786 $self->[_ReadOnly] = 1; |
|
3787 $self->[_C] = new XML::DOM::NodeList; |
|
3788 |
|
3789 $self->[_Entities] = new XML::DOM::NamedNodeMap (Doc => $doc, |
|
3790 Parent => $self, |
|
3791 ReadOnly => 1); |
|
3792 $self->[_Notations] = new XML::DOM::NamedNodeMap (Doc => $doc, |
|
3793 Parent => $self, |
|
3794 ReadOnly => 1); |
|
3795 $self->setParams (@_); |
|
3796 $self; |
|
3797 } |
|
3798 |
|
3799 sub getNodeType |
|
3800 { |
|
3801 DOCUMENT_TYPE_NODE; |
|
3802 } |
|
3803 |
|
3804 sub getNodeName |
|
3805 { |
|
3806 $_[0]->[_Name]; |
|
3807 } |
|
3808 |
|
3809 sub getName |
|
3810 { |
|
3811 $_[0]->[_Name]; |
|
3812 } |
|
3813 |
|
3814 sub getEntities |
|
3815 { |
|
3816 $_[0]->[_Entities]; |
|
3817 } |
|
3818 |
|
3819 sub getNotations |
|
3820 { |
|
3821 $_[0]->[_Notations]; |
|
3822 } |
|
3823 |
|
3824 sub setParentNode |
|
3825 { |
|
3826 my ($self, $parent) = @_; |
|
3827 $self->SUPER::setParentNode ($parent); |
|
3828 |
|
3829 $parent->[_Doctype] = $self |
|
3830 if $parent->getNodeType == DOCUMENT_NODE; |
|
3831 } |
|
3832 |
|
3833 sub cloneNode |
|
3834 { |
|
3835 my ($self, $deep) = @_; |
|
3836 |
|
3837 my $node = new XML::DOM::DocumentType ($self->[_Doc], $self->[_Name], |
|
3838 $self->[_SysId], $self->[_PubId], |
|
3839 $self->[_Internal]); |
|
3840 |
|
3841 #?? does it make sense to make a shallow copy? |
|
3842 |
|
3843 # clone the NamedNodeMaps |
|
3844 $node->[_Entities] = $self->[_Entities]->cloneNode ($deep); |
|
3845 |
|
3846 $node->[_Notations] = $self->[_Notations]->cloneNode ($deep); |
|
3847 |
|
3848 $node->cloneChildren ($self, $deep); |
|
3849 |
|
3850 $node; |
|
3851 } |
|
3852 |
|
3853 #------------------------------------------------------------ |
|
3854 # Extra method implementations |
|
3855 |
|
3856 sub getSysId |
|
3857 { |
|
3858 $_[0]->[_SysId]; |
|
3859 } |
|
3860 |
|
3861 sub getPubId |
|
3862 { |
|
3863 $_[0]->[_PubId]; |
|
3864 } |
|
3865 |
|
3866 sub getInternal |
|
3867 { |
|
3868 $_[0]->[_Internal]; |
|
3869 } |
|
3870 |
|
3871 sub setSysId |
|
3872 { |
|
3873 $_[0]->[_SysId] = $_[1]; |
|
3874 } |
|
3875 |
|
3876 sub setPubId |
|
3877 { |
|
3878 $_[0]->[_PubId] = $_[1]; |
|
3879 } |
|
3880 |
|
3881 sub setInternal |
|
3882 { |
|
3883 $_[0]->[_Internal] = $_[1]; |
|
3884 } |
|
3885 |
|
3886 sub setName |
|
3887 { |
|
3888 $_[0]->[_Name] = $_[1]; |
|
3889 } |
|
3890 |
|
3891 sub removeChildHoodMemories |
|
3892 { |
|
3893 my ($self, $dontWipeReadOnly) = @_; |
|
3894 |
|
3895 my $parent = $self->[_Parent]; |
|
3896 if (defined $parent && $parent->getNodeType == DOCUMENT_NODE) |
|
3897 { |
|
3898 undef $parent->[_Doctype]; # was delete |
|
3899 } |
|
3900 $self->SUPER::removeChildHoodMemories; |
|
3901 } |
|
3902 |
|
3903 sub dispose |
|
3904 { |
|
3905 my $self = shift; |
|
3906 |
|
3907 $self->[_Entities]->dispose; |
|
3908 $self->[_Notations]->dispose; |
|
3909 $self->SUPER::dispose; |
|
3910 } |
|
3911 |
|
3912 sub setOwnerDocument |
|
3913 { |
|
3914 my ($self, $doc) = @_; |
|
3915 $self->SUPER::setOwnerDocument ($doc); |
|
3916 |
|
3917 $self->[_Entities]->setOwnerDocument ($doc); |
|
3918 $self->[_Notations]->setOwnerDocument ($doc); |
|
3919 } |
|
3920 |
|
3921 sub expandEntity |
|
3922 { |
|
3923 my ($self, $ent, $param) = @_; |
|
3924 |
|
3925 my $kid = $self->[_Entities]->getNamedItem ($ent); |
|
3926 return $kid->getValue |
|
3927 if (defined ($kid) && $param == $kid->isParameterEntity); |
|
3928 |
|
3929 undef; # entity not found |
|
3930 } |
|
3931 |
|
3932 sub getAttlistDecl |
|
3933 { |
|
3934 my ($self, $elemName) = @_; |
|
3935 for my $kid (@{$_[0]->[_C]}) |
|
3936 { |
|
3937 return $kid if ($kid->getNodeType == ATTLIST_DECL_NODE && |
|
3938 $kid->getName eq $elemName); |
|
3939 } |
|
3940 undef; # not found |
|
3941 } |
|
3942 |
|
3943 sub getElementDecl |
|
3944 { |
|
3945 my ($self, $elemName) = @_; |
|
3946 for my $kid (@{$_[0]->[_C]}) |
|
3947 { |
|
3948 return $kid if ($kid->getNodeType == ELEMENT_DECL_NODE && |
|
3949 $kid->getName eq $elemName); |
|
3950 } |
|
3951 undef; # not found |
|
3952 } |
|
3953 |
|
3954 sub addElementDecl |
|
3955 { |
|
3956 my ($self, $name, $model, $hidden) = @_; |
|
3957 my $node = $self->getElementDecl ($name); |
|
3958 |
|
3959 #?? could warn |
|
3960 unless (defined $node) |
|
3961 { |
|
3962 $node = $self->[_Doc]->createElementDecl ($name, $model, $hidden); |
|
3963 $self->appendChild ($node); |
|
3964 } |
|
3965 $node; |
|
3966 } |
|
3967 |
|
3968 sub addAttlistDecl |
|
3969 { |
|
3970 my ($self, $name) = @_; |
|
3971 my $node = $self->getAttlistDecl ($name); |
|
3972 |
|
3973 unless (defined $node) |
|
3974 { |
|
3975 $node = $self->[_Doc]->createAttlistDecl ($name); |
|
3976 $self->appendChild ($node); |
|
3977 } |
|
3978 $node; |
|
3979 } |
|
3980 |
|
3981 sub addNotation |
|
3982 { |
|
3983 my $self = shift; |
|
3984 my $node = $self->[_Doc]->createNotation (@_); |
|
3985 $self->[_Notations]->setNamedItem ($node); |
|
3986 $node; |
|
3987 } |
|
3988 |
|
3989 sub addEntity |
|
3990 { |
|
3991 my $self = shift; |
|
3992 my $node = $self->[_Doc]->createEntity (@_); |
|
3993 |
|
3994 $self->[_Entities]->setNamedItem ($node); |
|
3995 $node; |
|
3996 } |
|
3997 |
|
3998 # All AttDefs for a certain Element are merged into a single ATTLIST |
|
3999 sub addAttDef |
|
4000 { |
|
4001 my $self = shift; |
|
4002 my $elemName = shift; |
|
4003 |
|
4004 # create the AttlistDecl if it doesn't exist yet |
|
4005 my $attListDecl = $self->addAttlistDecl ($elemName); |
|
4006 $attListDecl->addAttDef (@_); |
|
4007 } |
|
4008 |
|
4009 sub getDefaultAttrValue |
|
4010 { |
|
4011 my ($self, $elem, $attr) = @_; |
|
4012 my $elemNode = $self->getAttlistDecl ($elem); |
|
4013 (defined $elemNode) ? $elemNode->getDefaultAttrValue ($attr) : undef; |
|
4014 } |
|
4015 |
|
4016 sub getEntity |
|
4017 { |
|
4018 my ($self, $entity) = @_; |
|
4019 $self->[_Entities]->getNamedItem ($entity); |
|
4020 } |
|
4021 |
|
4022 sub setParams |
|
4023 { |
|
4024 my ($self, $name, $sysid, $pubid, $internal) = @_; |
|
4025 |
|
4026 $self->[_Name] = $name; |
|
4027 |
|
4028 #?? not sure if we need to hold on to these... |
|
4029 $self->[_SysId] = $sysid if defined $sysid; |
|
4030 $self->[_PubId] = $pubid if defined $pubid; |
|
4031 $self->[_Internal] = $internal if defined $internal; |
|
4032 |
|
4033 $self; |
|
4034 } |
|
4035 |
|
4036 sub rejectChild |
|
4037 { |
|
4038 # DOM Spec says: DocumentType -- no children |
|
4039 not $XML::DOM::IgnoreReadOnly; |
|
4040 } |
|
4041 |
|
4042 sub print |
|
4043 { |
|
4044 my ($self, $FILE) = @_; |
|
4045 |
|
4046 my $name = $self->[_Name]; |
|
4047 |
|
4048 my $sysId = $self->[_SysId]; |
|
4049 my $pubId = $self->[_PubId]; |
|
4050 |
|
4051 $FILE->print ("<!DOCTYPE $name"); |
|
4052 if (defined $pubId) |
|
4053 { |
|
4054 $FILE->print (" PUBLIC \"$pubId\" \"$sysId\""); |
|
4055 } |
|
4056 elsif (defined $sysId) |
|
4057 { |
|
4058 $FILE->print (" SYSTEM \"$sysId\""); |
|
4059 } |
|
4060 |
|
4061 my @entities = @{$self->[_Entities]->getValues}; |
|
4062 my @notations = @{$self->[_Notations]->getValues}; |
|
4063 my @kids = @{$self->[_C]}; |
|
4064 |
|
4065 if (@entities || @notations || @kids) |
|
4066 { |
|
4067 $FILE->print (" [\x0A"); |
|
4068 |
|
4069 for my $kid (@entities) |
|
4070 { |
|
4071 next if $kid->[_Hidden]; |
|
4072 |
|
4073 $FILE->print (" "); |
|
4074 $kid->print ($FILE); |
|
4075 $FILE->print ("\x0A"); |
|
4076 } |
|
4077 |
|
4078 for my $kid (@notations) |
|
4079 { |
|
4080 next if $kid->[_Hidden]; |
|
4081 |
|
4082 $FILE->print (" "); |
|
4083 $kid->print ($FILE); |
|
4084 $FILE->print ("\x0A"); |
|
4085 } |
|
4086 |
|
4087 for my $kid (@kids) |
|
4088 { |
|
4089 next if $kid->[_Hidden]; |
|
4090 |
|
4091 $FILE->print (" "); |
|
4092 $kid->print ($FILE); |
|
4093 $FILE->print ("\x0A"); |
|
4094 } |
|
4095 $FILE->print ("]"); |
|
4096 } |
|
4097 $FILE->print (">"); |
|
4098 } |
|
4099 |
|
4100 sub to_expat |
|
4101 { |
|
4102 my ($self, $iter) = @_; |
|
4103 |
|
4104 $iter->Doctype ($self->getName, $self->getSysId, $self->getPubId, $self->getInternal); |
|
4105 |
|
4106 for my $ent ($self->getEntities->getValues) |
|
4107 { |
|
4108 next if $ent->[_Hidden]; |
|
4109 $ent->to_expat ($iter); |
|
4110 } |
|
4111 |
|
4112 for my $nota ($self->getNotations->getValues) |
|
4113 { |
|
4114 next if $nota->[_Hidden]; |
|
4115 $nota->to_expat ($iter); |
|
4116 } |
|
4117 |
|
4118 for my $kid ($self->getChildNodes) |
|
4119 { |
|
4120 next if $kid->[_Hidden]; |
|
4121 $kid->to_expat ($iter); |
|
4122 } |
|
4123 } |
|
4124 |
|
4125 sub _to_sax |
|
4126 { |
|
4127 my ($self, $doch, $dtdh, $enth) = @_; |
|
4128 |
|
4129 $dtdh->doctype_decl ( { Name => $self->getName, |
|
4130 SystemId => $self->getSysId, |
|
4131 PublicId => $self->getPubId, |
|
4132 Internal => $self->getInternal }); |
|
4133 |
|
4134 for my $ent ($self->getEntities->getValues) |
|
4135 { |
|
4136 next if $ent->[_Hidden]; |
|
4137 $ent->_to_sax ($doch, $dtdh, $enth); |
|
4138 } |
|
4139 |
|
4140 for my $nota ($self->getNotations->getValues) |
|
4141 { |
|
4142 next if $nota->[_Hidden]; |
|
4143 $nota->_to_sax ($doch, $dtdh, $enth); |
|
4144 } |
|
4145 |
|
4146 for my $kid ($self->getChildNodes) |
|
4147 { |
|
4148 next if $kid->[_Hidden]; |
|
4149 $kid->_to_sax ($doch, $dtdh, $enth); |
|
4150 } |
|
4151 } |
|
4152 |
|
4153 ###################################################################### |
|
4154 package XML::DOM::Parser; |
|
4155 ###################################################################### |
|
4156 use vars qw ( @ISA ); |
|
4157 @ISA = qw( XML::Parser ); |
|
4158 |
|
4159 sub new |
|
4160 { |
|
4161 my ($class, %args) = @_; |
|
4162 |
|
4163 $args{Style} = 'Dom'; |
|
4164 $class->SUPER::new (%args); |
|
4165 } |
|
4166 |
|
4167 # This method needed to be overriden so we can restore some global |
|
4168 # variables when an exception is thrown |
|
4169 sub parse |
|
4170 { |
|
4171 my $self = shift; |
|
4172 |
|
4173 local $XML::Parser::Dom::_DP_doc; |
|
4174 local $XML::Parser::Dom::_DP_elem; |
|
4175 local $XML::Parser::Dom::_DP_doctype; |
|
4176 local $XML::Parser::Dom::_DP_in_prolog; |
|
4177 local $XML::Parser::Dom::_DP_end_doc; |
|
4178 local $XML::Parser::Dom::_DP_saw_doctype; |
|
4179 local $XML::Parser::Dom::_DP_in_CDATA; |
|
4180 local $XML::Parser::Dom::_DP_keep_CDATA; |
|
4181 local $XML::Parser::Dom::_DP_last_text; |
|
4182 |
|
4183 |
|
4184 # Temporarily disable checks that Expat already does (for performance) |
|
4185 local $XML::DOM::SafeMode = 0; |
|
4186 # Temporarily disable ReadOnly checks |
|
4187 local $XML::DOM::IgnoreReadOnly = 1; |
|
4188 |
|
4189 my $ret; |
|
4190 eval { |
|
4191 $ret = $self->SUPER::parse (@_); |
|
4192 }; |
|
4193 my $err = $@; |
|
4194 |
|
4195 if ($err) |
|
4196 { |
|
4197 my $doc = $XML::Parser::Dom::_DP_doc; |
|
4198 if ($doc) |
|
4199 { |
|
4200 $doc->dispose; |
|
4201 } |
|
4202 die $err; |
|
4203 } |
|
4204 |
|
4205 $ret; |
|
4206 } |
|
4207 |
|
4208 my $LWP_USER_AGENT; |
|
4209 sub set_LWP_UserAgent |
|
4210 { |
|
4211 $LWP_USER_AGENT = shift; |
|
4212 } |
|
4213 |
|
4214 sub parsefile |
|
4215 { |
|
4216 my $self = shift; |
|
4217 my $url = shift; |
|
4218 |
|
4219 # Any other URL schemes? |
|
4220 if ($url =~ /^(https?|ftp|wais|gopher|file):/) |
|
4221 { |
|
4222 # Read the file from the web with LWP. |
|
4223 # |
|
4224 # Note that we read in the entire file, which may not be ideal |
|
4225 # for large files. LWP::UserAgent also provides a callback style |
|
4226 # request, which we could convert to a stream with a fork()... |
|
4227 |
|
4228 my $result; |
|
4229 eval |
|
4230 { |
|
4231 use LWP::UserAgent; |
|
4232 |
|
4233 my $ua = $self->{LWP_UserAgent}; |
|
4234 unless (defined $ua) |
|
4235 { |
|
4236 unless (defined $LWP_USER_AGENT) |
|
4237 { |
|
4238 $LWP_USER_AGENT = LWP::UserAgent->new; |
|
4239 |
|
4240 # Load proxy settings from environment variables, i.e.: |
|
4241 # http_proxy, ftp_proxy, no_proxy etc. (see LWP::UserAgent(3)) |
|
4242 # You need these to go thru firewalls. |
|
4243 $LWP_USER_AGENT->env_proxy; |
|
4244 } |
|
4245 $ua = $LWP_USER_AGENT; |
|
4246 } |
|
4247 my $req = new HTTP::Request 'GET', $url; |
|
4248 my $response = $LWP_USER_AGENT->request ($req); |
|
4249 |
|
4250 # Parse the result of the HTTP request |
|
4251 $result = $self->parse ($response->content, @_); |
|
4252 }; |
|
4253 if ($@) |
|
4254 { |
|
4255 die "Couldn't parsefile [$url] with LWP: $@"; |
|
4256 } |
|
4257 return $result; |
|
4258 } |
|
4259 else |
|
4260 { |
|
4261 return $self->SUPER::parsefile ($url, @_); |
|
4262 } |
|
4263 } |
|
4264 |
|
4265 ###################################################################### |
|
4266 package XML::Parser::Dom; |
|
4267 ###################################################################### |
|
4268 |
|
4269 BEGIN |
|
4270 { |
|
4271 import XML::DOM::Node qw( :Fields ); |
|
4272 import XML::DOM::CharacterData qw( :Fields ); |
|
4273 } |
|
4274 |
|
4275 use vars qw( $_DP_doc |
|
4276 $_DP_elem |
|
4277 $_DP_doctype |
|
4278 $_DP_in_prolog |
|
4279 $_DP_end_doc |
|
4280 $_DP_saw_doctype |
|
4281 $_DP_in_CDATA |
|
4282 $_DP_keep_CDATA |
|
4283 $_DP_last_text |
|
4284 $_DP_level |
|
4285 $_DP_expand_pent |
|
4286 ); |
|
4287 |
|
4288 # This adds a new Style to the XML::Parser class. |
|
4289 # From now on you can say: $parser = new XML::Parser ('Style' => 'Dom' ); |
|
4290 # but that is *NOT* how a regular user should use it! |
|
4291 $XML::Parser::Built_In_Styles{Dom} = 1; |
|
4292 |
|
4293 sub Init |
|
4294 { |
|
4295 $_DP_elem = $_DP_doc = new XML::DOM::Document(); |
|
4296 $_DP_doctype = new XML::DOM::DocumentType ($_DP_doc); |
|
4297 $_DP_doc->setDoctype ($_DP_doctype); |
|
4298 $_DP_keep_CDATA = $_[0]->{KeepCDATA}; |
|
4299 |
|
4300 # Prepare for document prolog |
|
4301 $_DP_in_prolog = 1; |
|
4302 |
|
4303 # We haven't passed the root element yet |
|
4304 $_DP_end_doc = 0; |
|
4305 |
|
4306 # Expand parameter entities in the DTD by default |
|
4307 |
|
4308 $_DP_expand_pent = defined $_[0]->{ExpandParamEnt} ? |
|
4309 $_[0]->{ExpandParamEnt} : 1; |
|
4310 if ($_DP_expand_pent) |
|
4311 { |
|
4312 $_[0]->{DOM_Entity} = {}; |
|
4313 } |
|
4314 |
|
4315 $_DP_level = 0; |
|
4316 |
|
4317 undef $_DP_last_text; |
|
4318 } |
|
4319 |
|
4320 sub Final |
|
4321 { |
|
4322 unless ($_DP_saw_doctype) |
|
4323 { |
|
4324 my $doctype = $_DP_doc->removeDoctype; |
|
4325 $doctype->dispose; |
|
4326 } |
|
4327 $_DP_doc; |
|
4328 } |
|
4329 |
|
4330 sub Char |
|
4331 { |
|
4332 my $str = $_[1]; |
|
4333 |
|
4334 if ($_DP_in_CDATA && $_DP_keep_CDATA) |
|
4335 { |
|
4336 undef $_DP_last_text; |
|
4337 # Merge text with previous node if possible |
|
4338 $_DP_elem->addCDATA ($str); |
|
4339 } |
|
4340 else |
|
4341 { |
|
4342 # Merge text with previous node if possible |
|
4343 # Used to be: $expat->{DOM_Element}->addText ($str); |
|
4344 if ($_DP_last_text) |
|
4345 { |
|
4346 $_DP_last_text->[_Data] .= $str; |
|
4347 } |
|
4348 else |
|
4349 { |
|
4350 $_DP_last_text = $_DP_doc->createTextNode ($str); |
|
4351 $_DP_last_text->[_Parent] = $_DP_elem; |
|
4352 push @{$_DP_elem->[_C]}, $_DP_last_text; |
|
4353 } |
|
4354 } |
|
4355 } |
|
4356 |
|
4357 sub Start |
|
4358 { |
|
4359 my ($expat, $elem, @attr) = @_; |
|
4360 my $parent = $_DP_elem; |
|
4361 my $doc = $_DP_doc; |
|
4362 |
|
4363 if ($parent == $doc) |
|
4364 { |
|
4365 # End of document prolog, i.e. start of first Element |
|
4366 $_DP_in_prolog = 0; |
|
4367 } |
|
4368 |
|
4369 undef $_DP_last_text; |
|
4370 my $node = $doc->createElement ($elem); |
|
4371 $_DP_elem = $node; |
|
4372 $parent->appendChild ($node); |
|
4373 |
|
4374 my $n = @attr; |
|
4375 return unless $n; |
|
4376 |
|
4377 # Add attributes |
|
4378 my $first_default = $expat->specified_attr; |
|
4379 my $i = 0; |
|
4380 while ($i < $n) |
|
4381 { |
|
4382 my $specified = $i < $first_default; |
|
4383 my $name = $attr[$i++]; |
|
4384 undef $_DP_last_text; |
|
4385 my $attr = $doc->createAttribute ($name, $attr[$i++], $specified); |
|
4386 $node->setAttributeNode ($attr); |
|
4387 } |
|
4388 } |
|
4389 |
|
4390 sub End |
|
4391 { |
|
4392 $_DP_elem = $_DP_elem->[_Parent]; |
|
4393 undef $_DP_last_text; |
|
4394 |
|
4395 # Check for end of root element |
|
4396 $_DP_end_doc = 1 if ($_DP_elem == $_DP_doc); |
|
4397 } |
|
4398 |
|
4399 # Called at end of file, i.e. whitespace following last closing tag |
|
4400 # Also for Entity references |
|
4401 # May also be called at other times... |
|
4402 sub Default |
|
4403 { |
|
4404 my ($expat, $str) = @_; |
|
4405 |
|
4406 # shift; deb ("Default", @_); |
|
4407 |
|
4408 if ($_DP_in_prolog) # still processing Document prolog... |
|
4409 { |
|
4410 #?? could try to store this text later |
|
4411 #?? I've only seen whitespace here so far |
|
4412 } |
|
4413 elsif (!$_DP_end_doc) # ignore whitespace at end of Document |
|
4414 { |
|
4415 # if ($expat->{NoExpand}) |
|
4416 # { |
|
4417 $str =~ /^&(.+);$/os; |
|
4418 return unless defined ($1); |
|
4419 # Got a TextDecl (<?xml ...?>) from an external entity here once |
|
4420 |
|
4421 $_DP_elem->appendChild ( |
|
4422 $_DP_doc->createEntityReference ($1)); |
|
4423 undef $_DP_last_text; |
|
4424 # } |
|
4425 # else |
|
4426 # { |
|
4427 # $expat->{DOM_Element}->addText ($str); |
|
4428 # } |
|
4429 } |
|
4430 } |
|
4431 |
|
4432 # XML::Parser 2.19 added support for CdataStart and CdataEnd handlers |
|
4433 # If they are not defined, the Default handler is called instead |
|
4434 # with the text "<![CDATA[" and "]]" |
|
4435 sub CdataStart |
|
4436 { |
|
4437 $_DP_in_CDATA = 1; |
|
4438 } |
|
4439 |
|
4440 sub CdataEnd |
|
4441 { |
|
4442 $_DP_in_CDATA = 0; |
|
4443 } |
|
4444 |
|
4445 my $START_MARKER = "__DOM__START__ENTITY__"; |
|
4446 my $END_MARKER = "__DOM__END__ENTITY__"; |
|
4447 |
|
4448 sub Comment |
|
4449 { |
|
4450 undef $_DP_last_text; |
|
4451 |
|
4452 # These comments were inserted by ExternEnt handler |
|
4453 if ($_[1] =~ /(?:($START_MARKER)|($END_MARKER))/) |
|
4454 { |
|
4455 if ($1) # START |
|
4456 { |
|
4457 $_DP_level++; |
|
4458 } |
|
4459 else |
|
4460 { |
|
4461 $_DP_level--; |
|
4462 } |
|
4463 } |
|
4464 else |
|
4465 { |
|
4466 my $comment = $_DP_doc->createComment ($_[1]); |
|
4467 $_DP_elem->appendChild ($comment); |
|
4468 } |
|
4469 } |
|
4470 |
|
4471 sub deb |
|
4472 { |
|
4473 # return; |
|
4474 |
|
4475 my $name = shift; |
|
4476 print "$name (" . join(",", map {defined($_)?$_ : "(undef)"} @_) . ")\n"; |
|
4477 } |
|
4478 |
|
4479 sub Doctype |
|
4480 { |
|
4481 my $expat = shift; |
|
4482 # deb ("Doctype", @_); |
|
4483 |
|
4484 $_DP_doctype->setParams (@_); |
|
4485 $_DP_saw_doctype = 1; |
|
4486 } |
|
4487 |
|
4488 sub Attlist |
|
4489 { |
|
4490 my $expat = shift; |
|
4491 # deb ("Attlist", @_); |
|
4492 |
|
4493 $_[5] = "Hidden" unless $_DP_expand_pent || $_DP_level == 0; |
|
4494 $_DP_doctype->addAttDef (@_); |
|
4495 } |
|
4496 |
|
4497 sub XMLDecl |
|
4498 { |
|
4499 my $expat = shift; |
|
4500 # deb ("XMLDecl", @_); |
|
4501 |
|
4502 undef $_DP_last_text; |
|
4503 $_DP_doc->setXMLDecl (new XML::DOM::XMLDecl ($_DP_doc, @_)); |
|
4504 } |
|
4505 |
|
4506 sub Entity |
|
4507 { |
|
4508 my $expat = shift; |
|
4509 # deb ("Entity", @_); |
|
4510 |
|
4511 # Parameter Entities names are passed starting with '%' |
|
4512 my $parameter = 0; |
|
4513 if ($_[0] =~ /^%(.*)/s) |
|
4514 { |
|
4515 $_[0] = $1; |
|
4516 $parameter = 1; |
|
4517 |
|
4518 if (defined $_[2]) # was sysid specified? |
|
4519 { |
|
4520 # Store the Entity mapping for use in ExternEnt |
|
4521 if (exists $expat->{DOM_Entity}->{$_[2]}) |
|
4522 { |
|
4523 # If this ever happens, the name of entity may be the wrong one |
|
4524 # when writing out the Document. |
|
4525 XML::DOM::warning ("Entity $_[2] is known as %$_[0] and %" . |
|
4526 $expat->{DOM_Entity}->{$_[2]}); |
|
4527 } |
|
4528 else |
|
4529 { |
|
4530 $expat->{DOM_Entity}->{$_[2]} = $_[0]; |
|
4531 } |
|
4532 #?? remove this block when XML::Parser has better support |
|
4533 } |
|
4534 } |
|
4535 |
|
4536 undef $_DP_last_text; |
|
4537 |
|
4538 $_[5] = "Hidden" unless $_DP_expand_pent || $_DP_level == 0; |
|
4539 $_DP_doctype->addEntity ($parameter, @_); |
|
4540 } |
|
4541 |
|
4542 # |
|
4543 # Unparsed is called when it encounters e.g: |
|
4544 # |
|
4545 # <!ENTITY logo SYSTEM "http://server/logo.gif" NDATA gif> |
|
4546 # |
|
4547 sub Unparsed |
|
4548 { |
|
4549 Entity (@_); # same as regular ENTITY, as far as DOM is concerned |
|
4550 } |
|
4551 |
|
4552 sub Element |
|
4553 { |
|
4554 shift; |
|
4555 # deb ("Element", @_); |
|
4556 |
|
4557 undef $_DP_last_text; |
|
4558 push @_, "Hidden" unless $_DP_expand_pent || $_DP_level == 0; |
|
4559 $_DP_doctype->addElementDecl (@_); |
|
4560 } |
|
4561 |
|
4562 sub Notation |
|
4563 { |
|
4564 shift; |
|
4565 # deb ("Notation", @_); |
|
4566 |
|
4567 undef $_DP_last_text; |
|
4568 $_[4] = "Hidden" unless $_DP_expand_pent || $_DP_level == 0; |
|
4569 $_DP_doctype->addNotation (@_); |
|
4570 } |
|
4571 |
|
4572 sub Proc |
|
4573 { |
|
4574 shift; |
|
4575 # deb ("Proc", @_); |
|
4576 |
|
4577 undef $_DP_last_text; |
|
4578 push @_, "Hidden" unless $_DP_expand_pent || $_DP_level == 0; |
|
4579 $_DP_elem->appendChild ($_DP_doc->createProcessingInstruction (@_)); |
|
4580 } |
|
4581 |
|
4582 # |
|
4583 # ExternEnt is called when an external entity, such as: |
|
4584 # |
|
4585 # <!ENTITY externalEntity PUBLIC "-//Enno//TEXT Enno's description//EN" |
|
4586 # "http://server/descr.txt"> |
|
4587 # |
|
4588 # is referenced in the document, e.g. with: &externalEntity; |
|
4589 # If ExternEnt is not specified, the entity reference is passed to the Default |
|
4590 # handler as e.g. "&externalEntity;", where an EntityReference object is added. |
|
4591 # |
|
4592 # Also for %externalEntity; references in the DTD itself. |
|
4593 # |
|
4594 # It can also be called when XML::Parser parses the DOCTYPE header |
|
4595 # (just before calling the DocType handler), when it contains a |
|
4596 # reference like "docbook.dtd" below: |
|
4597 # |
|
4598 # <!DOCTYPE book PUBLIC "-//Norman Walsh//DTD DocBk XML V3.1.3//EN" |
|
4599 # "docbook.dtd" [ |
|
4600 # ... rest of DTD ... |
|
4601 # |
|
4602 sub ExternEnt |
|
4603 { |
|
4604 my ($expat, $base, $sysid, $pubid) = @_; |
|
4605 # deb ("ExternEnt", @_); |
|
4606 |
|
4607 # Invoke XML::Parser's default ExternEnt handler |
|
4608 my $content; |
|
4609 if ($XML::Parser::have_LWP) |
|
4610 { |
|
4611 $content = XML::Parser::lwp_ext_ent_handler (@_); |
|
4612 } |
|
4613 else |
|
4614 { |
|
4615 $content = XML::Parser::file_ext_ent_handler (@_); |
|
4616 } |
|
4617 |
|
4618 if ($_DP_expand_pent) |
|
4619 { |
|
4620 return $content; |
|
4621 } |
|
4622 else |
|
4623 { |
|
4624 my $entname = $expat->{DOM_Entity}->{$sysid}; |
|
4625 if (defined $entname) |
|
4626 { |
|
4627 $_DP_doctype->appendChild ($_DP_doc->createEntityReference ($entname, 1)); |
|
4628 # Wrap the contents in special comments, so we know when we reach the |
|
4629 # end of parsing the entity. This way we can omit the contents from |
|
4630 # the DTD, when ExpandParamEnt is set to 0. |
|
4631 |
|
4632 return "<!-- $START_MARKER sysid=[$sysid] -->" . |
|
4633 $content . "<!-- $END_MARKER sysid=[$sysid] -->"; |
|
4634 } |
|
4635 else |
|
4636 { |
|
4637 # We either read the entity ref'd by the system id in the |
|
4638 # <!DOCTYPE> header, or the entity was undefined. |
|
4639 # In either case, don't bother with maintaining the entity |
|
4640 # reference, just expand the contents. |
|
4641 return "<!-- $START_MARKER sysid=[DTD] -->" . |
|
4642 $content . "<!-- $END_MARKER sysid=[DTD] -->"; |
|
4643 } |
|
4644 } |
|
4645 } |
|
4646 |
|
4647 1; # module return code |
|
4648 |
|
4649 __END__ |
|
4650 |
|
4651 =head1 NAME |
|
4652 |
|
4653 XML::DOM - A perl module for building DOM Level 1 compliant document structures |
|
4654 |
|
4655 =head1 SYNOPSIS |
|
4656 |
|
4657 use XML::DOM; |
|
4658 |
|
4659 my $parser = new XML::DOM::Parser; |
|
4660 my $doc = $parser->parsefile ("file.xml"); |
|
4661 |
|
4662 # print all HREF attributes of all CODEBASE elements |
|
4663 my $nodes = $doc->getElementsByTagName ("CODEBASE"); |
|
4664 my $n = $nodes->getLength; |
|
4665 |
|
4666 for (my $i = 0; $i < $n; $i++) |
|
4667 { |
|
4668 my $node = $nodes->item ($i); |
|
4669 my $href = $node->getAttributeNode ("HREF"); |
|
4670 print $href->getValue . "\n"; |
|
4671 } |
|
4672 |
|
4673 # Print doc file |
|
4674 $doc->printToFile ("out.xml"); |
|
4675 |
|
4676 # Print to string |
|
4677 print $doc->toString; |
|
4678 |
|
4679 # Avoid memory leaks - cleanup circular references for garbage collection |
|
4680 $doc->dispose; |
|
4681 |
|
4682 =head1 DESCRIPTION |
|
4683 |
|
4684 This module extends the XML::Parser module by Clark Cooper. |
|
4685 The XML::Parser module is built on top of XML::Parser::Expat, |
|
4686 which is a lower level interface to James Clark's expat library. |
|
4687 |
|
4688 XML::DOM::Parser is derived from XML::Parser. It parses XML strings or files |
|
4689 and builds a data structure that conforms to the API of the Document Object |
|
4690 Model as described at http://www.w3.org/TR/REC-DOM-Level-1. |
|
4691 See the XML::Parser manpage for other available features of the |
|
4692 XML::DOM::Parser class. |
|
4693 Note that the 'Style' property should not be used (it is set internally.) |
|
4694 |
|
4695 The XML::Parser I<NoExpand> option is more or less supported, in that it will |
|
4696 generate EntityReference objects whenever an entity reference is encountered |
|
4697 in character data. I'm not sure how useful this is. Any comments are welcome. |
|
4698 |
|
4699 As described in the synopsis, when you create an XML::DOM::Parser object, |
|
4700 the parse and parsefile methods create an I<XML::DOM::Document> object |
|
4701 from the specified input. This Document object can then be examined, modified and |
|
4702 written back out to a file or converted to a string. |
|
4703 |
|
4704 When using XML::DOM with XML::Parser version 2.19 and up, setting the |
|
4705 XML::DOM::Parser option I<KeepCDATA> to 1 will store CDATASections in |
|
4706 CDATASection nodes, instead of converting them to Text nodes. |
|
4707 Subsequent CDATASection nodes will be merged into one. Let me know if this |
|
4708 is a problem. |
|
4709 |
|
4710 When using XML::Parser 2.27 and above, you can suppress expansion of |
|
4711 parameter entity references (e.g. %pent;) in the DTD, by setting I<ParseParamEnt> |
|
4712 to 1 and I<ExpandParamEnt> to 0. See L<Hidden Nodes|/_Hidden_Nodes_> for details. |
|
4713 |
|
4714 A Document has a tree structure consisting of I<Node> objects. A Node may contain |
|
4715 other nodes, depending on its type. |
|
4716 A Document may have Element, Text, Comment, and CDATASection nodes. |
|
4717 Element nodes may have Attr, Element, Text, Comment, and CDATASection nodes. |
|
4718 The other nodes may not have any child nodes. |
|
4719 |
|
4720 This module adds several node types that are not part of the DOM spec (yet.) |
|
4721 These are: ElementDecl (for <!ELEMENT ...> declarations), AttlistDecl (for |
|
4722 <!ATTLIST ...> declarations), XMLDecl (for <?xml ...?> declarations) and AttDef |
|
4723 (for attribute definitions in an AttlistDecl.) |
|
4724 |
|
4725 =head1 XML::DOM Classes |
|
4726 |
|
4727 The XML::DOM module stores XML documents in a tree structure with a root node |
|
4728 of type XML::DOM::Document. Different nodes in tree represent different |
|
4729 parts of the XML file. The DOM Level 1 Specification defines the following |
|
4730 node types: |
|
4731 |
|
4732 =over 4 |
|
4733 |
|
4734 =item * L<XML::DOM::Node> - Super class of all node types |
|
4735 |
|
4736 =item * L<XML::DOM::Document> - The root of the XML document |
|
4737 |
|
4738 =item * L<XML::DOM::DocumentType> - Describes the document structure: <!DOCTYPE root [ ... ]> |
|
4739 |
|
4740 =item * L<XML::DOM::Element> - An XML element: <elem attr="val"> ... </elem> |
|
4741 |
|
4742 =item * L<XML::DOM::Attr> - An XML element attribute: name="value" |
|
4743 |
|
4744 =item * L<XML::DOM::CharacterData> - Super class of Text, Comment and CDATASection |
|
4745 |
|
4746 =item * L<XML::DOM::Text> - Text in an XML element |
|
4747 |
|
4748 =item * L<XML::DOM::CDATASection> - Escaped block of text: <![CDATA[ text ]]> |
|
4749 |
|
4750 =item * L<XML::DOM::Comment> - An XML comment: <!-- comment --> |
|
4751 |
|
4752 =item * L<XML::DOM::EntityReference> - Refers to an ENTITY: &ent; or %ent; |
|
4753 |
|
4754 =item * L<XML::DOM::Entity> - An ENTITY definition: <!ENTITY ...> |
|
4755 |
|
4756 =item * L<XML::DOM::ProcessingInstruction> - <?PI target> |
|
4757 |
|
4758 =item * L<XML::DOM::DocumentFragment> - Lightweight node for cut & paste |
|
4759 |
|
4760 =item * L<XML::DOM::Notation> - An NOTATION definition: <!NOTATION ...> |
|
4761 |
|
4762 =back |
|
4763 |
|
4764 In addition, the XML::DOM module contains the following nodes that are not part |
|
4765 of the DOM Level 1 Specification: |
|
4766 |
|
4767 =over 4 |
|
4768 |
|
4769 =item * L<XML::DOM::ElementDecl> - Defines an element: <!ELEMENT ...> |
|
4770 |
|
4771 =item * L<XML::DOM::AttlistDecl> - Defines one or more attributes in an <!ATTLIST ...> |
|
4772 |
|
4773 =item * L<XML::DOM::AttDef> - Defines one attribute in an <!ATTLIST ...> |
|
4774 |
|
4775 =item * L<XML::DOM::XMLDecl> - An XML declaration: <?xml version="1.0" ...> |
|
4776 |
|
4777 =back |
|
4778 |
|
4779 Other classes that are part of the DOM Level 1 Spec: |
|
4780 |
|
4781 =over 4 |
|
4782 |
|
4783 =item * L<XML::DOM::Implementation> - Provides information about this implementation. Currently it doesn't do much. |
|
4784 |
|
4785 =item * L<XML::DOM::NodeList> - Used internally to store a node's child nodes. Also returned by getElementsByTagName. |
|
4786 |
|
4787 =item * L<XML::DOM::NamedNodeMap> - Used internally to store an element's attributes. |
|
4788 |
|
4789 =back |
|
4790 |
|
4791 Other classes that are not part of the DOM Level 1 Spec: |
|
4792 |
|
4793 =over 4 |
|
4794 |
|
4795 =item * L<XML::DOM::Parser> - An non-validating XML parser that creates XML::DOM::Documents |
|
4796 |
|
4797 =item * L<XML::DOM::ValParser> - A validating XML parser that creates XML::DOM::Documents. It uses L<XML::Checker> to check against the DocumentType (DTD) |
|
4798 |
|
4799 =item * L<XML::Handler::BuildDOM> - A PerlSAX handler that creates XML::DOM::Documents. |
|
4800 |
|
4801 =back |
|
4802 |
|
4803 =head1 XML::DOM package |
|
4804 |
|
4805 =over 4 |
|
4806 |
|
4807 =item Constant definitions |
|
4808 |
|
4809 The following predefined constants indicate which type of node it is. |
|
4810 |
|
4811 =back |
|
4812 |
|
4813 UNKNOWN_NODE (0) The node type is unknown (not part of DOM) |
|
4814 |
|
4815 ELEMENT_NODE (1) The node is an Element. |
|
4816 ATTRIBUTE_NODE (2) The node is an Attr. |
|
4817 TEXT_NODE (3) The node is a Text node. |
|
4818 CDATA_SECTION_NODE (4) The node is a CDATASection. |
|
4819 ENTITY_REFERENCE_NODE (5) The node is an EntityReference. |
|
4820 ENTITY_NODE (6) The node is an Entity. |
|
4821 PROCESSING_INSTRUCTION_NODE (7) The node is a ProcessingInstruction. |
|
4822 COMMENT_NODE (8) The node is a Comment. |
|
4823 DOCUMENT_NODE (9) The node is a Document. |
|
4824 DOCUMENT_TYPE_NODE (10) The node is a DocumentType. |
|
4825 DOCUMENT_FRAGMENT_NODE (11) The node is a DocumentFragment. |
|
4826 NOTATION_NODE (12) The node is a Notation. |
|
4827 |
|
4828 ELEMENT_DECL_NODE (13) The node is an ElementDecl (not part of DOM) |
|
4829 ATT_DEF_NODE (14) The node is an AttDef (not part of DOM) |
|
4830 XML_DECL_NODE (15) The node is an XMLDecl (not part of DOM) |
|
4831 ATTLIST_DECL_NODE (16) The node is an AttlistDecl (not part of DOM) |
|
4832 |
|
4833 Usage: |
|
4834 |
|
4835 if ($node->getNodeType == ELEMENT_NODE) |
|
4836 { |
|
4837 print "It's an Element"; |
|
4838 } |
|
4839 |
|
4840 B<Not In DOM Spec>: The DOM Spec does not mention UNKNOWN_NODE and, |
|
4841 quite frankly, you should never encounter it. The last 4 node types were added |
|
4842 to support the 4 added node classes. |
|
4843 |
|
4844 =head2 Global Variables |
|
4845 |
|
4846 =over 4 |
|
4847 |
|
4848 =item $VERSION |
|
4849 |
|
4850 The variable $XML::DOM::VERSION contains the version number of this |
|
4851 implementation, e.g. "1.07". |
|
4852 |
|
4853 =back |
|
4854 |
|
4855 =head2 METHODS |
|
4856 |
|
4857 These methods are not part of the DOM Level 1 Specification. |
|
4858 |
|
4859 =over 4 |
|
4860 |
|
4861 =item getIgnoreReadOnly and ignoreReadOnly (readOnly) |
|
4862 |
|
4863 The DOM Level 1 Spec does not allow you to edit certain sections of the document, |
|
4864 e.g. the DocumentType, so by default this implementation throws DOMExceptions |
|
4865 (i.e. NO_MODIFICATION_ALLOWED_ERR) when you try to edit a readonly node. |
|
4866 These readonly checks can be disabled by (temporarily) setting the global |
|
4867 IgnoreReadOnly flag. |
|
4868 |
|
4869 The ignoreReadOnly method sets the global IgnoreReadOnly flag and returns its |
|
4870 previous value. The getIgnoreReadOnly method simply returns its current value. |
|
4871 |
|
4872 my $oldIgnore = XML::DOM::ignoreReadOnly (1); |
|
4873 eval { |
|
4874 ... do whatever you want, catching any other exceptions ... |
|
4875 }; |
|
4876 XML::DOM::ignoreReadOnly ($oldIgnore); # restore previous value |
|
4877 |
|
4878 Another way to do it, using a local variable: |
|
4879 |
|
4880 { # start new scope |
|
4881 local $XML::DOM::IgnoreReadOnly = 1; |
|
4882 ... do whatever you want, don't worry about exceptions ... |
|
4883 } # end of scope ($IgnoreReadOnly is set back to its previous value) |
|
4884 |
|
4885 |
|
4886 =item isValidName (name) |
|
4887 |
|
4888 Whether the specified name is a valid "Name" as specified in the XML spec. |
|
4889 Characters with Unicode values > 127 are now also supported. |
|
4890 |
|
4891 =item getAllowReservedNames and allowReservedNames (boolean) |
|
4892 |
|
4893 The first method returns whether reserved names are allowed. |
|
4894 The second takes a boolean argument and sets whether reserved names are allowed. |
|
4895 The initial value is 1 (i.e. allow reserved names.) |
|
4896 |
|
4897 The XML spec states that "Names" starting with (X|x)(M|m)(L|l) |
|
4898 are reserved for future use. (Amusingly enough, the XML version of the XML spec |
|
4899 (REC-xml-19980210.xml) breaks that very rule by defining an ENTITY with the name |
|
4900 'xmlpio'.) |
|
4901 A "Name" in this context means the Name token as found in the BNF rules in the |
|
4902 XML spec. |
|
4903 |
|
4904 XML::DOM only checks for errors when you modify the DOM tree, not when the |
|
4905 DOM tree is built by the XML::DOM::Parser. |
|
4906 |
|
4907 =item setTagCompression (funcref) |
|
4908 |
|
4909 There are 3 possible styles for printing empty Element tags: |
|
4910 |
|
4911 =over 4 |
|
4912 |
|
4913 =item Style 0 |
|
4914 |
|
4915 <empty/> or <empty attr="val"/> |
|
4916 |
|
4917 XML::DOM uses this style by default for all Elements. |
|
4918 |
|
4919 =item Style 1 |
|
4920 |
|
4921 <empty></empty> or <empty attr="val"></empty> |
|
4922 |
|
4923 =item Style 2 |
|
4924 |
|
4925 <empty /> or <empty attr="val" /> |
|
4926 |
|
4927 This style is sometimes desired when using XHTML. |
|
4928 (Note the extra space before the slash "/") |
|
4929 See L<http://www.w3.org/TR/xhtml1> Appendix C for more details. |
|
4930 |
|
4931 =back |
|
4932 |
|
4933 By default XML::DOM compresses all empty Element tags (style 0.) |
|
4934 You can control which style is used for a particular Element by calling |
|
4935 XML::DOM::setTagCompression with a reference to a function that takes |
|
4936 2 arguments. The first is the tag name of the Element, the second is the |
|
4937 XML::DOM::Element that is being printed. |
|
4938 The function should return 0, 1 or 2 to indicate which style should be used to |
|
4939 print the empty tag. E.g. |
|
4940 |
|
4941 XML::DOM::setTagCompression (\&my_tag_compression); |
|
4942 |
|
4943 sub my_tag_compression |
|
4944 { |
|
4945 my ($tag, $elem) = @_; |
|
4946 |
|
4947 # Print empty br, hr and img tags like this: <br /> |
|
4948 return 2 if $tag =~ /^(br|hr|img)$/; |
|
4949 |
|
4950 # Print other empty tags like this: <empty></empty> |
|
4951 return 1; |
|
4952 } |
|
4953 |
|
4954 =back |
|
4955 |
|
4956 =head1 IMPLEMENTATION DETAILS |
|
4957 |
|
4958 =over 4 |
|
4959 |
|
4960 =item * Perl Mappings |
|
4961 |
|
4962 The value undef was used when the DOM Spec said null. |
|
4963 |
|
4964 The DOM Spec says: Applications must encode DOMString using UTF-16 (defined in |
|
4965 Appendix C.3 of [UNICODE] and Amendment 1 of [ISO-10646]). |
|
4966 In this implementation we use plain old Perl strings encoded in UTF-8 instead of |
|
4967 UTF-16. |
|
4968 |
|
4969 =item * Text and CDATASection nodes |
|
4970 |
|
4971 The Expat parser expands EntityReferences and CDataSection sections to |
|
4972 raw strings and does not indicate where it was found. |
|
4973 This implementation does therefore convert both to Text nodes at parse time. |
|
4974 CDATASection and EntityReference nodes that are added to an existing Document |
|
4975 (by the user) will be preserved. |
|
4976 |
|
4977 Also, subsequent Text nodes are always merged at parse time. Text nodes that are |
|
4978 added later can be merged with the normalize method. Consider using the addText |
|
4979 method when adding Text nodes. |
|
4980 |
|
4981 =item * Printing and toString |
|
4982 |
|
4983 When printing (and converting an XML Document to a string) the strings have to |
|
4984 encoded differently depending on where they occur. E.g. in a CDATASection all |
|
4985 substrings are allowed except for "]]>". In regular text, certain characters are |
|
4986 not allowed, e.g. ">" has to be converted to ">". |
|
4987 These routines should be verified by someone who knows the details. |
|
4988 |
|
4989 =item * Quotes |
|
4990 |
|
4991 Certain sections in XML are quoted, like attribute values in an Element. |
|
4992 XML::Parser strips these quotes and the print methods in this implementation |
|
4993 always uses double quotes, so when parsing and printing a document, single quotes |
|
4994 may be converted to double quotes. The default value of an attribute definition |
|
4995 (AttDef) in an AttlistDecl, however, will maintain its quotes. |
|
4996 |
|
4997 =item * AttlistDecl |
|
4998 |
|
4999 Attribute declarations for a certain Element are always merged into a single |
|
5000 AttlistDecl object. |
|
5001 |
|
5002 =item * Comments |
|
5003 |
|
5004 Comments in the DOCTYPE section are not kept in the right place. They will become |
|
5005 child nodes of the Document. |
|
5006 |
|
5007 =item * Hidden Nodes |
|
5008 |
|
5009 Previous versions of XML::DOM would expand parameter entity references |
|
5010 (like B<%pent;>), so when printing the DTD, it would print the contents |
|
5011 of the external entity, instead of the parameter entity reference. |
|
5012 With this release (1.27), you can prevent this by setting the XML::DOM::Parser |
|
5013 options ParseParamEnt => 1 and ExpandParamEnt => 0. |
|
5014 |
|
5015 When it is parsing the contents of the external entities, it *DOES* still add |
|
5016 the nodes to the DocumentType, but it marks these nodes by setting |
|
5017 the 'Hidden' property. In addition, it adds an EntityReference node to the |
|
5018 DocumentType node. |
|
5019 |
|
5020 When printing the DocumentType node (or when using to_expat() or to_sax()), |
|
5021 the 'Hidden' nodes are suppressed, so you will see the parameter entity |
|
5022 reference instead of the contents of the external entities. See test case |
|
5023 t/dom_extent.t for an example. |
|
5024 |
|
5025 The reason for adding the 'Hidden' nodes to the DocumentType node, is that |
|
5026 the nodes may contain <!ENTITY> definitions that are referenced further |
|
5027 in the document. (Simply not adding the nodes to the DocumentType could |
|
5028 cause such entity references to be expanded incorrectly.) |
|
5029 |
|
5030 Note that you need XML::Parser 2.27 or higher for this to work correctly. |
|
5031 |
|
5032 =back |
|
5033 |
|
5034 =head1 SEE ALSO |
|
5035 |
|
5036 The Japanese version of this document by Takanori Kawai (Hippo2000) |
|
5037 at L<http://member.nifty.ne.jp/hippo2000/perltips/xml/dom.htm> |
|
5038 |
|
5039 The DOM Level 1 specification at L<http://www.w3.org/TR/REC-DOM-Level-1> |
|
5040 |
|
5041 The XML spec (Extensible Markup Language 1.0) at L<http://www.w3.org/TR/REC-xml> |
|
5042 |
|
5043 The L<XML::Parser> and L<XML::Parser::Expat> manual pages. |
|
5044 |
|
5045 =head1 CAVEATS |
|
5046 |
|
5047 The method getElementsByTagName() does not return a "live" NodeList. |
|
5048 Whether this is an actual caveat is debatable, but a few people on the |
|
5049 www-dom mailing list seemed to think so. I haven't decided yet. It's a pain |
|
5050 to implement, it slows things down and the benefits seem marginal. |
|
5051 Let me know what you think. |
|
5052 |
|
5053 (To subscribe to the www-dom mailing list send an email with the subject |
|
5054 "subscribe" to www-dom-request@w3.org. I only look here occasionally, so don't |
|
5055 send bug reports or suggestions about XML::DOM to this list, send them |
|
5056 to enno@att.com instead.) |
|
5057 |
|
5058 =head1 AUTHOR |
|
5059 |
|
5060 Send bug reports, hints, tips, suggestions to Enno Derksen at |
|
5061 <F<enno@att.com>>. |
|
5062 |
|
5063 Thanks to Clark Cooper for his help with the initial version. |
|
5064 |
|
5065 =cut |
|