################################################################################

#

# Perl module: XML::DOM

#

# By Enno Derksen <enno@att.com>

#

################################################################################

#

# To do:

#

# * optimize Attr if it only contains 1 Text node to hold the value

# * fix setDocType!

#

# * BUG: setOwnerDocument - does not process default attr values correctly,

#   they still point to the old doc.

# * change Exception mechanism

# * maybe: more checking of sysId etc.

# * NoExpand mode (don't know what else is useful)

# * various odds and ends: see comments starting with "??"

# * normalize(1) could also expand CDataSections and EntityReferences

# * parse a DocumentFragment?

# * encoding support

#

######################################################################

######################################################################

package XML::DOM;

######################################################################

use strict;

use vars qw( $VERSION @ISA @EXPORT

	     $IgnoreReadOnly $SafeMode $TagStyle

	     %DefaultEntities %DecodeDefaultEntity

	   );

use Carp;

use XML::RegExp;

BEGIN

{

    require XML::Parser;

    $VERSION = '1.27';

    my $needVersion = '2.23';

    die "need at least XML::Parser version $needVersion (current=${XML::Parser::VERSION})"

	unless $XML::Parser::VERSION >= $needVersion;

    @ISA = qw( Exporter );

    # Constants for XML::DOM Node types

    @EXPORT = qw(

	     UNKNOWN_NODE

	     ELEMENT_NODE

	     ATTRIBUTE_NODE

	     TEXT_NODE

	     CDATA_SECTION_NODE

	     ENTITY_REFERENCE_NODE

	     ENTITY_NODE

	     PROCESSING_INSTRUCTION_NODE

	     COMMENT_NODE

	     DOCUMENT_NODE

	     DOCUMENT_TYPE_NODE

	     DOCUMENT_FRAGMENT_NODE

	     NOTATION_NODE

	     ELEMENT_DECL_NODE

	     ATT_DEF_NODE

	     XML_DECL_NODE

	     ATTLIST_DECL_NODE

	    );

}

#---- Constant definitions

# Node types

sub UNKNOWN_NODE                () { 0 }		# not in the DOM Spec

sub ELEMENT_NODE                () { 1 }

sub ATTRIBUTE_NODE              () { 2 }

sub TEXT_NODE                   () { 3 }

sub CDATA_SECTION_NODE          () { 4 }

sub ENTITY_REFERENCE_NODE       () { 5 }

sub ENTITY_NODE                 () { 6 }

sub PROCESSING_INSTRUCTION_NODE () { 7 }

sub COMMENT_NODE                () { 8 }

sub DOCUMENT_NODE               () { 9 }

sub DOCUMENT_TYPE_NODE          () { 10}

sub DOCUMENT_FRAGMENT_NODE      () { 11}

sub NOTATION_NODE               () { 12}

sub ELEMENT_DECL_NODE		() { 13 }	# not in the DOM Spec

sub ATT_DEF_NODE 		() { 14 }	# not in the DOM Spec

sub XML_DECL_NODE 		() { 15 }	# not in the DOM Spec

sub ATTLIST_DECL_NODE		() { 16 }	# not in the DOM Spec

%DefaultEntities = 

(

 "quot"		=> '"',

 "gt"		=> ">",

 "lt"		=> "<",

 "apos"		=> "'",

 "amp"		=> "&"

);

%DecodeDefaultEntity =

(

 '"' => """,

 ">" => ">",

 "<" => "&lt;",

 "'" => "'",

 "&" => "&"

);

#

# If you don't want DOM warnings to use 'warn', override this method like this:

#

# { # start block scope

#	local *XML::DOM::warning = \&my_warn;

#	... your code here ...

# } # end block scope (old XML::DOM::warning takes effect again)

#

sub warning	# static

{

    warn @_;

}

#

# This method defines several things in the caller's package, so you can use named constants to

# access the array that holds the member data, i.e. $self->[_Data]. It assumes the caller's package

# defines a class that is implemented as a blessed array reference.

# Note that this is very similar to using 'use fields' and 'use base'.

#

# E.g. if $fields eq "Name Model", $parent eq "XML::DOM::Node" and

# XML::DOM::Node had "A B C" as fields and it was called from package "XML::DOM::ElementDecl",

# then this code would basically do the following:

#

# package XML::DOM::ElementDecl;

#

# sub _Name  () { 3 }	# Note that parent class had three fields

# sub _Model () { 4 }

#

# # Maps constant names (without '_') to constant (int) value

# %HFIELDS = ( %XML::DOM::Node::HFIELDS, Name => _Name, Model => _Model );

#

# # Define XML:DOM::ElementDecl as a subclass of XML::DOM::Node

# @ISA = qw{ XML::DOM::Node };

#

# # The following function names can be exported into the user's namespace.

# @EXPORT_OK = qw{ _Name _Model };

#

# # The following function names can be exported into the user's namespace

# # with: import XML::DOM::ElementDecl qw( :Fields );

# %EXPORT_TAGS = ( Fields => qw{ _Name _Model } );

#

sub def_fields	# static

{

    my ($fields, $parent) = @_;

    my ($pkg) = caller;

    no strict 'refs';

    my @f = split (/\s+/, $fields);

    my $n = 0;

    my %hfields;

    if (defined $parent)

    {

	my %pf = %{"$parent\::HFIELDS"};

	%hfields = %pf;

	$n = scalar (keys %pf);

	@{"$pkg\::ISA"} = ( $parent );

    }

    my $i = $n;

    for (@f)

    {

	eval "sub $pkg\::_$_ () { $i }";

	$hfields{$_} = $i;

	$i++;

    }

    %{"$pkg\::HFIELDS"} = %hfields;

    @{"$pkg\::EXPORT_OK"} = map { "_$_" } @f;

    ${"$pkg\::EXPORT_TAGS"}{Fields} = [ map { "_$_" } @f ];

}

# sub blesh

# {

#     my $hashref = shift;

#     my $class = shift;

#     no strict 'refs';

#     my $self = bless [\%{"$class\::FIELDS"}], $class;

#     if (defined $hashref)

#     {

# 	for (keys %$hashref)

# 	{

# 	    $self->{$_} = $hashref->{$_};

# 	}

#     }

#     $self;

# }

# sub blesh2

# {

#     my $hashref = shift;

#     my $class = shift;

#     no strict 'refs';

#     my $self = bless [\%{"$class\::FIELDS"}], $class;

#     if (defined $hashref)

#     {

# 	for (keys %$hashref)

# 	{

# 	    eval { $self->{$_} = $hashref->{$_}; };

# 	    croak "ERROR in field [$_] $@" if $@;

# 	}

#     }

#     $self;

#}

#

# CDATA section may not contain "]]>"

#

sub encodeCDATA

{

    my ($str) = shift;

    $str =~ s/]]>/]]>/go;

    $str;

}

#

# PI may not contain "?>"

#

sub encodeProcessingInstruction

{

    my ($str) = shift;

    $str =~ s/\?>/?>/go;

    $str;

}

#

#?? Not sure if this is right - must prevent double minus somehow...

#

sub encodeComment

{

    my ($str) = shift;

    return undef unless defined $str;

    $str =~ s/--/--/go;

    $str;

}

#

# For debugging

#

sub toHex

{

    my $str = shift;

    my $len = length($str);

    my @a = unpack ("C$len", $str);

    my $s = "";

    for (@a)

    {

	$s .= sprintf ("%02x", $_);

    }

    $s;

}

#

# 2nd parameter $default: list of Default Entity characters that need to be 

# converted (e.g. "&<" for conversion to "&amp;" and "&lt;" resp.)

#

sub encodeText

{

    my ($str, $default) = @_;

    return undef unless defined $str;

    $str =~ s/([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)|([$default])|(]]>)/

	defined($1) ? XmlUtf8Decode ($1) : 

	defined ($2) ? $DecodeDefaultEntity{$2} : "]]>" /egs;

#?? could there be references that should not be expanded?

# e.g. should not replace &#nn; ¯ and &abc;

#    $str =~ s/&(?!($ReName|#[0-9]+|#x[0-9a-fA-F]+);)/&/go;

    $str;

}

#

# Used by AttDef - default value

#

sub encodeAttrValue

{

    encodeText (shift, '"&<');

}

#

# Converts an integer (Unicode - ISO/IEC 10646) to a UTF-8 encoded character 

# sequence.

# Used when converting e.g. { or Ͽ to a string value.

#

# Algorithm borrowed from expat/xmltok.c/XmlUtf8Encode()

#

# not checking for bad characters: < 0, x00-x08, x0B-x0C, x0E-x1F, xFFFE-xFFFF

#

sub XmlUtf8Encode

{

    my $n = shift;

    if ($n < 0x80)

    {

	return chr ($n);

    }

    elsif ($n < 0x800)

    {

	return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80));

    }

    elsif ($n < 0x10000)

    {

	return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80),

		     (($n & 0x3f) | 0x80));

    }

    elsif ($n < 0x110000)

    {

	return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80),

		     ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80));

    }

    croak "number is too large for Unicode [$n] in &XmlUtf8Encode";

}

#

# Opposite of XmlUtf8Decode plus it adds prefix "&#" or "&#x" and suffix ";"

# The 2nd parameter ($hex) indicates whether the result is hex encoded or not.

#

sub XmlUtf8Decode

{

    my ($str, $hex) = @_;

    my $len = length ($str);

    my $n;

    if ($len == 2)

    {

	my @n = unpack "C2", $str;

	$n = (($n[0] & 0x3f) << 6) + ($n[1] & 0x3f);

    }

    elsif ($len == 3)

    {

	my @n = unpack "C3", $str;

	$n = (($n[0] & 0x1f) << 12) + (($n[1] & 0x3f) << 6) + 

		($n[2] & 0x3f);

    }

    elsif ($len == 4)

    {

	my @n = unpack "C4", $str;

	$n = (($n[0] & 0x0f) << 18) + (($n[1] & 0x3f) << 12) + 

		(($n[2] & 0x3f) << 6) + ($n[3] & 0x3f);

    }

    elsif ($len == 1)	# just to be complete...

    {

	$n = ord ($str);

    }

    else

    {

	croak "bad value [$str] for XmlUtf8Decode";

    }

    $hex ? sprintf ("&#x%x;", $n) : "&#$n;";

}

$IgnoreReadOnly = 0;

$SafeMode = 1;

sub getIgnoreReadOnly

{

    $IgnoreReadOnly;

}

#

# The global flag $IgnoreReadOnly is set to the specified value and the old 

# value of $IgnoreReadOnly is returned.

#

# To temporarily disable read-only related exceptions (i.e. when parsing

# XML or temporarily), do the following:

#

# my $oldIgnore = XML::DOM::ignoreReadOnly (1);

# ... do whatever you want ...

# XML::DOM::ignoreReadOnly ($oldIgnore);

#

sub ignoreReadOnly

{

    my $i = $IgnoreReadOnly;

    $IgnoreReadOnly = $_[0];

    return $i;

}

#

# XML spec seems to break its own rules... (see ENTITY xmlpio)

#

sub forgiving_isValidName

{

    $_[0] =~ /^$XML::RegExp::Name$/o;

}

#

# Don't allow names starting with xml (either case)

#

sub picky_isValidName

{

    $_[0] =~ /^$XML::RegExp::Name$/o and $_[0] !~ /^xml/i;

}

# Be forgiving by default, 

*isValidName = \&forgiving_isValidName;

sub allowReservedNames		# static

{

    *isValidName = ($_[0] ? \&forgiving_isValidName : \&picky_isValidName);

}

sub getAllowReservedNames	# static

{

    *isValidName == \&forgiving_isValidName;

}

#

# Always compress empty tags by default

# This is used by Element::print.

#

$TagStyle = sub { 0 };

sub setTagCompression

{

    $TagStyle = shift;

}

######################################################################

package XML::DOM::PrintToFileHandle;

######################################################################

#

# Used by XML::DOM::Node::printToFileHandle

#

sub new

{

    my($class, $fn) = @_;

    bless $fn, $class;

}

sub print

{

    my ($self, $str) = @_;

    print $self $str;

}

######################################################################

package XML::DOM::PrintToString;

######################################################################

use vars qw{ $Singleton };

#

# Used by XML::DOM::Node::toString to concatenate strings

#

sub new

{

    my($class) = @_;

    my $str = "";

    bless \$str, $class;

}

sub print

{

    my ($self, $str) = @_;

    $$self .= $str;

}

sub toString

{

    my $self = shift;

    $$self;

}

sub reset

{

    ${$_[0]} = "";

}

$Singleton = new XML::DOM::PrintToString;

######################################################################

package XML::DOM::DOMImplementation;

######################################################################

$XML::DOM::DOMImplementation::Singleton =

  bless \$XML::DOM::DOMImplementation::Singleton, 'XML::DOM::DOMImplementation';

sub hasFeature 

{

    my ($self, $feature, $version) = @_;

    $feature eq 'XML' and $version eq '1.0';

}

######################################################################

package XML::XQL::Node;		# forward declaration

######################################################################

######################################################################

package XML::DOM::Node;

######################################################################

use vars qw( @NodeNames @EXPORT @ISA %HFIELDS @EXPORT_OK @EXPORT_TAGS );

BEGIN 

{

  use XML::DOM::DOMException;

  import Carp;

  require FileHandle;

  @ISA = qw( Exporter XML::XQL::Node );

  # NOTE: SortKey is used in XML::XQL::Node. 

  #       UserData is reserved for users (Hang your data here!)

  XML::DOM::def_fields ("C A Doc Parent ReadOnly UsedIn Hidden SortKey UserData");

  push (@EXPORT, qw(