File Coverage

blib/lib/XML/Writer.pm

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

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
5							# Copyright (c) 2004-2010 Joseph Walton
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		217066	use strict;
	3					4
	3					42
15	3			3		6	use vars qw($VERSION);
	3					2
	3					59
16	3			3		9	use Carp;
	3					5
	3					73
17	3			3		340	use IO::Handle;
	3					4446
	3					75
18							$VERSION = "0.900";
19
20	3			3		403	use overload '""' => \&_overload_string;
	3					1074
	3					9
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	330			330	1	66588	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	330	100				311	if ($params{NAMESPACES}) {
43	159					111	delete $params{NAMESPACES};
44	159					181	return XML::Writer::Namespaces->new(%params);
45							}
46
47							# Set up $self and basic parameters
48	171					107	my $self;
49							my $output;
50	171					109	my $unsafe = $params{UNSAFE};
51	171					105	my $newlines = $params{NEWLINES};
52	171					89	my $dataMode = $params{DATA_MODE};
53	171					98	my $dataIndent;
54							my $selfcontained_output;
55	171					84	my $use_selfcontained_output = 0;
56
57							# If the NEWLINES parameter is specified,
58							# set the $nl variable appropriately
59	171					96	my $nl = '';
60	171	100				121	if ($newlines) {
61	1					0	$nl = "\n";
62							}
63
64	171		100			323	my $outputEncoding = $params{ENCODING} \|\| "";
65	171					99	my ($checkUnencodedRepertoire, $escapeEncoding);
66	171	100				160	if (lc($outputEncoding) eq 'us-ascii') {
67	15					10	$checkUnencodedRepertoire = \&_croakUnlessASCII;
68	15					10	$escapeEncoding = \&_escapeASCII;
69							} else {
70	156			366		252	my $doNothing = sub {};
71	156					81	$checkUnencodedRepertoire = $doNothing;
72	156					102	$escapeEncoding = $doNothing;
73							}
74
75							# Parse variables
76	171					104	my @elementStack = ();
77	171					101	my $elementLevel = 0;
78	171					74	my %seen = ();
79
80	171					98	my $hasData = 0;
81	171					81	my @hasDataStack = ();
82	171					88	my $hasElement = 0;
83	171					74	my @hasElementStack = ();
84	171					94	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	187			187		110	my $atts = $_[0];
91	187					93	my $i = 1;
92	187					154	while ($atts->[$i]) {
93	72					73	my $aname = $atts->[$i++];
94	72					55	my $value = _escapeLiteral($atts->[$i++]);
95	72					53	$value =~ s/\x0a/\ \;/g;
96	72					42	$value =~ s/\x0d/\ \;/g;
97	72					47	$value =~ s/\x09/\ \;/g;
98	72					32	&{$escapeEncoding}($value);
	72					53
99	72					77	$output->print(" $aname=\"$value\"");
100							}
101	171					265	};
102
103							# Method implementations: the SAFE_
104							# versions perform error checking
105							# and then call the regular ones.
106							my $end = sub {
107	89			89		77	$output->print("\n");
108
109	89	100	100			213	return $selfcontained_output
110							if $use_selfcontained_output and defined wantarray;
111	171					178	};
112
113							my $SAFE_end = sub {
114	81	100		81		83	if (!$seen{ELEMENT}) {
		100
115	1					68	croak("Document cannot end without a document element");
116							} elsif ($elementLevel > 0) {
117	1					77	croak("Document ended with unmatched start tag(s): @elementStack");
118							} else {
119	79					38	@elementStack = ();
120	79					50	$elementLevel = 0;
121	79					59	%seen = ();
122	79					38	&{$end};
	79					57
123							}
124	171					198	};
125
126							my $xmlDecl = sub {
127	22			22		20	my ($encoding, $standalone) = (@_);
128	22	100	100			20	if ($standalone && $standalone ne 'no') {
129	1					1	$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				17	if (!defined($encoding)) {
136	18					11	$encoding = $outputEncoding;
137							}
138	22					26	$output->print("
139	21	100				58	if ($encoding) {
140	7					9	$output->print(" encoding=\"$encoding\"");
141							}
142	21	100				25	if ($standalone) {
143	2					3	$output->print(" standalone=\"$standalone\"");
144							}
145	21					21	$output->print("?>\n");
146	21					46	$hasHeading = 1;
147	171					218	};
148
149							my $SAFE_xmlDecl = sub {
150	23	100		23		17	if ($seen{ANYTHING}) {
151	2					82	croak("The XML declaration is not the first thing in the document");
152							} else {
153	21					14	$seen{ANYTHING} = 1;
154	21					15	$seen{XMLDECL} = 1;
155	21					7	&{$xmlDecl};
	21					16
156							}
157	171					172	};
158
159							my $pi = sub {
160	8			8		6	my ($target, $data) = (@_);
161	8	100				6	if ($data) {
162	3					4	$output->print("");
163							} else {
164	5					6	$output->print("");
165							}
166	8	100				23	if ($elementLevel == 0) {
167	7					6	$output->print("\n");
168	7					18	$hasHeading = 1;
169							}
170	171					218	};
171
172							my $SAFE_pi = sub {
173	11			11		10	my ($name, $data) = (@_);
174	11					8	$seen{ANYTHING} = 1;
175	11	100	100			20	if (($name =~ /^xml/i) && ($name !~ /^xml-(stylesheet\|model)$/i)) {
176	1					59	carp("Processing instruction target begins with 'xml'");
177							}
178
179	11	100	100			34	if ($name =~ /\?\>/ \|\| (defined($data) && $data =~ /\?\>/)) {
		100	100
180	2					110	croak("Processing instruction may not contain '?>'");
181							} elsif ($name =~ /\s/) {
182	1					53	croak("Processing instruction name may not contain whitespace");
183							} else {
184	8					5	&{$pi};
	8					5
185							}
186	171					200	};
187
188							my $comment = sub {
189	14			14		8	my $data = $_[0];
190	14	100	100			22	if ($dataMode && $elementLevel) {
191	5					3	$output->print("\n");
192	5					12	$output->print($dataIndent x $elementLevel);
193							}
194	14					28	$output->print("");
195	14	100	100			45	if ($dataMode && $elementLevel) {
		100
196	5					4	$hasElement = 1;
197							} elsif ($elementLevel == 0) {
198	8					6	$output->print("\n");
199	8					16	$hasHeading = 1;
200							}
201	171					182	};
202
203							my $SAFE_comment = sub {
204	14			14		7	my $data = $_[0];
205	14	100				24	if ($data =~ /--/) {
206	2					93	carp("Interoperability problem: \"--\" in comment text");
207							}
208
209	14	100				23	if ($data =~ /-->/) {
210	1					36	croak("Comment may not contain '-->'");
211							} else {
212	13					10	&{$checkUnencodedRepertoire}($data);
	13					11
213	12					11	$seen{ANYTHING} = 1;
214	12					4	&{$comment};
	12					14
215							}
216	171					183	};
217
218							my $doctype = sub {
219	10			10		9	my ($name, $publicId, $systemId) = (@_);
220	10					12	$output->print("
221	10	100				32	if ($publicId) {
		100
222	5	100				4	unless ( defined $systemId) {
223	2					138	croak("A DOCTYPE declaration with a public ID must also have a system ID");
224							}
225	3					3	$output->print(" PUBLIC \"$publicId\" \"$systemId\"");
226							} elsif ( defined $systemId ) {
227	2					2	$output->print(" SYSTEM \"$systemId\"");
228							}
229	8					13	$output->print(">\n");
230	8					21	$hasHeading = 1;
231	171					219	};
232
233							my $SAFE_doctype = sub {
234	11			11		7	my $name = $_[0];
235	11	100				11	if ($seen{DOCTYPE}) {
		100
236	1					45	croak("Attempt to insert second DOCTYPE declaration");
237							} elsif ($seen{ELEMENT}) {
238	1					45	croak("The DOCTYPE declaration must come before the first start tag");
239							} else {
240	9					4	$seen{ANYTHING} = 1;
241	9					8	$seen{DOCTYPE} = $name;
242	9					3	&{$doctype};
	9					8
243							}
244	171					174	};
245
246							my $startTag = sub {
247	107			107		53	my $name = $_[0];
248	107	100	100			140	if ($dataMode && ($hasHeading \|\| $elementLevel)) {
			100
249	29					26	$output->print("\n");
250	29					75	$output->print($dataIndent x $elementLevel);
251							}
252	107					97	$elementLevel++;
253	107					63	push @elementStack, $name;
254	107					149	$output->print("<$name");
255	106					256	&{$showAttributes}(\@_);
	106					93
256	106					175	$output->print("$nl>");
257	106	100				258	if ($dataMode) {
258	43					22	$hasElement = 1;
259	43					26	push @hasDataStack, $hasData;
260	43					21	$hasData = 0;
261	43					24	push @hasElementStack, $hasElement;
262	43					39	$hasElement = 0;
263							}
264	171					199	};
265
266							my $SAFE_startTag = sub {
267	104			104		65	my $name = $_[0];
268
269	104					88	_croakUnlessValidName($name);
270	104					66	&{$checkUnencodedRepertoire}($name);
	104					82
271	104					103	_checkAttributes(\@_, $checkUnencodedRepertoire);
272
273	104	100	100			327	if ($seen{ELEMENT} && $elementLevel == 0) {
		100	100
		100	100
			100
274	1					57	croak("Attempt to insert start tag after close of document element");
275							} elsif ($elementLevel == 0 && $seen{DOCTYPE} && $name ne $seen{DOCTYPE}) {
276							croak("Document element is \"$name\", but DOCTYPE is \""
277							. $seen{DOCTYPE}
278	1					49	. "\"");
279							} elsif ($dataMode && $hasData) {
280	2					100	croak("Mixed content not allowed in data mode: element $name");
281							} else {
282	100					73	$seen{ANYTHING} = 1;
283	100					58	$seen{ELEMENT} = 1;
284	100					51	&{$startTag};
	100					60
285							}
286	171					219	};
287
288							my $emptyTag = sub {
289	81			81		50	my $name = $_[0];
290	81	100	100			82	if ($dataMode && ($hasHeading \|\| $elementLevel)) {
			100
291	18					16	$output->print("\n");
292	18					40	$output->print($dataIndent x $elementLevel);
293							}
294	81					137	$output->print("<$name");
295	81					187	&{$showAttributes}(\@_);
	81					53
296	81					142	$output->print("$nl />");
297	81	100				185	if ($dataMode) {
298	19					17	$hasElement = 1;
299							}
300	171					200	};
301
302							my $SAFE_emptyTag = sub {
303	93			93		57	my $name = $_[0];
304
305	93					79	_croakUnlessValidName($name);
306	88					43	&{$checkUnencodedRepertoire}($name);
	88					68
307	86					81	_checkAttributes(\@_, $checkUnencodedRepertoire);
308
309	80	100	100			283	if ($seen{ELEMENT} && $elementLevel == 0) {
		100	100
		100	100
			100
310	1					50	croak("Attempt to insert empty tag after close of document element");
311							} elsif ($elementLevel == 0 && $seen{DOCTYPE} && $name ne $seen{DOCTYPE}) {
312							croak("Document element is \"$name\", but DOCTYPE is \""
313							. $seen{DOCTYPE}
314	1					57	. "\"");
315							} elsif ($dataMode && $hasData) {
316	1					51	croak("Mixed content not allowed in data mode: element $name");
317							} else {
318	77					47	$seen{ANYTHING} = 1;
319	77					39	$seen{ELEMENT} = 1;
320	77					37	&{$emptyTag};
	77					46
321							}
322	171					204	};
323
324							my $endTag = sub {
325	82			82		36	my $name = $_[0];
326	82					52	my $currentName = pop @elementStack;
327	82	100				72	$name = $currentName unless $name;
328	82					37	$elementLevel--;
329	82	100	100			89	if ($dataMode && $hasElement) {
330	20					18	$output->print("\n");
331	20					45	$output->print($dataIndent x $elementLevel);
332							}
333	82					117	$output->print("");
334	82	100				190	if ($dataMode) {
335	36					22	$hasData = pop @hasDataStack;
336	36					26	$hasElement = pop @hasElementStack;
337							}
338	171					209	};
339
340							my $SAFE_endTag = sub {
341	77			77		46	my $name = $_[0];
342	77					57	my $oldName = $elementStack[$#elementStack];
343	77	100	100			146	if ($elementLevel <= 0) {
		100
344	1					53	croak("End tag \"$name\" does not close any open element");
345							} elsif ($name && ($name ne $oldName)) {
346	1					107	croak("Attempt to end element \"$oldName\" with \"$name\" tag");
347							} else {
348	75					32	&{$endTag};
	75					51
349							}
350	171					185	};
351
352							my $characters = sub {
353	41			41		27	my $data = $_[0];
354	41	100				33	if ($data =~ /[\&\<\>]/) {
355	1					2	$data =~ s/\&/\&\;/g;
356	1					2	$data =~ s/\
357	1					1	$data =~ s/\>/\>\;/g;
358							}
359	41					28	&{$escapeEncoding}($data);
	41					27
360	41					49	$output->print($data);
361	41					87	$hasData = 1;
362	171					186	};
363
364							my $SAFE_characters = sub {
365	43	100	100	43		58	if ($elementLevel < 1) {
		100
366	1					53	croak("Attempt to insert characters outside of document element");
367							} elsif ($dataMode && $hasElement) {
368	1					46	croak("Mixed content not allowed in data mode: characters");
369							} else {
370	41					42	_croakUnlessDefinedCharacters($_[0]);
371	39					24	&{$characters};
	39					28
372							}
373	171					166	};
374
375							my $raw = sub {
376	1			1		1	$output->print($_[0]);
377							# Don't set $hasData or any other information: we know nothing
378							# about what was just written.
379							#
380	171					144	};
381
382							my $SAFE_raw = sub {
383	1			1		46	croak('raw() is only available when UNSAFE is set');
384	171					144	};
385
386							my $cdata = sub {
387	10			10		6	my $data = $_[0];
388	10					8	$data =~ s/\]\]>/\]\]\]\]>/g;
389	10					13	$output->print("");
390	10					23	$hasData = 1;
391	171					169	};
392
393							my $SAFE_cdata = sub {
394	11	100	100	11		18	if ($elementLevel < 1) {
		100
395	1					47	croak("Attempt to insert characters outside of document element");
396							} elsif ($dataMode && $hasElement) {
397	1					44	croak("Mixed content not allowed in data mode: characters");
398							} else {
399	9					8	_croakUnlessDefinedCharacters($_[0]);
400	8					4	&{$checkUnencodedRepertoire}($_[0]);
	8					7
401	7					3	&{$cdata};
	7					5
402							}
403	171					190	};
404
405							# Assign the correct closures based on
406							# the UNSAFE parameter
407	171	100				141	if ($unsafe) {
408	10					22	$self = {'END' => $end,
409							'XMLDECL' => $xmlDecl,
410							'PI' => $pi,
411							'COMMENT' => $comment,
412							'DOCTYPE' => $doctype,
413							'STARTTAG' => $startTag,
414							'EMPTYTAG' => $emptyTag,
415							'ENDTAG' => $endTag,
416							'CHARACTERS' => $characters,
417							'RAW' => $raw,
418							'CDATA' => $cdata
419							};
420							} else {
421	161					368	$self = {'END' => $SAFE_end,
422							'XMLDECL' => $SAFE_xmlDecl,
423							'PI' => $SAFE_pi,
424							'COMMENT' => $SAFE_comment,
425							'DOCTYPE' => $SAFE_doctype,
426							'STARTTAG' => $SAFE_startTag,
427							'EMPTYTAG' => $SAFE_emptyTag,
428							'ENDTAG' => $SAFE_endTag,
429							'CHARACTERS' => $SAFE_characters,
430							'RAW' => $SAFE_raw, # This will intentionally fail
431							'CDATA' => $SAFE_cdata
432							};
433							}
434
435							# Query methods
436							$self->{'IN_ELEMENT'} = sub {
437	1			1		1	my ($ancestor) = (@_);
438	1					2	return $elementStack[$#elementStack] eq $ancestor;
439	171					225	};
440
441							$self->{'WITHIN_ELEMENT'} = sub {
442	3			3		1	my ($ancestor) = (@_);
443	3					3	my $el;
444	3					2	foreach $el (@elementStack) {
445	4	100				5	return 1 if $el eq $ancestor;
446							}
447	1					1	return 0;
448	171					274	};
449
450							$self->{'CURRENT_ELEMENT'} = sub {
451	1			1		2	return $elementStack[$#elementStack];
452	171					170	};
453
454							$self->{'ANCESTOR'} = sub {
455	5			5		1	my ($n) = (@_);
456	5	100				6	if ($n < scalar(@elementStack)) {
457	3					5	return $elementStack[$#elementStack-$n];
458							} else {
459	2					4	return undef;
460							}
461	171					179	};
462
463							# Set and get the output destination.
464							$self->{'GETOUTPUT'} = sub {
465	7	100		7		6	if (ref($output) ne 'XML::Writer::_PrintChecker') {
466	4					7	return $output;
467							} else {
468	3					4	return $output->{HANDLE};
469							}
470	171					170	};
471
472							$self->{'SETOUTPUT'} = sub {
473	177			177		105	my $newOutput = $_[0];
474
475	177	100	100			282	if (defined($newOutput) && !ref($newOutput)) {
476	3	100				5	if ('self' eq $newOutput ) {
477	2					1	$newOutput = \$selfcontained_output;
478	2					3	$use_selfcontained_output = 1;
479							} else {
480	1					37	die "Output must be a handle, a reference or 'self'";
481							}
482							}
483
484	176	100				149	if (ref($newOutput) eq 'SCALAR') {
485	7					9	$output = XML::Writer::_String->new($newOutput);
486							} else {
487							# If there is no OUTPUT parameter,
488							# use standard output
489	169		100			156	$output = $newOutput \|\| \*STDOUT;
490	169	100	100			192	if ($outputEncoding && (ref($output) eq 'GLOB' \|\| $output->isa('IO::Handle'))) {
			100
491	21	100				24	if (lc($outputEncoding) eq 'utf-8') {
		100
492	4					17	binmode($output, ':encoding(utf-8)');
493							} elsif (lc($outputEncoding) eq 'us-ascii') {
494	1			1		2	binmode($output, ':encoding(us-ascii)');
	1					1
	1					2
	15					60
495							} else {
496	2					77	die 'The only supported encodings are utf-8 and us-ascii';
497							}
498							}
499							}
500
501	174	100				8181	if ($params{CHECK_PRINT}) {
502	6					5	$output = XML::Writer::_PrintChecker->new($output);
503							}
504	171					218	};
505
506							$self->{OVERLOADSTRING} = sub {
507							# if we don't use the self-contained output,
508							# simple passthrough
509	5	100		5		19	return $use_selfcontained_output ? $selfcontained_output : undef;
510	171					180	};
511
512							$self->{TOSTRING} = sub {
513	3	100		3		11	die "'to_string' can only be used with self-contained output\n"
514							unless $use_selfcontained_output;
515
516	1					1	return $selfcontained_output;
517	171					174	};
518
519							$self->{'SETDATAMODE'} = sub {
520	7			7		4	$dataMode = $_[0];
521	171					163	};
522
523							$self->{'GETDATAMODE'} = sub {
524	2			2		2	return $dataMode;
525	171					179	};
526
527							$self->{'SETDATAINDENT'} = sub {
528	179	100		179		290	if ($_[0] =~ /^\s*$/) {
529	169					124	$dataIndent = $_[0];
530							} else {
531	10					17	$dataIndent = ' ' x $_[0];
532							}
533	171					188	};
534
535							$self->{'GETDATAINDENT'} = sub {
536	8	100		8		9	if ($dataIndent =~ /^ *$/) {
537	7					12	return length($dataIndent);
538							} else {
539	1					1	return $dataIndent;
540							}
541	171					166	};
542
543							# Set the indent.
544	171		100			310	&{$self->{'SETDATAINDENT'}}($params{'DATA_INDENT'} \|\| '');
	171					183
545
546							# Set the output.
547	171					96	&{$self->{'SETOUTPUT'}}($params{'OUTPUT'});
	171					141
548
549							# Return the blessed object.
550	168					994	return bless $self, $class;
551							}
552
553
554
555							########################################################################
556							# Public methods
557							########################################################################
558
559							#
560							# Finish writing the document.
561							#
562							sub end {
563	91			91	1	468	my $self = shift;
564	91					43	&{$self->{END}};
	91					66
565							}
566
567							#
568							# Write an XML declaration.
569							#
570							sub xmlDecl {
571	24			24	1	172	my $self = shift;
572	24					10	&{$self->{XMLDECL}};
	24					21
573							}
574
575							#
576							# Write a processing instruction.
577							#
578							sub pi {
579	12			12	1	30	my $self = shift;
580	12					7	&{$self->{PI}};
	12					8
581							}
582
583							#
584							# Write a comment.
585							#
586							sub comment {
587	16			16	1	28	my $self = shift;
588	16					10	&{$self->{COMMENT}};
	16					11
589							}
590
591							#
592							# Write a DOCTYPE declaration.
593							#
594							sub doctype {
595	12			12	1	33	my $self = shift;
596	12					5	&{$self->{DOCTYPE}};
	12					11
597							}
598
599							#
600							# Write a start tag.
601							#
602							sub startTag {
603	111			111	1	185	my $self = shift;
604	111					52	&{$self->{STARTTAG}};
	111					94
605							}
606
607							#
608							# Write an empty tag.
609							#
610							sub emptyTag {
611	102			102	1	218	my $self = shift;
612	102					49	&{$self->{EMPTYTAG}};
	102					83
613							}
614
615							#
616							# Write an end tag.
617							#
618							sub endTag {
619	84			84	1	105	my $self = shift;
620	84					39	&{$self->{ENDTAG}};
	84					55
621							}
622
623							#
624							# Write a simple data element.
625							#
626							sub dataElement {
627	21			21	1	270	my ($self, $name, $data, @atts) = (@_);
628	21					27	$self->startTag($name, @atts);
629	21					18	$self->characters($data);
630	21					20	$self->endTag($name);
631							}
632
633							#
634							# Write a simple CDATA element.
635							#
636							sub cdataElement {
637	1			1	1	5	my ($self, $name, $data, %atts) = (@_);
638	1					1	$self->startTag($name, %atts);
639	1					1	$self->cdata($data);
640	1					1	$self->endTag($name);
641							}
642
643							#
644							# Write character data.
645							#
646							sub characters {
647	45			45	1	53	my $self = shift;
648	45					25	&{$self->{CHARACTERS}};
	45					39
649							}
650
651							#
652							# Write raw, unquoted, completely unchecked character data.
653							#
654							sub raw {
655	2			2	1	5	my $self = shift;
656	2					1	&{$self->{RAW}};
	2					2
657							}
658
659							#
660							# Write CDATA.
661							#
662							sub cdata {
663	14			14	1	19	my $self = shift;
664	14					8	&{$self->{CDATA}};
	14					7
665							}
666
667							#
668							# Query the current element.
669							#
670							sub in_element {
671	1			1	1	4	my $self = shift;
672	1					1	return &{$self->{IN_ELEMENT}};
	1					1
673							}
674
675							#
676							# Query the ancestors.
677							#
678							sub within_element {
679	3			3	1	5	my $self = shift;
680	3					2	return &{$self->{WITHIN_ELEMENT}};
	3					3
681							}
682
683							#
684							# Get the name of the current element.
685							#
686							sub current_element {
687	1			1	1	5	my $self = shift;
688	1					1	return &{$self->{CURRENT_ELEMENT}};
	1					2
689							}
690
691							#
692							# Get the name of the numbered ancestor (zero-based).
693							#
694							sub ancestor {
695	5			5	1	9	my $self = shift;
696	5					4	return &{$self->{ANCESTOR}};
	5					5
697							}
698
699							#
700							# Get the current output destination.
701							#
702							sub getOutput {
703	7			7	1	123	my $self = shift;
704	7					3	return &{$self->{GETOUTPUT}};
	7					5
705							}
706
707
708							#
709							# Set the current output destination.
710							#
711							sub setOutput {
712	6			6	1	155	my $self = shift;
713	6					4	return &{$self->{SETOUTPUT}};
	6					5
714							}
715
716							#
717							# Set the current data mode (true or false).
718							#
719							sub setDataMode {
720	7			7	1	14	my $self = shift;
721	7					3	return &{$self->{SETDATAMODE}};
	7					7
722							}
723
724
725							#
726							# Get the current data mode (true or false).
727							#
728							sub getDataMode {
729	2			2	1	4	my $self = shift;
730	2					2	return &{$self->{GETDATAMODE}};
	2					3
731							}
732
733
734							#
735							# Set the current data indent step.
736							#
737							sub setDataIndent {
738	8			8	1	8	my $self = shift;
739	8					5	return &{$self->{SETDATAINDENT}};
	8					6
740							}
741
742
743							#
744							# Get the current data indent step.
745							#
746							sub getDataIndent {
747	8			8	1	12	my $self = shift;
748	8					4	return &{$self->{GETDATAINDENT}};
	8					6
749							}
750
751
752							#
753							# Empty stub.
754							#
755				1	1		sub addPrefix {
756							}
757
758
759							#
760							# Empty stub.
761							#
762				1	1		sub removePrefix {
763							}
764
765							sub to_string {
766	3			3	1	641	my $self = shift;
767
768	3					4	$self->{TOSTRING}->();
769							}
770
771
772
773							########################################################################
774							# Private functions.
775							########################################################################
776
777							#
778							# Private: check for duplicate attributes and bad characters.
779							# Note - this starts at $_[1], because $_[0] is assumed to be an
780							# element name.
781							#
782							sub _checkAttributes {
783	190			190		105	my %anames;
784	190					100	my $i = 1;
785	190					91	my $checkUnencodedRepertoire = $_[1];
786
787	190					183	while ($_[0]->[$i]) {
788	73					46	my $name = $_[0]->[$i];
789	73					38	$i += 1;
790	73	100				53	if ($anames{$name}) {
791	2					109	croak("Two attributes named \"$name\"");
792							} else {
793	71					51	$anames{$name} = 1;
794							}
795	71					53	_croakUnlessValidName($name);
796	69					34	&{$checkUnencodedRepertoire}($name);
	69					53
797	68					55	_croakUnlessDefinedCharacters($_[0]->[$i]);
798	67					70	$i += 1;
799							}
800							}
801
802							#
803							# Private: escape an attribute value literal.
804							#
805							sub _escapeLiteral {
806	72			72		40	my $data = $_[0];
807	72	100				56	if ($data =~ /[\&\<\>\"]/) {
808	2					28	$data =~ s/\&/\&\;/g;
809	2					2	$data =~ s/\
810	2					2	$data =~ s/\>/\>\;/g;
811	2					2	$data =~ s/\"/\"\;/g;
812							}
813	72					52	return $data;
814							}
815
816							sub _escapeASCII($) {
817	7			7		8	$_[0] =~ s/([^\x00-\x7F])/sprintf('&#x%X;', ord($1))/ge;
	5					48
818							}
819
820							sub _croakUnlessASCII($) {
821	22	100		22		20	if ($_[0] =~ /[^\x00-\x7F]/) {
822	5					276	croak('Non-ASCII characters are not permitted in this part of a US-ASCII document');
823							}
824							}
825
826							# Enforce XML 1.0, section 2.2's definition of "Char" (only reject low ASCII,
827							# so as not to require Unicode support from perl)
828							sub _croakUnlessDefinedCharacters($) {
829	118	100		118		112	if ($_[0] =~ /([\x00-\x08\x0B-\x0C\x0E-\x1F])/) {
830	4					211	croak(sprintf('Code point \u%04X is not a valid character in XML', ord($1)));
831							}
832							}
833
834							# Ensure element and attribute names are non-empty, contain no whitespace and are
835							# otherwise valid XML names
836							sub _croakUnlessValidName($) {
837	268	100		268		188	if ($_[0] eq '') {
838	2					141	croak('Empty identifiers are not permitted in this part of an XML document');
839							}
840	266	100				265	if ($_[0] =~ /\s/) {
841	4					226	croak('Space characters are not permitted in this part of an XML identifier');
842							}
843
844							# From REC-xml-20081126
845							# [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]
846							# [4a] NameChar ::= NameStartChar \| "-" \| "." \| [0-9] \| #xB7 \| [#x0300-#x036F] \| [#x203F-#x2040]
847							# [5] Name ::= NameStartChar (NameChar)*
848
849	262	100				313	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}]*$/) {
850	1					50	croak('Not a valid XML name: '.$_[0]);
851							}
852
853							# ":" \| [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]
854
855							# \| "-" \| "." \| [0-9] \| #xB7 \| [#x0300-#x036F] \| [#x203F-#x2040]
856							}
857
858							sub _overload_string {
859	5			5		478	my $self = shift;
860	5	100				5	$self->{OVERLOADSTRING}->() \|\| overload::StrVal($self);
861							}
862
863							########################################################################
864							# XML::Writer::Namespaces - subclass for Namespace processing.
865							########################################################################
866
867							package XML::Writer::Namespaces;
868	3			3		5358	use strict;
	3					3
	3					34
869	3			3		6	use vars qw(@ISA);
	3					3
	3					47
870	3			3		5	use Carp;
	3					3
	3					2276
871
872							@ISA = qw(XML::Writer);
873
874							#
875							# Constructor
876							#
877							sub new {
878	159			159		143	my ($class, %params) = (@_);
879
880	159					114	my $unsafe = $params{UNSAFE};
881
882							# Snarf the prefix map, if any, and
883							# note the default prefix.
884	159					83	my %prefixMap = ();
885	159	100				126	if ($params{PREFIX_MAP}) {
886	8					6	%prefixMap = (%{$params{PREFIX_MAP}});
	8					11
887	8					6	delete $params{PREFIX_MAP};
888							}
889	159					125	$prefixMap{'http://www.w3.org/XML/1998/namespace'} = 'xml';
890
891							# Generate the reverse map for URIs
892	159					99	my $uriMap = {};
893	159					86	my $key;
894	159					176	foreach $key (keys(%prefixMap)) {
895	168					197	$uriMap->{$prefixMap{$key}} = $key;
896							}
897
898	159					114	my $defaultPrefix = $uriMap->{''};
899	159	100				133	delete $prefixMap{$defaultPrefix} if ($defaultPrefix);
900
901							# Create an instance of the parent.
902	159					143	my $self = XML::Writer->new(%params);
903
904							# Snarf the parent's methods that we're
905							# going to override.
906	156					160	my $OLD_startTag = $self->{STARTTAG};
907	156					82	my $OLD_emptyTag = $self->{EMPTYTAG};
908	156					89	my $OLD_endTag = $self->{ENDTAG};
909
910							# State variables
911	156					69	my @stack;
912	156					90	my $prefixCounter = 1;
913	156					138	my $nsDecls = {'http://www.w3.org/XML/1998/namespace' => 'xml'};
914	156					68	my $nsDefaultDecl = undef;
915	156					96	my $nsCopyFlag = 0;
916	156					69	my @forcedNSDecls = ();
917
918	156	100				128	if ($params{FORCED_NS_DECLS}) {
919	2					1	@forcedNSDecls = @{$params{FORCED_NS_DECLS}};
	2					2
920	2					2	delete $params{FORCED_NS_DECLS};
921							}
922
923							#
924							# Push the current declaration state.
925							#
926							my $pushState = sub {
927	194			194		201	push @stack, [$nsDecls, $nsDefaultDecl, $nsCopyFlag, $uriMap];
928	194					120	$nsCopyFlag = 0;
929	156					175	};
930
931
932							#
933							# Pop the current declaration state.
934							#
935							my $popState = sub {
936	150			150		64	($nsDecls, $nsDefaultDecl, $nsCopyFlag, $uriMap) = @{pop @stack};
	150					238
937	156					157	};
938
939							#
940							# Generate a new prefix.
941							#
942							my $genPrefix = sub {
943	34			34		21	my $uri = $_[0];
944	34					11	my $prefixCounter = 1;
945	34					24	my $prefix = $prefixMap{$uri};
946	34					14	my %clashMap = %{$uriMap};
	34					44
947	34					46	while( my ($u, $p) = each(%prefixMap)) {
948	45					54	$clashMap{$p} = $u;
949							}
950
951	34	100				30	if (!defined($prefix)) {
952							do {
953	36					29	$prefix = "__NS$prefixCounter";
954	36					29	$prefixCounter++;
955	24					13	} while ($clashMap{$prefix});
956							}
957
958	34					34	return $prefix;
959	156					187	};
960
961							#
962							# Perform namespace processing on a single name.
963							#
964							my $processName = sub {
965	71			71		50	my ($nameref, $atts, $attFlag) = (@_);
966	71					43	my ($uri, $local) = @{$$nameref};
	71					52
967	71					48	my $prefix = $nsDecls->{$uri};
968
969							# Is this an element name that matches
970							# the default NS?
971	71	100	100			154	if (!$attFlag && $defaultPrefix && ($uri eq $defaultPrefix)) {
		100	100
972	17	100	100			23	unless ($nsDefaultDecl && ($nsDefaultDecl eq $uri)) {
973	12					4	push @{$atts}, 'xmlns';
	12					11
974	12					7	push @{$atts}, $uri;
	12					6
975	12					8	$nsDefaultDecl = $uri;
976							}
977	17					10	$$nameref = $local;
978
979	17	100				14	if (defined($uriMap->{''})) {
980	9					9	delete ($nsDecls->{$uriMap->{''}});
981							}
982
983	17					13	$nsDecls->{$uri} = '';
984	17	100				10	unless ($nsCopyFlag) {
985	16					11	$uriMap = {%{$uriMap}};
	16					18
986	16					9	$nsDecls = {%{$nsDecls}};
	16					17
987	16					12	$nsCopyFlag = 1;
988							}
989	17					13	$uriMap->{''} = $uri;
990
991							# Is there a straight-forward prefix?
992							} elsif ($prefix) {
993	20					19	$$nameref = "$prefix:$local";
994							} else {
995	34					19	$prefix = &{$genPrefix}($uri);
	34					18
996	34	100				27	unless ($nsCopyFlag) {
997	30					15	$uriMap = {%{$uriMap}};
	30					30
998	30					18	$nsDecls = {%{$nsDecls}};
	30					28
999	30					18	$nsCopyFlag = 1;
1000							}
1001	34					26	$uriMap->{$prefix} = $uri;
1002	34					24	$nsDecls->{$uri} = $prefix;
1003	34					16	push @{$atts}, "xmlns:$prefix";
	34					44
1004	34					22	push @{$atts}, $uri;
	34					20
1005	34					43	$$nameref = "$prefix:$local";
1006							}
1007	156					264	};
1008
1009
1010							#
1011							# Perform namespace processing on element and attribute names.
1012							#
1013							my $nsProcess = sub {
1014	194	100		194		168	if (ref($_[0]->[0]) eq 'ARRAY') {
1015	54					32	my $x = \@{$_[0]->[0]};
	54					37
1016	54					37	&{$processName}(\$x, $_[0], 0);
	54					43
1017	54					27	splice(@{$_[0]}, 0, 1, $x);
	54					58
1018							}
1019	194					93	my $i = 1;
1020	194					153	while ($_[0]->[$i]) {
1021	74	100				67	if (ref($_[0]->[$i]) eq 'ARRAY') {
1022	14					6	my $x = \@{$_[0]->[$i]};
	14					11
1023	14					10	&{$processName}(\$x, $_[0], 1);
	14					9
1024	14					8	splice(@{$_[0]}, $i, 1, $x);
	14					12
1025							}
1026	74					59	$i += 2;
1027							}
1028
1029							# We do this if any declarations are forced, due either to
1030							# constructor arguments or to a call during processing.
1031	194	100				142	if (@forcedNSDecls) {
1032	3					2	foreach (@forcedNSDecls) {
1033	3					3	my @dummy = ($_, 'dummy');
1034	3					1	my $d2 = \@dummy;
1035	3	100	100			7	if ($defaultPrefix && ($_ eq $defaultPrefix)) {
1036	1					1	&{$processName}(\$d2, $_[0], 0);
	1					0
1037							} else {
1038	2					2	&{$processName}(\$d2, $_[0], 1);
	2					1
1039							}
1040							}
1041	3					3	@forcedNSDecls = ();
1042							}
1043	156					252	};
1044
1045
1046							# Indicate that a namespace should be declared by the next open element
1047							$self->{FORCENSDECL} = sub {
1048	1			1		1	push @forcedNSDecls, $_[0];
1049	156					306	};
1050
1051
1052							#
1053							# Start tag, with NS processing
1054							#
1055							$self->{STARTTAG} = sub {
1056	101			101		65	my $name = $_[0];
1057	101	100				75	unless ($unsafe) {
1058	94					80	_checkNSNames(\@_);
1059							}
1060	101					53	&{$pushState}();
	101					81
1061	101					65	&{$nsProcess}(\@_);
	101					104
1062	101					56	&{$OLD_startTag};
	101					66
1063	156					200	};
1064
1065
1066							#
1067							# Empty tag, with NS processing
1068							#
1069							$self->{EMPTYTAG} = sub {
1070	98	100		98		68	unless ($unsafe) {
1071	94					78	_checkNSNames(\@_);
1072							}
1073	93					44	&{$pushState}();
	93					85
1074	93					56	&{$nsProcess}(\@_);
	93					78
1075	93					52	&{$OLD_emptyTag};
	93					65
1076	78					34	&{$popState}();
	78					55
1077	156					203	};
1078
1079
1080							#
1081							# End tag, with NS processing
1082							#
1083							$self->{ENDTAG} = sub {
1084	74			74		46	my $name = $_[0];
1085	74	100				60	if (ref($_[0]) eq 'ARRAY') {
1086	22					17	my $pfx = $nsDecls->{$_[0]->[0]};
1087	22	100				15	if ($pfx) {
1088	17					15	$_[0] = $pfx . ':' . $_[0]->[1];
1089							} else {
1090	5					4	$_[0] = $_[0]->[1];
1091							}
1092							} else {
1093	52					27	$_[0] = $_[0];
1094							}
1095							# &{$nsProcess}(\@_);
1096	74					35	&{$OLD_endTag};
	74					52
1097	72					43	&{$popState}();
	72					44
1098	156					212	};
1099
1100
1101							#
1102							# Processing instruction, but only if not UNSAFE.
1103							#
1104	156	100				114	unless ($unsafe) {
1105	146					74	my $OLD_pi = $self->{PI};
1106							$self->{PI} = sub {
1107	12			12		7	my $target = $_[0];
1108	12	100				11	if (index($target, ':') >= 0) {
1109	1					70	croak "PI target '$target' contains a colon.";
1110							}
1111	11					9	&{$OLD_pi};
	11					5
1112							}
1113	146					170	};
1114
1115
1116							#
1117							# Add a prefix to the prefix map.
1118							#
1119							$self->{ADDPREFIX} = sub {
1120	18			18		15	my ($uri, $prefix) = (@_);
1121	18	100				16	if ($prefix) {
1122	7					9	$prefixMap{$uri} = $prefix;
1123							} else {
1124	11	100				7	if (defined($defaultPrefix)) {
1125	4					3	delete($prefixMap{$defaultPrefix});
1126							}
1127	11					10	$defaultPrefix = $uri;
1128							}
1129	156					190	};
1130
1131
1132							#
1133							# Remove a prefix from the prefix map.
1134							#
1135							$self->{REMOVEPREFIX} = sub {
1136	3			3		3	my ($uri) = (@_);
1137	3	100	100			45	if ($defaultPrefix && ($defaultPrefix eq $uri)) {
1138	1					1	$defaultPrefix = undef;
1139							}
1140	3					4	delete $prefixMap{$uri};
1141	156					166	};
1142
1143
1144							#
1145							# Bless and return the object.
1146							#
1147	156					8008	return bless $self, $class;
1148							}
1149
1150
1151							#
1152							# Add a preferred prefix for a namespace URI.
1153							#
1154							sub addPrefix {
1155	18			18		45	my $self = shift;
1156	18					12	return &{$self->{ADDPREFIX}};
	18					12
1157							}
1158
1159
1160							#
1161							# Remove a preferred prefix for a namespace URI.
1162							#
1163							sub removePrefix {
1164	3			3		9	my $self = shift;
1165	3					1	return &{$self->{REMOVEPREFIX}};
	3					3
1166							}
1167
1168
1169							#
1170							# Check names.
1171							#
1172							sub _checkNSNames {
1173	188			188		97	my $names = $_[0];
1174	188					84	my $i = 1;
1175	188					117	my $name = $names->[0];
1176
1177							# Check the element name.
1178	188	100				201	if (ref($name) eq 'ARRAY') {
		100
1179	55	100				50	if (index($name->[1], ':') >= 0) {
1180	1					48	croak("Local part of element name '" .
1181							$name->[1] .
1182							"' contains a colon.");
1183							}
1184							} elsif (index($name, ':') >= 0) {
1185	1					51	croak("Element name '$name' contains a colon.");
1186							}
1187
1188							# Check the attribute names.
1189	186					172	while ($names->[$i]) {
1190	29					15	my $name = $names->[$i];
1191	29	100				25	if (ref($name) eq 'ARRAY') {
1192	13					6	my $local = $name->[1];
1193	13	100				14	if (index($local, ':') >= 0) {
1194	1					51	croak "Local part of attribute name '$local' contains a colon.";
1195							}
1196							} else {
1197	16	100				22	if ($name =~ /^xmlns/) {
		100
1198	1					75	croak "Attribute name '$name' begins with 'xmlns'";
1199							} elsif (index($name, ':') >= 0) {
1200	1					52	croak "Attribute name '$name' contains ':'";
1201							}
1202							}
1203	26					29	$i += 2;
1204							}
1205							}
1206
1207							sub forceNSDecl
1208							{
1209	1			1		2	my $self = shift;
1210	1					1	return &{$self->{FORCENSDECL}};
	1					1
1211							}
1212
1213
1214							package XML::Writer::_String;
1215
1216							# Internal class, behaving sufficiently like an IO::Handle,
1217							# that stores written output in a string
1218							#
1219							# Heavily inspired by Simon Oliver's XML::Writer::String
1220
1221							sub new
1222							{
1223	7			7		5	my $class = shift;
1224	7					4	my $scalar_ref = shift;
1225	7					7	return bless($scalar_ref, $class);
1226							}
1227
1228							sub print
1229							{
1230	43			43		18	${(shift)} .= join('', @_);
	43					34
1231	43					26	return 1;
1232							}
1233
1234
1235							package XML::Writer::_PrintChecker;
1236
1237	3			3		9	use Carp;
	3					2
	3					173
1238
1239							sub new
1240							{
1241	6			6		3	my $class = shift;
1242	6					6	return bless({HANDLE => shift}, $class);
1243							}
1244
1245							sub print
1246							{
1247	4			4		0	my $self = shift;
1248	4	100				6	if ($self->{HANDLE}->print(shift)) {
1249	2					5	return 1;
1250							} else {
1251	2					93	croak "Failed to write output: $!";
1252							}
1253							}
1254
1255							1;
1256							__END__