File Coverage

blib/lib/XML/DOM.pm
Criterion Covered Total %
statement 13 18 72.2
branch 0 2 0.0
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 25 72.0


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