File Coverage

blib/lib/XML/Writer.pm

Criterion	Covered	Total	%
statement	639	639	100.0
branch	188	188	100.0
condition	102	102	100.0
subroutine	98	98	100.0
pod	32	32	100.0
total	1059	1059	100.0

line	stmt	bran	cond	sub	pod	time	code
1							########################################################################
2							# Writer.pm - write an XML document.
3							# Copyright (c) 1999 by Megginson Technologies.
4							# Copyright (c) 2003 Ed Avis <ed@membled.com>
5							# Copyright (c) 2004-2010 Joseph Walton <joe@kafsemo.org>
6							# Redistribution and use in source and compiled forms, with or without
7							# modification, are permitted under any circumstances. No warranty.
8							########################################################################
9
10							package XML::Writer;
11
12							require 5.004;
13
14	3			3		1040842	use strict;
	3					16
	3					328
15	3			3		34	use vars qw($VERSION);
	3					12
	3					338
16	3			3		34	use Carp;
	3					12
	3					492
17	3			3		1781	use IO::Handle;
	3					29887
	3					584
18							$VERSION = "0.621";
19
20	3			3		42	use overload '""' => \&_overload_string;
	3					13
	3					39618
21
22
23							########################################################################
24							# Constructor.
25							########################################################################
26
27							#
28							# Public constructor.
29							#
30							# This actually does most of the work of the module: it defines closures
31							# for all of the real processing, and selects the appropriate closures
32							# to use based on the value of the UNSAFE parameter. The actual methods
33							# are just stubs.
34							#
35							sub new {
36	297			297	1	769160	my ($class, %params) = (@_);
37
38							# If the user wants namespaces,
39							# intercept the request here; it will
40							# come back to this constructor
41							# from within XML::Writer::Namespaces::new()
42	297	100				3001	if ($params{NAMESPACES}) {
43	143					1225	delete $params{NAMESPACES};
44	143					2349	return XML::Writer::Namespaces->new(%params);
45							}
46
47							# Set up $self and basic parameters
48	154					801	my $self;
49	154					824	my $output;
50	154					898	my $unsafe = $params{UNSAFE};
51	154					941	my $newlines = $params{NEWLINES};
52	154					829	my $dataMode = $params{DATA_MODE};
53	154					678	my $dataIndent;
54	154					579	my $selfcontained_output;
55	154					761	my $use_selfcontained_output = 0;
56
57							# If the NEWLINES parameter is specified,
58							# set the $nl variable appropriately
59	154					1022	my $nl = '';
60	154	100				1216	if ($newlines) {
61	1					9	$nl = "\n";
62							}
63
64	154		100			3540	my $outputEncoding = $params{ENCODING} \|\| "";
65	154					711	my ($checkUnencodedRepertoire, $escapeEncoding);
66	154	100				1303	if (lc($outputEncoding) eq 'us-ascii') {
67	10					68	$checkUnencodedRepertoire = \&_croakUnlessASCII;
68	10					60	$escapeEncoding = \&_escapeASCII;
69							} else {
70	144			293		2503	my $doNothing = sub {};
	293					1121
71	144					692	$checkUnencodedRepertoire = $doNothing;
72	144					754	$escapeEncoding = $doNothing;
73							}
74
75							# Parse variables
76	154					766	my @elementStack = ();
77	154					636	my $elementLevel = 0;
78	154					703	my %seen = ();
79
80	154					635	my $hasData = 0;
81	154					571	my @hasDataStack = ();
82	154					564	my $hasElement = 0;
83	154					598	my @hasElementStack = ();
84	154					704	my $hasHeading = 0; # Does this document have anything before the first element?
85
86							#
87							# Private method to show attributes.
88							#
89							my $showAttributes = sub {
90	180			180		877	my $atts = $_[0];
91	180					695	my $i = 1;
92	180					1426	while ($atts->[$i]) {
93	71					1306	my $aname = $atts->[$i++];
94	71					454	my $value = _escapeLiteral($atts->[$i++]);
95	71					440	$value =~ s/\x0a/\&#10\;/g;
96	71					352	$value =~ s/\x0d/\&#13\;/g;
97	71					302	$value =~ s/\x09/\&#9\;/g;
98	71					248	&{$escapeEncoding}($value);
	71					387
99	71					3104	$output->print(" $aname=\"$value\"");
100							}
101	154					3473	};
102
103							# Method implementations: the SAFE_
104							# versions perform error checking
105							# and then call the regular ones.
106							my $end = sub {
107	85			85		3061	$output->print("\n");
108
109	85	100	100			5958	return $selfcontained_output
110							if $use_selfcontained_output and defined wantarray;
111	154					2127	};
112
113							my $SAFE_end = sub {
114	78	100		78		699	if (!$seen{ELEMENT}) {
		100
115	1					410	croak("Document cannot end without a document element");
116							} elsif ($elementLevel > 0) {
117	1					440	croak("Document ended with unmatched start tag(s): @elementStack");
118							} else {
119	76					330	@elementStack = ();
120	76					274	$elementLevel = 0;
121	76					469	%seen = ();
122	76					312	&{$end};
	76					405
123							}
124	154					2517	};
125
126							my $xmlDecl = sub {
127	22			22		134	my ($encoding, $standalone) = (@_);
128	22	100	100			213	if ($standalone && $standalone ne 'no') {
129	1					10	$standalone = 'yes';
130							}
131
132							# Only include an encoding if one has been explicitly supplied,
133							# either here or on construction. Allow the empty string
134							# to suppress it.
135	22	100				121	if (!defined($encoding)) {
136	18					102	$encoding = $outputEncoding;
137							}
138	22					909	$output->print("<?xml version=\"1.0\"");
139	21	100				1521	if ($encoding) {
140	7					294	$output->print(" encoding=\"$encoding\"");
141							}
142	21	100				483	if ($standalone) {
143	2					103	$output->print(" standalone=\"$standalone\"");
144							}
145	21					955	$output->print("?>\n");
146	21					1563	$hasHeading = 1;
147	154					2765	};
148
149							my $SAFE_xmlDecl = sub {
150	23	100		23		163	if ($seen{ANYTHING}) {
151	2					836	croak("The XML declaration is not the first thing in the document");
152							} else {
153	21					156	$seen{ANYTHING} = 1;
154	21					103	$seen{XMLDECL} = 1;
155	21					78	&{$xmlDecl};
	21					137
156							}
157	154					2224	};
158
159							my $pi = sub {
160	7			7		47	my ($target, $data) = (@_);
161	7	100				39	if ($data) {
162	2					94	$output->print("<?$target $data?>");
163							} else {
164	5					211	$output->print("<?$target?>");
165							}
166	7	100				421	if ($elementLevel == 0) {
167	6					228	$output->print("\n");
168	6					409	$hasHeading = 1;
169							}
170	154					2889	};
171
172							my $SAFE_pi = sub {
173	10			10		63	my ($name, $data) = (@_);
174	10					62	$seen{ANYTHING} = 1;
175	10	100	100			140	if (($name =~ /^xml/i) && ($name !~ /^xml-stylesheet$/i)) {
176	1					637	carp("Processing instruction target begins with 'xml'");
177							}
178
179	10	100	100			340	if ($name =~ /\?\>/ \|\| (defined($data) && $data =~ /\?\>/)) {
		100	100
180	2					1138	croak("Processing instruction may not contain '?>'");
181							} elsif ($name =~ /\s/) {
182	1					529	croak("Processing instruction name may not contain whitespace");
183							} else {
184	7					24	&{$pi};
	7					41
185							}
186	154					2354	};
187
188							my $comment = sub {
189	14			14		90	my $data = $_[0];
190	14	100	100			185	if ($dataMode && $elementLevel) {
191	5					193	$output->print("\n");
192	5					429	$output->print($dataIndent x $elementLevel);
193							}
194	14					913	$output->print("<!-- $data -->");
195	14	100	100			1070	if ($dataMode && $elementLevel) {
		100
196	5					110	$hasElement = 1;
197							} elsif ($elementLevel == 0) {
198	8					303	$output->print("\n");
199	8					544	$hasHeading = 1;
200							}
201	154					2373	};
202
203							my $SAFE_comment = sub {
204	14			14		70	my $data = $_[0];
205	14	100				164	if ($data =~ /--/) {
206	2					921	carp("Interoperability problem: \"--\" in comment text");
207							}
208
209	14	100				293	if ($data =~ /-->/) {
210	1					376	croak("Comment may not contain '-->'");
211							} else {
212	13					108	&{$checkUnencodedRepertoire}($data);
	13					124
213	12					71	$seen{ANYTHING} = 1;
214	12					44	&{$comment};
	12					63
215							}
216	154					2222	};
217
218							my $doctype = sub {
219	8			8		62	my ($name, $publicId, $systemId) = (@_);
220	8					351	$output->print("<!DOCTYPE $name");
221	8	100				480	if ($publicId) {
		100
222	3	100				22	unless ($systemId) {
223	1					549	croak("A DOCTYPE declaration with a public ID must also have a system ID");
224							}
225	2					85	$output->print(" PUBLIC \"$publicId\" \"$systemId\"");
226							} elsif ($systemId) {
227	2					82	$output->print(" SYSTEM \"$systemId\"");
228							}
229	7					452	$output->print(">\n");
230	7					528	$hasHeading = 1;
231	154					2675	};
232
233							my $SAFE_doctype = sub {
234	9			9		50	my $name = $_[0];
235	9	100				70	if ($seen{DOCTYPE}) {
		100
236	1					433	croak("Attempt to insert second DOCTYPE declaration");
237							} elsif ($seen{ELEMENT}) {
238	1					483	croak("The DOCTYPE declaration must come before the first start tag");
239							} else {
240	7					46	$seen{ANYTHING} = 1;
241	7					38	$seen{DOCTYPE} = $name;
242	7					28	&{$doctype};
	7					40
243							}
244	154					2041	};
245
246							my $startTag = sub {
247	105			105		577	my $name = $_[0];
248	105	100	100			1218	if ($dataMode && ($hasHeading \|\| $elementLevel)) {
			100
249	29					1212	$output->print("\n");
250	29					2708	$output->print($dataIndent x $elementLevel);
251							}
252	105					1776	$elementLevel++;
253	105					642	push @elementStack, $name;
254	105					4345	$output->print("<$name");
255	104					5755	&{$showAttributes}(\@_);
	104					827
256	104					5531	$output->print("$nl>");
257	104	100				6272	if ($dataMode) {
258	43					175	$hasElement = 1;
259	43					231	push @hasDataStack, $hasData;
260	43					153	$hasData = 0;
261	43					173	push @hasElementStack, $hasElement;
262	43					899	$hasElement = 0;
263							}
264	154					2657	};
265
266							my $SAFE_startTag = sub {
267	103			103		549	my $name = $_[0];
268
269	103					352	&{$checkUnencodedRepertoire}($name);
	103					588
270	103					660	_checkAttributes(\@_);
271
272	103	100	100			2837	if ($seen{ELEMENT} && $elementLevel == 0) {
		100	100
		100	100
			100
273	1					501	croak("Attempt to insert start tag after close of document element");
274							} elsif ($elementLevel == 0 && $seen{DOCTYPE} && $name ne $seen{DOCTYPE}) {
275	1					456	croak("Document element is \"$name\", but DOCTYPE is \""
276							. $seen{DOCTYPE}
277							. "\"");
278							} elsif ($dataMode && $hasData) {
279	2					877	croak("Mixed content not allowed in data mode: element $name");
280							} else {
281	99					598	$seen{ANYTHING} = 1;
282	99					478	$seen{ELEMENT} = 1;
283	99					376	&{$startTag};
	99					552
284							}
285	154					2876	};
286
287							my $emptyTag = sub {
288	76			76		450	my $name = $_[0];
289	76	100	100			794	if ($dataMode && ($hasHeading \|\| $elementLevel)) {
			100
290	18					761	$output->print("\n");
291	18					1665	$output->print($dataIndent x $elementLevel);
292							}
293	76					4101	$output->print("<$name");
294	76					4215	&{$showAttributes}(\@_);
	76					528
295	76					4257	$output->print("$nl />");
296	76	100				4199	if ($dataMode) {
297	19					98	$hasElement = 1;
298							}
299	154					2484	};
300
301							my $SAFE_emptyTag = sub {
302	80			80		507	my $name = $_[0];
303
304	80					307	&{$checkUnencodedRepertoire}($name);
	80					461
305	79					542	_checkAttributes(\@_);
306
307	76	100	100			1992	if ($seen{ELEMENT} && $elementLevel == 0) {
		100	100
		100	100
			100
308	1					473	croak("Attempt to insert empty tag after close of document element");
309							} elsif ($elementLevel == 0 && $seen{DOCTYPE} && $name ne $seen{DOCTYPE}) {
310	1					433	croak("Document element is \"$name\", but DOCTYPE is \""
311							. $seen{DOCTYPE}
312							. "\"");
313							} elsif ($dataMode && $hasData) {
314	1					439	croak("Mixed content not allowed in data mode: element $name");
315							} else {
316	73					382	$seen{ANYTHING} = 1;
317	73					315	$seen{ELEMENT} = 1;
318	73					246	&{$emptyTag};
	73					447
319							}
320	154					2836	};
321
322							my $endTag = sub {
323	80			80		399	my $name = $_[0];
324	80					365	my $currentName = pop @elementStack;
325	80	100				476	$name = $currentName unless $name;
326	80					272	$elementLevel--;
327	80	100	100			697	if ($dataMode && $hasElement) {
328	20					773	$output->print("\n");
329	20					1707	$output->print($dataIndent x $elementLevel);
330							}
331	80					3851	$output->print("</$name$nl>");
332	80	100				4250	if ($dataMode) {
333	36					149	$hasData = pop @hasDataStack;
334	36					190	$hasElement = pop @hasElementStack;
335							}
336	154					2414	};
337
338							my $SAFE_endTag = sub {
339	76			76		388	my $name = $_[0];
340	76					415	my $oldName = $elementStack[$#elementStack];
341	76	100	100			1283	if ($elementLevel <= 0) {
		100
342	1					540	croak("End tag \"$name\" does not close any open element");
343							} elsif ($name && ($name ne $oldName)) {
344	1					527	croak("Attempt to end element \"$oldName\" with \"$name\" tag");
345							} else {
346	74					259	&{$endTag};
	74					391
347							}
348	154					2297	};
349
350							my $characters = sub {
351	40			40		206	my $data = $_[0];
352	40	100				271	if ($data =~ /[\&\<\>]/) {
353	1					16	$data =~ s/\&/\&amp\;/g;
354	1					16	$data =~ s/\</\&lt\;/g;
355	1					12	$data =~ s/\>/\&gt\;/g;
356							}
357	40					149	&{$escapeEncoding}($data);
	40					210
358	40					1437	$output->print($data);
359	40					2161	$hasData = 1;
360	154					1975	};
361
362							my $SAFE_characters = sub {
363	42	100	100	42		490	if ($elementLevel < 1) {
		100
364	1					448	croak("Attempt to insert characters outside of document element");
365							} elsif ($dataMode && $hasElement) {
366	1					437	croak("Mixed content not allowed in data mode: characters");
367							} else {
368	40					272	_croakUnlessDefinedCharacters($_[0]);
369	38					141	&{$characters};
	38					192
370							}
371	154					2066	};
372
373							my $raw = sub {
374	1			1		41	$output->print($_[0]);
375							# Don't set $hasData or any other information: we know nothing
376							# about what was just written.
377							#
378	154					1807	};
379
380							my $SAFE_raw = sub {
381	1			1		436	croak('raw() is only available when UNSAFE is set');
382	154					1808	};
383
384							my $cdata = sub {
385	10			10		56	my $data = $_[0];
386	10					66	$data =~ s/\]\]>/\]\]\]\]><!\[CDATA\[>/g;
387	10					409	$output->print("<![CDATA[$data]]>");
388	10					664	$hasData = 1;
389	154					1969	};
390
391							my $SAFE_cdata = sub {
392	11	100	100	11		153	if ($elementLevel < 1) {
		100
393	1					457	croak("Attempt to insert characters outside of document element");
394							} elsif ($dataMode && $hasElement) {
395	1					441	croak("Mixed content not allowed in data mode: characters");
396							} else {
397	9					63	_croakUnlessDefinedCharacters($_[0]);
398	8					34	&{$checkUnencodedRepertoire}($_[0]);
	8					45
399	7					26	&{$cdata};
	7					34
400							}
401	154					2082	};
402
403							# Assign the correct closures based on
404							# the UNSAFE parameter
405	154	100				910	if ($unsafe) {
406	9					193	$self = {'END' => $end,
407							'XMLDECL' => $xmlDecl,
408							'PI' => $pi,
409							'COMMENT' => $comment,
410							'DOCTYPE' => $doctype,
411							'STARTTAG' => $startTag,
412							'EMPTYTAG' => $emptyTag,
413							'ENDTAG' => $endTag,
414							'CHARACTERS' => $characters,
415							'RAW' => $raw,
416							'CDATA' => $cdata
417							};
418							} else {
419	145					2879	$self = {'END' => $SAFE_end,
420							'XMLDECL' => $SAFE_xmlDecl,
421							'PI' => $SAFE_pi,
422							'COMMENT' => $SAFE_comment,
423							'DOCTYPE' => $SAFE_doctype,
424							'STARTTAG' => $SAFE_startTag,
425							'EMPTYTAG' => $SAFE_emptyTag,
426							'ENDTAG' => $SAFE_endTag,
427							'CHARACTERS' => $SAFE_characters,
428							'RAW' => $SAFE_raw, # This will intentionally fail
429							'CDATA' => $SAFE_cdata
430							};
431							}
432
433							# Query methods
434							$self->{'IN_ELEMENT'} = sub {
435	1			1		7	my ($ancestor) = (@_);
436	1					47	return $elementStack[$#elementStack] eq $ancestor;
437	154					2383	};
438
439							$self->{'WITHIN_ELEMENT'} = sub {
440	3			3		18	my ($ancestor) = (@_);
441	3					10	my $el;
442	3					17	foreach $el (@elementStack) {
443	4	100				87	return 1 if $el eq $ancestor;
444							}
445	1					45	return 0;
446	154					2300	};
447
448							$self->{'CURRENT_ELEMENT'} = sub {
449	1			1		47	return $elementStack[$#elementStack];
450	154					1905	};
451
452							$self->{'ANCESTOR'} = sub {
453	5			5		28	my ($n) = (@_);
454	5	100				45	if ($n < scalar(@elementStack)) {
455	3					142	return $elementStack[$#elementStack-$n];
456							} else {
457	2					101	return undef;
458							}
459	154					2123	};
460
461							# Set and get the output destination.
462							$self->{'GETOUTPUT'} = sub {
463	7	100		7		61	if (ref($output) ne 'XML::Writer::_PrintChecker') {
464	4					179	return $output;
465							} else {
466	3					126	return $output->{HANDLE};
467							}
468	154					2482	};
469
470							$self->{'SETOUTPUT'} = sub {
471	160			160		747	my $newOutput = $_[0];
472
473	160	100				1783	if ( $newOutput eq 'self' ) {
474	2					11	$newOutput = \$selfcontained_output;
475	2					11	$use_selfcontained_output = 1;
476							}
477
478	160	100				1299	if (ref($newOutput) eq 'SCALAR') {
479	7					78	$output = XML::Writer::_String->new($newOutput);
480							} else {
481
482							# If there is no OUTPUT parameter,
483							# use standard output
484	153		100			914	$output = $newOutput \|\| \*STDOUT;
485	153	100	100			1387	if ($outputEncoding && (ref($output) eq 'GLOB' \|\| $output->isa('IO::Handle'))) {
			100
486	14	100				141	if (lc($outputEncoding) eq 'utf-8') {
		100
487	1			1		16	binmode($output, ':encoding(utf-8)');
	1					4
	1					68
	2					177
488							} elsif (lc($outputEncoding) eq 'us-ascii') {
489	10					795	binmode($output, ':encoding(us-ascii)');
490							} else {
491	2					175	die 'The only supported encodings are utf-8 and us-ascii';
492							}
493							}
494							}
495
496							$self->{OVERLOADSTRING} = sub {
497							# if we don't use the self-contained output,
498							# simple passthrough
499	293	100				7794	return $use_selfcontained_output ? $self->to_string : $self ;
500	158					33554	};
501
502							$self->{TOSTRING} = sub {
503	4	100				86	die "'to_string' can only be used with self-contained output\n"
504							unless $use_selfcontained_output;
505
506	3					161	return $selfcontained_output;
507	158					2242	};
508
509	158	100				1557	if ($params{CHECK_PRINT}) {
510	6					61	$output = XML::Writer::_PrintChecker->new($output);
511							}
512	154					2999	};
513
514							$self->{'SETDATAMODE'} = sub {
515	7			7		146	$dataMode = $_[0];
516	154					2051	};
517
518							$self->{'GETDATAMODE'} = sub {
519	2			2		87	return $dataMode;
520	154					1890	};
521
522							$self->{'SETDATAINDENT'} = sub {
523	162	100		162		2670	if ($_[0] =~ /^\s*$/) {
524	152					1215	$dataIndent = $_[0];
525							} else {
526	10					209	$dataIndent = ' ' x $_[0];
527							}
528	154					2221	};
529
530							$self->{'GETDATAINDENT'} = sub {
531	8	100		8		109	if ($dataIndent =~ /^ *$/) {
532	7					350	return length($dataIndent);
533							} else {
534	1					59	return $dataIndent;
535							}
536	154					1736	};
537
538							# Set the indent.
539	154		100			2592	&{$self->{'SETDATAINDENT'}}($params{'DATA_INDENT'} \|\| '');
	154					1258
540
541							# Set the output.
542	154					799	&{$self->{'SETOUTPUT'}}($params{'OUTPUT'});
	154					1162
543
544							# Return the blessed object.
545	152					5054	return bless $self, $class;
546							}
547
548
549
550							########################################################################
551							# Public methods
552							########################################################################
553
554							#
555							# Finish writing the document.
556							#
557							sub end {
558	87			87	1	5655	my $self = shift;
559	87					346	&{$self->{END}};
	87					730
560							}
561
562							#
563							# Write an XML declaration.
564							#
565							sub xmlDecl {
566	24			24	1	1520	my $self = shift;
567	24					121	&{$self->{XMLDECL}};
	24					198
568							}
569
570							#
571							# Write a processing instruction.
572							#
573							sub pi {
574	11			11	1	634	my $self = shift;
575	11					44	&{$self->{PI}};
	11					75
576							}
577
578							#
579							# Write a comment.
580							#
581							sub comment {
582	16			16	1	710	my $self = shift;
583	16					64	&{$self->{COMMENT}};
	16					111
584							}
585
586							#
587							# Write a DOCTYPE declaration.
588							#
589							sub doctype {
590	10			10	1	582	my $self = shift;
591	10					44	&{$self->{DOCTYPE}};
	10					74
592							}
593
594							#
595							# Write a start tag.
596							#
597							sub startTag {
598	109			109	1	4918	my $self = shift;
599	109					460	&{$self->{STARTTAG}};
	109					863
600							}
601
602							#
603							# Write an empty tag.
604							#
605							sub emptyTag {
606	88			88	1	4717	my $self = shift;
607	88					392	&{$self->{EMPTYTAG}};
	88					638
608							}
609
610							#
611							# Write an end tag.
612							#
613							sub endTag {
614	82			82	1	2963	my $self = shift;
615	82					301	&{$self->{ENDTAG}};
	82					561
616							}
617
618							#
619							# Write a simple data element.
620							#
621							sub dataElement {
622	20			20	1	2368	my ($self, $name, $data, @atts) = (@_);
623	20					187	$self->startTag($name, @atts);
624	20					165	$self->characters($data);
625	20					149	$self->endTag($name);
626							}
627
628							#
629							# Write a simple CDATA element.
630							#
631							sub cdataElement {
632	1			1	1	77	my ($self, $name, $data, %atts) = (@_);
633	1					16	$self->startTag($name, %atts);
634	1					57	$self->cdata($data);
635	1					9	$self->endTag($name);
636							}
637
638							#
639							# Write character data.
640							#
641							sub characters {
642	44			44	1	1192	my $self = shift;
643	44					161	&{$self->{CHARACTERS}};
	44					334
644							}
645
646							#
647							# Write raw, unquoted, completely unchecked character data.
648							#
649							sub raw {
650	2			2	1	115	my $self = shift;
651	2					10	&{$self->{RAW}};
	2					16
652							}
653
654							#
655							# Write CDATA.
656							#
657							sub cdata {
658	14			14	1	558	my $self = shift;
659	14					57	&{$self->{CDATA}};
	14					103
660							}
661
662							#
663							# Query the current element.
664							#
665							sub in_element {
666	1			1	1	62	my $self = shift;
667	1					7	return &{$self->{IN_ELEMENT}};
	1					21
668							}
669
670							#
671							# Query the ancestors.
672							#
673							sub within_element {
674	3			3	1	117	my $self = shift;
675	3					13	return &{$self->{WITHIN_ELEMENT}};
	3					22
676							}
677
678							#
679							# Get the name of the current element.
680							#
681							sub current_element {
682	1			1	1	63	my $self = shift;
683	1					5	return &{$self->{CURRENT_ELEMENT}};
	1					9
684							}
685
686							#
687							# Get the name of the numbered ancestor (zero-based).
688							#
689							sub ancestor {
690	5			5	1	153	my $self = shift;
691	5					23	return &{$self->{ANCESTOR}};
	5					41
692							}
693
694							#
695							# Get the current output destination.
696							#
697							sub getOutput {
698	7			7	1	312	my $self = shift;
699	7					37	return &{$self->{GETOUTPUT}};
	7					59
700							}
701
702
703							#
704							# Set the current output destination.
705							#
706							sub setOutput {
707	6			6	1	1271	my $self = shift;
708	6					32	return &{$self->{SETOUTPUT}};
	6					76
709							}
710
711							#
712							# Set the current data mode (true or false).
713							#
714							sub setDataMode {
715	7			7	1	357	my $self = shift;
716	7					30	return &{$self->{SETDATAMODE}};
	7					54
717							}
718
719
720							#
721							# Get the current data mode (true or false).
722							#
723							sub getDataMode {
724	2			2	1	80	my $self = shift;
725	2					8	return &{$self->{GETDATAMODE}};
	2					15
726							}
727
728
729							#
730							# Set the current data indent step.
731							#
732							sub setDataIndent {
733	8			8	1	201	my $self = shift;
734	8					44	return &{$self->{SETDATAINDENT}};
	8					75
735							}
736
737
738							#
739							# Get the current data indent step.
740							#
741							sub getDataIndent {
742	8			8	1	242	my $self = shift;
743	8					47	return &{$self->{GETDATAINDENT}};
	8					68
744							}
745
746
747							#
748							# Empty stub.
749							#
750	1			1	1	71	sub addPrefix {
751							}
752
753
754							#
755							# Empty stub.
756							#
757	1			1	1	64	sub removePrefix {
758							}
759
760							sub to_string {
761	4			4	1	29	my $self = shift;
762
763	4					43	$self->{TOSTRING}->();
764							}
765
766
767
768							########################################################################
769							# Private functions.
770							########################################################################
771
772							#
773							# Private: check for duplicate attributes and bad characters.
774							# Note - this starts at $_[1], because $_[0] is assumed to be an
775							# element name.
776							#
777							sub _checkAttributes {
778	182			182		647	my %anames;
779	182					697	my $i = 1;
780	182					1509	while ($_[0]->[$i]) {
781	69					358	my $name = $_[0]->[$i];
782	69					240	$i += 1;
783	69	100				385	if ($anames{$name}) {
784	2					1049	croak("Two attributes named \"$name\"");
785							} else {
786	67					417	$anames{$name} = 1;
787							}
788	67					431	_croakUnlessDefinedCharacters($_[0]->[$i]);
789	66					579	$i += 1;
790							}
791							}
792
793							#
794							# Private: escape an attribute value literal.
795							#
796							sub _escapeLiteral {
797	71			71		299	my $data = $_[0];
798	71	100				479	if ($data =~ /[\&\<\>\"]/) {
799	2					11	$data =~ s/\&/\&amp\;/g;
800	2					10	$data =~ s/\</\&lt\;/g;
801	2					24	$data =~ s/\>/\&gt\;/g;
802	2					11	$data =~ s/\"/\&quot\;/g;
803							}
804	71					474	return $data;
805							}
806
807							sub _escapeASCII($) {
808	7			7		99	$_[0] =~ s/([^\x00-\x7F])/sprintf('&#x%X;', ord($1))/ge;
	5					96
809							}
810
811							sub _croakUnlessASCII($) {
812	15	100		15		156	if ($_[0] =~ /[^\x00-\x7F]/) {
813	3					1654	croak('Non-ASCII characters are not permitted in this part of a US-ASCII document');
814							}
815							}
816
817							# Enforce XML 1.0, section 2.2's definition of "Char" (only reject low ASCII,
818							# so as not to require Unicode support from perl)
819							sub _croakUnlessDefinedCharacters($) {
820	116	100		116		967	if ($_[0] =~ /([\x00-\x08\x0B-\x0C\x0E-\x1F])/) {
821	4					2049	croak(sprintf('Code point \u%04X is not a valid character in XML', ord($1)));
822							}
823							}
824
825							sub _overload_string {
826	293			293		4423	$_[0]->{OVERLOADSTRING}->();
827							}
828
829							########################################################################
830							# XML::Writer::Namespaces - subclass for Namespace processing.
831							########################################################################
832
833							package XML::Writer::Namespaces;
834	3			3		55	use strict;
	3					52
	3					237
835	3			3		31	use vars qw(@ISA);
	3					12
	3					379
836	3			3		33	use Carp;
	3					13
	3					16156
837
838							@ISA = qw(XML::Writer);
839
840							#
841							# Constructor
842							#
843							sub new {
844	143			143	1	1653	my ($class, %params) = (@_);
845
846	143					950	my $unsafe = $params{UNSAFE};
847
848							# Snarf the prefix map, if any, and
849							# note the default prefix.
850	143					853	my %prefixMap = ();
851	143	100				1185	if ($params{PREFIX_MAP}) {
852	8					48	%prefixMap = (%{$params{PREFIX_MAP}});
	8					133
853	8					73	delete $params{PREFIX_MAP};
854							}
855	143					1581	$prefixMap{'http://www.w3.org/XML/1998/namespace'} = 'xml';
856
857							# Generate the reverse map for URIs
858	143					983	my $uriMap = {};
859	143					746	my $key;
860	143					1600	foreach $key (keys(%prefixMap)) {
861	152					1874	$uriMap->{$prefixMap{$key}} = $key;
862							}
863
864	143					1154	my $defaultPrefix = $uriMap->{''};
865	143	100				1022	delete $prefixMap{$defaultPrefix} if ($defaultPrefix);
866
867							# Create an instance of the parent.
868	143					1912	my $self = XML::Writer->new(%params);
869
870							# Snarf the parent's methods that we're
871							# going to override.
872	141					1128	my $OLD_startTag = $self->{STARTTAG};
873	141					705	my $OLD_emptyTag = $self->{EMPTYTAG};
874	141					662	my $OLD_endTag = $self->{ENDTAG};
875
876							# State variables
877	141					504	my @stack;
878	141					484	my $prefixCounter = 1;
879	141					1295	my $nsDecls = {'http://www.w3.org/XML/1998/namespace' => 'xml'};
880	141					623	my $nsDefaultDecl = undef;
881	141					520	my $nsCopyFlag = 0;
882	141					637	my @forcedNSDecls = ();
883
884	141	100				894	if ($params{FORCED_NS_DECLS}) {
885	2					10	@forcedNSDecls = @{$params{FORCED_NS_DECLS}};
	2					16
886	2					15	delete $params{FORCED_NS_DECLS};
887							}
888
889							#
890							# Push the current declaration state.
891							#
892							my $pushState = sub {
893	179			179		1510	push @stack, [$nsDecls, $nsDefaultDecl, $nsCopyFlag, $uriMap];
894	179					848	$nsCopyFlag = 0;
895	141					2210	};
896
897
898							#
899							# Pop the current declaration state.
900							#
901							my $popState = sub {
902	144			144		544	($nsDecls, $nsDefaultDecl, $nsCopyFlag, $uriMap) = @{pop @stack};
	144					3798
903	141					1858	};
904
905							#
906							# Generate a new prefix.
907							#
908							my $genPrefix = sub {
909	34			34		158	my $uri = $_[0];
910	34					132	my $prefixCounter = 1;
911	34					149	my $prefix = $prefixMap{$uri};
912	34					108	my %clashMap = %{$uriMap};
	34					449
913	34					352	while( my ($u, $p) = each(%prefixMap)) {
914	45					489	$clashMap{$p} = $u;
915							}
916
917	34		100			400	while (!defined($prefix) \|\| ($clashMap{$prefix} && $clashMap{$prefix} ne $uri)) {
			100
918	36					209	$prefix = "__NS$prefixCounter";
919	36					700	$prefixCounter++;
920							}
921
922	34					316	return $prefix;
923	141					2046	};
924
925							#
926							# Perform namespace processing on a single name.
927							#
928							my $processName = sub {
929	71			71		369	my ($nameref, $atts, $attFlag) = (@_);
930	71					226	my ($uri, $local) = @{$$nameref};
	71					427
931	71					337	my $prefix = $nsDecls->{$uri};
932
933							# Is this an element name that matches
934							# the default NS?
935	71	100	100			1274	if (!$attFlag && $defaultPrefix && ($uri eq $defaultPrefix)) {
		100	100
936	17	100	100			206	unless ($nsDefaultDecl && ($nsDefaultDecl eq $uri)) {
937	12					41	push @{$atts}, 'xmlns';
	12					79
938	12					46	push @{$atts}, $uri;
	12					69
939	12					60	$nsDefaultDecl = $uri;
940							}
941	17					85	$$nameref = $local;
942
943	17	100				113	if (defined($uriMap->{''})) {
944	9					60	delete ($nsDecls->{$uriMap->{''}});
945							}
946
947	17					103	$nsDecls->{$uri} = '';
948	17	100				86	unless ($nsCopyFlag) {
949	16					56	$uriMap = {%{$uriMap}};
	16					200
950	16					69	$nsDecls = {%{$nsDecls}};
	16					181
951	16					76	$nsCopyFlag = 1;
952							}
953	17					123	$uriMap->{''} = $uri;
954
955							# Is there a straight-forward prefix?
956							} elsif ($prefix) {
957	20					170	$$nameref = "$prefix:$local";
958							} else {
959	34					124	$prefix = &{$genPrefix}($uri);
	34					210
960	34	100				177	unless ($nsCopyFlag) {
961	30					92	$uriMap = {%{$uriMap}};
	30					286
962	30					124	$nsDecls = {%{$nsDecls}};
	30					269
963	30					140	$nsCopyFlag = 1;
964							}
965	34					206	$uriMap->{$prefix} = $uri;
966	34					218	$nsDecls->{$uri} = $prefix;
967	34					112	push @{$atts}, "xmlns:$prefix";
	34					243
968	34					121	push @{$atts}, $uri;
	34					183
969	34					273	$$nameref = "$prefix:$local";
970							}
971	141					2855	};
972
973
974							#
975							# Perform namespace processing on element and attribute names.
976							#
977							my $nsProcess = sub {
978	179	100		179		1394	if (ref($_[0]->[0]) eq 'ARRAY') {
979	54					186	my $x = \@{$_[0]->[0]};
	54					389
980	54					291	&{$processName}(\$x, $_[0], 0);
	54					301
981	54					220	splice(@{$_[0]}, 0, 1, $x);
	54					457
982							}
983	179					727	my $i = 1;
984	179					1225	while ($_[0]->[$i]) {
985	70	100				497	if (ref($_[0]->[$i]) eq 'ARRAY') {
986	14					55	my $x = \@{$_[0]->[$i]};
	14					130
987	14					78	&{$processName}(\$x, $_[0], 1);
	14					96
988	14					50	splice(@{$_[0]}, $i, 1, $x);
	14					113
989							}
990	70					454	$i += 2;
991							}
992
993							# We do this if any declarations are forced, due either to
994							# constructor arguments or to a call during processing.
995	179	100				1210	if (@forcedNSDecls) {
996	3					22	foreach (@forcedNSDecls) {
997	3					23	my @dummy = ($_, 'dummy');
998	3					15	my $d2 = \@dummy;
999	3	100	100			48	if ($defaultPrefix && ($_ eq $defaultPrefix)) {
1000	1					6	&{$processName}(\$d2, $_[0], 0);
	1					7
1001							} else {
1002	2					11	&{$processName}(\$d2, $_[0], 1);
	2					14
1003							}
1004							}
1005	3					19	@forcedNSDecls = ();
1006							}
1007	141					2977	};
1008
1009
1010							# Indicate that a namespace should be declared by the next open element
1011							$self->{FORCENSDECL} = sub {
1012	1			1		25	push @forcedNSDecls, $_[0];
1013	141					1859	};
1014
1015
1016							#
1017							# Start tag, with NS processing
1018							#
1019							$self->{STARTTAG} = sub {
1020	100			100		622	my $name = $_[0];
1021	100	100				635	unless ($unsafe) {
1022	94					649	_checkNSNames(\@_);
1023							}
1024	100					387	&{$pushState}();
	100					636
1025	100					500	&{$nsProcess}(\@_);
	100					620
1026	100					388	&{$OLD_startTag};
	100					539
1027	141					2228	};
1028
1029
1030							#
1031							# Empty tag, with NS processing
1032							#
1033							$self->{EMPTYTAG} = sub {
1034	84	100		84		500	unless ($unsafe) {
1035	81					592	_checkNSNames(\@_);
1036							}
1037	79					342	&{$pushState}();
	79					442
1038	79					356	&{$nsProcess}(\@_);
	79					450
1039	79					324	&{$OLD_emptyTag};
	79					425
1040	73					310	&{$popState}();
	73					446
1041	141					2328	};
1042
1043
1044							#
1045							# End tag, with NS processing
1046							#
1047							$self->{ENDTAG} = sub {
1048	73			73		362	my $name = $_[0];
1049	73	100				431	if (ref($_[0]) eq 'ARRAY') {
1050	22					146	my $pfx = $nsDecls->{$_[0]->[0]};
1051	22	100				102	if ($pfx) {
1052	17					142	$_[0] = $pfx . ':' . $_[0]->[1];
1053							} else {
1054	5					38	$_[0] = $_[0]->[1];
1055							}
1056							} else {
1057	51					183	$_[0] = $_[0];
1058							}
1059							# &{$nsProcess}(\@_);
1060	73					243	&{$OLD_endTag};
	73					371
1061	71					277	&{$popState}();
	71					467
1062	141					2566	};
1063
1064
1065							#
1066							# Processing instruction, but only if not UNSAFE.
1067							#
1068	141	100				1020	unless ($unsafe) {
1069	132					793	my $OLD_pi = $self->{PI};
1070							$self->{PI} = sub {
1071	11			11		64	my $target = $_[0];
1072	11	100				80	if (index($target, ':') >= 0) {
1073	1					482	croak "PI target '$target' contains a colon.";
1074							}
1075	10					35	&{$OLD_pi};
	10					54
1076							}
1077	132					2060	};
1078
1079
1080							#
1081							# Add a prefix to the prefix map.
1082							#
1083							$self->{ADDPREFIX} = sub {
1084	18			18		137	my ($uri, $prefix) = (@_);
1085	18	100				93	if ($prefix) {
1086	7					164	$prefixMap{$uri} = $prefix;
1087							} else {
1088	11	100				74	if (defined($defaultPrefix)) {
1089	4					23	delete($prefixMap{$defaultPrefix});
1090							}
1091	11					231	$defaultPrefix = $uri;
1092							}
1093	141					2162	};
1094
1095
1096							#
1097							# Remove a prefix from the prefix map.
1098							#
1099							$self->{REMOVEPREFIX} = sub {
1100	3			3		23	my ($uri) = (@_);
1101	3	100	100			49	if ($defaultPrefix && ($defaultPrefix eq $uri)) {
1102	1					7	$defaultPrefix = undef;
1103							}
1104	3					210	delete $prefixMap{$uri};
1105	141					1975	};
1106
1107
1108							#
1109							# Bless and return the object.
1110							#
1111	141					3929	return bless $self, $class;
1112							}
1113
1114
1115							#
1116							# Add a preferred prefix for a namespace URI.
1117							#
1118							sub addPrefix {
1119	18			18	1	1162	my $self = shift;
1120	18					75	return &{$self->{ADDPREFIX}};
	18					130
1121							}
1122
1123
1124							#
1125							# Remove a preferred prefix for a namespace URI.
1126							#
1127							sub removePrefix {
1128	3			3	1	193	my $self = shift;
1129	3					14	return &{$self->{REMOVEPREFIX}};
	3					23
1130							}
1131
1132
1133							#
1134							# Check names.
1135							#
1136							sub _checkNSNames {
1137	175			175		730	my $names = $_[0];
1138	175					607	my $i = 1;
1139	175					868	my $name = $names->[0];
1140
1141							# Check the element name.
1142	175	100				1595	if (ref($name) eq 'ARRAY') {
		100
1143	55	100				428	if (index($name->[1], ':') >= 0) {
1144	1					471	croak("Local part of element name '" .
1145							$name->[1] .
1146							"' contains a colon.");
1147							}
1148							} elsif (index($name, ':') >= 0) {
1149	1					422	croak("Element name '$name' contains a colon.");
1150							}
1151
1152							# Check the attribute names.
1153	173					1340	while ($names->[$i]) {
1154	25					127	my $name = $names->[$i];
1155	25	100				156	if (ref($name) eq 'ARRAY') {
1156	13					61	my $local = $name->[1];
1157	13	100				86	if (index($local, ':') >= 0) {
1158	1					615	croak "Local part of attribute name '$local' contains a colon.";
1159							}
1160							} else {
1161	12	100				109	if ($name =~ /^xmlns/) {
		100
1162	1					474	croak "Attribute name '$name' begins with 'xmlns'";
1163							} elsif (index($name, ':') >= 0) {
1164	1					506	croak "Attribute name '$name' contains ':'";
1165							}
1166							}
1167	22					208	$i += 2;
1168							}
1169							}
1170
1171							sub forceNSDecl
1172							{
1173	1			1		54	my $self = shift;
1174	1					6	return &{$self->{FORCENSDECL}};
	1					10
1175							}
1176
1177
1178							package XML::Writer::_String;
1179
1180							# Internal class, behaving sufficiently like an IO::Handle,
1181							# that stores written output in a string
1182							#
1183							# Heavily inspired by Simon Oliver's XML::Writer::String
1184
1185							sub new
1186							{
1187	7			7	1	38	my $class = shift;
1188	7					27	my $scalar_ref = shift;
1189	7					138	return bless($scalar_ref, $class);
1190							}
1191
1192							sub print
1193							{
1194	43			43		168	${(shift)} .= join('', @_);
	43					318
1195	43					191	return 1;
1196							}
1197
1198
1199							package XML::Writer::_PrintChecker;
1200
1201	3			3		50	use Carp;
	3					13
	3					1304
1202
1203							sub new
1204							{
1205	6			6	1	33	my $class = shift;
1206	6					178	return bless({HANDLE => shift}, $class);
1207							}
1208
1209							sub print
1210							{
1211	4			4		18	my $self = shift;
1212	4	100				131	if ($self->{HANDLE}->print(shift)) {
1213	2					119	return 1;
1214							} else {
1215	2					1178	croak "Failed to write output: $!";
1216							}
1217							}
1218
1219							1;
1220							__END__
1221
1222							########################################################################
1223							# POD Documentation
1224							########################################################################
1225
1226							=head1 NAME
1227
1228							XML::Writer - Perl extension for writing XML documents.
1229
1230							=head1 SYNOPSIS
1231
1232							use XML::Writer;
1233							use IO::File;
1234
1235							my $output = IO::File->new(">output.xml");
1236
1237							my $writer = XML::Writer->new(OUTPUT => $output);
1238							$writer->startTag("greeting",
1239							"class" => "simple");
1240							$writer->characters("Hello, world!");
1241							$writer->endTag("greeting");
1242							$writer->end();
1243							$output->close();
1244
1245
1246							=head1 DESCRIPTION
1247
1248							XML::Writer is a helper module for Perl programs that write an XML
1249							document. The module handles all escaping for attribute values and
1250							character data and constructs different types of markup, such as tags,
1251							comments, and processing instructions.
1252
1253							By default, the module performs several well-formedness checks to
1254							catch errors during output. This behaviour can be extremely useful
1255							during development and debugging, but it can be turned off for
1256							production-grade code.
1257
1258							The module can operate either in regular mode in or Namespace
1259							processing mode. In Namespace mode, the module will generate
1260							Namespace Declarations itself, and will perform additional checks on
1261							the output.
1262
1263							Additional support is available for a simplified data mode with no
1264							mixed content: newlines are automatically inserted around elements and
1265							elements can optionally be indented based as their nesting level.
1266
1267
1268							=head1 METHODS
1269
1270							=head2 Writing XML
1271
1272							=over 4
1273
1274							=item new([$params])
1275
1276							Create a new XML::Writer object:
1277
1278							my $writer = XML::Writer->new(OUTPUT => $output, NEWLINES => 1);
1279
1280							Arguments are an anonymous hash array of parameters:
1281
1282							=over 4
1283
1284							=item OUTPUT
1285
1286							An object blessed into IO::Handle or one of its subclasses (such as IO::File),
1287							or a reference to a string, or any blessed object that has a print() method;
1288							if this parameter is not present, the module will write to standard output. If
1289							a string reference is passed, it will capture the generated XML (as a string;
1290							to get bytes use the C<Encode> module).
1291
1292							If the string I<self> is passed, the output will be captured internally by the
1293							object, and can be accessed via the C<to_string()> method, or by calling the
1294							object in a string context.
1295
1296							my $writer = XML::Writer->new( OUTPUT => 'self' );
1297
1298							$writer->dataElement( hello => 'world' );
1299
1300							print $writer->to_string; # outputs <hello>world</hello>
1301							print "$writer"; # ditto
1302
1303							=item NAMESPACES
1304
1305							A true (1) or false (0, undef) value; if this parameter is present and
1306							its value is true, then the module will accept two-member array
1307							reference in the place of element and attribute names, as in the
1308							following example:
1309
1310							my $rdfns = "http://www.w3.org/1999/02/22-rdf-syntax-ns#";
1311							my $writer = XML::Writer->new(NAMESPACES => 1);
1312							$writer->startTag([$rdfns, "Description"]);
1313
1314							The first member of the array is a namespace URI, and the second part
1315							is the local part of a qualified name. The module will automatically
1316							generate appropriate namespace declarations and will replace the URI
1317							part with a prefix.
1318
1319							=item PREFIX_MAP
1320
1321							A hash reference; if this parameter is present and the module is
1322							performing namespace processing (see the NAMESPACES parameter), then
1323							the module will use this hash to look up preferred prefixes for
1324							namespace URIs:
1325
1326
1327							my $rdfns = "http://www.w3.org/1999/02/22-rdf-syntax-ns#";
1328							my $writer = XML::Writer->new(NAMESPACES => 1,
1329							PREFIX_MAP => {$rdfns => 'rdf'});
1330
1331							The keys in the hash table are namespace URIs, and the values are the
1332							associated prefixes. If there is not a preferred prefix for the
1333							namespace URI in this hash, then the module will automatically
1334							generate prefixes of the form "__NS1", "__NS2", etc.
1335
1336							To set the default namespace, use '' for the prefix.
1337
1338							=item FORCED_NS_DECLS
1339
1340							An array reference; if this parameter is present, the document element
1341							will contain declarations for all the given namespace URIs.
1342							Declaring namespaces in advance is particularly useful when a large
1343							number of elements from a namespace are siblings, but don't share a direct
1344							ancestor from the same namespace.
1345
1346							=item NEWLINES
1347
1348							A true or false value; if this parameter is present and its value is
1349							true, then the module will insert an extra newline before the closing
1350							delimiter of start, end, and empty tags to guarantee that the document
1351							does not end up as a single, long line. If the parameter is not
1352							present, the module will not insert the newlines.
1353
1354							=item UNSAFE
1355
1356							A true or false value; if this parameter is present and its value is
1357							true, then the module will skip most well-formedness error checking.
1358							If the parameter is not present, the module will perform the
1359							well-formedness error checking by default. Turn off error checking at
1360							your own risk!
1361
1362							=item DATA_MODE
1363
1364							A true or false value; if this parameter is present and its value is
1365							true, then the module will enter a special data mode, inserting
1366							newlines automatically around elements and (unless UNSAFE is also
1367							specified) reporting an error if any element has both characters and
1368							elements as content.
1369
1370							=item DATA_INDENT
1371
1372							A numeric value or white space; if this parameter is present, it represents the
1373							indent step for elements in data mode (it will be ignored when not in
1374							data mode). If it is white space it will be repeated for each level of
1375							indentation.
1376
1377							=item ENCODING
1378
1379							A character encoding to use for the output; currently this must be one of
1380							'utf-8' or 'us-ascii'.
1381							If present, it will be used for the underlying character encoding and as the
1382							default in the XML declaration.
1383							All character data should be passed as Unicode strings when an encoding is
1384							set.
1385
1386							=item CHECK_PRINT
1387
1388							A true or false value; if this parameter is present and its value is
1389							true, all prints to the underlying output will be checked for success. Failures
1390							will cause a croak rather than being ignored.
1391
1392							=back
1393
1394							=item end()
1395
1396							Finish creating an XML document. This method will check that the
1397							document has exactly one document element, and that all start tags are
1398							closed:
1399
1400							$writer->end();
1401
1402							If I<OUTPUT> as been set to I<self>, C<end()> will return the generated
1403							document as well.
1404
1405							=item xmlDecl([$encoding, $standalone])
1406
1407							Add an XML declaration to the beginning of an XML document. The
1408							version will always be "1.0". If you provide a non-null encoding or
1409							standalone argument, its value will appear in the declaration (any
1410							non-null value for standalone except 'no' will automatically be
1411							converted to 'yes'). If not given here, the encoding will be taken from the
1412							ENCODING argument. Pass the empty string to suppress this behaviour.
1413
1414							$writer->xmlDecl("UTF-8");
1415
1416							=item doctype($name, [$publicId, $systemId])
1417
1418							Add a DOCTYPE declaration to an XML document. The declaration must
1419							appear before the beginning of the root element. If you provide a
1420							publicId, you must provide a systemId as well, but you may provide
1421							just a system ID by passing 'undef' for the publicId.
1422
1423							$writer->doctype("html");
1424
1425							=item comment($text)
1426
1427							Add a comment to an XML document. If the comment appears outside the
1428							document element (either before the first start tag or after the last
1429							end tag), the module will add a carriage return after it to improve
1430							readability. In data mode, comments will be treated as empty tags:
1431
1432							$writer->comment("This is a comment");
1433
1434							=item pi($target [, $data])
1435
1436							Add a processing instruction to an XML document:
1437
1438							$writer->pi('xml-stylesheet', 'href="style.css" type="text/css"');
1439
1440							If the processing instruction appears outside the document element
1441							(either before the first start tag or after the last end tag), the
1442							module will add a carriage return after it to improve readability.
1443
1444							The $target argument must be a single XML name. If you provide the
1445							$data argument, the module will insert its contents following the
1446							$target argument, separated by a single space.
1447
1448							=item startTag($name [, $aname1 => $value1, ...])
1449
1450							Add a start tag to an XML document. Any arguments after the element
1451							name are assumed to be name/value pairs for attributes: the module
1452							will escape all '&', '<', '>', and '"' characters in the attribute
1453							values using the predefined XML entities:
1454
1455							$writer->startTag('doc', 'version' => '1.0',
1456							'status' => 'draft',
1457							'topic' => 'AT&T');
1458
1459							All start tags must eventually have matching end tags.
1460
1461							=item emptyTag($name [, $aname1 => $value1, ...])
1462
1463							Add an empty tag to an XML document. Any arguments after the element
1464							name are assumed to be name/value pairs for attributes (see startTag()
1465							for details):
1466
1467							$writer->emptyTag('img', 'src' => 'portrait.jpg',
1468							'alt' => 'Portrait of Emma.');
1469
1470							=item endTag([$name])
1471
1472							Add an end tag to an XML document. The end tag must match the closest
1473							open start tag, and there must be a matching and properly-nested end
1474							tag for every start tag:
1475
1476							$writer->endTag('doc');
1477
1478							If the $name argument is omitted, then the module will automatically
1479							supply the name of the currently open element:
1480
1481							$writer->startTag('p');
1482							$writer->endTag();
1483
1484							=item dataElement($name, $data [, $aname1 => $value1, ...])
1485
1486							Print an entire element containing only character data. This is
1487							equivalent to
1488
1489							$writer->startTag($name [, $aname1 => $value1, ...]);
1490							$writer->characters($data);
1491							$writer->endTag($name);
1492
1493							=item characters($data)
1494
1495							Add character data to an XML document. All '<', '>', and '&'
1496							characters in the $data argument will automatically be escaped using
1497							the predefined XML entities:
1498
1499							$writer->characters("Here is the formula: ");
1500							$writer->characters("a < 100 && a > 5");
1501
1502							You may invoke this method only within the document element
1503							(i.e. after the first start tag and before the last end tag).
1504
1505							In data mode, you must not use this method to add whitespace between
1506							elements.
1507
1508							=item raw($data)
1509
1510							Print data completely unquoted and unchecked to the XML document. For
1511							example C<raw('<')> will print a literal < character. This
1512							necessarily bypasses all well-formedness checking, and is therefore
1513							only available in unsafe mode.
1514
1515							This can sometimes be useful for printing entities which are defined
1516							for your XML format but the module doesn't know about, for example
1517							for XHTML.
1518
1519							=item cdata($data)
1520
1521							As C<characters()> but writes the data quoted in a CDATA section, that
1522							is, between <![CDATA[ and ]]>. If the data to be written itself
1523							contains ]]>, it will be written as several consecutive CDATA
1524							sections.
1525
1526							=item cdataElement($name, $data [, $aname1 => $value1, ...])
1527
1528							As C<dataElement()> but the element content is written as one or more
1529							CDATA sections (see C<cdata()>).
1530
1531							=item setOutput($output)
1532
1533							Set the current output destination, as in the OUTPUT parameter for the
1534							constructor.
1535
1536							=item getOutput()
1537
1538							Return the current output destination, as in the OUTPUT parameter for
1539							the constructor.
1540
1541							=item setDataMode($mode)
1542
1543							Enable or disable data mode, as in the DATA_MODE parameter for the
1544							constructor.
1545
1546							=item getDataMode()
1547
1548							Return the current data mode, as in the DATA_MODE parameter for the
1549							constructor.
1550
1551							=item setDataIndent($step)
1552
1553							Set the indent step for data mode, as in the DATA_INDENT parameter for
1554							the constructor.
1555
1556							=item getDataIndent()
1557
1558							Return the indent step for data mode, as in the DATA_INDENT parameter
1559							for the constructor.
1560
1561
1562							=back
1563
1564							=head2 Querying XML
1565
1566							=over 4
1567
1568							=item in_element($name)
1569
1570							Return a true value if the most recent open element matches $name:
1571
1572							if ($writer->in_element('dl')) {
1573							$writer->startTag('dt');
1574							} else {
1575							$writer->startTag('li');
1576							}
1577
1578							=item within_element($name)
1579
1580							Return a true value if any open element matches $name:
1581
1582							if ($writer->within_element('body')) {
1583							$writer->startTag('h1');
1584							} else {
1585							$writer->startTag('title');
1586							}
1587
1588							=item current_element()
1589
1590							Return the name of the currently open element:
1591
1592							my $name = $writer->current_element();
1593
1594							This is the equivalent of
1595
1596							my $name = $writer->ancestor(0);
1597
1598							=item ancestor($n)
1599
1600							Return the name of the nth ancestor, where $n=0 for the current open
1601							element.
1602
1603							=back
1604
1605
1606							=head2 Additional Namespace Support
1607
1608							As of 0.510, these methods may be used while writing a document.
1609
1610							=over 4
1611
1612							=item addPrefix($uri, $prefix)
1613
1614							Add a preferred mapping between a Namespace URI and a prefix. See
1615							also the PREFIX_MAP constructor parameter.
1616
1617							To set the default namespace, omit the $prefix parameter or set it to
1618							''.
1619
1620							=item removePrefix($uri)
1621
1622							Remove a preferred mapping between a Namespace URI and a prefix.
1623
1624							=item forceNSDecl($uri)
1625
1626							Indicate that a namespace declaration for this URI should be included
1627							with the next element to be started.
1628
1629							=back
1630
1631
1632							=head1 ERROR REPORTING
1633
1634							With the default settings, the XML::Writer module can detect several
1635							basic XML well-formedness errors:
1636
1637							=over 4
1638
1639							=item *
1640
1641							Lack of a (top-level) document element, or multiple document elements.
1642
1643							=item *
1644
1645							Unclosed start tags.
1646
1647							=item *
1648
1649							Misplaced delimiters in the contents of processing instructions or
1650							comments.
1651
1652							=item *
1653
1654							Misplaced or duplicate XML declaration(s).
1655
1656							=item *
1657
1658							Misplaced or duplicate DOCTYPE declaration(s).
1659
1660							=item *
1661
1662							Mismatch between the document type name in the DOCTYPE declaration and
1663							the name of the document element.
1664
1665							=item *
1666
1667							Mismatched start and end tags.
1668
1669							=item *
1670
1671							Attempts to insert character data outside the document element.
1672
1673							=item *
1674
1675							Duplicate attributes with the same name.
1676
1677							=back
1678
1679							During Namespace processing, the module can detect the following
1680							additional errors:
1681
1682							=over 4
1683
1684							=item *
1685
1686							Attempts to use PI targets or element or attribute names containing a
1687							colon.
1688
1689							=item *
1690
1691							Attempts to use attributes with names beginning "xmlns".
1692
1693							=back
1694
1695							To ensure full error detection, a program must also invoke the end
1696							method when it has finished writing a document:
1697
1698							$writer->startTag('greeting');
1699							$writer->characters("Hello, world!");
1700							$writer->endTag('greeting');
1701							$writer->end();
1702
1703							This error reporting can catch many hidden bugs in Perl programs that
1704							create XML documents; however, if necessary, it can be turned off by
1705							providing an UNSAFE parameter:
1706
1707							my $writer = XML::Writer->new(OUTPUT => $output, UNSAFE => 1);
1708
1709							=head2 PRINTING OUTPUT
1710
1711							If I<OUTPUT> has been set to I<self> and the object has been called in
1712							a string context, it'll return the xml document.
1713
1714							=over 4
1715
1716							=item to_string
1717
1718							If I<OUTPUT> has been set to I<self>, calls an implicit C<end()> on the
1719							document and prints it. Dies if I<OUTPUT> has been set to anything else.
1720
1721							=back
1722
1723							=head1 AUTHOR
1724
1725							David Megginson E<lt>david@megginson.comE<gt>
1726
1727
1728							=head1 COPYRIGHT AND LICENSE
1729
1730							Copyright (c) 1999 by Megginson Technologies.
1731
1732							Copyright (c) 2003 Ed Avis E<lt>ed@membled.comE<gt>
1733
1734							Copyright (c) 2004-2010 Joseph Walton E<lt>joe@kafsemo.orgE<gt>
1735
1736							Redistribution and use in source and compiled forms, with or without
1737							modification, are permitted under any circumstances. No warranty.
1738
1739							=head1 SEE ALSO
1740
1741							XML::Parser
1742
1743							=cut
1744