#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

# $Id: XmlElementTree.pm,v 1.13 2004/06/06 23:35:48 eric Exp $

use strict;
require Exporter;
require AutoLoader;

$W3C::XML::XmlElementTree::REVISION = '$Id: XmlElementTree.pm,v 1.13 2004/06/06 23:35:48 eric Exp $ ';

package W3C::XML::XmlElementTree;
use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK @TODO);
@ISA = qw(Exporter AutoLoader);
@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = 0.96;
$DSLI = 'adpO';
@TODO = ('!!! this is radically different than the java equivilent. Not only is it not done, there are design conflicts between the Java and the Perl versions.');

package W3C::XML::XmlElement;

#####
# constants

*W3C::XML::XmlElement::XMLELEMENT = \1;
*W3C::XML::XmlElement::XMLDATAELEMENT = \2;
*W3C::XML::XmlElement::XMLIGNORABLEELEMENT = \3;

#####
# per-class data

my $Debugging = 0;	# whether to show debugging stuff
my $Outstanding = 0;	# count of outstanding connections

#####
# per-object data
# ATTIBUTES	- array of all the collected attributes
# DEBUG		- per-object control of debugging info

#####
# new - prepare a W3C::XML::XmlElement

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    $self->{TYPE} = $W3C::XML::XmlElement::XMLELEMENT;
    $self->{TREE} = shift;
    $self->{NAME} = shift;
    $self->{ATTRIBUTES} = shift; # may be undef
    $self->{PARENT} = shift; # may be undef
    $self->{CHILDREN} = [];
    $self->{DEBUG} = 0;
    $self->{"_OUTSTANDING"} = \$Outstanding;
    bless ($self, $class);
    ++ ${ $self->{"_OUTSTANDING"} };
    return $self;
}

sub getName {
    my ($self) = @_;
    return $self->{NAME};
}

sub getAttribute {
    my ($self, $name) = @_;
    return $self->{ATTRIBUTES}->getValue($name);
}

sub getParent {
    my ($self) = @_;
    return $self->{PARENT};
}

sub addChild {
    my ($self, $child) = @_;
    push (@{$self->{CHILDREN}}, $child);
}

sub getChildren {
    my ($self) = @_;
    return @{$self->{CHILDREN}};
}

sub getType {
    my ($self) = @_;
    return $self->{TYPE};
}

# returns: ARRAY of [DATA] or value from name=value pair or undef

sub findTag {
    my ($self, $needed) = @_;
    return $self if ($self->{NAME} eq $needed);
    return (defined $self->{PARENT}) ? 
	$self->{PARENT}->findTag($needed) :
	    undef;
}

sub findTagOrAttributeInside {
    my ($self, $needed, $inside) = @_;
    if ($self->{NAME} eq $needed) {
	# This overrides previous defs, now see if it's empty or not
	foreach my $child (@{$self->{CHILDREN}}) {
	    return ($self, $W3C::XML::XmlElement::XMLDATAELEMENT) if ($child->getName() eq '[DATA]');
	}
	return ($self, undef);
    }
    return ($self, $W3C::XML::XmlElement::XMLELEMENT) if (defined $self->{ATTRIBUTES}->getValue($needed));
#    for (my $i = 0; $i <= $self->{ATTRIBUTES}->getLength(); $i++) {
#	($self->{ATTRIBUTES}->getName($i), $self->{ATTRIBUTES}->getType($i), $self->{ATTRIBUTES}->getValue($i));
#    }
    return ($self->{NAME} ne $inside && defined $self->{PARENT}) ? 
	$self->{PARENT}->findTagOrAttributeInside($needed, $inside) :
	    (undef, undef);
}

sub show {
    my ($self, $prefix) = @_;
    my $ret;
    $ret .= $prefix.$self."\n";
    $ret .= $prefix.'NAME: '.$self->{TREE}->unmapNamespace($self->{NAME})."\n";
    $ret .= $prefix.'TYPE: '.$self->{TYPE}.'('.(ref $self).")\n";
    my $attributes;
    $attributes = $self->{ATTRIBUTES}->show($prefix, $self->{TREE}) if ($self->{ATTRIBUTES});
    $ret .= $prefix.'ATTRIBUTES: '.$attributes if ($attributes =~ /\S/);
    return $ret;
}

sub showTree {
    my ($self, $lookFor, $prefix) = @_;
    my $ret;
    $ret .= "*************\n" if ($self == $lookFor);
    $ret .= $self->show($prefix);
    foreach my $child (@{$self->{CHILDREN}}) {
	$ret .= $child->showTree($lookFor, $prefix.'  ');
    }
    return $ret;
}

#####
# debug - cannonical debugging stuff from
# http://www.perl.com/CPAN-local/doc/manual/html/pod/perltoot/Debuging_Methods.html

sub debug {
    my ($self, $level) = @_;
    warn "usage: thing->debug(level)"    unless @_ == 1;
    if (ref($self))  {
	$self->{"_DEBUG"} = $level;         # just myself
    } else {
	$Debugging        = $level;         # whole class
    }
}

#####
# DESTROY - hook to display debugging info

sub DESTROY {
    my ($self) = @_;
    if ($Debugging || $self->{"_DEBUG"}) {
	warn "W3C::XML::XmlElement destroying $self " . $self->name;
    }
    -- ${ $self->{"_OUTSTANDING"} };
}

#####
# END - hook to display debugging info

sub END {
    if ($Debugging) {
	print "All XmlElements are going away now.\n";
    }
}

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

package W3C::XML::XmlDataElement;

@W3C::XML::XmlDataElement::ISA = ("W3C::XML::XmlElement");

#####
# per-object data

#####
# new - prepare a special kind of W3C::XML::XmlElement

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $data = shift;
    my $self = $class->SUPER::new(shift, '[DATA]', undef, shift);
    $self->{TYPE} = $W3C::XML::XmlElement::XMLDATAELEMENT;
    $self->{DATA} = $data;
    $self->{ID_STR} = 'DATA';
    bless ($self, $class);
    return $self;
}

sub getData {
    my ($self) = @_;
    return $self->{DATA};
}

sub show {
    my ($self, $prefix) = @_;
    my $ret;
    $ret .= $self->SUPER::show($prefix);
    $ret .= $prefix.$self->{ID_STR}.': '.$self->{DATA}."\n";
    return $ret;
}

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

package W3C::XML::XmlIgnorableElement;
@W3C::XML::XmlIgnorableElement::ISA = ("W3C::XML::XmlDataElement");

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(shift, shift, shift); # '[IGNORABLE]', undef, shift);
    $self->{TYPE} = $W3C::XML::XmlElement::XMLIGNORABLEELEMENT;
    $self->{NAME} = '[IGNORABLE]';
    $self->{ID_STR} = 'WHITESPACE';
    bless ($self, $class);
    return $self;
}

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

package W3C::XML::XmlElementTree;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless ($self, $class);
    $self->clear;
    return $self;
}

sub clear {
    my ($self) = @_;
    $self->{CURRENT} = undef;
    $self->{ROOT} = undef;
}

sub addChild {
    my ($self, $newEl) = @_;
    if (defined $self->{CURRENT}) {
	$self->{CURRENT}->addChild($newEl);
    } else {
	$self->{ROOT} = $newEl;
    }
}

sub hasRoot {
    my ($self) = @_;
    return defined $self->{ROOT};
}

sub atRoot {
    my ($self) = @_;
#    return $self->{CURRENT} == $self->{ROOT};
    return $self->{CURRENT} == undef;
}

sub getCurrent {
    my ($self) = @_;
    return $self->{CURRENT};
}

#####
# documentHandler routines

sub setDocumentLocator {
    my ($self, $xmlParser) = @_;
    $self->{SOURCE_ID} = $xmlParser->getPublicId;
}

sub startDocument {
    my $self = shift;
    $self->clear;
}

sub endDocument {
    my $self = shift;
}

sub startElement { # @@@ make a shortcut that just maintains a stack
    my ($self, $name, $attributeList) = @_;
    my $newEl = new W3C::XML::XmlElement($self, $name, $attributeList, $self->{CURRENT});
    $self->addChild($newEl);
    $self->{CURRENT} = $newEl;
    return $newEl;
}

sub endElement { # @@@ make a shortcut that just maintains a stack
    my ($self, $name) = @_;
    my $ret = $self->{CURRENT};
    $self->{CURRENT} = $self->{CURRENT}->getParent();
    return $ret;
}

sub characters { # @@@ make a shortcut that just maintains a stack
    my ($self, $ch, $start, $length) = @_;
    my $data = substr($ch, $start, $start+$length);
    my $newEl = new W3C::XML::XmlDataElement($data, $self, $self->{CURRENT});
    $self->addChild($newEl);
    return $newEl;
    # do not set new data element to be {CURRENT}!
}

sub ignorableWhitespace {
    my ($self, $ch, $start, $length) = @_;
    my $data = substr($ch, $start, $start+$length);
    my $newEl = new W3C::XML::XmlIgnorableElement($data, $self, $self->{CURRENT});
    $self->addChild($newEl);
    return $newEl;
}

sub processingInstruction {
    my $self = shift;
}

sub addNamespace {
    my ($self, $sAs, $sHref) = @_;
}

#####
# pretty-print the data

sub setNamespaceHandler {
    my ($self, $namespaceHandler) = @_;
    $self->{NAMESPACE_HANDLER} = $namespaceHandler;
}

# support the W3C::XML::OldNamespaceHandler::unmapNamespace function so we can _be_ a W3C::XML::OldNamespaceHandler

sub unmapNamespace {
    my ($self, $name) = @_;
    $name = $self->{NAMESPACE_HANDLER}->unmapNamespace($name, $self->{SOURCE_ID}) if ($self->{NAMESPACE_HANDLER});
    $name =~ s/\A\Q$self->{SOURCE_ID}\E/<source>/;
    return $name;
}

sub show {
    my ($self) = shift;
    return $self->{ROOT}->showTree($self->{CURRENT}, @_);
}

1;

__END__

=head1 NAME

W3C::XML::XmlElementTree.pm - SAX document handler to build a tree of XML nodes

=head1 SYNOPSIS

  use W3C::XML::XmlParser;
  use W3C::XML::VerboseXmlHandler;
  use W3C::XML::XmlElementTree;
  use W3C::XML::InputSource;
  my $xmlParser = new W3C::XML::PerlXmlParser;
  my $verboseHandler = new W3C::XML::VerboseXmlHandler;
  my $treeHandler = new W3C::XML::XmlElementTree;

  my $handlerList = new W3C::XML::HandlerList([$treeHandler, $verboseHandler], [$verboseHandler]);

  # set the W3C::XML::HandlerList be the document handler and the error handler
  $xmlParser->setDocumentHandler($handler);
  $xmlParser->setErrorHandler($handler);

  # assign a URI to the XML in InputSorce and parse it
  my $inputSource = new W3C::XML::FileInputSource($source);
  eval {$xmlParser->parse($inputSource);};

=head1 DESCRIPTION

The XmlElementTree is a simple tree of XML elements.

This module is part of the W3C::XML CPAN module.

=head1 AUTHOR

Eric Prud\'hommeaux <eric@w3.org>

=head1 SEE ALSO

perl(1).

=cut
