package XML::Handler::Composer;

use strict;

use XML::UM;

use Carp;

use vars qw{ %DEFAULT_QUOTES %XML_MAPPING_CRITERIA };

%DEFAULT_QUOTES = (

		   XMLDecl => '"', 

		   Attr => '"',

		   Entity => '"',

		   SystemLiteral => '"',

		  );

%XML_MAPPING_CRITERIA = 

(

 Text => 

 {

   '<' => '&lt;',

   '&' => '&',

   ']]>' => ']]>',

 },

 CDataSection => 

 {

   ']]>' => ']]>',	# NOTE: this won't be translated back correctly

 },

 Attr =>	# attribute value (assuming double quotes "" are used)

 {

#   '"' => '"',	# Use ("'" => ''') when using single quotes

   '<' => '&lt;',

   '&' => '&',

 },

 Entity =>	# entity value (assuming double quotes "" are used)

 {

#   '"' => '"',	# Use ("'" => ''') when using single quotes

   '%' => '%',

   '&' => '&',

 },

 Comment => 

 {

   '--' => '--',	# NOTE: this won't be translated back correctly

 },

 ProcessingInstruction =>

 {

   '?>' => '?>',	# not sure if this will be translated back correctly

 },

 # The SYSTEM and PUBLIC identifiers in DOCTYPE declaration (quoted strings)

 SystemLiteral => 

 {

#   '"' => '"',	# Use ("'" => ''') when using single quotes

 },

);

sub new

{

    my ($class, %options) = @_;

    my $self = bless \%options, $class;

    $self->{EndWithNewline} = 1 unless defined $self->{EndWithNewline};

    if (defined $self->{Newline})

    {

	$self->{ConvertNewlines} = 1;

    }

    else

    {

	# Use this when printing newlines in case the user didn't specify one

	$self->{Newline} = "\x0A";

    }

    $self->{DocTypeIndent}  = $self->{Newline} . "  " 

	unless defined $self->{DocTypeIndent};

    $self->{IndentAttlist}  = "        " unless defined $self->{IndentAttlist};

    $self->{Print}	    = sub { print @_ } unless defined $self->{Print};

    $self->{Quote} ||= {};

    for my $q (keys %DEFAULT_QUOTES)

    {

	$self->{Quote}->{$q} ||= $DEFAULT_QUOTES{$q};

    }

    # Convert to UTF-8 by default, i.e. when <?xml encoding=...?> is missing 

    # and no {Encoding} is specified.

    # Note that the internal representation *is* UTF-8, so we

    # simply return the (string) parameter.

    $self->{Encode} = sub { shift } unless defined $self->{Encode};

    # Convert unmapped characters to hexadecimal constants a la '号'

    $self->{EncodeUnmapped} = \&XML::UM::encode_unmapped_hex

	unless defined $self->{EncodeUnmapped};

    my $encoding = $self->{Encoding};

    $self->setEncoding ($encoding) if defined $encoding;

    $self->initMappers;

    $self;

}

#

# Setup the mapping routines that convert '<' to '&lt;' etc.

# for the specific XML constructs.

#

sub initMappers

{

    my $self = shift;

    my %escape;

    my $convert_newlines = $self->{ConvertNewlines};

    for my $n (qw{ Text Comment CDataSection Attr SystemLiteral

		   ProcessingInstruction Entity })

    {

	$escape{$n} = $self->create_utf8_mapper ($n, $convert_newlines);

    }

    # Text with xml:space="preserve", should not have newlines converted.

    $escape{TextPreserveNL} = $self->create_utf8_mapper ('Text', 0);

    # (If newline conversion is inactive, $escape{TextPreserveNL} does the 

    # same as $escape{Text} defined above ...)

    $self->{Escape} = \%escape;

}

sub setEncoding

{

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

    $self->{Encode} = XML::UM::get_encode (

	Encoding => $encoding, EncodeUnmapped => $self->{EncodeUnmapped});

}

sub create_utf8_mapper

{

    my ($self, $construct, $convert_newlines) = @_;

    my $c = $XML_MAPPING_CRITERIA{$construct};

    croak "no XML mapping criteria defined for $construct" 

           unless defined $c;

    my %hash = %$c;

    # If this construct appears between quotes in the XML document

    # (and it has a quoting character defined), 

    # ensure that the quoting character is appropriately converted

    # to " or '

    my $quote = $self->{Quote}->{$construct};

    if (defined $quote)

    {

	$hash{$quote} = $quote eq '"' ? '"' : ''';

    }

    if ($convert_newlines)

    {

	$hash{"\x0A"} = $self->{Newline};

    }

    gen_utf8_subst (%hash);

}

#

# Converts a string literal e.g. "ABC" into '\x41\x42\x43'

# so it can be stuffed into a regular expression

#

sub str_to_hex		# static

{

    my $s = shift;

    $s =~ s/(.)/ sprintf ("\\x%02x", ord ($1)) /egos;

    $s;

}

#

# In later perl versions (5.005_55 and up) we can simply say:

#

# use utf8;

# $literals = join ("|", map { str_to_hex ($_) } keys %hash);

# $s =~ s/($literals)/$hash{$1}/ego;

#

sub gen_utf8_subst	# static

{

    my (%hash) = @_;

    my $code = 'sub { my $s = shift; $s =~ s/(';

    $code .= join ("|", map { str_to_hex ($_) } keys %hash);

    $code .= ')|(';

    $code .= '[\\x00-\\xBF]|[\\xC0-\\xDF].|[\\xE0-\\xEF]..|[\\xF0-\\xFF]...';

    $code .= ')/ defined ($1) ? $hash{$1} : $2 /ego; $s }';

    my $f = eval $code;

    croak "XML::Handler::Composer - can't eval code: $code\nReason: $@" if $@;

    $f;

}

# This should be optimized!

sub print

{

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

    $self->{Print}->($self->{Encode}->($str));

}

# Used by start_element. It determines the style in which empty elements

# are printed. The default implementation returns "/>" so they are printed

# like this: <a/>

# Override this method to support e.g. XHTML style tags. 

sub get_compressed_element_suffix

{

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

    "/>";

    # return " />" for XHTML style, or

    # "><$tagName/>" for uncompressed tags (where $tagName is $event->{Name})

}

#----- PerlSAX handlers -------------------------------------------------------

sub start_document

{

    my ($self) = @_;

    $self->{InCDATA} = 0;

    $self->{DTD} = undef;

    $self->{PreserveWS} = 0;	# root element has xml:space="default"

    $self->{PreserveStack} = [];

    $self->{PrintedXmlDecl} = 0;	# whether <?xml ...?> was printed

}

sub end_document

{

    my ($self) = @_;

    # Print final Newline at the end of the XML document (if desired)

    $self->print ($self->{Newline}) if $self->{EndWithNewline};

}

# This event is received *AFTER* the Notation, Element, Attlist etc. events 

# that are contained within the DTD.

sub doctype_decl

{

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

    $self->flush_xml_decl;

    my $q = $self->{Quote}->{SystemLiteral};

    my $escape_literal = $self->{Escape}->{SystemLiteral};

    my $name = $event->{Name};

    my $sysId = $event->{SystemId};

    $sysId = &$escape_literal ($sysId) if defined $sysId;

    my $pubId = $event->{PublicId};

    $pubId = &$escape_literal ($pubId) if defined $pubId;

    my $str = "<!DOCTYPE $name";

    if (defined $pubId)

    {

	$str .= " PUBLIC $q$pubId$q $q$sysId$q";

    }

    elsif (defined $sysId)

    {

	$str .= " SYSTEM $q$sysId$q";

    }

    my $dtd_contents = $self->{DTD};

    my $nl = $self->{Newline};

    if (defined $dtd_contents)

    {

	delete $self->{DTD};

	$str .= " [$dtd_contents$nl]>$nl";

    }

    else

    {

	$str .= ">$nl";

    }

    $self->print ($str);

}

sub start_element

{

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

    my $preserve_stack = $self->{PreserveStack};

    if (@$preserve_stack == 0)

    {

	# This is the root element. Print the <?xml ...?> declaration now if

	# it wasn't printed and it should be.

	$self->flush_xml_decl;

    }

    my $str = "<" . $event->{Name};

    my $suffix = ">";

    if ($event->{Compress})

    {

	$suffix = $self->get_compressed_element_suffix ($event);

    }

    # Push PreserveWS state of parent element on the stack

    push @{ $preserve_stack }, $self->{PreserveWS};

    $self->{PreserveWS} = $event->{PreserveWS};

    my $ha = $event->{Attributes};

    my @attr;

    if (exists $event->{AttributeOrder})

    {

	my $defaulted = $event->{Defaulted};

	if (defined $defaulted && !$self->{PrintDefaultAttr})

	{

	    if ($defaulted > 0)

	    {

		@attr = @{ $event->{AttributeOrder} }[0 .. $defaulted - 1];

	    }

	    # else: all attributes are defaulted i.e. @attr = ();

	}

	else	# no attr are defaulted

	{

	    @attr = @{ $event->{AttributeOrder} };

	}

    }

    else	# no attr order defined

    {

	@attr = keys %$ha;

    }

    my $escape = $self->{Escape}->{Attr};

    my $q = $self->{Quote}->{Attr};

    for (my $i = 0; $i < @attr; $i++)

    {

#?? could print a newline every so often...

	my $name = $attr[$i];

	my $val = &$escape ($ha->{$name});

	$str .= " $name=$q$val$q";

    }

    $str .= $suffix;

    $self->print ($str);

}

sub end_element

{

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

    $self->{PreserveWS} = pop @{ $self->{PreserveStack} };

    return if $event->{Compress};

    $self->print ("</" . $event->{Name} . ">");

}

sub characters

{

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

    if ($self->{InCDATA})

    {

#?? should this use $self->{PreserveWS} ?

	my $esc = $self->{Escape}->{CDataSection};

	$self->print (&$esc ($event->{Data}));

    }

    else # regular text

    {

	my $esc = $self->{PreserveWS} ? 

	    $self->{Escape}->{TextPreserveNL} :

	    $self->{Escape}->{Text};

	$self->print (&$esc ($event->{Data}));

    }

}

sub start_cdata

{

    my $self = shift;

    $self->{InCDATA} = 1;

    $self->print ("<![CDATA[");

}

sub end_cdata

{

    my $self = shift;

    $self->{InCDATA} = 0;

    $self->print ("]]>");

}

sub comment

{

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

    $self->flush_xml_decl;

    my $esc = $self->{Escape}->{Comment};

#?? still need to support comments in the DTD

    $self->print ("<!--" . &$esc ($event->{Data}) . "-->");

}

sub entity_reference

{

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

    $self->flush_xml_decl;

    my $par = $event->{Parameter} ? '%' : '&';

#?? parameter entities (like %par;) are NOT supported!

# PerlSAX::handle_default should be fixed!

    $self->print ($par . $event->{Name} . ";");

}

sub unparsed_entity_decl

{

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

    $self->flush_xml_decl;

    $self->entity_decl ($event);

}

sub notation_decl

{

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

    $self->flush_xml_decl;

    my $name = $event->{Name};

    my $sysId = $event->{SystemId};

    my $pubId = $event->{PublicId};

    my $q = $self->{Quote}->{SystemLiteral};

    my $escape = $self->{Escape}->{SystemLiteral};

    $sysId = &$escape ($sysId) if defined $sysId;

    $pubId = &$escape ($pubId) if defined $pubId;

    my $str = $self->{DocTypeIndent} . "<!NOTATION $name";

    if (defined $pubId)

    {

	$str .= " PUBLIC $q$pubId$q";	

    }

    if (defined $sysId)

    {

	$str .= " SYSTEM $q$sysId$q";	

    }

    $str .= ">";

    $self->{DTD} .= $str;

}

sub element_decl

{

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

    $self->flush_xml_decl;

    my $name = $event->{Name};

    my $model = $event->{Model};

    $self->{DTD} .= $self->{DocTypeIndent} . "<!ELEMENT $name $model>";

}

sub entity_decl

{

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

    $self->flush_xml_decl;

    my $name = $event->{Name};

    my $par = "";

    if ($name =~ /^%/)

    {

	# It's a parameter entity (i.e. %ent; instead of &ent;)

	$name = substr ($name, 1);

	$par = "% ";

    }

    my $str = $self->{DocTypeIndent} . "<!ENTITY $par$name";

    my $value = $event->{Value};

    my $sysId = $event->{SysId};

    my $pubId = $event->{PubId};

    my $ndata = $event->{Ndata};

    my $q = $self->{Quote}->{SystemLiteral};

    my $escape = $self->{Escape}->{SystemLiteral};

    if (defined $value)

    {

#?? use {Entity} quote etc...

	my $esc = $self->{Escape}->{Entity};

	my $p = $self->{Quote}->{Entity};

	$str .= " $p" . &$esc ($value) . $p;

    }

    if (defined $pubId)

    {

	$str .= " PUBLIC $q" . &$escape ($pubId) . $q;	

    }

    elsif (defined $sysId)

    {

	$str .= " SYSTEM";

    }

    if (defined $sysId)

    {

	$str .= " $q" . &$escape ($sysId) . $q;

    }

    $str .= " NDATA $ndata" if defined $ndata;

    $str .= ">";

    $self->{DTD} .= $str;

}

sub attlist_decl

{

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

    $self->flush_xml_decl;