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

# $Id: XmlSerializer.pm,v 1.57 2005/09/25 14:55:45 eric Exp $

use strict;
require Exporter;
#require AutoLoader;

$W3C::XML::XmlSerializer::REVISION = '$Id: XmlSerializer.pm,v 1.57 2005/09/25 14:55:45 eric Exp $ ';

package W3C::XML::XmlSerializer; # implements W3C::XML::DocumentLocator
# W3C::XML::XmlSerializer - Serialize according to W3C's Exclusive XML
# Canonicalization 1.0 ( http://www.w3.org/TR/2002/REC-xml-exc-c14n-20020718/)
# 
# Checks namespaces of tag and attribute names, throws exception if not defined.

use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK);
use W3C::Util::Object;
@ISA = qw(W3C::Util::NamedParmObject); # W3C::XML::NamespaceHandler); # Exporter AutoLoader);
#@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = 0.90;
$DSLI = 'adpO';

use W3C::Util::Exception;
use W3C::XML::SAXParseException;
use W3C::Util::XmlConstants qw($QName);

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->{-elementStack} ||= [];
    $self->{-lineNumber} ||= 0;
    $self->{-columnNumber} ||= 1;
    $self->{-target} ||= [];
    $self->{NEW_NAMESPACES} = {};
    $self->{NAMESPACE_STACK} = [];

    return $self;
}

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

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

sub addXmlDecl {
    my ($self, @args) = @_;
    $self->print('<?xml version="1.0"?>');
}

sub pendNamespace {
    my ($self, $prefix, $ns) = @_;
    $self->{NEW_NAMESPACES}{$prefix} = $ns;
}

sub startElement {
    my ($self, $tag, $attributes, $flags) = @_;
    push (@{$self->{-elementStack}}, $tag);

#    # Create xmlns decls for the new namespace mappings and tell the NamespaceHandler about them.
#    foreach my $prefix (keys %{$self->{NEW_NAMESPACES}}) {
#	$self->{-namespaceHandler}->addNamespace($prefix, $self->{NEW_NAMESPACES}{$prefix}, {});
#    }

    # Check for tag namespace (likely to use newly mapped namespaces).
    $self->_checkNamespace($tag);
    my @attrs;
    foreach my $attribute (keys %$attributes) {
	push (@attrs, [$self->_checkNamespace($attribute), $attribute]);
    }

    # Store piecs of the element in @elements.
    my @elements = ($tag);

    # Record namespace declarations for all new namespaces.
    foreach my $prefix (sort keys %{$self->{NEW_NAMESPACES}}) { # sort by prefix
	my $declAttr = $prefix ? "xmlns:$prefix" : 'xmlns';
	push (@elements, "$declAttr=\"$self->{NEW_NAMESPACES}{$prefix}\"");
    }
    $self->{NEW_NAMESPACES} = {};

    # Pend the new element.
    my $indent = $self->{-prettyPrint} ? '   ' x (@{$self->{-elementStack}}-1) : '';
    foreach my $attr (sort {$a->[0] eq $b->[0] ? $a->[1] cmp $b->[1] : $a->[0] cmp $b->[0]} @attrs) { # sort by ns,localName
	my ($ns, $localName, $prefix, $attribute) = @$attr;
	my $value = $attributes->{$attribute};
	$value = &XMLEntityEncode($value);
	push (@elements, "$attribute=\"$value\"");
    }
    my $element = join ($self->{-prettyPrint} ? "\n$indent " : ' ', @elements);
    # flush the pending element
    $self->flush;
    $self->{-emptyElement} = "$indent<$element";
}

sub XMLEntityEncode {
    my ($value) = @_;
    $value=~s/&/&amp;/g;
    $value=~s/\"/&quot;/g;
    $value=~s/>/&gt;/g;
    $value=~s/</&lt;/g;
    return $value;
}

sub flush {
    my ($self) = @_;
    if ($self->{-emptyElement}) {
	$self->print("$self->{-emptyElement}>");
	$self->{-emptyElement} = undef;
    } elsif ($self->{-mixedElement}) {
	$self->print($self->{-mixedElement});
	$self->{-mixedElement} = undef;
    }
}

sub endElement {
    my ($self, $mapped) = @_;
    if ($mapped ne $self->{-elementStack}[-1]) {
	$self->flush();
	my $doc = $self->getText();
	$doc =~ s/^/  /g;
	&throw(new W3C::XML::SAXParseException(-errorMessage => "end tag mismatch: expected \"$self->{-elementStack}[-1]\" - got \"$mapped\"\n$doc", -locator => $self));
    }

    # finish up existing element
    if ($self->{-emptyElement}) {
	# empty elements can just be closed with a '/'
	if ($self->{-prettyPrint}) {
	    $self->print("$self->{-emptyElement} />");
	} else {
	    $self->print("$self->{-emptyElement}></$mapped>");
	}
	$self->{-emptyElement} = undef;
    } elsif ($self->{-mixedElement}) {
	# mixed elements need to be dumped and have a full close tag
	$self->print("$self->{-mixedElement}</$mapped>");
	$self->{-mixedElement} = undef;
    } else {
	# we just close a tag so close this one too
	my $indent = $self->{-prettyPrint} ? ('   ' x (@{$self->{-elementStack}} - 1)) : '';
	$self->print("$indent</$mapped>");
    }

    # set stack state
    pop (@{$self->{NAMESPACE_STACK}});
    pop (@{$self->{-elementStack}});
}

sub finishElement {
    my ($self) = @_;
    $self->endElement($self->{-elementStack}[-1]);
}

sub comment {
    my ($self, $comment) = @_;
    if ($comment =~ m/\-\-/) {
	&throw(new W3C::XML::SAXParseException(-errorMessage => "comment contains '--': \"$comment\"", -locator => $self))
    }
    $self->flush;
    $self->print("<!-- $comment -->");
}

sub characters {
    my ($self, $characters, $flags) = @_;
    $characters = &XMLEntityEncode($characters) unless ($flags->{-dontEncode});
    if ($self->{-emptyElement}) {
	# Create a mixedElement so endElement will know to keep the close 
	#   tag tight to the text, rather than indented on the next line.
	$self->{-mixedElement} = "$self->{-emptyElement}>$characters";
	$self->{-emptyElement} = undef;
    } else {
	$self->{-mixedElement} .= $characters;
    }
}

sub _checkNamespace {
    my ($self, $qName) = @_;
    if ($qName !~ m/^$QName$/ && (!$DB::deep || $qName !~ m/^(?:[A-Z_a-z][A-Z_a-z\-\.0-9]*:)?[A-Z_a-z][A-Z_a-z\-\.0-9]*$/)) {
	&throw(new W3C::Util::Exception(-message => "bad qname \"$qName\""));
    }
    if (!$self->{-namespaceHandler}) {
	return (undef, $qName, undef); # ugly early return
    }
    my $namespaceHandler = $self->{-namespaceHandler};
    my ($ns, $remainder, $prefix);
    eval {
	($ns, $remainder, $prefix) = $namespaceHandler->mapNamespace($qName, undef);
    }; if ($@) {if (my $ex = &catch('W3C::Util::Exception')) {
	if ($self->{-importMap}) {
	    ($ns, $remainder, $prefix) = $self->{-importMap}->mapNamespace($qName, undef);
	    if (defined $ns) {
		$namespaceHandler->addNamespace($prefix, $ns, {});
		$self->{NEW_NAMESPACES}{$prefix} = $ns;
	    }
	}
	if (!defined $ns) {
	    &throw(new W3C::Util::Exception(-message => "no namespace known for \"$qName\""));
	}
    }}
    return ($ns, $remainder, $prefix);
}

sub print {
    my ($self, $toPrint) = @_;
    while ($toPrint =~ m/\G (.*?) ((?:\r\n)|\r|\n) /gcxs) {
	$self->{-columnNumber} = 0;
	$self->{-lineNumber}++;
    }
    $self->{-columnNumber} += length($toPrint) - pos $toPrint;
    &W3C::Util::Exception::printMessage($toPrint, $self->{-target});
}

sub getText {
    my ($self) = @_;
    if (ref $self->{-target} eq 'ARRAY') {
	return join ($self->{-prettyPrint} ? "\n" : '', @{$self->{-target}}, undef);
    } elsif (ref $self->{-target} eq 'SCALAR') {
	return $ {$self->{-target}};
    } else {
	&throw(new W3C::Util::ProgramFlowException());
    }
}

sub getCurrentNamespaceHandler {
    my ($self) = @_;
    return @{$self->{NAMESPACE_STACK}} ? $self->{NAMESPACE_STACK}[-1] : undef;
}

# W3C::XML::DocumentLocator interface

sub getPublicId {
    my ($self) = @_;
    return $self->{-publicId};
}

sub getSystemId {
    my ($self) = @_;
    return $self->{-systemId};
}

sub getLineNumber {
    my ($self) = @_;
    return $self->{-lineNumber};
}

sub getColumnNumber {
    my ($self) = @_;
    return $self->{-columnNumber};
}

package W3C::XML::UriXmlSerializer;
# W3C::XML::UriXmlSerializer - like XmlSerializer except tag and attribute names
#                              are URIs instead of qNames.
# This hase a reference to an XmlSerializer to which it passes all of the mapped
# qnames.

use W3C::Util::Exception;
use W3C::Util::NamespaceHandler qw($NS_FAIL);
use W3C::Util::XmlConstants qw($XmlNs);

@W3C::XML::UriXmlSerializer::ISA = qw(W3C::XML::XmlSerializer);

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

    # some ideas yet to manifest...
    $self->{-namespaceElementSweep} ||= 5;
    $self->{-namespaceElementTrip} ||= 2;
    $self->{TAG_NS_STACK} = [];
    return $self;
}

sub startElement {
    my ($self, $tag, $attributes, $flags) = @_;

    my $namespaceHandler = $self->{-namespaceHandler} ? $self->{-namespaceHandler} :
	$self->{-namespaceFactory} ? 
	&{$self->{-namespaceFactory}}($self->{-importMap}, $self->getCurrentNamespaceHandler()) : 
	new W3C::Util::NamespaceInventor(-importMap => $self->{-importMap}, 
					 -copyHandler => $self->getCurrentNamespaceHandler());

    # Prepare a new NamespaceHandler for this depth in the tree.
    # Default to using an searcher if no factory was given.
    push (@{$self->{NAMESPACE_STACK}}, $namespaceHandler);

    if ($flags->{-addNamespaces}) {
	foreach my $prefix (@{$flags->{-addNamespaces}}) {
	    my $ns = $self->{-importMap}->getNamespace($prefix);
	    if (!$ns) {
		&throw(new W3C::Util::CantCreateNamespaceException(-namespace => $prefix))
	    }
	    $self->pendNamespace($prefix, $ns);
	    $namespaceHandler->addNamespace($prefix, $ns, -collide => $NS_FAIL);
	}
    }

    my ($tagPrefix, $mapped) = $self->_ensureNamespace($tag, undef, undef);
    $tag = $mapped;

    my $mappedAttributes = {};
    foreach my $name (keys %$attributes) {
	my $value = $attributes->{$name};
	my ($attrPrefix, $mappedName) = $self->_ensureNamespace($name, undef, $self->{-defaultAttrNamespace} ? $tagPrefix : undef);
	$mappedAttributes->{$mappedName} = $value;
    }

    $self->SUPER::startElement($mapped, $mappedAttributes, $flags);
    push (@{$self->{TAG_NS_STACK}}, $tagPrefix); # usefull when there are multiple matching namespaces and we need to close with the correct one.
}

sub endElement {
    my ($self, $tag) = @_;
    my ($tagPrefix, $mapped) = $self->_ensureNamespace($tag, $self->{TAG_NS_STACK}[-1], undef);
    $self->SUPER::endElement($mapped);
    pop (@{$self->{TAG_NS_STACK}});
}

sub _ensureNamespace {
    my ($self, $name, $firstPrefix, $defaultPrefix) = @_;
    if ($name =~ m/^\Q$XmlNs\E(.*)$/) {
	return ('xml', "xml:$1");
    }
    my ($ns, $prefix, $remainder, $new) = 
	$self->
	getCurrentNamespaceHandler()->unmapNamespace($name, $firstPrefix, $defaultPrefix);

    if (!$ns) {
	&throw(new W3C::Util::CantCreateNamespaceException(-namespace => $name));
    }

    if ($new) {
	# Note that we will have to write a decl for it.
	$self->pendNamespace($prefix, $ns);
    }

    # XML attributes may default to their element namespace.
    if (!$prefix || $prefix eq $defaultPrefix) {
	return ($prefix, $remainder);
    } else {
	return ($prefix, "${prefix}:$remainder");
    }
}

package W3C::XML::XmlSerializer;

1;

__END__

=head1 NAME

W3C::XML::XmlSerializer - create well-formed XML documents via a SAX-like interface

=head1 SYNOPSIS

  use W3C::Util::NamespaceHandler;
  my $seed = new W3C::Util::NamespaceHandler();
  $seed->addNamespace('pre', 'http://...');
  use W3C::XML::XmlSerializer;
  my $serializer = new W3C::XML::XmlSerializer(-prettyPrint => 1, 
      -namespaceFactory => sub {return $self->_namespaceHandlerFactory(@_);}, 
      -namespaceCreativity => $self->{-namespaceCreativity}, 
      -namespaceForce => [$rdfNS], 
      -noDefaultAttrNamespace => 1, 
      -importMap => $seed);
  }
  $serializer->startDocument();
  $serializer->startElement('pre:Root', undef);
  $serializer->endElement('pre:Root');
  print $serializer->getText(),"\n";

=head1 DESCRIPTION

This module provides namespace enforcement and open/close element balancing for
creating XML documents. It also has some attractive pretty-print features.

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

=head1 AUTHOR

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

=head1 SEE ALSO

perl(1).

=cut

