r2522 - in packages: . libxml-writer-perl
libxml-writer-perl/branches libxml-writer-perl/branches/upstream
libxml-writer-perl/branches/upstream/current
libxml-writer-perl/branches/upstream/current/t
Niko Tyni
ntyni-guest at costa.debian.org
Sun Apr 9 09:56:26 UTC 2006
Author: ntyni-guest
Date: 2006-04-09 09:56:25 +0000 (Sun, 09 Apr 2006)
New Revision: 2522
Added:
packages/libxml-writer-perl/
packages/libxml-writer-perl/branches/
packages/libxml-writer-perl/branches/upstream/
packages/libxml-writer-perl/branches/upstream/current/
packages/libxml-writer-perl/branches/upstream/current/Changes
packages/libxml-writer-perl/branches/upstream/current/MANIFEST
packages/libxml-writer-perl/branches/upstream/current/META.yml
packages/libxml-writer-perl/branches/upstream/current/Makefile.PL
packages/libxml-writer-perl/branches/upstream/current/README
packages/libxml-writer-perl/branches/upstream/current/TODO
packages/libxml-writer-perl/branches/upstream/current/Writer.pm
packages/libxml-writer-perl/branches/upstream/current/t/
packages/libxml-writer-perl/branches/upstream/current/t/01_main.t
packages/libxml-writer-perl/tags/
Log:
[svn-inject] Installing original source of libxml-writer-perl
Added: packages/libxml-writer-perl/branches/upstream/current/Changes
===================================================================
--- packages/libxml-writer-perl/branches/upstream/current/Changes 2006-04-08 18:23:48 UTC (rev 2521)
+++ packages/libxml-writer-perl/branches/upstream/current/Changes 2006-04-09 09:56:25 UTC (rev 2522)
@@ -0,0 +1,91 @@
+Revision history for Perl extension XML::Writer.
+
+0.545 Mon May 16 08:11:17 BST 2005 <joe at kafsemo.org>
+ - Format comments like elements when in data mode.
+ - Only attempt Unicode tests for Perl >= 5.8.1.
+
+0.540 Tue May 10 18:18:58 BST 2005 <joe at kafsemo.org>
+ - Don't die when ENCODING is specified with a scalar OUTPUT.
+ - Add support for US-ASCII encoding.
+
+0.531 Mon Mar 14 22:11:33 GMT 2005 <joe at kafsemo.org>
+ - Rename internal String package to avoid clash with external modules.
+ - Fix Unicode test skipping for Perls before 5.8.
+
+0.530 Tue Feb 1 13:09:31 GMT 2005 <joe at kafsemo.org>
+ - Allow scalar references for the OUTPUT parameter, inspired by
+ Simon Oliver's XML::Writer::String (patch from Yanick Champoux)
+ - Added ENCODING parameter; currently only UTF-8 is supported
+ - Escape newlines in attribute values
+
+0.520 Wed Sep 1 16:18:46 BST 2004 <joe at kafsemo.org>
+ - Fixed bug with forced declaration of the default namespace (#7266)
+ - Removed dead code. Added copyright notices to pod.
+ - Improved test coverage
+
+0.510 Tue May 25 19:46:04 BST 2004 <joe at kafsemo.org>
+ - Permitted in-document namespace prefix control
+ - Don't reopen STDOUT for output (closes #6232)
+ - Moved tests into t/. Added tests for mid-document namespace changes.
+ Show diffs when comparison tests fail
+
+0.500 Sat Mar 6 22:45:54 GMT 2004 <joe at kafsemo.org>
+ - Prepared metadata for a consistent, CPAN-friendly 0.500 release
+ - Added a META.yml to prevent XML::Writer::Namespaces from
+ being indexed
+ - Writer.pm: Removed a duplicate check for valid attribute names
+ - test.pl: Added more tests for full coverage of the cdata method
+
+0.4.6 Tue Mar 2 16:54:04 GMT 2004 <joe at kafsemo.org>
+ - test.pl: Revert to using a temporary file, rather than an
+ IO::String, for compatibility with older Perls
+
+0.4.5 Mon Mar 1 14:46:47 GMT 2004 <joe at kafsemo.org>
+ - added FORCED_NS_DECLS parameter, to declare namespaces ahead of use
+ - fixed check for duplicate attributes
+ - correctly take the default namespace from the supplied prefix map
+ - no longer produce namespace declarations for the 'xml:' prefix
+ - allow xml-stylesheet PIs
+ - fixed warnings about uninitialised values
+ - added a comprehensive suite of tests, using Test::More
+
+0.4.2 Sun Feb 22 15:33:44 GMT 2004 ed at membled.com
+ - added raw() to print raw, unescaped text
+ - patch from srinithan adding cdata() and cdataElement() to
+ write CDATA sections
+
+0.4.1 Sat Oct 18 19:51:51 BST 2003 ed at membled.com
+ - fixed deprecation warning from 'use IO'
+
+0.4 Tue Apr 4 21:59:51 EDT 2000
+ - added support for a simple data mode (off by default), with
+ no mixed content and automatic whitespace and indenting
+ - added get/setDataMode and get/setDataIndent methods
+ - added DATA_MODE and DATA_INDENT parameters to constructor
+ - added dataElement method for simple case (character data
+ content only)
+
+0.3 Thu Dec 9 12:49:28 EST 1999
+ - fixed frequently-reported attribute-list bug
+ - changed xmlDecl() so that first argument is the encoding
+ - added 'use IO;' to avoid errors
+ - documented the doctype() method
+
+0.2
+ - added Namespace support (XML::Writer::Namespaces subclass
+ and NAMESPACES constructor parameter)
+ - added PREFIX_MAP constructor parameter, and
+ add/removePrefix() methods for Namespace support
+ - added getOutput() and setOutput() methods
+ - added new query methods in_element(), within_element(),
+ current_element(), and ancestor()
+ - changed constructor to use parameterized arguments
+ - added constructor option to insert newlines in tags
+ - element name is now optional in endTag() method
+ - fixed test.pl to work on Mac, and added new test
+ - added more examples in documentation
+ - require at least Perl 5.004
+
+0.1 Mon Apr 19 12:27:36 1999
+ - original version; created by h2xs 1.19
+
Added: packages/libxml-writer-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libxml-writer-perl/branches/upstream/current/MANIFEST 2006-04-08 18:23:48 UTC (rev 2521)
+++ packages/libxml-writer-perl/branches/upstream/current/MANIFEST 2006-04-09 09:56:25 UTC (rev 2522)
@@ -0,0 +1,8 @@
+README
+Changes
+MANIFEST
+Makefile.PL
+META.yml
+Writer.pm
+t/01_main.t
+TODO
Added: packages/libxml-writer-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libxml-writer-perl/branches/upstream/current/META.yml 2006-04-08 18:23:48 UTC (rev 2521)
+++ packages/libxml-writer-perl/branches/upstream/current/META.yml 2006-04-09 09:56:25 UTC (rev 2522)
@@ -0,0 +1,25 @@
+# http://module-build.sourceforge.net/META-spec-new.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+meta-spec: 1.1
+name: XML-Writer
+version: 0.600
+abstract: Easily generate well-formed, namespace-aware XML.
+authored_by:
+ - David Megginson <david at megginson.com>
+ - Ed Avis <ed at membled.com>
+ - Joseph Walton <joe at kafsemo.org>
+license: perl
+distribution_type: module
+installdirs: site
+
+build_requires:
+ perl: 5.006_000
+recommends:
+ perl: 5.008_001
+
+no_index:
+ package:
+ - XML::Writer::Namespaces
+
+dynamic_config: 0
+generated_by: Hand
Added: packages/libxml-writer-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libxml-writer-perl/branches/upstream/current/Makefile.PL 2006-04-08 18:23:48 UTC (rev 2521)
+++ packages/libxml-writer-perl/branches/upstream/current/Makefile.PL 2006-04-09 09:56:25 UTC (rev 2522)
@@ -0,0 +1,15 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'XML::Writer',
+ 'VERSION' => '0.600',
+
+ # A manually-created META.yml has all the other metadata;
+ # we don't want it overwritten
+ NO_META => 1
+);
Added: packages/libxml-writer-perl/branches/upstream/current/README
===================================================================
--- packages/libxml-writer-perl/branches/upstream/current/README 2006-04-08 18:23:48 UTC (rev 2521)
+++ packages/libxml-writer-perl/branches/upstream/current/README 2006-04-09 09:56:25 UTC (rev 2522)
@@ -0,0 +1,32 @@
+XML::Writer is a simple Perl module for writing XML documents: it
+takes care of constructing markup and escaping data correctly, and by
+default, it also performs a significant amount of well-formedness
+checking on the output, to make certain (for example) that start and
+end tags match, that there is exactly one document element, and that
+there are not duplicate attribute names.
+
+Here is an example:
+
+ my $writer = new XML::Writer();
+
+ $writer->startTag('greeting', 'type' => 'simple');
+ $writer->characters("Hello, world!");
+ $writer->endTag('greeting');
+ $writer->end();
+
+If necessary, error-checking can be turned off for production use.
+
+This release bumps the version number so the changes in the 0.4.x releases
+can automatically be picked up by CPAN users.
+
+See the Changes file for detailed changes between versions.
+
+Copyright (c) 1999 by David Megginson,
+copyright 2003 Ed Avis, <ed at membled.com> and others.
+Some fixes, and a rewritten test suite,
+copyright 2004, 2005 Joseph Walton <joe at kafsemo.org>
+
+Current development is hosted at <http://xml-writer-perl.berlios.de/>.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
Added: packages/libxml-writer-perl/branches/upstream/current/TODO
===================================================================
--- packages/libxml-writer-perl/branches/upstream/current/TODO 2006-04-08 18:23:48 UTC (rev 2521)
+++ packages/libxml-writer-perl/branches/upstream/current/TODO 2006-04-09 09:56:25 UTC (rev 2522)
@@ -0,0 +1,10 @@
+- Correctness. It's still possible to generate bad XML. Especially in
+ safe mode, checks on processing instructions, comments and DOCTYPE
+ declarations should be rigorously matched against the spec.
+
+- Control over presentation. How much is too much? Entities vs. CDATA,
+ placement of namespace declarations, whitespace. How much control
+ should the user be given?
+
+- Performance. Reducing the use of closures may speed things up, and
+ benchmarking would show whether or not it's worth it.
Added: packages/libxml-writer-perl/branches/upstream/current/Writer.pm
===================================================================
--- packages/libxml-writer-perl/branches/upstream/current/Writer.pm 2006-04-08 18:23:48 UTC (rev 2521)
+++ packages/libxml-writer-perl/branches/upstream/current/Writer.pm 2006-04-09 09:56:25 UTC (rev 2522)
@@ -0,0 +1,1622 @@
+########################################################################
+# Writer.pm - write an XML document.
+# Copyright (c) 1999 by Megginson Technologies.
+# Copyright (c) 2004, 2005 by Joseph Walton <joe at kafsemo.org>.
+# No warranty. Commercial and non-commercial use freely permitted.
+#
+# $Id: Writer.pm,v 1.48 2005/06/30 22:17:04 josephw Exp $
+########################################################################
+
+package XML::Writer;
+
+require 5.004;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+use IO::Handle;
+$VERSION = "0.600";
+
+
+
+########################################################################
+# 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 new XML::Writer::Namespaces(%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 = $params{DATA_INDENT} || 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;
+ &{$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");
+ };
+
+ 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("<?xml version=\"1.0\"");
+ 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("<?$target $data?>");
+ } else {
+ $output->print("<?$target?>");
+ }
+ 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$/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(" " x ($elementLevel * $dataIndent));
+ }
+ $output->print("<!-- $data -->");
+ 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("<!DOCTYPE $name");
+ if ($publicId) {
+ unless ($systemId) {
+ croak("A DOCTYPE declaration with a public ID must also have a system ID");
+ }
+ $output->print(" PUBLIC \"$publicId\" \"$systemId\"");
+ } elsif ($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(" " x ($elementLevel * $dataIndent));
+ }
+ $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];
+
+ &{$checkUnencodedRepertoire}($name);
+ _checkAttributes(\@_);
+
+ 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(" " x ($elementLevel * $dataIndent));
+ }
+ $output->print("<$name");
+ &{$showAttributes}(\@_);
+ $output->print("$nl />");
+ if ($dataMode) {
+ $hasElement = 1;
+ }
+ };
+
+ my $SAFE_emptyTag = sub {
+ my $name = $_[0];
+
+ &{$checkUnencodedRepertoire}($name);
+ _checkAttributes(\@_);
+
+ 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(" " x ($elementLevel * $dataIndent));
+ }
+ $output->print("</$name$nl>");
+ 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/\</\<\;/g;
+ $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/\]\]>/\]\]\]\]><!\[CDATA\[>/g;
+ $output->print("<![CDATA[$data]]>");
+ $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 {
+ return $output;
+ };
+
+ $self->{'SETOUTPUT'} = sub {
+ my $newOutput = $_[0];
+
+ if (ref($newOutput) eq 'SCALAR') {
+ $output = new XML::Writer::_String($newOutput);
+ } else {
+ # If there is no OUTPUT parameter,
+ # use standard output
+ $output = $newOutput || \*STDOUT;
+ if ($outputEncoding) {
+ 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';
+ }
+ }
+ }
+ };
+
+ $self->{'SETDATAMODE'} = sub {
+ $dataMode = $_[0];
+ };
+
+ $self->{'GETDATAMODE'} = sub {
+ return $dataMode;
+ };
+
+ $self->{'SETDATAINDENT'} = sub {
+ $dataIndent = $_[0];
+ };
+
+ $self->{'GETDATAINDENT'} = sub {
+ return $dataIndent;
+ };
+
+ # 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 {
+}
+
+
+
+########################################################################
+# 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;
+ while ($_[0]->[$i]) {
+ my $name = $_[0]->[$i];
+ $i += 1;
+ if ($anames{$name}) {
+ croak("Two attributes named \"$name\"");
+ } else {
+ $anames{$name} = 1;
+ }
+ _croakUnlessDefinedCharacters($_[0]->[$i]);
+ $i += 1;
+ }
+}
+
+#
+# Private: escape an attribute value literal.
+#
+sub _escapeLiteral {
+ my $data = $_[0];
+ if ($data =~ /[\&\<\>\"]/) {
+ $data =~ s/\&/\&\;/g;
+ $data =~ s/\</\<\;/g;
+ $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)));
+ }
+}
+
+
+########################################################################
+# XML::Writer::Namespaces - subclass for Namespace processing.
+########################################################################
+
+package XML::Writer::Namespaces;
+use strict;
+use vars qw(@ISA);
+use Carp;
+
+ at 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 = new XML::Writer(%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;
+ }
+
+ while (!defined($prefix) || ($clashMap{$prefix} && $clashMap{$prefix} ne $uri)) {
+ $prefix = "__NS$prefixCounter";
+ $prefixCounter++;
+ }
+
+ 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') {
+ &{$processName}(\$_[0]->[0], $_[0], 0);
+ }
+ my $i = 1;
+ while ($_[0]->[$i]) {
+ if (ref($_[0]->[$i]) eq 'ARRAY') {
+ &{$processName}(\$_[0]->[$i], $_[0], 1);
+ }
+ $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;
+}
+
+1;
+__END__
+
+########################################################################
+# POD Documentation
+########################################################################
+
+=head1 NAME
+
+XML::Writer - Perl extension for writing XML documents.
+
+=head1 SYNOPSIS
+
+ use XML::Writer;
+ use IO::File;
+
+ my $output = new IO::File(">output.xml");
+
+ my $writer = new XML::Writer(OUTPUT => $output);
+ $writer->startTag("greeting",
+ "class" => "simple");
+ $writer->characters("Hello, world!");
+ $writer->endTag("greeting");
+ $writer->end();
+ $output->close();
+
+
+=head1 DESCRIPTION
+
+XML::Writer is a helper module for Perl programs that write an XML
+document. The module handles all escaping for attribute values and
+character data and constructs different types of markup, such as tags,
+comments, and processing instructions.
+
+By default, the module performs several well-formedness checks to
+catch errors during output. This behaviour can be extremely useful
+during development and debugging, but it can be turned off for
+production-grade code.
+
+The module can operate either in regular mode in or Namespace
+processing mode. In Namespace mode, the module will generate
+Namespace Declarations itself, and will perform additional checks on
+the output.
+
+Additional support is available for a simplified data mode with no
+mixed content: newlines are automatically inserted around elements and
+elements can optionally be indented based as their nesting level.
+
+
+=head1 METHODS
+
+=head2 Writing XML
+
+=over 4
+
+=item new([$params])
+
+Create a new XML::Writer object:
+
+ my $writer = new XML::Writer(OUTPUT => $output, NEWLINES => 1);
+
+Arguments are an anonymous hash array of parameters:
+
+=over 4
+
+=item OUTPUT
+
+An object blessed into IO::Handle or one of its subclasses (such as
+IO::File), or a reference to a string; if this parameter is not present,
+the module will write to standard output. If a string reference is passed,
+it will capture the generated XML (as a string; to get bytes use the
+C<Encode> module).
+
+=item NAMESPACES
+
+A true (1) or false (0, undef) value; if this parameter is present and
+its value is true, then the module will accept two-member array
+reference in the place of element and attribute names, as in the
+following example:
+
+ my $rdfns = "http://www.w3.org/1999/02/22-rdf-syntax-ns#";
+ my $writer = new XML::Writer(NAMESPACES => 1);
+ $writer->startTag([$rdfns, "Description"]);
+
+The first member of the array is a namespace URI, and the second part
+is the local part of a qualified name. The module will automatically
+generate appropriate namespace declarations and will replace the URI
+part with a prefix.
+
+=item PREFIX_MAP
+
+A hash reference; if this parameter is present and the module is
+performing namespace processing (see the NAMESPACES parameter), then
+the module will use this hash to look up preferred prefixes for
+namespace URIs:
+
+
+ my $rdfns = "http://www.w3.org/1999/02/22-rdf-syntax-ns#";
+ my $writer = new XML::Writer(NAMESPACES => 1,
+ PREFIX_MAP => {$rdfns => 'rdf'});
+
+The keys in the hash table are namespace URIs, and the values are the
+associated prefixes. If there is not a preferred prefix for the
+namespace URI in this hash, then the module will automatically
+generate prefixes of the form "__NS1", "__NS2", etc.
+
+To set the default namespace, use '' for the prefix.
+
+=item FORCED_NS_DECLS
+
+An array reference; if this parameter is present, the document element
+will contain declarations for all the given namespace URIs.
+Declaring namespaces in advance is particularly useful when a large
+number of elements from a namespace are siblings, but don't share a direct
+ancestor from the same namespace.
+
+=item NEWLINES
+
+A true or false value; if this parameter is present and its value is
+true, then the module will insert an extra newline before the closing
+delimiter of start, end, and empty tags to guarantee that the document
+does not end up as a single, long line. If the paramter is not
+present, the module will not insert the newlines.
+
+=item UNSAFE
+
+A true or false value; if this parameter is present and its value is
+true, then the module will skip most well-formedness error checking.
+If the parameter is not present, the module will perform the
+well-formedness error checking by default. Turn off error checking at
+your own risk!
+
+=item DATA_MODE
+
+A true or false value; if this parameter is present and its value is
+true, then the module will enter a special data mode, inserting
+newlines automatically around elements and (unless UNSAFE is also
+specified) reporting an error if any element has both characters and
+elements as content.
+
+=item DATA_INDENT
+
+A numeric value; if this parameter is present, it represents the
+indent step for elements in data mode (it will be ignored when not in
+data mode).
+
+=item ENCODING
+
+A character encoding; currently this must be one of 'utf-8' or 'us-ascii'.
+If present, it will be used for the underlying character encoding and as the
+default in the XML declaration.
+
+=back
+
+=item end()
+
+Finish creating an XML document. This method will check that the
+document has exactly one document element, and that all start tags are
+closed:
+
+ $writer->end();
+
+=item xmlDecl([$encoding, $standalone])
+
+Add an XML declaration to the beginning of an XML document. The
+version will always be "1.0". If you provide a non-null encoding or
+standalone argument, its value will appear in the declaration (any
+non-null value for standalone except 'no' will automatically be
+converted to 'yes'). If not given here, the encoding will be taken from the
+ENCODING argument. Pass the empty string to suppress this behaviour.
+
+ $writer->xmlDecl("UTF-8");
+
+=item doctype($name, [$publicId, $systemId])
+
+Add a DOCTYPE declaration to an XML document. The declaration must
+appear before the beginning of the root element. If you provide a
+publicId, you must provide a systemId as well, but you may provide
+just a system ID by passing 'undef' for the publicId.
+
+ $writer->doctype("html");
+
+=item comment($text)
+
+Add a comment to an XML document. If the comment appears outside the
+document element (either before the first start tag or after the last
+end tag), the module will add a carriage return after it to improve
+readability. In data mode, comments will be treated as empty tags:
+
+ $writer->comment("This is a comment");
+
+=item pi($target [, $data])
+
+Add a processing instruction to an XML document:
+
+ $writer->pi('xml-stylesheet', 'href="style.css" type="text/css"');
+
+If the processing instruction appears outside the document element
+(either before the first start tag or after the last end tag), the
+module will add a carriage return after it to improve readability.
+
+The $target argument must be a single XML name. If you provide the
+$data argument, the module will insert its contents following the
+$target argument, separated by a single space.
+
+=item startTag($name [, $aname1 => $value1, ...])
+
+Add a start tag to an XML document. Any arguments after the element
+name are assumed to be name/value pairs for attributes: the module
+will escape all '&', '<', '>', and '"' characters in the attribute
+values using the predefined XML entities:
+
+ $writer->startTag('doc', 'version' => '1.0',
+ 'status' => 'draft',
+ 'topic' => 'AT&T');
+
+All start tags must eventually have matching end tags.
+
+=item emptyTag($name [, $aname1 => $value1, ...])
+
+Add an empty tag to an XML document. Any arguments after the element
+name are assumed to be name/value pairs for attributes (see startTag()
+for details):
+
+ $writer->emptyTag('img', 'src' => 'portrait.jpg',
+ 'alt' => 'Portrait of Emma.');
+
+=item endTag([$name])
+
+Add an end tag to an XML document. The end tag must match the closest
+open start tag, and there must be a matching and properly-nested end
+tag for every start tag:
+
+ $writer->endTag('doc');
+
+If the $name argument is omitted, then the module will automatically
+supply the name of the currently open element:
+
+ $writer->startTag('p');
+ $writer->endTag();
+
+=item dataElement($name, $data [, $aname1 => $value1, ...])
+
+Print an entire element containing only character data. This is
+equivalent to
+
+ $writer->startTag($name [, $aname1 => $value1, ...]);
+ $writer->characters($data);
+ $writer->endTag($name);
+
+=item characters($data)
+
+Add character data to an XML document. All '<', '>', and '&'
+characters in the $data argument will automatically be escaped using
+the predefined XML entities:
+
+ $writer->characters("Here is the formula: ");
+ $writer->characters("a < 100 && a > 5");
+
+You may invoke this method only within the document element
+(i.e. after the first start tag and before the last end tag).
+
+In data mode, you must not use this method to add whitespace between
+elements.
+
+=item raw($data)
+
+Print data completely unquoted and unchecked to the XML document. For
+example C<raw('<')> will print a literal < character. This
+necessarily bypasses all well-formedness checking, and is therefore
+only available in unsafe mode.
+
+This can sometimes be useful for printing entities which are defined
+for your XML format but the module doesn't know about, for example
+ for XHTML.
+
+=item cdata($data)
+
+As C<characters()> but writes the data quoted in a CDATA section, that
+is, between <![CDATA[ and ]]>. If the data to be written itself
+contains ]]>, it will be written as several consecutive CDATA
+sections.
+
+=item cdataElement($name, $data [, $aname1 => $value1, ...])
+
+As C<dataElement()> but the element content is written as one or more
+CDATA sections (see C<cdata()>).
+
+=item setOutput($output)
+
+Set the current output destination, as in the OUTPUT parameter for the
+constructor.
+
+=item getOutput()
+
+Return the current output destination, as in the OUTPUT parameter for
+the constructor.
+
+=item setDataMode($mode)
+
+Enable or disable data mode, as in the DATA_MODE parameter for the
+constructor.
+
+=item getDataMode()
+
+Return the current data mode, as in the DATA_MODE parameter for the
+constructor.
+
+=item setDataIndent($step)
+
+Set the indent step for data mode, as in the DATA_INDENT parameter for
+the constructor.
+
+=item getDataIndent()
+
+Return the indent step for data mode, as in the DATA_INDENT parameter
+for the constructor.
+
+
+=back
+
+=head2 Querying XML
+
+=over 4
+
+=item in_element($name)
+
+Return a true value if the most recent open element matches $name:
+
+ if ($writer->in_element('dl')) {
+ $writer->startTag('dt');
+ } else {
+ $writer->startTag('li');
+ }
+
+=item within_element($name)
+
+Return a true value if any open element matches $name:
+
+ if ($writer->within_element('body')) {
+ $writer->startTag('h1');
+ } else {
+ $writer->startTag('title');
+ }
+
+=item current_element()
+
+Return the name of the currently open element:
+
+ my $name = $writer->current_element();
+
+This is the equivalent of
+
+ my $name = $writer->ancestor(0);
+
+=item ancestor($n)
+
+Return the name of the nth ancestor, where $n=0 for the current open
+element.
+
+=back
+
+
+=head2 Additional Namespace Support
+
+As of 0.510, these methods may be used while writing a document.
+
+=over 4
+
+=item addPrefix($uri, $prefix)
+
+Add a preferred mapping between a Namespace URI and a prefix. See
+also the PREFIX_MAP constructor parameter.
+
+To set the default namespace, omit the $prefix parameter or set it to
+''.
+
+=item removePrefix($uri)
+
+Remove a preferred mapping between a Namespace URI and a prefix.
+
+=item forceNSDecl($uri)
+
+Indicate that a namespace declaration for this URI should be included
+with the next element to be started.
+
+=back
+
+
+=head1 ERROR REPORTING
+
+With the default settings, the XML::Writer module can detect several
+basic XML well-formedness errors:
+
+=over 4
+
+=item *
+
+Lack of a (top-level) document element, or multiple document elements.
+
+=item *
+
+Unclosed start tags.
+
+=item *
+
+Misplaced delimiters in the contents of processing instructions or
+comments.
+
+=item *
+
+Misplaced or duplicate XML declaration(s).
+
+=item *
+
+Misplaced or duplicate DOCTYPE declaration(s).
+
+=item *
+
+Mismatch between the document type name in the DOCTYPE declaration and
+the name of the document element.
+
+=item *
+
+Mismatched start and end tags.
+
+=item *
+
+Attempts to insert character data outside the document element.
+
+=item *
+
+Duplicate attributes with the same name.
+
+=back
+
+During Namespace processing, the module can detect the following
+additional errors:
+
+=over 4
+
+=item *
+
+Attempts to use PI targets or element or attribute names containing a
+colon.
+
+=item *
+
+Attempts to use attributes with names beginning "xmlns".
+
+=back
+
+To ensure full error detection, a program must also invoke the end
+method when it has finished writing a document:
+
+ $writer->startTag('greeting');
+ $writer->characters("Hello, world!");
+ $writer->endTag('greeting');
+ $writer->end();
+
+This error reporting can catch many hidden bugs in Perl programs that
+create XML documents; however, if necessary, it can be turned off by
+providing an UNSAFE parameter:
+
+ my $writer = new XML::Writer(OUTPUT => $output, UNSAFE => 1);
+
+
+=head1 AUTHOR
+
+David Megginson E<lt>david at megginson.comE<gt>
+
+
+=head1 COPYRIGHT
+
+Copyright 1999, 2000 David Megginson E<lt>david at megginson.comE<gt>
+
+Copyright 2004, 2005 Joseph Walton E<lt>joe at kafsemo.orgE<gt>
+
+
+=head1 SEE ALSO
+
+XML::Parser
+
+=cut
Added: packages/libxml-writer-perl/branches/upstream/current/t/01_main.t
===================================================================
--- packages/libxml-writer-perl/branches/upstream/current/t/01_main.t 2006-04-08 18:23:48 UTC (rev 2521)
+++ packages/libxml-writer-perl/branches/upstream/current/t/01_main.t 2006-04-09 09:56:25 UTC (rev 2522)
@@ -0,0 +1,1745 @@
+#!/usr/bin/perl -w
+########################################################################
+# test.pl - test script for XML::Writer module.
+# Copyright (c) 1999 by Megginson Technologies.
+# Copyright (c) 2004, 2005 by Joseph Walton <joe at kafsemo.org>.
+# No warranty. Commercial and non-commercial use freely permitted.
+#
+# $Id: 01_main.t,v 1.22 2005/06/30 21:57:52 josephw Exp $
+########################################################################
+
+# Before 'make install' is performed this script should be runnable with
+# 'make test'. After 'make install' it should work as 'perl 01_main.t'
+
+use strict;
+
+use Test::More(tests => 207);
+
+
+# Catch warnings
+my $warning;
+
+$SIG{__WARN__} = sub {
+ ($warning) = @_ unless ($warning);
+};
+
+sub wasNoWarning($)
+{
+ my ($reason) = @_;
+
+ if (!ok(!$warning, $reason)) {
+ diag($warning);
+ }
+}
+
+# Constants for Unicode support
+my $unicodeSkipMessage = 'Unicode only supported with Perl >= 5.8.1';
+
+sub isUnicodeSupported()
+{
+ return $] >= 5.008001;
+}
+
+require XML::Writer;
+
+wasNoWarning('Loading XML::Writer should not result in warnings');
+
+use IO::File;
+
+# The XML::Writer that will be used
+my $w;
+
+my $outputFile = IO::File->new_tmpfile or die "Unable to create temporary file: $!";
+
+# Fetch the current contents of the scratch file as a scalar
+sub getBufStr()
+{
+ local($/);
+ binmode($outputFile, ':bytes') if isUnicodeSupported();
+ $outputFile->seek(0, 0);
+ return <$outputFile>;
+}
+
+# Set up the environment to run a test.
+sub initEnv(@)
+{
+ my (%args) = @_;
+
+ # Reset the scratch file
+ $outputFile->seek(0, 0);
+ $outputFile->truncate(0);
+ binmode($outputFile, ':raw');
+
+ # Overwrite OUTPUT so it goes to the scratch file
+ $args{'OUTPUT'} = $outputFile;
+
+ # Set NAMESPACES, unless it's present
+ $args{'NAMESPACES'} = 1 unless(defined($args{'NAMESPACES'}));
+
+ undef($warning);
+ $w = new XML::Writer(%args) || die "Cannot create XML writer";
+}
+
+#
+# Check the results in the temporary output file.
+#
+# $expected - the exact output expected
+#
+sub checkResult($$)
+{
+ my ($expected, $explanation) = (@_);
+
+ my $actual = getBufStr();
+
+ if ($expected eq $actual) {
+ ok(1, $explanation);
+ } else {
+ my @e = split(/\n/, $expected);
+ my @a = split(/\n/, $actual);
+
+ if (@e + @a == 2) {
+ is(getBufStr(), $expected, $explanation);
+ } else {
+ if (eval {require Algorithm::Diff;}) {
+ fail($explanation);
+
+ Algorithm::Diff::traverse_sequences( \@e, \@a, {
+ MATCH => sub { diag(" $e[$_[0]]\n"); },
+ DISCARD_A => sub { diag("-$e[$_[0]]\n"); },
+ DISCARD_B => sub { diag("+$a[$_[1]]\n"); }
+ });
+ } else {
+ fail($explanation);
+ diag(" got: '$actual'\n");
+ diag(" expected: '$expected'\n");
+ }
+ }
+ }
+
+ wasNoWarning('(no warnings)');
+}
+
+#
+# Expect an error of some sort, and check that the message matches.
+#
+# $pattern - a regular expression that must match the error message
+# $value - the return value from an eval{} block
+#
+sub expectError($$) {
+ my ($pattern, $value) = (@_);
+ if (!ok((!defined($value) and ($@ =~ $pattern)), "Error expected: $pattern"))
+ {
+ diag('Actual error:');
+ if ($@) {
+ diag($@);
+ } else {
+ diag('(no error)');
+ diag(getBufStr());
+ }
+ }
+}
+
+# Empty element tag.
+TEST: {
+ initEnv();
+ $w->emptyTag("foo");
+ $w->end();
+ checkResult("<foo />\n", 'An empty element tag');
+};
+
+# Empty element tag with XML decl.
+TEST: {
+ initEnv();
+ $w->xmlDecl();
+ $w->emptyTag("foo");
+ $w->end();
+ checkResult(<<"EOS", 'Empty element tag with XML declaration');
+<?xml version="1.0"?>
+<foo />
+EOS
+};
+
+# A document with a public and system identifier set
+TEST: {
+ initEnv();
+ $w->doctype('html', "-//W3C//DTD XHTML 1.1//EN",
+ "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd");
+ $w->emptyTag('html');
+ $w->end();
+ checkResult(<<"EOS", 'A document with a public and system identifier');
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html />
+EOS
+};
+
+# A document with a public and system identifier set, using startTag
+TEST: {
+ initEnv();
+ $w->doctype('html', "-//W3C//DTD XHTML 1.1//EN",
+ "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd");
+ $w->startTag('html');
+ $w->endTag('html');
+ $w->end();
+ checkResult(<<"EOS", 'A document with a public and system identifier');
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html></html>
+EOS
+};
+
+# A document with a only a public identifier
+TEST: {
+ initEnv();
+ expectError("A DOCTYPE declaration with a public ID must also have a system ID", eval {
+ $w->doctype('html', "-//W3C//DTD XHTML 1.1//EN");
+ });
+};
+
+# A document with only a system identifier set
+TEST: {
+ initEnv();
+ $w->doctype('html', undef, "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd");
+ $w->emptyTag('html');
+ $w->end();
+ checkResult(<<"EOS", 'A document with just a system identifier');
+<!DOCTYPE html SYSTEM "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html />
+EOS
+};
+
+# Empty element tag with standalone set
+TEST: {
+ initEnv();
+ $w->xmlDecl(undef, 'yes');
+ $w->emptyTag("foo");
+ $w->end();
+ checkResult(<<"EOS", 'A document with "standalone" declared');
+<?xml version="1.0" standalone="yes"?>
+<foo />
+EOS
+};
+
+# Empty element tag with standalone explicitly set to 'no'
+TEST: {
+ initEnv();
+ $w->xmlDecl(undef, 'no');
+ $w->emptyTag("foo");
+ $w->end();
+ checkResult(<<"EOS", "A document with 'standalone' declared as 'no'");
+<?xml version="1.0" standalone="no"?>
+<foo />
+EOS
+};
+
+# xmlDecl with encoding set
+TEST: {
+ initEnv();
+ $w->xmlDecl('ISO-8859-1');
+ $w->emptyTag("foo");
+ $w->end();
+ checkResult(<<"EOS", 'A document with a declared encoding');
+<?xml version="1.0" encoding="ISO-8859-1"?>
+<foo />
+EOS
+};
+
+# Start/end tag.
+TEST: {
+ initEnv();
+ $w->startTag("foo");
+ $w->endTag("foo");
+ $w->end();
+ checkResult("<foo></foo>\n", 'A separate start and end tag');
+};
+
+# Attributes
+TEST: {
+ initEnv();
+ $w->emptyTag("foo", "x" => "1>2");
+ $w->end();
+ checkResult("<foo x=\"1>2\" />\n", 'Simple attributes');
+};
+
+# Character data
+TEST: {
+ initEnv();
+ $w->startTag("foo");
+ $w->characters("<tag>&</tag>");
+ $w->endTag("foo");
+ $w->end();
+ checkResult("<foo><tag>&amp;</tag></foo>\n", 'Escaped character data');
+};
+
+# Comment outside document element
+TEST: {
+ initEnv();
+ $w->comment("comment");
+ $w->emptyTag("foo");
+ $w->end();
+ checkResult("<!-- comment -->\n<foo />\n", 'A comment outside the document element');
+};
+
+# Processing instruction without data (outside document element)
+TEST: {
+ initEnv();
+ $w->pi("pi");
+ $w->emptyTag("foo");
+ $w->end();
+ checkResult("<?pi?>\n<foo />\n", 'A data-less processing instruction');
+};
+
+# Processing instruction with data (outside document element)
+TEST: {
+ initEnv();
+ $w->pi("pi", "data");
+ $w->emptyTag("foo");
+ $w->end();
+ checkResult("<?pi data?>\n<foo />\n", 'A processing instruction with data');
+};
+
+# Comment inside document element
+TEST: {
+ initEnv();
+ $w->startTag("foo");
+ $w->comment("comment");
+ $w->endTag("foo");
+ $w->end();
+ checkResult("<foo><!-- comment --></foo>\n", 'A comment inside an element');
+};
+
+# Processing instruction inside document element
+TEST: {
+ initEnv();
+ $w->startTag("foo");
+ $w->pi("pi");
+ $w->endTag("foo");
+ $w->end();
+ checkResult("<foo><?pi?></foo>\n", 'A processing instruction inside an element');
+};
+
+# WFE for mismatched tags
+TEST: {
+ initEnv();
+ $w->startTag("foo");
+ expectError("Attempt to end element \"foo\" with \"bar\" tag", eval {
+ $w->endTag("bar");
+ });
+};
+
+# WFE for unclosed elements
+TEST: {
+ initEnv();
+ $w->startTag("foo");
+ $w->startTag("foo");
+ $w->endTag("foo");
+ expectError("Document ended with unmatched start tag\\(s\\)", eval {
+ $w->end();
+ });
+};
+
+# WFE for no document element
+TEST: {
+ initEnv();
+ $w->xmlDecl();
+ expectError("Document cannot end without a document element", eval {
+ $w->end();
+ });
+};
+
+# WFE for multiple document elements (non-empty)
+TEST: {
+ initEnv();
+ $w->startTag('foo');
+ $w->endTag('foo');
+ expectError("Attempt to insert start tag after close of", eval {
+ $w->startTag('foo');
+ });
+};
+
+# WFE for multiple document elements (empty)
+TEST: {
+ initEnv();
+ $w->emptyTag('foo');
+ expectError("Attempt to insert empty tag after close of", eval {
+ $w->emptyTag('foo');
+ });
+};
+
+# DOCTYPE mismatch with empty tag
+TEST: {
+ initEnv();
+ $w->doctype('foo');
+ expectError("Document element is \"bar\", but DOCTYPE is \"foo\"", eval {
+ $w->emptyTag('bar');
+ });
+};
+
+# DOCTYPE mismatch with start tag
+TEST: {
+ initEnv();
+ $w->doctype('foo');
+ expectError("Document element is \"bar\", but DOCTYPE is \"foo\"", eval {
+ $w->startTag('bar');
+ });
+};
+
+# DOCTYPE declarations
+TEST: {
+ initEnv();
+ $w->doctype('foo');
+ expectError("Attempt to insert second DOCTYPE", eval {
+ $w->doctype('bar');
+ });
+};
+
+# Misplaced DOCTYPE declaration
+TEST: {
+ initEnv();
+ $w->startTag('foo');
+ expectError("The DOCTYPE declaration must come before", eval {
+ $w->doctype('foo');
+ });
+};
+
+# Multiple XML declarations
+TEST: {
+ initEnv();
+ $w->xmlDecl();
+ expectError("The XML declaration is not the first thing", eval {
+ $w->xmlDecl();
+ });
+};
+
+# Misplaced XML declaration
+TEST: {
+ initEnv();
+ $w->comment();
+ expectError("The XML declaration is not the first thing", eval {
+ $w->xmlDecl();
+ });
+};
+
+# Implied end-tag name.
+TEST: {
+ initEnv();
+ $w->startTag('foo');
+ $w->endTag();
+ $w->end();
+ checkResult("<foo></foo>\n", 'A tag ended using an implied tag name');
+};
+
+# in_element query
+TEST: {
+ initEnv();
+ $w->startTag('foo');
+ $w->startTag('bar');
+ ok($w->in_element('bar'), 'in_element should identify the current element');
+};
+
+# within_element query
+TEST: {
+ initEnv();
+ $w->startTag('foo');
+ $w->startTag('bar');
+ ok($w->within_element('foo') && $w->within_element('bar'),
+ 'within_element should know about all elements above us');
+};
+
+# current_element query
+TEST: {
+ initEnv();
+ $w->startTag('foo');
+ $w->startTag('bar');
+ is($w->current_element(), 'bar', 'current_element should identify the element we are in');
+};
+
+# ancestor query
+TEST: {
+ initEnv();
+ $w->startTag('foo');
+ $w->startTag('bar');
+ ok($w->ancestor(0) eq 'bar' && $w->ancestor(1) eq 'foo',
+ 'ancestor() should match the startTag calls that have been made');
+};
+
+# Basic namespace processing with empty element
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->addPrefix($ns, 'foo');
+ $w->emptyTag([$ns, 'doc']);
+ $w->end();
+ checkResult("<foo:doc xmlns:foo=\"$ns\" />\n", 'Basic namespace processing');
+};
+
+# Basic namespace processing with start/end tags
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->addPrefix($ns, 'foo');
+ $w->startTag([$ns, 'doc']);
+ $w->endTag([$ns, 'doc']);
+ $w->end();
+ checkResult("<foo:doc xmlns:foo=\"$ns\"></foo:doc>\n", 'Basic namespace processing');
+};
+
+# Basic namespace processing with generated prefix
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->startTag([$ns, 'doc']);
+ $w->endTag([$ns, 'doc']);
+ $w->end();
+ checkResult("<__NS1:doc xmlns:__NS1=\"$ns\"></__NS1:doc>\n",
+ 'Basic namespace processing with a generated prefix');
+};
+
+# Basic namespace processing with attributes and empty tag.
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->addPrefix($ns, 'foo');
+ $w->emptyTag([$ns, 'doc'], [$ns, 'id'] => 'x');
+ $w->end();
+ checkResult("<foo:doc foo:id=\"x\" xmlns:foo=\"$ns\" />\n",
+ 'A namespaced element with a namespaced attribute');
+};
+
+# Same as above, but with default namespace.
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->addPrefix($ns, '');
+ $w->emptyTag([$ns, 'doc'], [$ns, 'id'] => 'x');
+ $w->end();
+ checkResult("<doc __NS1:id=\"x\" xmlns=\"$ns\" xmlns:__NS1=\"$ns\" />\n",
+ 'Same as above, but with a default namespace');
+};
+
+# Same as above, but passing namespace prefixes through constructor
+TEST: {
+ my $ns = 'http://www.foo.com/';
+ initEnv(PREFIX_MAP => {$ns => ''});
+ $w->emptyTag([$ns, 'doc'], [$ns, 'id'] => 'x');
+ $w->end();
+ checkResult("<doc __NS1:id=\"x\" xmlns=\"$ns\" xmlns:__NS1=\"$ns\" />\n",
+ 'Same as above, but passing the prefixes through the constructor');
+};
+
+# Same as above, but passing namespace prefixes through constructor and
+# then removing them programatically
+TEST: {
+ my $ns = 'http://www.foo.com/';
+ initEnv(PREFIX_MAP => {$ns => ''});
+ $w->removePrefix($ns);
+ $w->emptyTag([$ns, 'doc'], [$ns, 'id'] => 'x');
+ $w->end();
+ checkResult("<__NS1:doc __NS1:id=\"x\" xmlns:__NS1=\"$ns\" />\n",
+ 'Same as above, but removing the prefix before the document starts');
+};
+
+# Verify that removePrefix works when there is no default prefix
+TEST: {
+ my $ns = 'http://www.foo.com/';
+ initEnv(PREFIX_MAP => {$ns => 'pfx'});
+ $w->removePrefix($ns);
+ wasNoWarning('removePrefix should not warn when there is no default prefix');
+}
+
+# Verify that a removed namespace prefix behaves as if it were never added
+TEST: {
+ my $ns = 'http://www.foo.com/';
+ initEnv(PREFIX_MAP => {$ns => 'pfx', 'http://www.example.com/' => ''});
+ $w->removePrefix($ns);
+ $w->startTag([$ns, 'x']);
+ $w->emptyTag([$ns, 'y']);
+ $w->endTag([$ns, 'x']);
+ $w->end();
+ checkResult("<__NS1:x xmlns:__NS1=\"$ns\"><__NS1:y /></__NS1:x>\n",
+ 'Same as above, but with a non-default namespace');
+};
+
+# Test that autogenerated prefixes avoid collision.
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->addPrefix('http://www.bar.com/', '__NS1');
+ $w->emptyTag([$ns, 'doc']);
+ $w->end();
+ checkResult("<__NS2:doc xmlns:__NS2=\"$ns\" />\n",
+ "Make sure that an autogenerated prefix doesn't clash");
+};
+
+# Check for proper declaration nesting with subtrees.
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->addPrefix($ns, 'foo');
+ $w->startTag('doc');
+ $w->characters("\n");
+ $w->emptyTag([$ns, 'ptr1']);
+ $w->characters("\n");
+ $w->emptyTag([$ns, 'ptr2']);
+ $w->characters("\n");
+ $w->endTag('doc');
+ $w->end();
+ checkResult(<<"EOS", 'Check for proper declaration nesting with subtrees.');
+<doc>
+<foo:ptr1 xmlns:foo="$ns" />
+<foo:ptr2 xmlns:foo="$ns" />
+</doc>
+EOS
+};
+
+# Check for proper declaration nesting with top level.
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->addPrefix($ns, 'foo');
+ $w->startTag([$ns, 'doc']);
+ $w->characters("\n");
+ $w->emptyTag([$ns, 'ptr1']);
+ $w->characters("\n");
+ $w->emptyTag([$ns, 'ptr2']);
+ $w->characters("\n");
+ $w->endTag([$ns, 'doc']);
+ $w->end();
+ checkResult(<<"EOS", 'Check for proper declaration nesting with top level.');
+<foo:doc xmlns:foo="$ns">
+<foo:ptr1 />
+<foo:ptr2 />
+</foo:doc>
+EOS
+};
+
+# Check for proper default declaration nesting with subtrees.
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->addPrefix($ns, '');
+ $w->startTag('doc');
+ $w->characters("\n");
+ $w->emptyTag([$ns, 'ptr1']);
+ $w->characters("\n");
+ $w->emptyTag([$ns, 'ptr2']);
+ $w->characters("\n");
+ $w->endTag('doc');
+ $w->end();
+ checkResult(<<"EOS", 'Check for proper default declaration nesting with subtrees.');
+<doc>
+<ptr1 xmlns="$ns" />
+<ptr2 xmlns="$ns" />
+</doc>
+EOS
+};
+
+# Check for proper default declaration nesting with top level.
+TEST: {
+ initEnv();
+ my $ns = 'http://www.foo.com/';
+ $w->addPrefix($ns, '');
+ $w->startTag([$ns, 'doc']);
+ $w->characters("\n");
+ $w->emptyTag([$ns, 'ptr1']);
+ $w->characters("\n");
+ $w->emptyTag([$ns, 'ptr2']);
+ $w->characters("\n");
+ $w->endTag([$ns, 'doc']);
+ $w->end();
+ checkResult(<<"EOS", 'Check for proper default declaration nesting with top level.');
+<doc xmlns="$ns">
+<ptr1 />
+<ptr2 />
+</doc>
+EOS
+};
+
+# Namespace error: attribute name beginning 'xmlns'
+TEST: {
+ initEnv();
+ expectError("Attribute name.*begins with 'xmlns'", eval {
+ $w->emptyTag('foo', 'xmlnsxxx' => 'x');
+ });
+};
+
+# Namespace error: Detect an illegal colon in a PI target.
+TEST: {
+ initEnv();
+ expectError("PI target.*contains a colon", eval {
+ $w->pi('foo:foo');
+ });
+};
+
+# Namespace error: Detect an illegal colon in an element name.
+TEST: {
+ initEnv();
+ expectError("Element name.*contains a colon", eval {
+ $w->emptyTag('foo:foo');
+ });
+};
+
+# Namespace error: Detect an illegal colon in local part of an element name.
+TEST: {
+ initEnv();
+ expectError("Local part of element name.*contains a colon", eval {
+ my $ns = 'http://www.foo.com/';
+ $w->emptyTag([$ns, 'foo:foo']);
+ });
+};
+
+# Namespace error: attribute name containing ':'.
+TEST: {
+ initEnv();
+ expectError("Attribute name.*contains ':'", eval {
+ $w->emptyTag('foo', 'foo:bar' => 'x');
+ });
+};
+
+# Namespace error: Detect a colon in the local part of an att name.
+TEST: {
+ initEnv();
+ expectError("Local part of attribute name.*contains a colon.", eval {
+ my $ns = "http://www.foo.com/";
+ $w->emptyTag('foo', [$ns, 'foo:bar']);
+ });
+};
+
+# Verify that no warning is generated when namespace prefixes are passed
+# in on construction.
+TEST: {
+ initEnv();
+ $w->emptyTag(['uri:null', 'element']);
+ $w->end();
+
+ wasNoWarning('No warnings should be generated during writing');
+};
+
+# Verify that the 'xml:' prefix is known, and that the declaration is not
+# passed through.
+#
+TEST: {
+ initEnv();
+ $w->emptyTag('elem', ['http://www.w3.org/XML/1998/namespace', 'space'] => 'preserve');
+ $w->end();
+
+ if (!unlike(getBufStr(), qr/1998/, "No declaration should be generated for the 'xml:' prefix"))
+ {
+ diag(getBufStr());
+ }
+};
+
+# This is an API-driving test; to pass, it needs an added method to force XML
+# namespace declarations on outer elements that aren't necessarily
+# in the namespace themselves.
+TEST: {
+ initEnv(PREFIX_MAP => {'uri:test', 'test'},
+ FORCED_NS_DECLS => ['uri:test']
+ );
+
+ $w->startTag('doc');
+ $w->emptyTag(['uri:test', 'elem']);
+ $w->emptyTag(['uri:test', 'elem']);
+ $w->emptyTag(['uri:test', 'elem']);
+ $w->endTag('doc');
+ $w->end();
+
+ if (!unlike(getBufStr(), qr/uri:test.*uri:test/, 'An API should allow forced namespace declarations'))
+ {
+ diag(getBufStr());
+ }
+};
+
+# Verify that a processing instruction of 'xml-stylesheet' can be added
+# without causing a warning, as well as a PI that contains 'xml'
+# other than at the beginning, and a PI with no data
+TEST: {
+ initEnv();
+ $w->pi('xml-stylesheet', "type='text/xsl' href='style.xsl'");
+ $w->pi('not-reserved-by-xml-spec', '');
+ $w->pi('pi-with-no-data');
+
+ $w->emptyTag('x');
+
+ $w->end();
+
+ wasNoWarning('The test processing instructions should not cause warnings');
+};
+
+# Verify that a still-reserved processing instruction generates
+# a warning.
+TEST: {
+ initEnv();
+ $w->pi('xml-reserves-this-name');
+
+ $w->emptyTag('x');
+ $w->end();
+
+ ok($warning =~ "^Processing instruction target begins with 'xml'",
+ "Reserved processing instruction names should cause warnings");
+};
+
+# Processing instruction data may not contain '?>'
+TEST: {
+ initEnv();
+ expectError("Processing instruction may not contain", eval {
+ $w->pi('test', 'This string is bad?>');
+ });
+};
+
+# A processing instruction name may not contain '?>'
+TEST: {
+ initEnv();
+ expectError("Processing instruction may not contain", eval {
+ $w->pi('bad-processing-instruction-bad?>');
+ });
+};
+
+# A processing instruction name can't contain spaces
+TEST: {
+ initEnv();
+ expectError("", eval {
+ $w->pi('processing instruction');
+ });
+};
+
+# Verify that dataMode can be turned on and off for specific elements
+TEST: {
+ initEnv(
+ DATA_MODE => 1,
+ DATA_INDENT => 1
+ );
+
+ ok($w->getDataMode(), 'Should be in data mode');
+ $w->startTag('doc');
+ $w->dataElement('data', 'This is data');
+ $w->dataElement('empty', '');
+ $w->emptyTag('empty');
+ $w->startTag('mixed');
+ $w->setDataMode(0);
+ $w->characters('This is ');
+ $w->emptyTag('mixed');
+ ok(!$w->getDataMode(), 'Should be in mixed mode');
+ $w->characters(' ');
+ $w->startTag('x');
+ $w->characters('content');
+ $w->endTag('x');
+ $w->characters('.');
+ $w->setDataMode(1);
+ $w->setDataIndent(5);
+ $w->endTag('mixed');
+ is($w->getDataIndent(), 5, 'Data indent should be changeable');
+ $w->dataElement('data', 'This is data');
+ $w->endTag('doc');
+ $w->end();
+
+ checkResult(<<"EOS", 'Turning dataMode on and off whilst writing');
+<doc>
+ <data>This is data</data>
+ <empty></empty>
+ <empty />
+ <mixed>This is <mixed /> <x>content</x>.</mixed>
+ <data>This is data</data>
+</doc>
+EOS
+};
+
+# Verify that DATA_MODE on its own doesn't cause warnings
+TEST: {
+ initEnv(
+ DATA_MODE => 1
+ );
+
+ $w->startTag('doc');
+ $w->endTag('doc');
+
+ wasNoWarning('DATA_MODE should not cause warnings');
+};
+
+# Test DATA_MODE and initial spacing
+TEST: {
+ initEnv(
+ DATA_MODE => 1
+ );
+
+ $w->emptyTag('doc');
+ $w->end();
+ checkResult("<doc />\n", "An empty element with DATA_MODE");
+};
+
+# Test DATA_MODE and initial spacing
+TEST: {
+ initEnv(
+ DATA_MODE => 1
+ );
+
+ $w->xmlDecl();
+ $w->emptyTag('doc');
+ $w->end();
+ checkResult(<<"EOS", "An empty element with DATA_MODE");
+<?xml version="1.0"?>
+
+<doc />
+EOS
+};
+
+# Test DATA_MODE and initial spacing
+TEST: {
+ initEnv(
+ DATA_MODE => 1,
+ DATA_INDENT => 1
+ );
+
+ $w->xmlDecl();
+ $w->startTag('doc');
+ $w->emptyTag('item');
+ $w->endTag('doc');
+ $w->end();
+ checkResult(<<"EOS", "A nested element with DATA_MODE and a declaration");
+<?xml version="1.0"?>
+
+<doc>
+ <item />
+</doc>
+EOS
+};
+
+# Writing without namespaces should allow colons
+TEST: {
+ initEnv(NAMESPACES => 0);
+ $w->startTag('test:doc', 'x:attr' => 'value');
+ $w->endTag('test:doc');
+
+ checkResult('<test:doc x:attr="value"></test:doc>', 'A namespace-less document that uses colons in names');
+};
+
+# Test with NEWLINES
+TEST: {
+ initEnv(NEWLINES => 1);
+ $w->startTag('test');
+ $w->endTag('test');
+ $w->end();
+
+ checkResult("<test\n></test\n>\n", 'Use of the NEWLINES parameter');
+};
+
+# Test bad comments
+TEST: {
+ initEnv();
+ expectError("Comment may not contain '-->'", eval {
+ $w->comment('A bad comment -->');
+ });
+};
+
+# Test invadvisible comments
+TEST: {
+ initEnv();
+ $w->comment("Comments shouldn't contain double dashes i.e., --");
+ $w->emptyTag('x');
+ $w->end();
+
+ ok($warning =~ "Interoperability problem: ", 'Comments with doubled dashes should cause warnings');
+};
+
+# Expect to break on mixed content in data mode
+TEST: {
+ initEnv();
+ $w->setDataMode(1);
+ $w->startTag('x');
+ $w->characters('Text');
+ expectError("Mixed content not allowed in data mode: element x", eval {
+ $w->startTag('x');
+ });
+};
+
+# Break with mixed content with emptyTag as well
+TEST: {
+ initEnv();
+ $w->setDataMode(1);
+ $w->startTag('x');
+ $w->characters('Text');
+ expectError("Mixed content not allowed in data mode: element empty", eval {
+ $w->emptyTag('empty');
+ });
+};
+
+# Break with mixed content when the element is written before the characters
+TEST: {
+ initEnv();
+ $w->setDataMode(1);
+ $w->startTag('x');
+ $w->emptyTag('empty');
+ expectError("Mixed content not allowed in data mode: characters", eval {
+ $w->characters('Text');
+ });
+};
+
+# Break if there are two attributes with the same name
+TEST: {
+ initEnv(NAMESPACES => 0);
+ expectError("Two attributes named", eval {
+ $w->emptyTag('x', 'a' => 'First', 'a' => 'Second');
+ });
+};
+
+# Break if there are two attributes with the same namespace-qualified name
+TEST: {
+ initEnv();
+ expectError("Two attributes named", eval {
+ $w->emptyTag('x', ['x', 'a'] => 'First', ['x', 'a'] => 'Second');
+ });
+};
+
+# Succeed if there are two attributes with the same local name, but
+# in different namespaces
+TEST: {
+ initEnv();
+ $w->emptyTag('x', ['x', 'a'] => 'First', ['y', 'a'] => 'Second');
+ checkResult('<x __NS1:a="First" __NS2:a="Second" xmlns:__NS1="x" xmlns:__NS2="y" />', 'Two attributes with the same local name, but in different namespaces');
+};
+
+# Check failure when characters are written outside the document
+TEST: {
+ initEnv();
+ expectError('Attempt to insert characters outside of document element',
+ eval {
+ $w->characters('This should fail.');
+ });
+};
+
+# Make sure that closing a tag straight off fails
+TEST: {
+ initEnv();
+ expectError('End tag .* does not close any open element', eval {
+ $w->endTag('x');
+ });
+};
+
+# Use UNSAFE to allow attributes with emptyTag
+TEST: {
+ initEnv(UNSAFE => 1);
+ $w->emptyTag('x', 'xml:space' => 'preserve', ['x', 'y'] => 'z');
+ $w->end();
+ checkResult("<x xml:space=\"preserve\" __NS1:y=\"z\" xmlns:__NS1=\"x\" />\n", 'Using UNSAFE to bypass the namespace system for emptyTag');
+};
+
+# Use UNSAFE to allow attributes with startTag
+TEST: {
+ initEnv(UNSAFE => 1);
+ $w->startTag('sys:element', 'xml:space' => 'preserve', ['x', 'y'] => 'z');
+ $w->endTag('sys:element');
+ $w->end();
+ checkResult("<sys:element xml:space=\"preserve\" __NS1:y=\"z\" xmlns:__NS1=\"x\"></sys:element>\n", 'Using UNSAFE to bypass the namespace system for startTag');
+};
+
+# Exercise nesting and namespaces
+TEST: {
+ initEnv(DATA_MODE => 1, DATA_INDENT => 1);
+ $w->startTag(['a', 'element']);
+ $w->startTag(['a', 'element']);
+ $w->startTag(['b', 'element']);
+ $w->startTag(['b', 'element']);
+ $w->startTag(['c', 'element']);
+ $w->startTag(['d', 'element']);
+ $w->endTag(['d', 'element']);
+ $w->startTag(['d', 'element']);
+ $w->endTag(['d', 'element']);
+ $w->endTag(['c', 'element']);
+ $w->endTag(['b', 'element']);
+ $w->endTag(['b', 'element']);
+ $w->endTag(['a', 'element']);
+ $w->endTag(['a', 'element']);
+ $w->end();
+
+ checkResult(<<"EOS", "Deep-nesting, to exercise prefix management");
+<__NS1:element xmlns:__NS1="a">
+ <__NS1:element>
+ <__NS2:element xmlns:__NS2="b">
+ <__NS2:element>
+ <__NS3:element xmlns:__NS3="c">
+ <__NS4:element xmlns:__NS4="d"></__NS4:element>
+ <__NS4:element xmlns:__NS4="d"></__NS4:element>
+ </__NS3:element>
+ </__NS2:element>
+ </__NS2:element>
+ </__NS1:element>
+</__NS1:element>
+EOS
+};
+
+# Raw output.
+TEST: {
+ initEnv(UNSAFE => 1);
+ $w->startTag("foo");
+ $w->raw("<bar/>");
+ $w->endTag("foo");
+ $w->end();
+ checkResult("<foo><bar/></foo>\n", 'raw() should pass text through without escaping it');
+};
+
+# Attempting raw output in safe mode
+TEST: {
+ initEnv();
+ $w->startTag("foo");
+ expectError('raw\(\) is only available when UNSAFE is set', eval {
+ $w->raw("<bar/>");
+ });
+}
+
+# Inserting a CDATA section.
+TEST: {
+ initEnv();
+ $w->startTag("foo");
+ $w->cdata("cdata testing - test");
+ $w->endTag("foo");
+ $w->end();
+ checkResult("<foo><![CDATA[cdata testing - test]]></foo>\n",
+ 'cdata() should create CDATA sections');
+};
+
+# Inserting CDATA containing CDATA delimeters ']]>'.
+TEST: {
+ initEnv();
+ $w->startTag("foo");
+ $w->cdata("This is a CDATA section <![CDATA[text]]>");
+ $w->endTag("foo");
+ $w->end();
+ checkResult("<foo><![CDATA[This is a CDATA section <![CDATA[text]]]]><![CDATA[>]]></foo>\n", 'If a CDATA section would be invalid, it should be split up');
+};
+
+# cdataElement().
+TEST: {
+ initEnv();
+ $w->cdataElement("foo", "hello", a => 'b');
+ $w->end();
+ checkResult(qq'<foo a="b"><![CDATA[hello]]></foo>\n',
+ 'cdataElement should produce a valid element containing a CDATA section');
+};
+
+# Verify that writing characters using CDATA outside of an element fails
+TEST: {
+ initEnv();
+ expectError('Attempt to insert characters outside of document element',
+ eval {
+ $w->cdata('Test');
+ });
+};
+
+# Expect to break on mixed content in data mode
+TEST: {
+ initEnv();
+ $w->setDataMode(1);
+ $w->startTag('x');
+ $w->cdata('Text');
+ expectError("Mixed content not allowed in data mode: element x", eval {
+ $w->startTag('x');
+ });
+};
+
+# Break with mixed content when the element is written before the characters
+TEST: {
+ initEnv();
+ $w->setDataMode(1);
+ $w->startTag('x');
+ $w->emptyTag('empty');
+ expectError("Mixed content not allowed in data mode: characters", eval {
+ $w->cdata('Text');
+ });
+};
+
+# Make sure addPrefix-caused clashes are resolved
+TEST: {
+ initEnv();
+
+ $w->addPrefix('a', '');
+ $w->addPrefix('b', '');
+
+ $w->startTag(['a', 'doc']);
+ $w->emptyTag(['b', 'elem']);
+ $w->endTag(['a', 'doc']);
+ $w->end();
+
+ checkResult(<<"EOS", 'Later addPrefix()s should override earlier ones');
+<__NS1:doc xmlns:__NS1="a"><elem xmlns="b" /></__NS1:doc>
+EOS
+};
+
+# addPrefix should work in the middle of a document
+TEST: {
+ initEnv();
+
+ $w->addPrefix('a', '');
+ $w->startTag(['a', 'doc']);
+
+ $w->addPrefix('b', '');
+ $w->emptyTag(['b', 'elem']);
+ $w->endTag(['a', 'doc']);
+ $w->end();
+
+ checkResult(<<"EOS", 'addPrefix should work in the middle of a document');
+<doc xmlns="a"><elem xmlns="b" /></doc>
+EOS
+};
+
+# Verify changing the default namespace
+TEST: {
+ initEnv(
+ DATA_MODE => 1,
+ DATA_INDENT => 1
+ );
+
+ $w->addPrefix('a', '');
+
+ $w->startTag(['a', 'doc']);
+
+ $w->startTag(['b', 'elem1']);
+ $w->emptyTag(['b', 'elem1']);
+ $w->emptyTag(['a', 'elem2']);
+ $w->endTag(['b', 'elem1']);
+
+ $w->addPrefix('b', '');
+
+ $w->startTag(['b', 'elem1']);
+ $w->emptyTag(['b', 'elem1']);
+ $w->emptyTag(['a', 'elem2']);
+ $w->endTag(['b', 'elem1']);
+
+ $w->addPrefix('a', '');
+
+ $w->startTag(['b', 'elem1']);
+ $w->emptyTag(['b', 'elem1']);
+ $w->emptyTag(['a', 'elem2']);
+ $w->endTag(['b', 'elem1']);
+
+ $w->endTag(['a', 'doc']);
+ $w->end();
+
+ checkResult(<<"EOS", 'The default namespace should be modifiable during a document');
+<doc xmlns="a">
+ <__NS1:elem1 xmlns:__NS1="b">
+ <__NS1:elem1 />
+ <elem2 />
+ </__NS1:elem1>
+ <elem1 xmlns="b">
+ <elem1 />
+ <__NS1:elem2 xmlns:__NS1="a" />
+ </elem1>
+ <__NS1:elem1 xmlns:__NS1="b">
+ <__NS1:elem1 />
+ <elem2 />
+ </__NS1:elem1>
+</doc>
+EOS
+};
+
+# Verify forcing namespace declarations mid-document
+TEST: {
+ initEnv(
+ DATA_MODE => 1,
+ DATA_INDENT => 1
+ );
+
+ $w->addPrefix('a', '');
+
+ $w->startTag(['a', 'doc']);
+
+ $w->forceNSDecl('c');
+ $w->startTag(['b', 'elem1']);
+
+ $w->emptyTag(['c', 'elem3']);
+ $w->emptyTag(['c', 'elem3']);
+ $w->emptyTag(['c', 'elem3']);
+
+ $w->endTag(['b', 'elem1']);
+
+ $w->endTag(['a', 'doc']);
+ $w->end();
+
+ checkResult(<<"EOS", 'Namespace declarations should be forceable mid-document');
+<doc xmlns="a">
+ <__NS1:elem1 xmlns:__NS1="b" xmlns:__NS2="c">
+ <__NS2:elem3 />
+ <__NS2:elem3 />
+ <__NS2:elem3 />
+ </__NS1:elem1>
+</doc>
+EOS
+};
+
+# Verify that PREFIX_MAP's default prefix is not ignored when
+# a document element is from a different namespace
+TEST: {
+ initEnv(PREFIX_MAP => {'uri:test', ''},
+ FORCED_NS_DECLS => ['uri:test']
+ );
+
+ $w->emptyTag(['uri:test2', 'document']);
+
+ $w->end();
+
+ checkResult(<<"EOS", 'The default namespace declaration should be present and correct when the document element belongs to a different namespace');
+<__NS1:document xmlns:__NS1="uri:test2" xmlns="uri:test" />
+EOS
+};
+
+# Without namespaces, addPrefix and removePrefix should be safe NOPs
+TEST: {
+ initEnv(NAMESPACES => 0);
+
+ $w->addPrefix('these', 'arguments', 'are', 'ignored');
+ $w->removePrefix('as', 'are', 'these');
+
+ wasNoWarning('Prefix manipulation on a namespace-unaware instance should not warn');
+};
+
+# Make sure that getting and setting the output stream behaves as expected
+TEST: {
+ initEnv();
+
+ my $out = $w->getOutput();
+
+ isnt($out, undef, 'Output for this fixture must be defined');
+
+ $w->setOutput(\*STDERR);
+ is($w->getOutput(), \*STDERR, 'Changing output should be reflected in a subsequent get');
+
+ $w->setOutput($out);
+ is ($w->getOutput(), $out, 'Changing output back should succeed');
+
+ $w->emptyTag('x');
+ $w->end();
+ checkResult("<x />\n", 'After changing the output a document should still be generated');
+};
+
+# Make sure that undef implies STDOUT for setOutput
+TEST: {
+ initEnv();
+
+ $w->setOutput();
+
+ is($w->getOutput(), \*STDOUT, 'If no output is given, STDOUT should be used');
+};
+
+# Create an ill-formed document using unsafe mode
+TEST: {
+ initEnv(UNSAFE => 1);
+
+ $w->xmlDecl('us-ascii');
+ $w->comment("--");
+ $w->characters("Test\n");
+ $w->cdata("Test\n");
+ $w->doctype('y', undef, '/');
+ $w->emptyTag('x');
+ $w->end();
+ checkResult(<<EOR, 'Unsafe mode should not enforce validity tests.');
+<?xml version="1.0" encoding="us-ascii"?>
+<!-- -- -->
+Test
+<![CDATA[Test
+]]><!DOCTYPE y SYSTEM "/">
+<x />
+EOR
+
+};
+
+# Ensure that newlines in attributes are escaped
+TEST: {
+ initEnv();
+
+ $w->emptyTag('x', 'a' => "A\nB");
+ $w->end();
+
+ checkResult("<x a=\"A B\" />\n", 'Newlines in attribute values should be escaped');
+};
+
+# Make sure UTF-8 is written properly
+SKIP: {
+ skip $unicodeSkipMessage, 2 unless isUnicodeSupported();
+
+ initEnv(ENCODING => 'utf-8', DATA_MODE => 1);
+
+ $w->xmlDecl();
+ $w->comment("\$ \x{A3} \x{20AC}");
+ $w->startTag('a');
+ $w->dataElement('b', '$');
+ $w->dataElement('b', "\x{A3}");
+ $w->dataElement('b', "\x{20AC}");
+ $w->startTag('c');
+ $w->cdata(" \$ \x{A3} \x{20AC} ");
+ $w->endTag('c');
+ $w->endTag('a');
+ $w->end();
+
+ checkResult(<<EOR, 'When requested, output should be UTF-8 encoded');
+<?xml version="1.0" encoding="utf-8"?>
+<!-- \$ \x{C2}\x{A3} \x{E2}\x{82}\x{AC} -->
+
+<a>
+<b>\x{24}</b>
+<b>\x{C2}\x{A3}</b>
+<b>\x{E2}\x{82}\x{AC}</b>
+<c><![CDATA[ \$ \x{C2}\x{A3} \x{E2}\x{82}\x{AC} ]]></c>
+</a>
+EOR
+};
+
+# Capture generated XML in a scalar
+TEST: {
+ my $s;
+
+ $w = new XML::Writer(OUTPUT => \$s);
+ $w->emptyTag('x');
+ $w->end();
+
+ wasNoWarning('Capturing in a scalar should not cause warnings');
+ is($s, "<x />\n", "Output should be stored in a scalar, if one is passed");
+};
+
+# Modify the scalar during capture
+TEST: {
+ my $s;
+
+ $w = new XML::Writer(OUTPUT => \$s);
+ $w->startTag('foo', bar => 'baz');
+ is($s, "<foo bar=\"baz\">", 'Scalars should be up-to-date during writing');
+
+ $s = '';
+ $w->dataElement('txt', 'blah');
+ $w->endTag('foo');
+ $w->end();
+
+ is($s, "<txt>blah</txt></foo>\n", 'Resetting the scalar should work properly');
+};
+
+# Ensure that ENCODING and SCALAR don't cause failure when used together
+TEST: {
+ my $s;
+
+ ok(eval {$w = new XML::Writer(OUTPUT => \$s,
+ ENCODING => 'utf-8'
+ );}, 'OUTPUT and ENCODING should not cause failure');
+}
+
+# Verify that unknown encodings cause failure
+TEST: {
+ expectError('encoding', eval {
+ initEnv(ENCODING => 'x-unsupported-encoding');
+ });
+}
+
+# Make sure scalars are built up as UTF-8 (if UTF-8 is passed in)
+SKIP: {
+ skip $unicodeSkipMessage, 2 unless isUnicodeSupported();
+
+ my $s;
+
+ $w = new XML::Writer(OUTPUT => \$s);
+
+ my $x = 'x';
+ utf8::upgrade($x);
+
+ $w->emptyTag($x);
+ $w->end();
+
+ ok(utf8::is_utf8($s), 'A storage scalar should preserve utf8-ness');
+
+
+ undef($s);
+ $w = new XML::Writer(OUTPUT => \$s);
+ $w->startTag('a');
+ $w->dataElement('x', "\$");
+ $w->dataElement('x', "\x{A3}");
+ $w->dataElement('x', "\x{20AC}");
+ $w->endTag('a');
+ $w->end();
+
+ is($s, "<a><x>\$</x><x>\x{A3}</x><x>\x{20AC}</x></a>\n",
+ 'A storage scalar should work with utf8 strings');
+}
+
+# Test US-ASCII encoding
+SKIP: {
+ skip $unicodeSkipMessage, 7 unless isUnicodeSupported();
+
+ initEnv(ENCODING => 'us-ascii', DATA_MODE => 1);
+
+ $w->xmlDecl();
+ $w->startTag('a');
+ $w->dataElement('x', "\$", 'a' => "\$");
+ $w->dataElement('x', "\x{A3}", 'a' => "\x{A3}");
+ $w->dataElement('x', "\x{20AC}", 'a' => "\x{20AC}");
+ $w->endTag('a');
+ $w->end();
+
+ checkResult(<<'EOR', 'US-ASCII support should cover text and attributes');
+<?xml version="1.0" encoding="us-ascii"?>
+
+<a>
+<x a="$">$</x>
+<x a="£">£</x>
+<x a="€">€</x>
+</a>
+EOR
+
+
+ # Make sure non-ASCII characters that can't be represented
+ # as references cause failure
+ my $text = "\x{A3}";
+# utf8::upgrade($text);
+
+ initEnv(ENCODING => 'us-ascii', DATA_MODE => 1);
+ $w->startTag('a');
+ $w->cdata('Text');
+ expectError('ASCII', eval {
+ $w->cdata($text);
+ });
+
+
+ initEnv(ENCODING => 'us-ascii', DATA_MODE => 1);
+ $w->startTag('a');
+ $w->comment('Text');
+ expectError('ASCII', eval {
+ $w->comment($text);
+ });
+
+
+ initEnv(ENCODING => 'us-ascii', DATA_MODE => 1);
+ expectError('ASCII', eval {
+ $w->emptyTag("\x{DC}berpr\x{FC}fung");
+ });
+
+
+ # Make sure Unicode generates warnings when it makes it through
+ # to a US-ASCII-encoded stream
+ initEnv(ENCODING => 'us-ascii', DATA_MODE => 1, UNSAFE => 1);
+ $w->startTag('a');
+ $w->cdata($text);
+ $w->endTag('a');
+ $w->end();
+
+ $outputFile->flush();
+ ok($warning && $warning =~ /does not map to ascii/,
+ 'Perl IO should warn about non-ASCII characters in output');
+
+
+ initEnv(ENCODING => 'us-ascii', DATA_MODE => 1, UNSAFE => 1);
+ $w->startTag('a');
+ $w->comment($text);
+ $w->endTag('a');
+ $w->end();
+
+ $outputFile->flush();
+ ok($warning && $warning =~ /does not map to ascii/,
+ 'Perl IO should warn about non-ASCII characters in output');
+
+}
+
+# Make sure comments are formatted in data mode
+TEST: {
+ initEnv(DATA_MODE => 1, DATA_INDENT => 1);
+
+ $w->xmlDecl();
+ $w->comment("Test");
+ $w->comment("Test");
+ $w->startTag("x");
+ $w->comment("Test 2");
+ $w->startTag("y");
+ $w->comment("Test 3");
+ $w->endTag("y");
+ $w->comment("Test 4");
+ $w->startTag("y");
+ $w->endTag("y");
+ $w->endTag("x");
+ $w->end();
+ $w->comment("Test 5");
+
+ checkResult(<<'EOR', 'Comments should be formatted like elements when in data mode');
+<?xml version="1.0"?>
+<!-- Test -->
+<!-- Test -->
+
+<x>
+ <!-- Test 2 -->
+ <y>
+ <!-- Test 3 -->
+ </y>
+ <!-- Test 4 -->
+ <y></y>
+</x>
+<!-- Test 5 -->
+EOR
+}
+
+# Test characters outside the BMP
+SKIP: {
+ skip $unicodeSkipMessage, 4 unless isUnicodeSupported();
+
+ my $s = "\x{10480}"; # U+10480 OSMANYA LETTER ALEF
+
+ initEnv(ENCODING => 'utf-8');
+
+ $w->dataElement('x', $s);
+ $w->end();
+
+ checkResult(<<"EOR", 'Characters outside the BMP should be encoded correctly in UTF-8');
+<x>\xF0\x90\x92\x80</x>
+EOR
+
+ initEnv(ENCODING => 'us-ascii');
+
+ $w->dataElement('x', $s);
+ $w->end();
+
+ checkResult(<<'EOR', 'Characters outside the BMP should be encoded correctly in US-ASCII');
+<x>𐒀</x>
+EOR
+}
+
+
+# Ensure 'ancestor' returns undef beyond the document
+TEST: {
+ initEnv();
+
+ is($w->ancestor(0), undef, 'With no document, ancestors should be undef');
+
+ $w->startTag('x');
+ is($w->ancestor(0), 'x', 'ancestor(0) should return the current element');
+ is($w->ancestor(1), undef, 'ancestor should return undef beyond the document');
+}
+
+# Don't allow undefined Unicode characters, but do allow whitespace
+TEST: {
+ # Test characters
+
+ initEnv();
+
+ $w->startTag('x');
+ expectError('\u0000', eval {
+ $w->characters("\x00");
+ });
+
+ initEnv();
+
+ $w->dataElement('x', "\x09\x0A\x0D ");
+ $w->end();
+
+ checkResult(<<"EOR", 'Whitespace below \u0020 is valid.');
+<x>\x09\x0A\x0D </x>
+EOR
+
+
+ # CDATA
+
+ initEnv();
+ $w->startTag('x');
+ expectError('\u0000', eval {
+ $w->cdata("\x00");
+ });
+
+ initEnv();
+
+ $w->startTag('x');
+ $w->cdata("\x09\x0A\x0D ");
+ $w->endTag('x');
+ $w->end();
+
+ checkResult(<<"EOR", 'Whitespace below \u0020 is valid.');
+<x><![CDATA[\x09\x0A\x0D ]]></x>
+EOR
+
+
+ # Attribute values
+
+ initEnv();
+ expectError('\u0000', eval {
+ $w->emptyTag('x', 'a' => "\x00");
+ });
+
+ initEnv();
+ $w->emptyTag('x', 'a' => "\x09\x0A\x0D ");
+ $w->end();
+
+ # Currently, \u000A is escaped. This test is for lack of errors,
+ # not exact serialisation, so change it if necessary.
+ checkResult(<<"EOR", 'Whitespace below \u0020 is valid.');
+<x a="\x09 \x0D " />
+EOR
+}
+
+# Unsafe mode should not enforce character validity tests
+TEST: {
+ initEnv(UNSAFE => 1);
+
+ $w->dataElement('x', "\x00");
+ $w->end();
+ checkResult(<<"EOR", 'Unsafe mode should not enforce character validity tests');
+<x>\x00</x>
+EOR
+
+ initEnv(UNSAFE => 1);
+ $w->startTag('x');
+ $w->cdata("\x00");
+ $w->endTag('x');
+ $w->end();
+ checkResult(<<"EOR", 'Unsafe mode should not enforce character validity tests');
+<x><![CDATA[\x00]]></x>
+EOR
+
+ initEnv(UNSAFE => 1);
+ $w->emptyTag('x', 'a' => "\x00");
+ $w->end();
+ checkResult(<<"EOR", 'Unsafe mode should not enforce character validity tests');
+<x a="\x00" />
+EOR
+}
+
+# Cover XML declaration encoding cases
+TEST: {
+ # No declaration unless specified
+ initEnv();
+ $w->xmlDecl();
+ $w->emptyTag('x');
+ $w->end();
+
+ checkResult(<<"EOR", 'When no encoding is specified, the declaration should not include one');
+<?xml version="1.0"?>
+<x />
+EOR
+
+ # An encoding specified in the constructor carries across to the declaration
+ initEnv(ENCODING => 'us-ascii');
+ $w->xmlDecl();
+ $w->emptyTag('x');
+ $w->end();
+
+ checkResult(<<"EOR", 'If an encoding is specified for the document, it should appear in the declaration');
+<?xml version="1.0" encoding="us-ascii"?>
+<x />
+EOR
+
+ # Anything passed in the xmlDecl call should override
+ initEnv(ENCODING => 'us-ascii');
+ $w->xmlDecl('utf-8');
+ $w->emptyTag('x');
+ $w->end();
+ checkResult(<<"EOR", 'An encoding passed to xmlDecl should override any other encoding');
+<?xml version="1.0" encoding="utf-8"?>
+<x />
+EOR
+
+ # The empty string should force the omission of the decl
+ initEnv(ENCODING => 'us-ascii');
+ $w->xmlDecl('');
+ $w->emptyTag('x');
+ $w->end();
+ checkResult(<<"EOR", 'xmlDecl should treat the empty string as instruction to omit the encoding from the declaration');
+<?xml version="1.0"?>
+<x />
+EOR
+}
+
+
+# Free test resources
+$outputFile->close() or die "Unable to close temporary file: $!";
+
+1;
+
+__END__
More information about the Pkg-perl-cvs-commits
mailing list