XML-Writer-0.900/0000755000175000017500000000000013737062715011563 5ustar joejoeXML-Writer-0.900/MANIFEST0000644000175000017500000000052113650576245012714 0ustar joejoeREADME Changes MANIFEST Makefile.PL META.yml Writer.pm t/01_main.t t/pod.t t/pod-coverage.t t/selfcontained_output.t TODO examples/simple-xml.pl examples/double-escaping-example.pl examples/namespace-prefixes.pl examples/xml-writer-string.pl examples/data-mode-sample.pl examples/writing-unicode.pl examples/directory-as-atom.pl LICENSE XML-Writer-0.900/README0000644000175000017500000000165013650576245012447 0ustar joejoeXML::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. See the Changes file for detailed changes between versions. Copyright (c) 1999 by Megginson Technologies. Copyright (c) 2003 Ed Avis Copyright (c) 2004-2010 Joseph Walton Current development is hosted at . XML-Writer-0.900/Changes0000644000175000017500000001733113650576245013065 0ustar joejoeRevision history for Perl extension XML::Writer. 0.900 Fri Mar 8 00:19:28 2019 +1100 - Drop support for building on (very) old perls. - Check for valid element names (#107239) - Fail when a scalar other than 'self' is passed as OUTPUT. 0.625 Thu Jun 5 23:55:42 2014 +1000 - Allow xml-model processing instructions (#94078). - Don't warn when undef is passed to setOutput (#94369). 0.624 Wed Feb 12 23:28:39 2014 +1100 - Allow an empty system ID in a doctype declaration. 0.623 Thu Jun 13 23:29:52 2013 +1000 - Fix a memory leak introduced in 0.620. - Avoid issue with implicit stringification. 0.622 Tue May 28 23:02:56 2013 +1000 - Fix bug where output is an IO::Scalar. 0.621 Sun Apr 14 22:42:38 2013 +1000 - Include selfcontained_output.t in the distribution. 0.620 Sun Apr 14 22:20:33 2013 +1000 - Allow OUTPUT => 'self' (#81327). 0.615 Tue Jan 17 01:32:07 2012 +1100 - Fix test skipping when Unicode is unsupported. 0.614 Mon Jan 9 00:24:10 2012 +1100 - Fix regression in 0.613 and set encoding on GLOBs. 0.613 Sat Jan 7 22:51:26 2012 +1100 - Use 'Object->new()' syntax throughout (#65840). - Support passing in any arbitrary object that has a print() method (from Jason Rodrigues). 0.612 Mon Aug 16 00:10:16 2010 +1000 - Allow DATA_INDENT to specify arbitrary white space for indentation. If it is numeric then use that many space characters. 0.611 Thu Apr 22 13:09:12 BST 2010 - Adopt rewritten license text to explicitly allow modification. 0.610 Mon Mar 29 02:29:32 BST 2010 - Add a CHECK_PRINT constructor parameter to check the output print success (#50465). It will croak when printing to output fails. 0.607 Mon Mar 22 14:46:26 GMT 2010 - Address license confusion by reverting to the original license, with contributor permission, and removing unintentional references to the (more restrictive) GPL/Artistic. 0.606 Wed Dec 3 00:09:34 GMT 2008 - Ensure META.yml spec version matches URL. 0.605 Mon Dec 1 23:01:21 GMT 2008 - Use MIT license, formalising David Megginson's original ("No warranty. Commercial and non-commercial use freely permitted."). - Fix from Yanick Champoux for dataElements namespaces (#41359). 0.604 Thu Feb 21 00:42:06 GMT 2008 - Patch from Andreas Koenig for lc(undef) warning in 5.11 (#32874). - Include example code. 0.603 Mon Jun 25 22:31:40 BST 2007 - Escape all necessary white space in attributes (#25499). 0.602 Sat Nov 11 16:54:22 GMT 2006 - Fix bugs in test case to avoid breaking with new Perls. - Make test case work with older Perls, tested against 5.004 (#17288). - Include pod syntax and coverage tests. 0.601 Fri Sep 1 15:01:45 BST 2006 - Don't modify list references passed as tag or attribute names (cpan #14854). 0.600 Thu Jun 30 23:17:00 BST 2005 - Don't include an encoding in the XML declaration unless one is specified. - Check for, and croak on, invalid characters (including ASCII NUL). - Fixed 'ancestor' with out-of-bounds indexes. 0.545 Mon May 16 08:11:17 BST 2005 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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@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@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 XML-Writer-0.900/t/0000755000175000017500000000000013737062715012026 5ustar joejoeXML-Writer-0.900/t/01_main.t0000755000175000017500000014070713650576245013455 0ustar joejoe#!/usr/bin/perl -w ######################################################################## # test.pl - test script for XML::Writer module. # 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. ######################################################################## # 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 Errno; use Test::More(tests => 262); # Catch warnings my $warning; $SIG{__WARN__} = sub { ($warning) = @_ unless ($warning); }; sub wasNoWarning($) { my ($reason) = @_; if (!ok(!$warning, $reason)) { diag($warning); } } require XML::Writer; TEST: { 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'); $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') if $] >= 5.006; # Overwrite OUTPUT so it goes to the scratch file $args{'OUTPUT'} = $outputFile unless(defined($args{'OUTPUT'})); # Set NAMESPACES, unless it's present $args{'NAMESPACES'} = 1 unless(defined($args{'NAMESPACES'})); undef($warning); defined($w = XML::Writer->new(%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("\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'); 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'); 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'); 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 a public identifier and an undefined system 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", undef); }); }; # A document with a public identifier and an empty system identifier TEST: { initEnv(); $w->doctype('html', "-//W3C//DTD XHTML 1.1//EN", ""); $w->emptyTag('html'); $w->end(); checkResult(<<"EOS", 'A document with a public and an empty system identifier'); EOS }; # 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'); 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'); 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'"); 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'); EOS }; # Start/end tag. TEST: { initEnv(); $w->startTag("foo"); $w->endTag("foo"); $w->end(); checkResult("\n", 'A separate start and end tag'); }; # Empty element names and names with spaces TEST: { initEnv(); expectError("Empty identifiers are not permitted in this part of ", eval { $w->emptyTag(""); }); } TEST: { initEnv(); expectError("Space characters are not permitted in this part of ", eval { $w->emptyTag("a\tb"); }); } TEST: { initEnv(ENCODING => 'us-ascii'); expectError("Empty identifiers are not permitted in this part of ", eval { $w->emptyTag(""); }); } TEST: { initEnv(ENCODING => 'us-ascii'); expectError("Space characters are not permitted in this part of ", eval { $w->emptyTag("a\tb"); }); } # Attributes TEST: { initEnv(); $w->emptyTag("foo", "x" => "1>2"); $w->end(); checkResult("\n", 'Simple attributes'); }; TEST: { initEnv(); expectError("Space characters are not permitted in this part of ", eval { $w->emptyTag("foo", "a b" => "2>1"); }); } TEST: { initEnv(ENCODING => 'us-ascii'); expectError("Space characters are not permitted in this part of ", eval { $w->emptyTag("foo", "a b" => "2>1"); }); } # Character data TEST: { initEnv(); $w->startTag("foo"); $w->characters("&"); $w->endTag("foo"); $w->end(); checkResult("<tag>&amp;</tag>\n", 'Escaped character data'); }; # Comment outside document element TEST: { initEnv(); $w->comment("comment"); $w->emptyTag("foo"); $w->end(); checkResult("\n\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("\n\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("\n\n", 'A processing instruction with data'); }; # Comment inside document element TEST: { initEnv(); $w->startTag("foo"); $w->comment("comment"); $w->endTag("foo"); $w->end(); checkResult("\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("\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("\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'); }; # within_element returning false TEST: { initEnv(); $w->startTag('foo'); ok(!$w->within_element('bar'), 'within_element should return false for non-parent elements'); }; # 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("\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("\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\">\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("\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("\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("\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 />\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.'); 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.'); 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.'); 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.'); 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(), '/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(), '/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'); }; # Additionally, confirm that 'xml-model' is also permitted TEST: { initEnv(); $w->pi('xml-model', 'href="http://example.org/example.rng"'); $w->emptyTag('x'); $w->end(); wasNoWarning('An xml-model processing instruction should not cause warnings'); checkResult(<<"EOS", "A document with an xsl-model pi"); EOS }; # 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'); This is data This is content. This is data 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("\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"); 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"); EOS }; # Writing without namespaces should allow colons TEST: { initEnv(NAMESPACES => 0); $w->startTag('test:doc', 'x:attr' => 'value'); $w->endTag('test:doc'); checkResult('', '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("\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('', '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("\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("\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 xmlns:__NS4="d"> EOS }; # Raw output. TEST: { initEnv(UNSAFE => 1); $w->startTag("foo"); $w->raw(""); $w->endTag("foo"); $w->end(); checkResult("\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(""); }); } # Inserting a CDATA section. TEST: { initEnv(); $w->startTag("foo"); $w->cdata("cdata testing - test"); $w->endTag("foo"); $w->end(); checkResult("\n", 'cdata() should create CDATA sections'); }; # Inserting CDATA containing CDATA delimeters ']]>'. TEST: { initEnv(); $w->startTag("foo"); $w->cdata("This is a CDATA section "); $w->endTag("foo"); $w->end(); checkResult("]]>\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'\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"> 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'); 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'); <__NS1:elem1 xmlns:__NS1="b"> <__NS1:elem1 /> <__NS1:elem2 xmlns:__NS1="a" /> <__NS1:elem1 xmlns:__NS1="b"> <__NS1:elem1 /> 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'); <__NS1:elem1 xmlns:__NS1="b" xmlns:__NS2="c"> <__NS2:elem3 /> <__NS2:elem3 /> <__NS2:elem3 /> 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("\n", 'After changing the output a document should still be generated'); }; # Make sure that undef implies STDOUT for setOutput TEST: { initEnv(); $w->setOutput(); wasNoWarning('setOutput without a defined argument should not cause warnings'); 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(< Test EOR }; # Ensure that newlines in attributes are escaped TEST: { initEnv(); $w->emptyTag('x', 'a' => "A\nB"); $w->end(); checkResult("\n", 'Newlines in attribute values should be escaped'); }; # Make sure UTF-8 is written properly TEST: { initEnv(ENCODING => 'utf-8', DATA_MODE => 1); $w->xmlDecl(); $w->comment("\$ \x{A3} \x{20AC}"); $w->startTag('a'); $w->dataElement('b', '$'); # I need U+00A3 as an is_utf8 string; I want to keep the source ASCII. # There must be a better way to do this. require Encode; my $text = Encode::decode('iso-8859-1', "\x{A3}"); $w->dataElement('b', $text); $w->dataElement('b', "\x{20AC}"); $w->startTag('c'); $w->cdata(" \$ \x{A3} \x{20AC} "); $w->endTag('c'); $w->endTag('a'); $w->end(); checkResult(< \x{24} \x{C2}\x{A3} \x{E2}\x{82}\x{AC} EOR }; # Test UTF-8 element name TEST: { # I need U+00E9 as an is_utf8 string; I want to keep the source ASCII. # There must be a better way to do this. require Encode; my $text = Encode::decode('iso-8859-1', "\x{E9}"); initEnv(ENCODING => 'utf-8'); $w->emptyTag("r${text}sum${text}"); checkResult("", 'E-acute element name permitted'); }; # Test UTF-8 attribute name TEST: { # I need U+00E9 as an is_utf8 string; I want to keep the source ASCII. # There must be a better way to do this. require Encode; my $text = Encode::decode('iso-8859-1', "\x{E9}"); initEnv(ENCODING => 'utf-8'); $w->emptyTag("foo", "fianc${text}" => 'true'); checkResult("", 'E-acute attribute name permitted'); }; # Capture generated XML in a scalar TEST: { initEnv(); my $s; $w = XML::Writer->new(OUTPUT => \$s); $w->emptyTag('x'); $w->end(); wasNoWarning('Capturing in a scalar should not cause warnings'); is($s, "\n", "Output should be stored in a scalar, if one is passed"); }; # Modify the scalar during capture TEST: { initEnv(); my $s; $w = XML::Writer->new(OUTPUT => \$s); $w->startTag('foo', bar => 'baz'); is($s, "", 'Scalars should be up-to-date during writing'); $s = ''; $w->dataElement('txt', 'blah'); $w->endTag('foo'); $w->end(); is($s, "blah\n", 'Resetting the scalar should work properly'); }; # Ensure that ENCODING and SCALAR don't cause failure when used together TEST: { initEnv(); my $s; ok(eval {$w = XML::Writer->new(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) TEST: { initEnv(); my $s; $w = XML::Writer->new(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 = XML::Writer->new(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, "\$\x{A3}\x{20AC}\n", 'A storage scalar should work with utf8 strings'); } # Test US-ASCII encoding TEST: { 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'); $ £ € EOR # Make sure non-ASCII characters that can't be represented # as references cause failure # I need U+00A3 as an is_utf8 string; I want to keep the source ASCII. # There must be a better way to do this. require Encode; my $text = Encode::decode('iso-8859-1', "\x{A3}"); 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"); }); initEnv(ENCODING => 'us-ascii', DATA_MODE => 1); expectError("Non-ASCII characters are not permitted in this part of ", eval { $w->emptyTag("r\x{E9}sum\x{E9}"); }); initEnv(ENCODING => 'us-ascii', DATA_MODE => 1); expectError("Non-ASCII characters are not permitted in this part of ", eval { $w->emptyTag("foo", "fianc\x{E9}" => 'true'); }); # 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'); EOR } # Test characters outside the BMP TEST: { 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'); \xF0\x90\x92\x80 EOR initEnv(ENCODING => 'us-ascii'); $w->dataElement('x', $s); $w->end(); checkResult(<<'EOR', 'Characters outside the BMP should be encoded correctly in US-ASCII'); 𐒀 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.'); \x09\x0A\x0D 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.'); EOR # Attribute values initEnv(); expectError('\u0000', eval { $w->emptyTag('x', 'a' => "\x00"); }); initEnv(); $w->emptyTag('x', 'a' => "\x09\x0A\x0D "); $w->end(); # \u0009, \u000A and \u000D are escaped. This test is for lack of errors, # not exact serialisation, so change it if necessary. checkResult(<<"EOR", 'Whitespace below \u0020 is valid.'); 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'); \x00 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'); EOR initEnv(UNSAFE => 1); $w->emptyTag('x', 'a' => "\x00"); $w->end(); checkResult(<<"EOR", 'Unsafe mode should not enforce character validity tests'); 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'); 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'); 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'); 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'); EOR } # Bug report: [cpan #14854] Broken namespace report # Passing a list reference as an argument should work more than once TEST: { my $t = ['uri:test', 'elem']; initEnv(PREFIX_MAP => {'uri:test' => 'prefix'}); $w->startTag($t); ok(eval {$w->emptyTag($t);}, 'Passing an array twice should not cause failure'); $w->endTag($t); $w->end(); checkResult(<<"EOR", 'An array passed by reference should not be modified'); EOR } # As per #14854, list references should also work for attribute names TEST: { my $t = ['uri:test', 'elem']; initEnv(PREFIX_MAP => {'uri:test' => 'prefix'}); $w->startTag('x', $t => ''); ok(eval {$w->emptyTag('y', $t => '');}, 'Passing an array twice should not cause failure'); $w->endTag('x'); $w->end(); checkResult(<<"EOR", 'An array passed by reference should not be modified'); EOR } # #25499 - all three whitespace characters should be escaped in attributes TEST: { initEnv(); $w->emptyTag('x', 'a' => "A\nB\rC\tD\t\r\n"); $w->end(); checkResult("\n", 'Newlines in attribute values should be escaped'); }; # #25499 - ]]> must be represented as ]]< in attributes TEST: { initEnv(); $w->emptyTag('x', 'a' => ']]>'); $w->end(); checkResult("\n", "]]> must be escaped in attributes"); }; # #41359 - ensure dataElement expands namespace attributes TEST: { initEnv(); my $ns = 'http://foo'; $w->addPrefix($ns => 'foo'); $w->startTag('doc'); $w->dataElement( [$ns, 'bar'], 'yadah', [$ns, 'baz'] => 'x' ); $w->endTag('doc'); checkResult('yadah', "A dataElement call must expand namespace attributes"); }; # Confirm that vertical spaces are not permitted in XML 1.0 (rejecting #45194) TEST: { initEnv(); $w->startTag('test'); expectError('\u000B is not a valid character in XML', eval { $w->characters(chr(11)); # Vertical tab }); }; # Get the string for our test error $! = Errno::ENOSPC; my $enospcMessage = $!; # A failing underlying write is caught when the CHECK_PRINT flag is set TEST: { my $failingWriter = XML::Writer::Test::FailingWriter->new(); initEnv(OUTPUT => $failingWriter, CHECK_PRINT => 1); expectError("Failed to write output: $enospcMessage", eval { $w->xmlDecl(); }); }; # Changing the underlying target to a failing one makes the next write fail TEST: { my $failingWriter = XML::Writer::Test::FailingWriter->new(); initEnv(CHECK_PRINT => 1); $w->xmlDecl(); $w->setOutput($failingWriter); expectError("Failed to write output: $enospcMessage", eval { $w->startTag('x'); }); }; # A failing underlying write is ignored when the CHECK_PRINT flag is not set TEST: { my $failingWriter = XML::Writer::Test::FailingWriter->new(); initEnv(OUTPUT => $failingWriter); $w->xmlDecl(); }; # getOutput() with CHECK_PRINT should get the underlying stream, not the wrapper TEST: { initEnv(CHECK_PRINT => 1); my $out = $w->getOutput(); $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'); }; # Test changing numeric indentation TEST: { initEnv(); is($w->getDataIndent(), 0, 'Indent should default to zero'); $w->setDataIndent(1); is($w->getDataIndent(), 1, 'Indent should be as set'); }; # Generate a document with an indent of more than one TEST: { initEnv( DATA_MODE => 1, DATA_INDENT => 2 ); $w->xmlDecl(); $w->startTag('doc'); $w->emptyTag('item'); $w->endTag('doc'); $w->end(); checkResult(<<"EOS", "Numeric indent should indicate the number of spaces"); EOS }; # Test getting and setting indentation as a whitespace string TEST: { initEnv(); is($w->getDataIndent(), 0, 'Indent should be returned as the number of spaces'); $w->setDataIndent(' '); is($w->getDataIndent(), 1, 'Indent should be returned as the number of spaces'); $w->setDataIndent(' '); is($w->getDataIndent(), 2, 'Indent should be returned as the number of spaces'); $w->setDataIndent("\t"); is($w->getDataIndent(), "\t", 'Indent should be returned as a string when given as non-space whitespace'); }; # Generate a document with whitespace string indentation TEST: { initEnv( DATA_MODE => 1, DATA_INDENT => '' ); $w->xmlDecl(); $w->startTag('doc'); $w->emptyTag('item'); $w->setDataIndent(' '); $w->emptyTag('item'); $w->setDataIndent("\t"); $w->emptyTag('item'); $w->endTag('doc'); $w->end(); checkResult(<<"EOS", "Numeric indent should indicate the number of spaces"); \t EOS }; # A non-whitespace, non-numeric indent should fall back to 0 TEST: { initEnv(); $w->setDataIndent('x'); is($w->getDataIndent(), 0, 'Non-numeric indent should fall back to zero'); }; TEST: { my $output; bless \$output, 'DuckOutput'; ok(eval { initEnv( OUTPUT=>\$output, ENCODING=>'UTF-8' ); }, "An encoding for a blessed ref shouldn't cause errors."); $w->xmlDecl(); is($output, qq{\n}, "Basic Duck Typing output"); }; # We should try to set the encoding on GLOBs as well as IO::Handles TEST: { expectError('encoding', eval { initEnv(OUTPUT => \*STDOUT, ENCODING => 'x-unsupported-encoding'); }); }; # Confirm that a scalar other than 'self' is treated as an error TEST: { expectError('Output must be a handle', eval { initEnv(OUTPUT => 'not-self'); }); } # Unsafe mode should not enforce element name checks TEST: { initEnv(UNSAFE => 1); $w->startTag('teemptyTag('teendTag('teend(); checkResult(<<"EOR", 'Unsafe mode should not enforce element name checks'); EOR } # Safe mode should enforce element name checks TEST: { initEnv(); expectError("Not a valid XML name: teemptyTag("teclose() or die "Unable to close temporary file: $!"; 1; package DuckOutput; sub print { ${(shift)} .= join('', @_); } package XML::Writer::Test::FailingWriter; sub new { my $class = shift; return bless({}, $class); } sub print { $! = Errno::ENOSPC; return 0; } __END__ XML-Writer-0.900/t/selfcontained_output.t0000644000175000017500000000340213650576245016452 0ustar joejoeuse strict; use warnings; use Test::More tests => 10; use XML::Writer; my $normal = XML::Writer->new( OUTPUT => \my $normal_output ); my $contained = XML::Writer->new( OUTPUT => 'self' ); $normal->dataElement( normal => 'good old classic way' ); $contained->dataElement( selfcontained => 'new and shiny' ); is $normal_output => 'good old classic way', 'classic OUTPUT behaves the same way'; my $contained_result = "new and shiny\n"; is $contained->end => $contained_result, "end()"; is $contained->to_string => $contained_result, 'to_string() on self-contained'; eval { $normal->to_string }; like $@ => qr/'to_string' can only be used with self-contained output/, "to_string on normal OUTPUT"; is "$contained" => $contained_result, 'auto-stringification on self-contained'; like "$normal" => qr/^XML::Writer=HASH/, 'auto-stringification on normal'; is ref($normal->_overload_string) => '', 'auto-stringification returns a string directly'; $contained = XML::Writer->new( OUTPUT => 'self' ); $contained->emptyTag('empty'); $contained->end; is "$contained" => "\n", 'Calling end in a void context.'; SKIP: { eval { require IO::Scalar; }; skip "IO::Scalar is not installed", 2 if $@; my $text = ''; my $writer_ioscalar = XML::Writer->new( OUTPUT => IO::Scalar->new(\$text) ); my $ioscalar_out = "the IO::Scalar way\n"; $writer_ioscalar->dataElement( ioscalar => 'the IO::Scalar way' ); $writer_ioscalar->end; is $text => $ioscalar_out, 'IO::Scalar OUTPUT behaves the same way'; eval { $writer_ioscalar->to_string }; like $@ => qr/'to_string' can only be used with self-contained output/, "to_string on IO::Scalar OUTPUT"; } XML-Writer-0.900/t/pod-coverage.t0000644000175000017500000000026413650576245014572 0ustar joejoeuse Test::More; eval "use Test::Pod::Coverage"; plan skip_all => "Test::Pod::Coverage required for testing pod coverage" if $@; plan tests => 1; pod_coverage_ok('XML::Writer'); XML-Writer-0.900/t/pod.t0000644000175000017500000000023313650576245012775 0ustar joejoeuse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; plan tests => 1; pod_file_ok('Writer.pm'); XML-Writer-0.900/LICENSE0000644000175000017500000000047713650576245012602 0ustar joejoeWriter.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. XML-Writer-0.900/TODO0000644000175000017500000000075213650576245012261 0ustar joejoe- 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. XML-Writer-0.900/META.yml0000644000175000017500000000104013650576245013031 0ustar joejoe--- #YAML:1.0 meta-spec: version: 1.4 url: http://module-build.sourceforge.net/META-spec-v1.4.html name: XML-Writer version: 0.900 abstract: Easily generate well-formed, namespace-aware XML. author: - David Megginson - Ed Avis - Joseph Walton license: unrestricted distribution_type: module installdirs: site build_requires: perl: 5.008_001 Test::More: 0.047 no_index: package: - XML::Writer::Namespaces dynamic_config: 0 generated_by: Hand XML-Writer-0.900/Makefile.PL0000644000175000017500000000055213650576245013541 0ustar joejoe#!/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.900', # A manually-created META.yml has all the other metadata; # we don't want it overwritten NO_META => 1 ); XML-Writer-0.900/Writer.pm0000755000175000017500000012710313650576245013406 0ustar joejoe######################################################################## # 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("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("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/\/\>\;/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/\/\>\;/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__ ######################################################################## # POD Documentation ######################################################################## =head1 NAME XML::Writer - Perl extension for writing XML documents. =head1 SYNOPSIS use XML::Writer; use IO::File; my $output = IO::File->new(">output.xml"); my $writer = XML::Writer->new(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 = XML::Writer->new(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, or any blessed object that has a print() method; 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 module). If the string I is passed, the output will be captured internally by the object, and can be accessed via the C method, or by calling the object in a string context. my $writer = XML::Writer->new( OUTPUT => 'self' ); $writer->dataElement( hello => 'world' ); print $writer->to_string; # outputs world print "$writer"; # ditto =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 = XML::Writer->new(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 = XML::Writer->new(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 parameter 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 or white space; if this parameter is present, it represents the indent step for elements in data mode (it will be ignored when not in data mode). If it is white space it will be repeated for each level of indentation. =item ENCODING A character encoding to use for the output; 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. All character data should be passed as Unicode strings when an encoding is set. =item CHECK_PRINT A true or false value; if this parameter is present and its value is true, all prints to the underlying output will be checked for success. Failures will cause a croak rather than being ignored. =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(); If I as been set to I, C will return the generated document as well. =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 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 but writes the data quoted in a CDATA section, that is, between . 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 but the element content is written as one or more CDATA sections (see C). =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 = XML::Writer->new(OUTPUT => $output, UNSAFE => 1); =head2 PRINTING OUTPUT If I has been set to I and the object has been called in a string context, it'll return the xml document. =over 4 =item to_string If I has been set to I, calls an implicit C on the document and prints it. Dies if I has been set to anything else. =back =head1 AUTHOR David Megginson Edavid@megginson.comE =head1 COPYRIGHT AND LICENSE Copyright (c) 1999 by Megginson Technologies. Copyright (c) 2003 Ed Avis Eed@membled.comE Copyright (c) 2004-2010 Joseph Walton Ejoe@kafsemo.orgE Redistribution and use in source and compiled forms, with or without modification, are permitted under any circumstances. No warranty. =head1 SEE ALSO XML::Parser =cut XML-Writer-0.900/examples/0000755000175000017500000000000013737062715013401 5ustar joejoeXML-Writer-0.900/examples/writing-unicode.pl0000755000175000017500000000050113650576245017046 0ustar joejoe#!/usr/bin/perl -w # Generate UTF-8 output of a Unicode string use strict; use XML::Writer; my $unicodeString = "\x{201C}This\x{201D} is a test - \$ \x{00A3} \x{20AC}"; my $w = XML::Writer->new(ENCODING => 'utf-8'); $w->xmlDecl(); $w->startTag('doc'); $w->characters($unicodeString); $w->endTag('doc'); $w->end(); XML-Writer-0.900/examples/simple-xml.pl0000755000175000017500000000067013650576245016035 0ustar joejoe#!/usr/bin/perl -w # Write a simple XML document to a file use strict; use XML::Writer; my $output; open($output, '>', 'output.xml') or die "Unable to open output file: $!"; my $writer = XML::Writer->new(OUTPUT => $output); $writer->startTag("greeting", "class" => "simple"); $writer->characters("Hello, world!"); $writer->endTag("greeting"); $writer->end(); close($output) or die "Failed to close output file: $!"; XML-Writer-0.900/examples/namespace-prefixes.pl0000755000175000017500000000256413650576245017531 0ustar joejoe#!/usr/bin/perl -w # A skeleton Atom document with extensions, to show different # behaviour of namespaces and prefixes use strict; use XML::Writer; my $ATOM = 'http://www.w3.org/2005/Atom'; my $EXT = 'http://www.example.com/feed-extension'; my $EXT2 = 'http://www.example.com/feed-extension-2'; my $EXT3 = 'http://www.example.com/feed-extension-3'; my $w = XML::Writer->new( NAMESPACES => 1, DATA_MODE => 1, # Define prefixes for most of the namespaces PREFIX_MAP => { $ATOM => '', $EXT => 'ext', $EXT2 => 'ext2' }, # Force a declaration for the first extension on the root element FORCED_NS_DECLS => [$EXT] ); $w->comment(' An Atom feed with namespace declarations '); $w->startTag([$ATOM, 'feed']); # The root element will include a declaration for its own namespace # and the contents of FORCED_NS_DECLS $w->dataElement([$ATOM, 'title'], "Feed Title"); # This namespace has already been declared on the root as the default $w->dataElement([$EXT, 'example'], "true"); # This namespace had its name defined but the declaration hasn't appeared yet. # It will be included on demand, on this element. $w->dataElement([$EXT2, 'definitely-an-example'], "true"); # This namespace has no prefix defined - an artificial prefix will be # used (something like __NS1) $w->dataElement([$EXT3, 'most-definitely-an-example'], "true"); $w->endTag([$ATOM, 'feed']); $w->end(); XML-Writer-0.900/examples/data-mode-sample.pl0000755000175000017500000000102713650576245017055 0ustar joejoe#!/usr/bin/perl -w # Use DATA_MODE and DATA_INDENT to make data documents easier to read use strict; use XML::Writer; use IO::File; my $writer = XML::Writer->new(DATA_MODE => 1, DATA_INDENT => 2); $writer->startTag("doc"); $writer->startTag("x"); $writer->dataElement("y", "Hello, world!"); $writer->dataElement("y", "Hello, world!"); $writer->endTag("x"); $writer->startTag("x"); $writer->dataElement("y", "Hello, world!"); $writer->dataElement("y", "Hello, world!"); $writer->endTag("x"); $writer->endTag("doc"); $writer->end(); XML-Writer-0.900/examples/directory-as-atom.pl0000755000175000017500000000661613650576245017317 0ustar joejoe#!/usr/bin/perl -w # A full example that presents a directory as an Atom feed # It demonstrates namespace and formatting control. # Intended to productise the /junk convention. # Usage: directory-as-atom.pl [feed title] [feed subtitle] # e.g., directory-as-atom.pl /home/user/public_html/junk http://www.example.com/~user/junk/ >index.atom use strict; use DirHandle; use URI::URL; use DateTime; use XML::Writer; my ($dir, $base, $title, $subtitle) = @ARGV; defined($base) or die "Usage: directory-as-atom.pl [feed title] [feed subtitle]"; $dir ||= '.'; $title ||= '/junk/'; $subtitle ||= 'ls -ltr $dir | head -10'; my $uid = (stat($dir))[4]; my $dh = DirHandle->new($dir) || die "Unable to opendir $dir: $!"; my @de; while(my $e = $dh->read()) { # Skip dotfiles next if ($e =~ /^\./); my $n = "$dir/$e"; next unless (-f $n); my ($mtime, $bytes) = (stat($n))[9,7]; my $desc; # undef, for now if (defined($mtime)) {push(@de, [$e, $mtime, $desc, $bytes])}; } undef($dh); # Sort into reverse date order... @de = sort { $b->[1] <=> $a->[1]; } @de; # ...take the most recent ten if (@de > 10) { @de = @de[0..9]; } # Constants for the namespace URIs my $ATOM = 'http://www.w3.org/2005/Atom'; my $HTML = 'http://www.w3.org/1999/xhtml'; my $XML = 'http://www.w3.org/XML/1998/namespace'; sub toIsoDate($) { my $t = shift; my $d = DateTime->from_epoch(epoch => $t); $d->set_time_zone('UTC'); return $d->iso8601 . "Z"; } my $w = XML::Writer->new( # Use namespaces NAMESPACES => 1, # Write in data mode, with indentation DATA_MODE => 1, DATA_INDENT => 1, # Use specific namespace prefixes PREFIX_MAP => {$ATOM => '', $HTML => 'html'}, # Force an xmlns:html declaration on the root element FORCED_NS_DECLS => [$HTML], # Encode text as UTF-8 ENCODING => 'utf-8' ); $base = URI::URL->new($base)->abs; my $feedUrl = URI::URL->new('index.atom', $base); $w->xmlDecl(); # Start the root element with an xml:base declaration $w->startTag([$ATOM, 'feed'], [$XML, 'base'] => $base); $w->dataElement([$ATOM, 'id'], $feedUrl->abs); # Mandatory Atom feed elements $w->dataElement([$ATOM, 'title'], $title); $w->dataElement([$ATOM, 'subtitle'], $subtitle); $w->dataElement('generator', 'Old-skool directory-based CMS'); $w->emptyTag('link', 'rel' => 'self', 'href' => $feedUrl) if $feedUrl; $w->dataElement([$ATOM, 'updated'] => toIsoDate(time)); # Find out the directory owner's name if (my ($name) = (getpwuid($uid))[0]) { $w->startTag([$ATOM, 'author']); $w->dataElement([$ATOM, 'name'], $name); $w->endTag([$ATOM, 'author']); } # Write an entry for each file foreach (@de) { my ($n, $mtime, $desc, $bytes) = @{$_}; my $url = url($n, $base)->abs->as_string; $w->startTag([$ATOM, 'entry']); $w->dataElement([$ATOM, 'title'], $n); $w->dataElement([$ATOM, 'id'], $url); $w->emptyTag([$ATOM, 'link'], 'href' => $n); $w->dataElement([$ATOM, 'updated'], toIsoDate($mtime)); # Write atom:content as XHTML; turn off data mode # to control whitespace inside the html:div element $w->startTag([$ATOM, 'content'], 'type' => 'xhtml'); $w->startTag([$HTML, 'div']); $w->setDataMode(0); $w->dataElement([$HTML, 'code'], $n); $w->characters(" - ${bytes} bytes"); $w->characters(" - ${desc}") if $desc; $w->setDataMode(1); $w->endTag([$HTML, 'div']); $w->endTag([$ATOM, 'content']); $w->endTag([$ATOM, 'entry']); } $w->endTag([$ATOM, 'feed']); $w->end(); XML-Writer-0.900/examples/double-escaping-example.pl0000755000175000017500000000061213650576245020434 0ustar joejoe#!/usr/bin/perl -w # Demonstrate that ampersands are double-escaped # Even if your text looks like already-escaped XML, it will be escaped # again to make sure that the same text arrives at the other end. use strict; use XML::Writer; my $w = XML::Writer->new(); $w->startTag('doc'); $w->characters('In HTML and XML, an ampersand must be escaped as &'); $w->endTag('doc'); $w->end(); XML-Writer-0.900/examples/xml-writer-string.pl0000755000175000017500000000040213650576245017355 0ustar joejoe#!/usr/bin/perl -w # Write to a string, then print the output use strict; use XML::Writer; my $s; my $w = XML::Writer->new(OUTPUT => \$s); $w->startTag('doc'); $w->characters('text'); $w->endTag('doc'); $w->end(); # Print the string contents print $s