File Coverage

blib/lib/XML/Handler/Composer.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package XML::Handler::Composer;
use strict;
use XML::UM;
use Carp;

use vars qw{ $VERSION %DEFAULT_QUOTES %XML_MAPPING_CRITERIA };

$VERSION = '0.01';

%DEFAULT_QUOTES = (
		   XMLDecl => '"',
		   Attr => '"',
		   Entity => '"',
		   SystemLiteral => '"',
		  );

%XML_MAPPING_CRITERIA =
(
 Text =>
 {
   '<' => '<',
   '&' => '&',

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

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

 Attr =>	# attribute value (assuming double quotes "" are used)
 {
#   '"' => '"',	# Use ("'" => ''') when using single quotes
   '<' => '<',
   '&' => '&',
 },

 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  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 '<' 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:
# 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  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 = "
    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  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 ("{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 ("
}

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 ("");
}

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} . "

    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} . "";
}

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} . "

    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;

    my $elem = $event->{ElementName};

    my $str = $event->{AttributeName} . " " . $event->{Type};
    $str .= " #FIXED" if defined $event->{Fixed};

    $str = $str;

    my $def = $event->{Default};
    if (defined $def)
    {
	$str .= " $def";

	# Note sometimes Default is a value with quotes.
	# We'll use the existing quotes in that case...
    }

    my $indent;
    if (!exists($event->{First}) || $event->{First})
    {
	$self->{DTD} .= $self->{DocTypeIndent} . "

	if ($event->{MoreFollow})
	{
	    $indent = $self->{Newline} . $self->{IndentAttlist};
	}
	else
	{
	    $indent = " ";
	}
    }
    else
    {
	$indent = $self->{Newline} . $self->{IndentAttlist};
    }

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

    unless ($event->{MoreFollow})
    {
	$self->{DTD} .= '>';
    }
}

sub xml_decl
{
    my ($self, $event) = @_;
    return if $self->{PrintedXmlDecl};	# already printed it

    my $version = $event->{Version};
    my $encoding = $event->{Encoding};
    if (defined $self->{Encoding})
    {
	$encoding = $self->{Encoding};
    }
    else
    {
	$self->setEncoding ($encoding) if defined $encoding;
    }

    my $standalone = $event->{Standalone};
    $standalone = ($standalone ? "yes" : "no") if defined $standalone;

    my $q = $self->{Quote}->{XMLDecl};
    my $nl = $self->{Newline};

    my $str = "
    $str .= " version=$q$version$q"	  if defined $version;
    $str .= " encoding=$q$encoding$q"	  if defined $encoding;
    $str .= " standalone=$q$standalone$q" if defined $standalone;
    $str .= "?>$nl$nl";

    $self->print ($str);
    $self->{PrintedXmlDecl} = 1;
}

#
# Prints the  declaration if it wasn't already printed
# *and* the user wanted it to be printed (because s/he set $self->{Encoding})
#
sub flush_xml_decl
{
    my ($self) = @_;
    return if $self->{PrintedXmlDecl};

    if (defined $self->{Encoding})
    {
	$self->xml_decl ({ Version => '1.0', Encoding => $self->{Encoding} });
    }

    # If it wasn't printed just now, it doesn't need to be printed at all,
    # so pretend we did print it.
    $self->{PrintedXmlDecl} = 1;
}

sub processing_instruction
{
    my ($self, $event) = @_;
    $self->flush_xml_decl;

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

    my $str = "{Target} . " " .
		&$escape ($event->{Data}). "?>";

    $self->print ($str);
}

1; # package return code

__END__