File Coverage

blib/lib/XML/Writer.pm

Criterion	Covered	Total	%
statement	650	650	100.0
branch	200	200	100.0
condition	99	99	100.0
subroutine	101	101	100.0
pod	27	27	100.0
total	1077	1077	100.0

########################################################################
# Writer.pm - write an XML document.
# Copyright (c) 1999 by Megginson Technologies.
# Copyright (c) 2003 Ed Avis
# Copyright (c) 2004-2010 Joseph Walton
# Redistribution and use in source and compiled forms, with or without
# modification, are permitted under any circumstances.  No warranty.
########################################################################

package XML::Writer;

require 5.004;

use strict;
use vars qw($VERSION);
use Carp;
use IO::Handle;
$VERSION = "0.900";

use overload '""' => \&_overload_string;


########################################################################
# Constructor.
########################################################################

#
# Public constructor.
#
# This actually does most of the work of the module: it defines closures
# for all of the real processing, and selects the appropriate closures
# to use based on the value of the UNSAFE parameter.  The actual methods
# are just stubs.
#
sub new {
  my ($class, %params) = (@_);

                                # If the user wants namespaces,
                                # intercept the request here; it will
                                # come back to this constructor
                                # from within XML::Writer::Namespaces::new()
  if ($params{NAMESPACES}) {
    delete $params{NAMESPACES};
    return XML::Writer::Namespaces->new(%params);
  }

                                # Set up $self and basic parameters
  my $self;
  my $output;
  my $unsafe = $params{UNSAFE};
  my $newlines = $params{NEWLINES};
  my $dataMode = $params{DATA_MODE};
  my $dataIndent;
  my $selfcontained_output;
  my $use_selfcontained_output = 0;

                                # If the NEWLINES parameter is specified,
                                # set the $nl variable appropriately
  my $nl = '';
  if ($newlines) {
    $nl = "\n";
  }

  my $outputEncoding = $params{ENCODING} || "";
  my ($checkUnencodedRepertoire, $escapeEncoding);
  if (lc($outputEncoding) eq 'us-ascii') {
    $checkUnencodedRepertoire = \&_croakUnlessASCII;
    $escapeEncoding = \&_escapeASCII;
  } else {
    my $doNothing = sub {};
    $checkUnencodedRepertoire = $doNothing;
    $escapeEncoding = $doNothing;
  }

                                # Parse variables
  my @elementStack = ();
  my $elementLevel = 0;
  my %seen = ();

  my $hasData = 0;
  my @hasDataStack = ();
  my $hasElement = 0;
  my @hasElementStack = ();
  my $hasHeading = 0; # Does this document have anything before the first element?

  #
  # Private method to show attributes.
  #
  my $showAttributes = sub {
    my $atts = $_[0];
    my $i = 1;
    while ($atts->[$i]) {
      my $aname = $atts->[$i++];
      my $value = _escapeLiteral($atts->[$i++]);
      $value =~ s/\x0a/\
\;/g;
      $value =~ s/\x0d/\
\;/g;
      $value =~ s/\x09/\	\;/g;
      &{$escapeEncoding}($value);
      $output->print(" $aname=\"$value\"");
    }
  };

                                # Method implementations: the SAFE_
                                # versions perform error checking
                                # and then call the regular ones.
  my $end = sub {
    $output->print("\n");

    return $selfcontained_output
        if $use_selfcontained_output and defined wantarray;
  };

  my $SAFE_end = sub {
    if (!$seen{ELEMENT}) {
      croak("Document cannot end without a document element");
    } elsif ($elementLevel > 0) {
      croak("Document ended with unmatched start tag(s): @elementStack");
    } else {
      @elementStack = ();
      $elementLevel = 0;
      %seen = ();
      &{$end};
    }
  };

  my $xmlDecl = sub {
    my ($encoding, $standalone) = (@_);
    if ($standalone && $standalone ne 'no') {
      $standalone = 'yes';
    }

    # Only include an encoding if one has been explicitly supplied,
    #  either here or on construction. Allow the empty string
    #  to suppress it.
    if (!defined($encoding)) {
      $encoding = $outputEncoding;
    }
    $output->print("
    if ($encoding) {
      $output->print(" encoding=\"$encoding\"");
    }
    if ($standalone) {
      $output->print(" standalone=\"$standalone\"");
    }
    $output->print("?>\n");
    $hasHeading = 1;
  };

  my $SAFE_xmlDecl = sub {
    if ($seen{ANYTHING}) {
      croak("The XML declaration is not the first thing in the document");
    } else {
      $seen{ANYTHING} = 1;
      $seen{XMLDECL} = 1;
      &{$xmlDecl};
    }
  };

  my $pi = sub {
    my ($target, $data) = (@_);
    if ($data) {
      $output->print("");
    } else {
      $output->print("");
    }
    if ($elementLevel == 0) {
      $output->print("\n");
      $hasHeading = 1;
    }
  };

  my $SAFE_pi = sub {
    my ($name, $data) = (@_);
    $seen{ANYTHING} = 1;
    if (($name =~ /^xml/i) && ($name !~ /^xml-(stylesheet|model)$/i)) {
      carp("Processing instruction target begins with 'xml'");
    }

    if ($name =~ /\?\>/ || (defined($data) && $data =~ /\?\>/)) {
      croak("Processing instruction may not contain '?>'");
    } elsif ($name =~ /\s/) {
      croak("Processing instruction name may not contain whitespace");
    } else {
      &{$pi};
    }
  };

  my $comment = sub {
    my $data = $_[0];
    if ($dataMode && $elementLevel) {
      $output->print("\n");
      $output->print($dataIndent x $elementLevel);
    }
    $output->print("");
    if ($dataMode && $elementLevel) {
      $hasElement = 1;
    } elsif ($elementLevel == 0) {
      $output->print("\n");
      $hasHeading = 1;
    }
  };

  my $SAFE_comment = sub {
    my $data = $_[0];
    if ($data =~ /--/) {
      carp("Interoperability problem: \"--\" in comment text");
    }

    if ($data =~ /-->/) {
      croak("Comment may not contain '-->'");
    } else {
      &{$checkUnencodedRepertoire}($data);
      $seen{ANYTHING} = 1;
      &{$comment};
    }
  };

  my $doctype = sub {
    my ($name, $publicId, $systemId) = (@_);
    $output->print("
    if ($publicId) {
      unless ( defined $systemId) {
        croak("A DOCTYPE declaration with a public ID must also have a system ID");
      }
      $output->print(" PUBLIC \"$publicId\" \"$systemId\"");
    } elsif ( defined $systemId ) {
      $output->print(" SYSTEM \"$systemId\"");
    }
    $output->print(">\n");
    $hasHeading = 1;
  };

  my $SAFE_doctype = sub {
    my $name = $_[0];
    if ($seen{DOCTYPE}) {
      croak("Attempt to insert second DOCTYPE declaration");
    } elsif ($seen{ELEMENT}) {
      croak("The DOCTYPE declaration must come before the first start tag");
    } else {
      $seen{ANYTHING} = 1;
      $seen{DOCTYPE} = $name;
      &{$doctype};
    }
  };

  my $startTag = sub {
    my $name = $_[0];
    if ($dataMode && ($hasHeading || $elementLevel)) {
      $output->print("\n");
      $output->print($dataIndent x $elementLevel);
    }
    $elementLevel++;
    push @elementStack, $name;
    $output->print("<$name");
    &{$showAttributes}(\@_);
    $output->print("$nl>");
    if ($dataMode) {
      $hasElement = 1;
      push @hasDataStack, $hasData;
      $hasData = 0;
      push @hasElementStack, $hasElement;
      $hasElement = 0;
    }
  };

  my $SAFE_startTag = sub {
    my $name = $_[0];

    _croakUnlessValidName($name);
    &{$checkUnencodedRepertoire}($name);
    _checkAttributes(\@_, $checkUnencodedRepertoire);

    if ($seen{ELEMENT} && $elementLevel == 0) {
      croak("Attempt to insert start tag after close of document element");
    } elsif ($elementLevel == 0 && $seen{DOCTYPE} && $name ne $seen{DOCTYPE}) {
      croak("Document element is \"$name\", but DOCTYPE is \""
            . $seen{DOCTYPE}
            . "\"");
    } elsif ($dataMode && $hasData) {
      croak("Mixed content not allowed in data mode: element $name");
    } else {
      $seen{ANYTHING} = 1;
      $seen{ELEMENT} = 1;
      &{$startTag};
    }
  };

  my $emptyTag = sub {
    my $name = $_[0];
    if ($dataMode && ($hasHeading || $elementLevel)) {
      $output->print("\n");
      $output->print($dataIndent x $elementLevel);
    }
    $output->print("<$name");
    &{$showAttributes}(\@_);
    $output->print("$nl />");
    if ($dataMode) {
      $hasElement = 1;
    }
  };

  my $SAFE_emptyTag = sub {
    my $name = $_[0];

    _croakUnlessValidName($name);
    &{$checkUnencodedRepertoire}($name);
    _checkAttributes(\@_, $checkUnencodedRepertoire);

    if ($seen{ELEMENT} && $elementLevel == 0) {
      croak("Attempt to insert empty tag after close of document element");
    } elsif ($elementLevel == 0 && $seen{DOCTYPE} && $name ne $seen{DOCTYPE}) {
      croak("Document element is \"$name\", but DOCTYPE is \""
            . $seen{DOCTYPE}
            . "\"");
    } elsif ($dataMode && $hasData) {
      croak("Mixed content not allowed in data mode: element $name");
    } else {
      $seen{ANYTHING} = 1;
      $seen{ELEMENT} = 1;
      &{$emptyTag};
    }
  };

  my $endTag = sub {
    my $name = $_[0];
    my $currentName = pop @elementStack;
    $name = $currentName unless $name;
    $elementLevel--;
    if ($dataMode && $hasElement) {
      $output->print("\n");
      $output->print($dataIndent x $elementLevel);
    }
    $output->print("");
    if ($dataMode) {
      $hasData = pop @hasDataStack;
      $hasElement = pop @hasElementStack;
    }
  };

  my $SAFE_endTag = sub {
    my $name = $_[0];
    my $oldName = $elementStack[$#elementStack];
    if ($elementLevel <= 0) {
      croak("End tag \"$name\" does not close any open element");
    } elsif ($name && ($name ne $oldName)) {
      croak("Attempt to end element \"$oldName\" with \"$name\" tag");
    } else {
      &{$endTag};
    }
  };

  my $characters = sub {
    my $data = $_[0];
    if ($data =~ /[\&\<\>]/) {
      $data =~ s/\&/\&\;/g;
      $data =~ s/\
      $data =~ s/\>/\>\;/g;
    }
    &{$escapeEncoding}($data);
    $output->print($data);
    $hasData = 1;
  };

  my $SAFE_characters = sub {
    if ($elementLevel < 1) {
      croak("Attempt to insert characters outside of document element");
    } elsif ($dataMode && $hasElement) {
      croak("Mixed content not allowed in data mode: characters");
    } else {
      _croakUnlessDefinedCharacters($_[0]);
      &{$characters};
    }
  };

  my $raw = sub {
    $output->print($_[0]);
    # Don't set $hasData or any other information: we know nothing
    # about what was just written.
    #
  };

  my $SAFE_raw = sub {
    croak('raw() is only available when UNSAFE is set');
  };

  my $cdata = sub {
      my $data = $_[0];
      $data    =~ s/\]\]>/\]\]\]\]>/g;
      $output->print("");
      $hasData = 1;
  };

  my $SAFE_cdata = sub {
    if ($elementLevel < 1) {
      croak("Attempt to insert characters outside of document element");
    } elsif ($dataMode && $hasElement) {
      croak("Mixed content not allowed in data mode: characters");
    } else {
      _croakUnlessDefinedCharacters($_[0]);
      &{$checkUnencodedRepertoire}($_[0]);
      &{$cdata};
    }
  };

                                # Assign the correct closures based on
                                # the UNSAFE parameter
  if ($unsafe) {
    $self = {'END' => $end,
             'XMLDECL' => $xmlDecl,
             'PI' => $pi,
             'COMMENT' => $comment,
             'DOCTYPE' => $doctype,
             'STARTTAG' => $startTag,
             'EMPTYTAG' => $emptyTag,
             'ENDTAG' => $endTag,
             'CHARACTERS' => $characters,
             'RAW' => $raw,
             'CDATA' => $cdata
            };
  } else {
    $self = {'END' => $SAFE_end,
             'XMLDECL' => $SAFE_xmlDecl,
             'PI' => $SAFE_pi,
             'COMMENT' => $SAFE_comment,
             'DOCTYPE' => $SAFE_doctype,
             'STARTTAG' => $SAFE_startTag,
             'EMPTYTAG' => $SAFE_emptyTag,
             'ENDTAG' => $SAFE_endTag,
             'CHARACTERS' => $SAFE_characters,
             'RAW' => $SAFE_raw,               # This will intentionally fail
             'CDATA' => $SAFE_cdata
            };
  }

                                # Query methods
  $self->{'IN_ELEMENT'} = sub {
    my ($ancestor) = (@_);
    return $elementStack[$#elementStack] eq $ancestor;
  };

  $self->{'WITHIN_ELEMENT'} = sub {
    my ($ancestor) = (@_);
    my $el;
    foreach $el (@elementStack) {
      return 1 if $el eq $ancestor;
    }
    return 0;
  };

  $self->{'CURRENT_ELEMENT'} = sub {
    return $elementStack[$#elementStack];
  };

  $self->{'ANCESTOR'} = sub {
    my ($n) = (@_);
    if ($n < scalar(@elementStack)) {
      return $elementStack[$#elementStack-$n];
    } else {
      return undef;
    }
  };

                                # Set and get the output destination.
  $self->{'GETOUTPUT'} = sub {
    if (ref($output) ne 'XML::Writer::_PrintChecker') {
      return $output;
    } else {
      return $output->{HANDLE};
    }
  };

  $self->{'SETOUTPUT'} = sub {
    my $newOutput = $_[0];

    if (defined($newOutput) && !ref($newOutput)) {
      if ('self' eq $newOutput ) {
        $newOutput = \$selfcontained_output;
        $use_selfcontained_output = 1;
      } else {
        die "Output must be a handle, a reference or 'self'";
      }
    }

    if (ref($newOutput) eq 'SCALAR') {
      $output = XML::Writer::_String->new($newOutput);
    } else {
                                # If there is no OUTPUT parameter,
                                # use standard output
      $output = $newOutput || \*STDOUT;
      if ($outputEncoding && (ref($output) eq 'GLOB' || $output->isa('IO::Handle'))) {
        if (lc($outputEncoding) eq 'utf-8') {
          binmode($output, ':encoding(utf-8)');
        } elsif (lc($outputEncoding) eq 'us-ascii') {
          binmode($output, ':encoding(us-ascii)');
        } else {
          die 'The only supported encodings are utf-8 and us-ascii';
        }
      }
    }

    if ($params{CHECK_PRINT}) {
      $output = XML::Writer::_PrintChecker->new($output);
    }
  };

  $self->{OVERLOADSTRING} = sub {
      # if we don't use the self-contained output,
      # simple passthrough
      return $use_selfcontained_output ? $selfcontained_output : undef;
  };

  $self->{TOSTRING} = sub {
      die "'to_string' can only be used with self-contained output\n"
          unless $use_selfcontained_output;

      return $selfcontained_output;
  };

  $self->{'SETDATAMODE'} = sub {
    $dataMode = $_[0];
  };

  $self->{'GETDATAMODE'} = sub {
    return $dataMode;
  };

  $self->{'SETDATAINDENT'} = sub {
    if ($_[0] =~ /^\s*$/) {
      $dataIndent = $_[0];
    } else {
      $dataIndent = ' ' x $_[0];
    }
  };

  $self->{'GETDATAINDENT'} = sub {
    if ($dataIndent =~ /^ *$/) {
      return length($dataIndent);
    } else {
      return $dataIndent;
    }
  };

                                # Set the indent.
  &{$self->{'SETDATAINDENT'}}($params{'DATA_INDENT'} || '');

                                # Set the output.
  &{$self->{'SETOUTPUT'}}($params{'OUTPUT'});

                                # Return the blessed object.
  return bless $self, $class;
}



########################################################################
# Public methods
########################################################################

#
# Finish writing the document.
#
sub end {
  my $self = shift;
  &{$self->{END}};
}

#
# Write an XML declaration.
#
sub xmlDecl {
  my $self = shift;
  &{$self->{XMLDECL}};
}

#
# Write a processing instruction.
#
sub pi {
  my $self = shift;
  &{$self->{PI}};
}

#
# Write a comment.
#
sub comment {
  my $self = shift;
  &{$self->{COMMENT}};
}

#
# Write a DOCTYPE declaration.
#
sub doctype {
  my $self = shift;
  &{$self->{DOCTYPE}};
}

#
# Write a start tag.
#
sub startTag {
  my $self = shift;
  &{$self->{STARTTAG}};
}

#
# Write an empty tag.
#
sub emptyTag {
  my $self = shift;
  &{$self->{EMPTYTAG}};
}

#
# Write an end tag.
#
sub endTag {
  my $self = shift;
  &{$self->{ENDTAG}};
}

#
# Write a simple data element.
#
sub dataElement {
  my ($self, $name, $data, @atts) = (@_);
  $self->startTag($name, @atts);
  $self->characters($data);
  $self->endTag($name);
}

#
# Write a simple CDATA element.
#
sub cdataElement {
    my ($self, $name, $data, %atts) = (@_);
    $self->startTag($name, %atts);
    $self->cdata($data);
    $self->endTag($name);
}

#
# Write character data.
#
sub characters {
  my $self = shift;
  &{$self->{CHARACTERS}};
}

#
# Write raw, unquoted, completely unchecked character data.
#
sub raw {
  my $self = shift;
  &{$self->{RAW}};
}

#
# Write CDATA.
#
sub cdata {
    my $self = shift;
    &{$self->{CDATA}};
}

#
# Query the current element.
#
sub in_element {
  my $self = shift;
  return &{$self->{IN_ELEMENT}};
}

#
# Query the ancestors.
#
sub within_element {
  my $self = shift;
  return &{$self->{WITHIN_ELEMENT}};
}

#
# Get the name of the current element.
#
sub current_element {
  my $self = shift;
  return &{$self->{CURRENT_ELEMENT}};
}

#
# Get the name of the numbered ancestor (zero-based).
#
sub ancestor {
  my $self = shift;
  return &{$self->{ANCESTOR}};
}

#
# Get the current output destination.
#
sub getOutput {
  my $self = shift;
  return &{$self->{GETOUTPUT}};
}


#
# Set the current output destination.
#
sub setOutput {
  my $self = shift;
  return &{$self->{SETOUTPUT}};
}

#
# Set the current data mode (true or false).
#
sub setDataMode {
  my $self = shift;
  return &{$self->{SETDATAMODE}};
}


#
# Get the current data mode (true or false).
#
sub getDataMode {
  my $self = shift;
  return &{$self->{GETDATAMODE}};
}


#
# Set the current data indent step.
#
sub setDataIndent {
  my $self = shift;
  return &{$self->{SETDATAINDENT}};
}


#
# Get the current data indent step.
#
sub getDataIndent {
  my $self = shift;
  return &{$self->{GETDATAINDENT}};
}


#
# Empty stub.
#
sub addPrefix {
}


#
# Empty stub.
#
sub removePrefix {
}

sub to_string {
    my $self = shift;

    $self->{TOSTRING}->();
}



########################################################################
# Private functions.
########################################################################

#
# Private: check for duplicate attributes and bad characters.
# Note - this starts at $_[1], because $_[0] is assumed to be an
# element name.
#
sub _checkAttributes {
  my %anames;
  my $i = 1;
  my $checkUnencodedRepertoire = $_[1];

  while ($_[0]->[$i]) {
    my $name = $_[0]->[$i];
    $i += 1;
    if ($anames{$name}) {
      croak("Two attributes named \"$name\"");
    } else {
      $anames{$name} = 1;
    }
    _croakUnlessValidName($name);
    &{$checkUnencodedRepertoire}($name);
    _croakUnlessDefinedCharacters($_[0]->[$i]);
    $i += 1;
  }
}

#
# Private: escape an attribute value literal.
#
sub _escapeLiteral {
  my $data = $_[0];
  if ($data =~ /[\&\<\>\"]/) {
    $data =~ s/\&/\&\;/g;
    $data =~ s/\
    $data =~ s/\>/\>\;/g;
    $data =~ s/\"/\"\;/g;
  }
  return $data;
}

sub _escapeASCII($) {
  $_[0] =~ s/([^\x00-\x7F])/sprintf('&#x%X;', ord($1))/ge;
}

sub _croakUnlessASCII($) {
  if ($_[0] =~ /[^\x00-\x7F]/) {
    croak('Non-ASCII characters are not permitted in this part of a US-ASCII document');
  }
}

# Enforce XML 1.0, section 2.2's definition of "Char" (only reject low ASCII,
#  so as not to require Unicode support from perl)
sub _croakUnlessDefinedCharacters($) {
  if ($_[0] =~ /([\x00-\x08\x0B-\x0C\x0E-\x1F])/) {
    croak(sprintf('Code point \u%04X is not a valid character in XML', ord($1)));
  }
}

# Ensure element and attribute names are non-empty, contain no whitespace and are
#  otherwise valid XML names
sub _croakUnlessValidName($) {
  if ($_[0] eq '') {
    croak('Empty identifiers are not permitted in this part of an XML document');
  }
  if ($_[0] =~ /\s/) {
    croak('Space characters are not permitted in this part of an XML identifier');
  }

  # From REC-xml-20081126
  #  [4]   	NameStartChar	   ::=   	":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6] | [#xD8-#xF6] | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF] | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF]
  #  [4a]   	NameChar	   ::=   	NameStartChar | "-" | "." | [0-9] | #xB7 | [#x0300-#x036F] | [#x203F-#x2040]
  #  [5]   	Name	   ::=   	NameStartChar (NameChar)*

  if ($_[0] !~ /^[:A-Z_a-z\x{C0}-\x{D6}\x{D8}-\x{F6}\x{F8}-\x{2FF}\x{370}-\x{37D}\x{37F}-\x{1FFF}\x{200C}-\x{200D}\x{2070}-\x{218F}\x{2C00}-\x{2FEF}\x{3001}-\x{D7FF}\x{F900}-\x{FDCF}\x{FDF0}-\x{FFFD}\x{10000}\x{EFFFF}][-.0-9\x{B7}\x{0300}-\x{036F}\x{203F}-\x{2040}:A-Z_a-z\x{C0}-\x{D6}\x{D8}-\x{F6}\x{F8}-\x{2FF}\x{370}-\x{37D}\x{37F}-\x{1FFF}\x{200C}-\x{200D}\x{2070}-\x{218F}\x{2C00}-\x{2FEF}\x{3001}-\x{D7FF}\x{F900}-\x{FDCF}\x{FDF0}-\x{FFFD}\x{10000}\x{EFFFF}]*$/) {
    croak('Not a valid XML name: '.$_[0]);
  }

	  #	  ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6] | [#xD8-#xF6] | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF] | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF]

	  #	  | "-" | "." | [0-9] | #xB7 | [#x0300-#x036F] | [#x203F-#x2040]
}

sub _overload_string {
    my $self = shift;
    $self->{OVERLOADSTRING}->() || overload::StrVal($self);
}

########################################################################
# XML::Writer::Namespaces - subclass for Namespace processing.
########################################################################

package XML::Writer::Namespaces;
use strict;
use vars qw(@ISA);
use Carp;

@ISA = qw(XML::Writer);

#
# Constructor
#
sub new {
  my ($class, %params) = (@_);

  my $unsafe = $params{UNSAFE};

                                # Snarf the prefix map, if any, and
                                # note the default prefix.
  my %prefixMap = ();
  if ($params{PREFIX_MAP}) {
    %prefixMap = (%{$params{PREFIX_MAP}});
    delete $params{PREFIX_MAP};
  }
  $prefixMap{'http://www.w3.org/XML/1998/namespace'} = 'xml';

                                # Generate the reverse map for URIs
  my $uriMap = {};
  my $key;
  foreach $key (keys(%prefixMap)) {
    $uriMap->{$prefixMap{$key}} = $key;
  }

  my $defaultPrefix = $uriMap->{''};
  delete $prefixMap{$defaultPrefix} if ($defaultPrefix);

                                # Create an instance of the parent.
  my $self = XML::Writer->new(%params);

                                # Snarf the parent's methods that we're
                                # going to override.
  my $OLD_startTag = $self->{STARTTAG};
  my $OLD_emptyTag = $self->{EMPTYTAG};
  my $OLD_endTag = $self->{ENDTAG};

                                # State variables
  my @stack;
  my $prefixCounter = 1;
  my $nsDecls = {'http://www.w3.org/XML/1998/namespace' => 'xml'};
  my $nsDefaultDecl = undef;
  my $nsCopyFlag = 0;
  my @forcedNSDecls = ();

  if ($params{FORCED_NS_DECLS}) {
    @forcedNSDecls = @{$params{FORCED_NS_DECLS}};
    delete $params{FORCED_NS_DECLS};
  }

  #
  # Push the current declaration state.
  #
  my $pushState = sub {
    push @stack, [$nsDecls, $nsDefaultDecl, $nsCopyFlag, $uriMap];
    $nsCopyFlag = 0;
  };


  #
  # Pop the current declaration state.
  #
  my $popState = sub {
    ($nsDecls, $nsDefaultDecl, $nsCopyFlag, $uriMap) = @{pop @stack};
  };

  #
  # Generate a new prefix.
  #
  my $genPrefix = sub {
    my $uri = $_[0];
    my $prefixCounter = 1;
    my $prefix = $prefixMap{$uri};
    my %clashMap = %{$uriMap};
    while( my ($u, $p) = each(%prefixMap)) {
      $clashMap{$p} = $u;
    }

    if (!defined($prefix)) {
      do {
        $prefix = "__NS$prefixCounter";
        $prefixCounter++;
      } while ($clashMap{$prefix});
    }

    return $prefix;
  };

  #
  # Perform namespace processing on a single name.
  #
  my $processName = sub {
    my ($nameref, $atts, $attFlag) = (@_);
    my ($uri, $local) = @{$$nameref};
    my $prefix = $nsDecls->{$uri};

                                # Is this an element name that matches
                                # the default NS?
    if (!$attFlag && $defaultPrefix && ($uri eq $defaultPrefix)) {
      unless ($nsDefaultDecl && ($nsDefaultDecl eq $uri)) {
        push @{$atts}, 'xmlns';
        push @{$atts}, $uri;
        $nsDefaultDecl = $uri;
      }
      $$nameref = $local;

      if (defined($uriMap->{''})) {
        delete ($nsDecls->{$uriMap->{''}});
      }

      $nsDecls->{$uri} = '';
      unless ($nsCopyFlag) {
        $uriMap = {%{$uriMap}};
        $nsDecls = {%{$nsDecls}};
        $nsCopyFlag = 1;
      }
      $uriMap->{''} = $uri;

                                # Is there a straight-forward prefix?
    } elsif ($prefix) {
      $$nameref = "$prefix:$local";
    } else {
      $prefix = &{$genPrefix}($uri);
      unless ($nsCopyFlag) {
        $uriMap = {%{$uriMap}};
        $nsDecls = {%{$nsDecls}};
        $nsCopyFlag = 1;
      }
      $uriMap->{$prefix} = $uri;
      $nsDecls->{$uri} = $prefix;
      push @{$atts}, "xmlns:$prefix";
      push @{$atts}, $uri;
      $$nameref = "$prefix:$local";
    }
  };


  #
  # Perform namespace processing on element and attribute names.
  #
  my $nsProcess = sub {
    if (ref($_[0]->[0]) eq 'ARRAY') {
      my $x = \@{$_[0]->[0]};
      &{$processName}(\$x, $_[0], 0);
      splice(@{$_[0]}, 0, 1, $x);
    }
    my $i = 1;
    while ($_[0]->[$i]) {
      if (ref($_[0]->[$i]) eq 'ARRAY') {
        my $x = \@{$_[0]->[$i]};
        &{$processName}(\$x, $_[0], 1);
        splice(@{$_[0]}, $i, 1, $x);
      }
      $i += 2;
    }

    # We do this if any declarations are forced, due either to
    #  constructor arguments or to a call during processing.
    if (@forcedNSDecls) {
      foreach (@forcedNSDecls) {
        my @dummy = ($_, 'dummy');
        my $d2 = \@dummy;
        if ($defaultPrefix && ($_ eq $defaultPrefix)) {
          &{$processName}(\$d2, $_[0], 0);
        } else {
          &{$processName}(\$d2, $_[0], 1);
        }
      }
      @forcedNSDecls = ();
    }
  };


  # Indicate that a namespace should be declared by the next open element
  $self->{FORCENSDECL} = sub {
    push @forcedNSDecls, $_[0];
  };


  #
  # Start tag, with NS processing
  #
  $self->{STARTTAG} = sub {
    my $name = $_[0];
    unless ($unsafe) {
      _checkNSNames(\@_);
    }
    &{$pushState}();
    &{$nsProcess}(\@_);
    &{$OLD_startTag};
  };


  #
  # Empty tag, with NS processing
  #
  $self->{EMPTYTAG} = sub {
    unless ($unsafe) {
      _checkNSNames(\@_);
    }
    &{$pushState}();
    &{$nsProcess}(\@_);
    &{$OLD_emptyTag};
    &{$popState}();
  };


  #
  # End tag, with NS processing
  #
  $self->{ENDTAG} = sub {
    my $name = $_[0];
    if (ref($_[0]) eq 'ARRAY') {
      my $pfx = $nsDecls->{$_[0]->[0]};
      if ($pfx) {
        $_[0] = $pfx . ':' . $_[0]->[1];
      } else {
        $_[0] = $_[0]->[1];
      }
    } else {
      $_[0] = $_[0];
    }
#    &{$nsProcess}(\@_);
    &{$OLD_endTag};
    &{$popState}();
  };


  #
  # Processing instruction, but only if not UNSAFE.
  #
  unless ($unsafe) {
    my $OLD_pi = $self->{PI};
    $self->{PI} = sub {
      my $target = $_[0];
      if (index($target, ':') >= 0) {
        croak "PI target '$target' contains a colon.";
      }
      &{$OLD_pi};
    }
  };


  #
  # Add a prefix to the prefix map.
  #
  $self->{ADDPREFIX} = sub {
    my ($uri, $prefix) = (@_);
    if ($prefix) {
      $prefixMap{$uri} = $prefix;
    } else {
      if (defined($defaultPrefix)) {
        delete($prefixMap{$defaultPrefix});
      }
      $defaultPrefix = $uri;
    }
  };


  #
  # Remove a prefix from the prefix map.
  #
  $self->{REMOVEPREFIX} = sub {
    my ($uri) = (@_);
    if ($defaultPrefix && ($defaultPrefix eq $uri)) {
      $defaultPrefix = undef;
    }
    delete $prefixMap{$uri};
  };


  #
  # Bless and return the object.
  #
  return bless $self, $class;
}


#
# Add a preferred prefix for a namespace URI.
#
sub addPrefix {
  my $self = shift;
  return &{$self->{ADDPREFIX}};
}


#
# Remove a preferred prefix for a namespace URI.
#
sub removePrefix {
  my $self = shift;
  return &{$self->{REMOVEPREFIX}};
}


#
# Check names.
#
sub _checkNSNames {
  my $names = $_[0];
  my $i = 1;
  my $name = $names->[0];

                                # Check the element name.
  if (ref($name) eq 'ARRAY') {
    if (index($name->[1], ':') >= 0) {
      croak("Local part of element name '" .
            $name->[1] .
            "' contains a colon.");
    }
  } elsif (index($name, ':') >= 0) {
    croak("Element name '$name' contains a colon.");
  }

                                # Check the attribute names.
  while ($names->[$i]) {
    my $name = $names->[$i];
    if (ref($name) eq 'ARRAY') {
      my $local = $name->[1];
      if (index($local, ':') >= 0) {
        croak "Local part of attribute name '$local' contains a colon.";
      }
    } else {
      if ($name =~ /^xmlns/) {
        croak "Attribute name '$name' begins with 'xmlns'";
      } elsif (index($name, ':') >= 0) {
        croak "Attribute name '$name' contains ':'";
      }
    }
    $i += 2;
  }
}

sub forceNSDecl
{
  my $self = shift;
  return &{$self->{FORCENSDECL}};
}


package XML::Writer::_String;

# Internal class, behaving sufficiently like an IO::Handle,
#  that stores written output in a string
#
# Heavily inspired by Simon Oliver's XML::Writer::String

sub new
{
  my $class = shift;
  my $scalar_ref = shift;
  return bless($scalar_ref, $class);
}

sub print
{
  ${(shift)} .= join('', @_);
  return 1;
}


package XML::Writer::_PrintChecker;

use Carp;

sub new
{
  my $class = shift;
  return bless({HANDLE => shift}, $class);
}

sub print
{
  my $self = shift;
  if ($self->{HANDLE}->print(shift)) {
    return 1;
  } else {
    croak "Failed to write output: $!";
  }
}

1;
__END__