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

# $Id: HandlerBase.pm,v 1.45 2004/06/06 21:21:28 eric Exp $

use strict;
require Exporter;
require AutoLoader;

$W3C::XML::HandlerBase::REVISION = '$Id: HandlerBase.pm,v 1.45 2004/06/06 21:21:28 eric Exp $ ';

package W3C::XML::HandlerBase;
use W3C::Util::Exception;
use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK @CHANGES);
@ISA = qw(Exporter AutoLoader);
@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = 0.98;
$DSLI = 'adpO';
@CHANGES = (
	    {'0.96' => ['added NamespaceHandler::addNamespace']}, 
	    {'0.95' => ['started keeping track']});

package W3C::XML::UnknownNamespaceException;
@W3C::XML::UnknownNamespaceException::ISA = qw(W3C::Util::Exception);
sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-namespace') if (!exists $self->{-namespace});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'unknown namespace: "'.$_[0]->getNamespace.'"';}
sub getNamespace {return $_[0]->{-namespace};}

package W3C::XML::HandlerBase;

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self;
    if (ref $parms[0] eq 'HASH') {
	$self = $parms[0];
    } elsif (!ref $parms[0] && !(@parms % 2)) {
	$self = {@parms};
    } else {
	&throw(new W3C::Util::Exception(-parameter => $parms[0], 
					-message => $class.' must be constructed with a HASH, not a '.ref $parms[0]));
    }
    eval {
	bless ($self, $class);
    }; if ($@) {
	&throw(new W3C::Util::Exception($@));
    }
    return $self;
}

#####
# entityResolver routines

sub resolveEntity {
    my ($self, $publicId, $systemId) = @_;
    return undef;
}

#####
# DTDHandler routines

sub notationDecl {
    my ($self, $name, $publicId, $systemId) = @_;
}

sub unparsedEntityDecl {
    my ($self, $name, $publicId, $systemId, $notationName) = @_;
}

#####
# documentHandler routines

sub setDocumentLocator {
    my ($self, $locator) = @_;
}

sub startDocument {
    my ($self) = @_;
}

sub endDocument {
    my ($self) = @_;
}

sub startElement {
    my ($self, $name, $attributeList) = @_;
}

sub endElement {
    my ($self, $name) = @_;
}

sub characters {
    my ($self, $ch, $start, $length) = @_;
}

sub ignorableWhitespace {
    my ($self, $ch, $start, $length) = @_;
}

sub processingInstruction {
    my ($self, $target, $data) = @_;
}

#####
# ErrorHandler routines

sub warning {
    my ($self, $exception) = @_;
}

sub error {
    my ($self, $exception) = @_;
}

sub fatalError {
    my ($self, $exception) = @_;
    &throw($exception);
}

package W3C::XML::StackDocumentHandler;
use W3C::Util::Exception;
@W3C::XML::StackDocumentHandler::ISA = ("W3C::XML::HandlerBase");

#####
# new - prepare a new stack to maintain state

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->{PARMS} = [0]; # default to SAX1
    return $self;
}

sub setDocumentLocator {
    my $self = shift;
    $self->SUPER::setDocumentLocator(@_);
    $self->{DOCUMENT_LOCATOR} = $_[0];
}

sub startDocument {
    my $self = shift;
    $self->SUPER::startDocument(@_);
    $self->{ELEMENT_STACK} = [];
}

sub endDocument {
    my $self = shift;
    $self->SUPER::endDocument(@_);
    if (@{$self->{ELEMENT_STACK}}) {
	&throw(new W3C::XML::SAXParserException($self->{DOCUMENT_LOCATOR}));
    }
}

sub startElement {
    my $self = shift;
    $self->SUPER::startElement(@_);
    push (@{$self->{ELEMENT_STACK}}, [@_[@{$self->{PARMS}}]]);
}

sub endElement {
    my $self = shift;
    $self->SUPER::endElement(@_);
    pop (@{$self->{ELEMENT_STACK}});
}

sub show {
    my ($self) = shift;
    my $ret;
    eval {$ret = $self->SUPER::show(@_)."\n";}; # don't assume the function exists
    return $ret;
}

package W3C::XML::HandlerStream;
use W3C::Util::Exception;
@W3C::XML::HandlerStream::ISA = ("W3C::XML::HandlerBase");

#####
# new - 

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    return $self;
}

sub setDocumentHandler {
    my ($self, $handler) = @_;
    $self->{-documentHandler} = $handler;
}
sub setErrorHandler {
    my ($self, $handler) = @_;
    $self->{-errorHandler} = $handler;
}
sub setEntityResolver {
    my ($self, $handler) = @_;
    $self->{-entityHandler} = $handler;
}
sub setDTDHandler {
    my ($self, $handler) = @_;
    $self->{-dtdHandler} = $handler;
}

#####
# entityResolver routines

sub resolveEntity {
    my $self = shift;
    return $self->{-entityHandler}->resolveEntity(@_);
}

#####
# DTDHandler routines

sub notationDecl {
    my $self = shift;
    return $self->{-documentHandler}->notationDecl(@_);
}

sub unparsedEntityDecl {
    my $self = shift;
    $self->{-documentHandler}->unparsedEntityDecl(@_);
}

#####
# documentHandler routines

sub setDocumentLocator {
    my $self = shift;
    $self->{-documentHandler}->setDocumentLocator(@_);
}

sub startDocument {
    my $self = shift;
    $self->{-documentHandler}->startDocument(@_);
}

sub endDocument {
    my $self = shift;
    $self->{-documentHandler}->endDocument(@_);
}

sub startElement {
    my $self = shift;
    $self->{-documentHandler}->startElement(@_);
}

sub endElement {
    my $self = shift;
    $self->{-documentHandler}->endElement(@_);
}

sub characters {
    my $self = shift;
    $self->{-documentHandler}->characters(@_);
}

sub ignorableWhitespace {
    my $self = shift;
    $self->{-documentHandler}->ignorableWhitespace(@_);
}

sub processingInstruction {
    my $self = shift;
    $self->{-documentHandler}->processingInstruction(@_);
}

sub addNamespace {
    my ($self) = shift;
    $self->{-documentHandler}->addNamespace(@_);
}

#####
# ErrorHandler routines

sub warning {
    my $self = shift;
    $self->{-errorHandler}->warning(@_);
}

sub error {
    my $self = shift;
    $self->{-errorHandler}->error(@_);
}

sub fatalError {
    my $self = shift;
    $self->{-errorHandler}->fatalError(@_);
    my $exception = shift;
    &throw($exception);
}

sub show {
    my ($self) = shift;
    my $ret;
    eval {$ret = $self->{-documentHandler}->show(@_)."\n";}; # don't assume the function exists
    return $ret;
}

# W3C::XML::OldNamespaceHandler is a simple stream to implement hierarchical namespaces
# according to http://www.w3.org/TR/1999/REC-xml-names-19990114. It maintains a
# NAMESPACE_STACK so namespace mappings fall out of scope when their bounding
# element ends (see http://www.w3.org/TR/1999/REC-xml-names-19990114#scoping).

# This also stores the namespace mappings by their source ID after they have
# gone out of scope. This makes it possible to call unmapNamespace after the
# parser has finished with the document.

package W3C::XML::OldNamespaceHandler;
@W3C::XML::OldNamespaceHandler::ISA = ("W3C::XML::HandlerStream");
use W3C::Util::Exception;
$W3C::XML::OldNamespaceHandler::TRANSLATE = \ 'translate';
$W3C::XML::OldNamespaceHandler::TRANSPARENT = \ 'transparent';

sub new {
    require W3C::XML::AttributeListImpl;
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    bless ($self, $class);
    if ($self->{-copyHandler}) {
        #tricky bit to copy the namespace stack ([0] is default ns and [1] is defined ns's)
        $self->{NAMESPACE_STACK} = [map {$_->[0], {%{$_->[1]}}} @{$self->{-copyHandler}{NAMESPACE_STACK}}];
        $self->{NAMESPACE_REVERSE} = {%{$self->{-copyHandler}{NAMESPACE_REVERSE}}};
        $self->{UNKNOWN_NAMESPACES} = {%{$self->{-copyHandler}{UNKNOWN_NAMESPACES}}};
    } else {
        $self->{NAMESPACE_STACK} = [[undef, {}]]; # default namespace and top namespace frame
        $self->{NAMESPACE_REVERSE} = {};
        $self->{UNKNOWN_NAMESPACES} = {};
    }
    $self->{MODE} = $W3C::XML::OldNamespaceHandler::TRANSLATE;
    return $self;
}

sub setMode {
    my ($self, $mode) = @_;
    $self->{MODE} = $mode;
}

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

#    $namespaceHandler->addNamespace('xsl', 'http://www.w3.org/TR/WD-xsl', $inputSource->getPublicId);
sub addNamespace {
    my ($self, $prefix, $expanded, $sourceId, $flags) = @_;
    my $namespaceFrame = $self->{NAMESPACE_STACK}[-1][1];
    $namespaceFrame->{$prefix} = $expanded;
    $self->{NAMESPACE_REVERSE}{$sourceId}{$expanded} = $prefix
	if (!exists $self->{NAMESPACE_REVERSE}{$sourceId}{$expanded});
    delete $self->{UNKNOWN_NAMESPACES}{$prefix};
    $self->{-remapAndRestart} = 1;
}

sub startElement {
    my ($self, $name, $attributeList) = @_;

    if ($self->{MODE} == $W3C::XML::OldNamespaceHandler::TRANSPARENT) {
	if ($self->{-useSAX2}) {
	    $self->{-documentHandler}->startElement(undef, $name, $name, $attributeList);
	} else {
	    $self->{-documentHandler}->startElement($name, $attributeList);
	}
	return; # ugly short return. oh well
    }

    # default namespace for this element is the namespace for the tag
    my ($defaultNamespace) = $name =~ m/\A (?: ([^:]* ) :)? /x;

    # create current context from the default namespace and a copy of the last namespace frame
    push (@{$self->{NAMESPACE_STACK}}, [$defaultNamespace, {%{$self->{NAMESPACE_STACK}[-1][1]}}]);

    # update namespace to reflect xmlns directives in the $attributeList
    my $sourceId = $self->{SOURCE_ID};
    for (my $i = 0; $i < $attributeList->getLength; $i++) {
	my ($attributeName, $attributeValue) = ($attributeList->getName($i), $attributeList->getValue($i));
	if ($attributeName =~ m/\A xmlns(:(\w+))? \Z/x) {
	    $self->addNamespace($2, $attributeValue, $sourceId);
	}
    }

    # map namespaces and call startElement
    for ($self->{-remapAndRestart} = 1; $self->{-remapAndRestart};) {
	$self->{-remapAndRestart} = 0;
	$self->restartElement($defaultNamespace, $name, $attributeList);
    }
}

sub restartElement {
    my ($self, $defaultNamespace, $name, $attributeList) = @_;
    my %attrs;

    for (my $i = 0; $i < $attributeList->getLength; $i++) {
	my ($attributeName, $attributeValue) = ($attributeList->getName($i), $attributeList->getValue($i));
	if ($attributeName =~ m/\A xmlns(:(\w+))? \Z/x) {
	} else {
	    if (substr ($attributeName, -1) eq ':') {	# added to play with := namespace stuff - EGP
		$attrs{substr ($attributeName, 0, -1)} = [$self->mapNamespace($attributeValue)];
	    } else {
		$attrs{$attributeName} = [undef, $attributeValue];
	    }
	}
    }

    # build new AttributeList that has the mapped attribute names
    my $oldAttributeList = $attributeList;
    if ($self->{-useSAX2}) {
	$attributeList = new W3C::XML::SAX2AttributeList($defaultNamespace);
    } else {
	$attributeList = new W3C::XML::AttributeListImpl($defaultNamespace);
    }
    # $attributeList->clear;
    foreach my $attr (keys %attrs) {
	my ($vns, $value) = @{$attrs{$attr}};
	my ($ans, $attribute) = $self->mapNamespace($attr);
	if ($self->{-useSAX2}) {
	    $attributeList->addAttribute($ans, $attribute, "CDATA", $vns, $value);
	} else {
	    $attributeList->addAttribute($ans.$attribute, "CDATA", $vns.$value);
	}
    }

    # pass to regularly scheduled document handler
    my ($nameNs, $nameTag) = $self->mapNamespace($name);
    if ($self->{-useSAX2}) {
	$self->{-documentHandler}->startElement($nameNs, $nameTag, $name, $attributeList);
    } else {
	$self->{-documentHandler}->startElement($nameNs.$nameTag, $attributeList);
    }
}

sub endElement {
    my ($self, $name) = @_;

    if ($self->{MODE} == $W3C::XML::OldNamespaceHandler::TRANSPARENT) {
	if ($self->{-useSAX2}) {
	    $self->{-documentHandler}->endElement(undef, $name, $name);
	} else {
	    $self->{-documentHandler}->endElement($name);
	}
	return; # ugly short return. oh well
    }

    my ($nameNs, $nameTag) = $self->mapNamespace($name);
    if ($self->{-useSAX2}) {
	$self->{-documentHandler}->endElement($nameNs, $name, $nameTag);
    } else {
	$self->{-documentHandler}->endElement($nameNs.$nameTag);
    }
    pop @{$self->{NAMESPACE_STACK}};
}

sub mapNamespace {
    my ($self, $toMap) = @_;
    my ($defaultNamespace, $namespaceFrame) = (@{$self->{NAMESPACE_STACK}[-1]});
    my ($namespace, $property) = $toMap =~ m/(?:([^:]*):)?(.*)/;
    $namespace ||= $defaultNamespace;
    if (exists $namespaceFrame->{$namespace}) {
	return ($namespaceFrame->{$namespace}, $property);
    } else {
	if ($self->{-passUnknownNamespaces}) {
	    push (@{$self->{UNKNOWN_NAMESPACES}{$namespace}}, $property) if (!exists $self->{UNKNOWN_NAMESPACES}{$namespace});
	    return (undef, defined $namespace ? $namespace.':'.$property : $property);
	} else {
	    &throw(new W3C::XML::UnknownNamespaceException(-namespace => $namespace));
	}
    }
}

sub getUnknownNamespaces {
    my ($self) = @_;
    return keys %{$self->{UNKNOWN_NAMESPACES}};
}

sub setRemapAndRestart {
    my ($self, $value) = @_;
    $self->{-remapAndRestart} = defined $value ? $value : 1;
}

sub getUnknownNamespaceDeclaration {
    my ($self, $namespace) = @_;
    return $self->{UNKNOWN_NAMESPACES}{$namespace};
}

# makes an attempt at reversing namespaces for printing - will not follow hierarchy
# $sourceId is optional
sub unmapNamespace ($;$) {
    my ($self, $name, $sourceId) = @_;
    my @idList = defined $sourceId ? ($sourceId) : keys %{$self->{NAMESPACE_REVERSE}};
    foreach my $id (@idList) {
	# poke through the keys - starting with the longest so we get the best match
	my ($ns, $mapped) = W3C::XML::OldNamespaceHandler::staticUnmapNamespace($name, $self->{NAMESPACE_REVERSE}{$id});
	if ($ns) {
	    return ($id, $ns, $mapped);
	}
    }
    return (undef, undef, $name);
}

sub staticUnmapNamespace {
    my ($name, $map) = @_;
    foreach my $namespace (sort {length $b <=> length $a} keys %$map) {
	if ($name =~ m/\A \Q$namespace\E (.*) \Z/x) {
	    return ($namespace, $map->{$namespace}.':'.$1);
	}
    }
    return (undef, undef);
}

sub getFrame {
    my ($self, $attributeHash, $prefixes, $frameIndex) = @_;
    my ($defaultNamespace, $namespaceFrame) = (@{$self->{NAMESPACE_STACK}[-1+$frameIndex]});
    foreach my $prefix (@$prefixes) {
	$attributeHash->{'xmlns:'.$prefix} = $namespaceFrame->{$prefix}
    }
}

sub dump {
    my ($self, $handle, $sourceId) = @_;
    my @idList = defined $sourceId ? ($sourceId) : keys %{$self->{NAMESPACE_REVERSE}};
    foreach my $id (@idList) {
	# poke through the keys - starting with the longest so we get the best match
	foreach my $url (sort keys %{$self->{NAMESPACE_REVERSE}{$id}}) {
	    my $namespace = $self->{NAMESPACE_REVERSE}{$id}{$url};
	    print $handle "$id xmlns:$namespace=\"$url\"\n";
	}
    }
}

package W3C::XML::OldNamespaceAndStringHandler;
@W3C::XML::OldNamespaceAndStringHandler::ISA = ("W3C::XML::OldNamespaceHandler");

sub addStringMap ($$) {
    my ($self, $from, $to) = @_;
    $self->{STRING_REVERSE}{$from} = $to;
}

sub addResourceMap ($$) {
    my ($self, $resource) = @_;
    my $base = $resource;
    $base =~ s/[\?\#].*//;
    if ($base =~ m/([^\\\/\:]+)$/ || $base =~ m/([^\\\/\:]+)[^\\\/\:]$/) {
	$base = $1;
    }
    my $to = $base; # start with the plain base name
    my $revNo = 1;
    while (exists $self->{STRING_FORWARD}{$to}) {$to = $base.'<'.++$revNo.'>'};
    $self->{STRING_FORWARD}{$to} = $resource;
    $self->{STRING_REVERSE}{$resource} = $to;
}

sub unmapString ($) {
    my ($self, $string) = @_;
    foreach my $key (sort {length $b <=> length $a} keys %{$self->{STRING_REVERSE}}) {
	return ($self->{STRING_REVERSE}{$key}.$1) if ($string =~ m/\A \Q$key\E (.*) \Z/x);
    }
    return $string;
}

sub unmapNamespace ($;$) {
    my ($self, $name, $sourceId) = @_;
    my ($id, $key, $translated) = $self->SUPER::unmapNamespace($name, $sourceId);
    $translated = $self->unmapString($translated) if (!defined $key);
    return ($id, $key, $translated);
}

package W3C::XML::HandlerList;
use W3C::Util::Exception;
@W3C::XML::HandlerList::ISA = ("W3C::XML::HandlerBase"); # @@@ should it not be one?

sub setDocumentHandler {
    my ($self, $handler) = @_;
    $self->{-documentHandlers} = [$handler];
}
sub setErrorHandler {
    my ($self, $handler) = @_;
    $self->{-errorHandlers} = [$handler];
}
sub setEntityResolver {
    my ($self, $handler) = @_;
    $self->{-entityHandlers} = [$handler];
}
sub setDTDHandler {
    my ($self, $handler) = @_;
    $self->{-dtdHandlers} = [$handler];
}

sub addDocumentHandler {
    my ($self, @handlers) = @_;
    push (@{$self->{-documentHandlers}}, @handlers);
}
sub addErrorHandler {
    my ($self, @handlers) = @_;
    push (@{$self->{-errorHandlers}}, @handlers);
}
sub addEntityResolver {
    my ($self, @handlers) = @_;
    push (@{$self->{-entityHandlers}}, @handlers);
}
sub addDTDHandler {
    my ($self, @handlers) = @_;
    push (@{$self->{-dtdHandlers}}, @handlers);
}

#####
# entityResolver routines

sub resolveEntity {
    my $self = shift;
    my $ret;
    map {return $ret if (defined ($ret = $_->resolveEntity(@_)))} @{$self->{-entityHandlers}};
    return undef;
}

#####
# DTDHandler routines

sub notationDecl {
    my $self = shift;
    map {$_->notationDecl(@_)} @{$self->{-documentHandlers}};
}

sub unparsedEntityDecl {
    my $self = shift;
    map {$_->unparsedEntityDecl(@_)} @{$self->{-documentHandlers}};
}

#####
# documentHandler routines

sub setDocumentLocator {
    my $self = shift;
    map {$_->setDocumentLocator(@_)} @{$self->{-documentHandlers}};
}

sub startDocument {
    my $self = shift;
    map {$_->startDocument(@_)} @{$self->{-documentHandlers}};
}

sub endDocument {
    my $self = shift;
    map {$_->endDocument(@_)} @{$self->{-documentHandlers}};
}

sub startElement {
    my $self = shift;
    map {$_->startElement(@_)} @{$self->{-documentHandlers}};
}

sub endElement {
    my $self = shift;
    map {$_->endElement(@_)} @{$self->{-documentHandlers}};
}

sub characters {
    my $self = shift;
    map {$_->characters(@_)} @{$self->{-documentHandlers}};
}

sub ignorableWhitespace {
    my $self = shift;
    map {$_->ignorableWhitespace(@_)} @{$self->{-documentHandlers}};
}

sub processingInstruction {
    my $self = shift;
    map {$_->processingInstruction(@_)} @{$self->{-documentHandlers}};
}

sub addNamespace {
    my ($self) = shift;
    map {$_->addNamespace(@_)} @{$self->{-documentHandlers}};
}

#####
# ErrorHandler routines

sub warning {
    my $self = shift;
    map {$_->warning(@_)} @{$self->{-errorHandlers}};
}

sub error {
    my $self = shift;
    map {$_->error(@_)} @{$self->{-errorHandlers}};
}

sub fatalError {
    my $self = shift;
    map {$_->fatalError(@_)} @{$self->{-errorHandlers}};
    my $exception = shift;
    &throw($exception->getMessage);
}

sub show {
    my ($self) = shift;
    my $ret;
    map {eval {$ret .= $_->show(@_)."\n";}} @{$self->{-documentHandlers}}; # don't assume the function exists
    return $ret;
}

1;

package W3C::XML::HandlerBase; # so make doesn't complain about the package

__END__

=head1 NAME

W3C::XML::HandlerBase.pm - default methods for all the SAX handler routines

=head1 SYNOPSIS

  package myHandler;
  @myHandler::ISA = qw(W3C::XML::HandlerBase);
  sub new {
    my $self = shift;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new();
  }
  sub startElement {
  }
  sub endElement {
  }  

=head1 DESCRIPTION

HandlerBase provides default methods for all the SAX handler routines.
Other handy packages:
  HandlerStream - pass all handler calls to a downstream handler.
  HandlerList - pass all handler calls to a list of downstream handlers.
  NamespaceHandler - provide a hierarchical namespaces.

=head2 HandlerStream

  package myHandler;
  @myHandler::ISA = qw(W3C::XML::HandlerStream);
  sub new {
    my ($self, $nextHandler) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($nextHandler);
  }
  sub startElement {
    my ($self, $name, $attributeList) = @_;
    $self->SUPER::startElement($name, $attributeList);
  }
  sub endElement {
    my ($self, $name) = @_;
    $self->SUPER::endElement($name);
  }  

=head2 HandlerList

  use W3C::XML::XmlParser;
  use W3C::XML::VerboseXmlHandler;
  use W3C::XML::InputSource;
  use W3C::XML::XmlElementTree;
  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);};

=head2 NamespaceHandler

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

  # use a W3C::XML::OldNamespaceHandler stream to map from prefix:tag
  my $namespaceHandler = new W3C::XML::OldNamespaceHandler($verboseHandler);

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

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

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

=head1 AUTHOR

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

=head1 SEE ALSO

perl(1).

=cut
