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

# $Id: NamespaceHandler.pm,v 1.17 2005/03/30 16:08:12 eric Exp $

use strict;
require Exporter;
require AutoLoader;

$W3C::XML::HandlerBase::REVISION = '$Id: NamespaceHandler.pm,v 1.17 2005/03/30 16:08:12 eric Exp $ ';

package W3C::XML::NamespaceHandler;
use W3C::Util::Exception;
use W3C::Util::NamespaceHandler qw($NS_REPLACE $NS_IGNORE $NS_FAIL);
use W3C::XML::AttributeListImpl;

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

use vars qw($TRANSLATE $TRANSPARENT);
$TRANSLATE = \ 'translate';
$TRANSPARENT = \ 'transparent';

use vars qw($NCName);
$NCName = '\w[\w\d\.\-]*';

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    bless ($self, $class);
    $self->{REVERSE} = {};
    $self->{NAMESPACE_STACK} = [];
    if ($self->{-copyHandler}) {
        #tricky bit to copy the namespace stack ([0] is default ns and [1] is defined ns's)
        $self->{REVERSE_ALL} = new W3C::Util::NamespaceHandler(-copyHandler => $self->{-copyHandler}{REVERSE_ALL}, 
							       -collide => $NS_IGNORE);
	foreach my $oldFrame (@{$self->{-copyHandler}{NAMESPACE_STACK}}) {
	    my $newFrame = new W3C::Util::NamespaceHandler(-copyHandler => $oldFrame, 
							   -collide => $NS_REPLACE);
	    push (@{$self->{NAMESPACE_STACK}}, $newFrame);
	}
	foreach my $resource (keys %{$self->{-copyHandler}{REVERSE}}) {
	    my $oldFrame = $self->{-copyHandler}{REVERSE}{$resource};
	    my $newFrame = new W3C::Util::NamespaceHandler(-copyHandler => $oldFrame, 
							   -collide => $NS_IGNORE);
	    $self->{REVERSE}{$resource} = $newFrame;
	}
    } else {
        $self->{REVERSE_ALL} = new W3C::Util::NamespaceHandler(-collide => $NS_IGNORE);
    }
    $self->{MODE} = $TRANSLATE;
    return $self;
}

sub getAggregateNamespaceHandler {
    my ($self) = @_;
    return $self->{REVERSE_ALL};
}

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

sub setDocumentLocator {
    my ($self, $locator) = @_;
    $self->SUPER::setDocumentLocator($locator);
    $self->{SOURCE_ID} = $locator->getPublicId;
    $self->{REVERSE}{$self->{SOURCE_ID}} = new W3C::Util::NamespaceHandler(-relay => $self->{REVERSE_ALL}, 
									   -collide => $NS_IGNORE);
    push (@{$self->{NAMESPACE_STACK}}, new W3C::Util::NamespaceHandler(-relay => $self->{REVERSE}{$self->{SOURCE_ID}}, 
								       -collide => $NS_FAIL));
    # xml prefix defined by http://www.w3.org/TR/xml-names11/#xmlReserved
    $self->{NAMESPACE_STACK}[-1]->addNamespace('xml', 'http://www.w3.org/XML/1998/namespace');
}

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

sub setXmlBase {
    my ($self, $base, $sourceId) = @_;
    $self->{NAMESPACE_STACK}[-1]->setXmlBase($base);
}

sub getXmlBase {
    my ($self) = @_;
    return $self->{NAMESPACE_STACK}[-1]->getXmlBase();
}

sub setXmlLang {
    my ($self, $lang, $sourceId) = @_;
    $self->{NAMESPACE_STACK}[-1]->setXmlLang($lang);
}

sub getXmlLang {
    my ($self) = @_;
    return $self->{NAMESPACE_STACK}[-1]->getXmlLang();
}

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

    if ($self->{MODE} == $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 ($elementNamespace) = $name =~ m/\A (?: ([^:]* ) :)? /x;

    # create current context from the default namespace and a copy of the last namespace frame
    push (@{$self->{NAMESPACE_STACK}}, new W3C::Util::NamespaceHandler(-copyHandler => $self->{NAMESPACE_STACK}[-1], 
								       -collide => $NS_REPLACE));

    # 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 xml/x) {
	    if ($attributeName =~ m/\A xmlns(:($NCName))? \Z/x) {
		$self->addNamespace($2, $attributeValue, $sourceId);
	    } elsif ($attributeName =~ m/\A xml:base \Z/x) {
		$self->setXmlBase($attributeValue, $sourceId);
	    } elsif ($attributeName =~ m/\A xml:lang \Z/x) {
		$self->setXmlLang($attributeValue, $sourceId);
	    } else {
		&throw(new W3C::Util::Exception(-message => "unknown xml directive: \"$attributeName\""));
	    }
	}
    }

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

sub restartElement {
    my ($self, $elementNamespace, $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(:($NCName))? \Z/x || 
	    $attributeName =~ m/\A xml:base \Z/x || 
	    $attributeName =~ m/\A xml:lang \Z/x) {
	} else {
	    if (substr ($attributeName, -1) eq ':') {	# added to play with := namespace stuff - EGP
		my ($ns, $remaining) = $self->mapNamespace($attributeValue, undef);
		$attrs{substr ($attributeName, 0, -1)} = [$ns, $remaining, $attributeValue];
	    } else {
		$attrs{$attributeName} = [undef, undef, $attributeValue];
	    }
	}
    }

    # build new AttributeList that has the mapped attribute names
    my $oldAttributeList = $attributeList;
    if ($self->{-useSAX2}) {
	$attributeList = new W3C::XML::AttributesImpl();
    } else {
	$attributeList = new W3C::XML::AttributeListImpl($elementNamespace);
    }
    # $attributeList->clear;
    foreach my $attr (keys %attrs) {
	my ($vns, $vRemaining, $value) = @{$attrs{$attr}};
	my ($ans, $attribute);
	eval {
	    ($ans, $attribute) = $self->mapNamespace($attr, $elementNamespace);
	}; if ($@) {
	    if (my $ex = &catch('W3C::Util::Exception')) {
		if ($ex->isa('W3C::Util::UnknownNamespaceException') && $ex->getNamespace eq '' && $self->{-failAttrNStoEltNs}) {
		    ($ans, $attribute) = ($self->{NAMESPACE_STACK}[-1]->getNamespace($elementNamespace), $attr);
		    $attr = "$elementNamespace:$attr";
		} else {
		    &throw($ex);
		}
	    } else {&throw()}
	}
	if ($self->{-useSAX2}) {
	    $attributeList->addAttribute($ans, $attribute, $attr, "CDATA", $value, $vns, $vRemaining);
	} else {
	    $attributeList->addAttribute($ans.$attribute, "CDATA", $vns.$value);
	}
    }

    # pass to regularly scheduled document handler
    my ($nameNs, $nameTag) = $self->mapNamespace($name, undef);
    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} == $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, undef);
    if ($self->{-useSAX2}) {
	$self->{-documentHandler}->endElement($nameNs, $nameTag, $name);
    } else {
	$self->{-documentHandler}->endElement($nameNs.$nameTag);
    }
    pop @{$self->{NAMESPACE_STACK}};
}

sub mapNamespace {
    my ($self, $toMap, $elementNamespace) = @_;
    my $namespaceFrame = $self->{NAMESPACE_STACK}[-1];
    return $namespaceFrame->mapNamespace($toMap, $elementNamespace);

    my $defaultNamespace = $namespaceFrame->getMappedNamespace('');
    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::Util::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::NamespaceHandler::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 dump {
    my ($self, $handle, $sourceId) = @_;
    my @idList = defined $sourceId ? ($sourceId) : keys %{$self->{REVERSE}};
    foreach my $id (@idList) {
	print "$id:\n";
	$self->{REVERSE}{$id}->dump;
    }
    if (!$sourceId) {
	my $fwrd = $self->{REVERSE_ALL}{NAMESPACE_FORWARD};
	print "all:\n";
	foreach my $ns (keys %$fwrd) {
	    print "  $ns $fwrd->{$ns}\n";
	}
    }
    return;
}

package W3C::XML::NamespaceAndStringHandler;
@W3C::XML::NamespaceAndStringHandler::ISA = ("W3C::XML::NamespaceHandler");

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::NamespaceHandler;

1;

# W3C::XML::NamespaceHandler 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.

__END__

=head1 NAME

W3C::Util::NamespaceHandler.pm - hierarchical namespace storage and resolution

=head1 SYNOPSIS

  use W3C::XML::NamespaceHandler;
  my $namespaceHandler = new W3C::XML::NamespaceHandler(
    -documentHandler => $self, 
    -passUnknownNamespaces => 1, 
    -useSAX2 => 1, 
    -failAttrNStoEltNs => 0);
  my $xmlParser = new W3C::XML::PerlXmlParser();
  $xmlParser->setDocumentHandler($namespaceHandler);
  my $inputStream = new W3C::XML::FileInputSource('foo.xml');
  $xmlParser->parse($inputStream);

  sub setDocumentLocator {}
  sub startDocument {}
  sub endDocument {}
  sub startElement {
    my ($self, $namespace, $localName, $qName, $attributeList) = @_;
    print "start: $namespace $localName\n";
  }
  sub endElement {
    my ($self, $namespace, $localName, $qName) = @_;
    print "end: $namespace $localName\n";
  }

=head1 DESCRIPTION

This namespace handler imposes namespace resolution on SAX events comiing from
an XML parser. It changes the calling convention for startElement and
endElement for the downstream document handler.

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

=head1 AUTHOR

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

=head1 SEE ALSO

W3C::Util::NamespaceHandler(1) perl(1).

=cut
