Commits

Toby Inkster committed 4806500

print_xml feature

Comments (0)

Files changed (4)

lib/XML/LibXML/PrettyPrint.pm

 }
 
 use Carp 0 qw(croak carp);
+use IO::Handle 0 qw();
 use Scalar::Util 0 qw(blessed refaddr);
-use XML::LibXML 1.62 qw();
+use XML::LibXML 1.62 qw(:ns);
+
+use base qw(Pragmatic);
+
+BEGIN
+{
+	our %PRAGMATA = (
+		io => sub {
+					*IO::Handle::print_xml = sub ($$;$)
+					{
+						my ($handle, $xml, $indent) = @_;
+						unless (blessed($xml))
+						{
+							local $@ = undef;
+							eval { $xml = XML::LibXML->new->parse_string($xml); 1; }
+								or croak("Could not parse XML: $@");
+						}
+						$indent //= 0;
+						$handle->print(__PACKAGE__->pretty_print($xml, $indent)->toString);
+					};
+				},
+		);
+	our @EXPORT      = qw();
+	our @EXPORT_OK   = qw(print_xml);
+	our %EXPORT_TAGS = ();
+}
 
 our $Whitespace = qr/[\x20\t\r\n]/; # @@TODO need to check XML spec
 
 	
 	$self->strip_whitespace($node);
 	$self->indent($node, $indent_level);
+	return $node;
 }
 
 sub _run_checks
 	my ($self, $node) = @_;
 	$self = $self->_ensure_self;
 
-	return undef unless blessed($node) && $node->isa('XML::LibXML::Element');
+	return undef unless blessed($node); 
+	return TRUE if $node->nodeName eq '#comment';
+	return TRUE if $node->isa('XML::LibXML::PI');
+	
 	return TRUE if $self->_run_checks(preserves_whitespace => $node);
-	return FALSE;
+	
+	return TRUE
+		if $node->isa('XML::LibXML::Element')
+		&& $node->hasAttributeNS(XML_XML_NS, 'space')
+		&& lc $node->getAttributeNS(XML_XML_NS, 'space') eq 'preserve'; 
+	
+	return FALSE if $node->isa('XML::LibXML::Element');
+	return undef;
+}
+
+sub print_xml ($;$)
+{
+	my ($xml, $indent) = @_;
+	unless (blessed($xml))
+	{
+		local $@ = undef;
+		eval { $xml = XML::LibXML->new->parse_string($xml); 1; }
+			or croak("Could not parse XML: $@");
+	}
+	$indent //= 0;
+	print __PACKAGE__->pretty_print($xml, $indent)->toString;
 }
 
 TRUE;
 characters are replaced with a single space. Whitespace is not changed
 within an element that preserves whitespace.
 
+The node is modified in place.
+
 =item C<< indent($node, $level) >>
 
 Indents the node to a certain indentation level, and its direct children to
 C<< $level + 1 >>, grandchildren to C<< $level + 2 >>, etc. Typically you'd
 just want to indent the root node to level 0.
 
-Elements that preserve whitespace are not touched.
+The node is modified in place.
+
+Elements that preserve whitespace are not changed.
 
 =item C<< pretty_print($node, $level) >>
 
-Strip whitespace and indent.
+Strip whitespace and indent. The node is modified in place and returned.
+
+Example use as a class method:
+
+ print XML::LibXML::PrettyPrint
+   ->pretty_print(XML::LibXML->new->parse_string($XML))
+   ->toString;
 
 =item C<< indent_string($level) >>
 
 
 =back
 
+=head2 Functions
+
+=over
+
+=item C<< print_xml $xml >>
+
+Given an XML string or an XML::LibXML::Node object, prints it nicely.
+
+This function is not exported by default, but can be requested:
+
+ use XML::LibXML::PrettyPrint 0.001 qw(print_xml);
+
+Use like this:
+
+ print_xml '<foo> <bar> </bar> </foo>';
+
+=item C<< IO::Handle::print_xml($handle, $xml) >>
+
+Partly experimental, partly mental. You can enable this feature like this:
+
+ use XML::LibXML::PrettyPrint 0.001 qw(-io);
+
+And that will allow stuff like this to work:
+
+ open LOG, '>mylog.xml';
+ print_xml LOG '<foo> <bar> </bar> </foo>';
+ close LOG;
+
+ open my $log, '>otherlog.xml';
+ print_xml $log '<foo> <bar> </bar> </foo>';
+ close $log;
+
+ print_xml STDERR '<foo> <bar> </bar> </foo>';
+
+=back
+
 =head1 ELEMENT CATEGORIES
 
 There are three categories of element: inline, block and compact.
 dist:project :release dist:v_0-001 .
 dist:v_0-001
 	a               :Version ;
-	dc:issued       "2011-10-19"^^xsd:date ;
+	dc:issued       "2011-10-20"^^xsd:date ;
 	:revision       "0.001"^^xsd:string ;
 	:file-release   <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/XML-LibXML-PrettyPrint-0.001.tar.gz> ;
 	rdfs:label      "Initial release" .

meta/makefile.ttl

 	:version_from _:main ;
 	:readme_from _:main ;
 	:test_requires "Test::More 0.61" ;
-	:requires "Scalar::Util" , "common::sense" .
+	:requires 
+		"Scalar::Util" ,
+		"Carp" ,
+		"IO::Handle" ,
+		"XML::LibXML 1.62" ,
+		"common::sense" .
 
 _:main <http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#fileName> "lib/XML/LibXML/PrettyPrint.pm" .
 
+use Test::More tests => 3;
+use XML::LibXML::PrettyPrint 0.001 qw(-io);
+
+my $FN = 'print_xml.tmp';
+
+SKIP: {
+	open FILE, '>', $FN
+		or skip "cannot write to temporary file.", 1;
+	print_xml FILE '<foo>  <bar>  </bar>  </foo>';
+	close FILE;
+
+	my $contents = do { open my $fh, $FN; local $/ = <$fh>; };
+
+	is($contents, <<'DATA', 'print_xml works with bareword handle');
+<?xml version="1.0"?>
+<foo>
+	<bar/>
+</foo>
+DATA
+
+	unlink $FN;
+}
+
+SKIP: {
+	open my $file, '>', $FN
+		or skip "cannot write to temporary file.", 1;
+	print_xml $file '<foo>  <bar>  </bar>  </foo>';
+	close $file;
+
+	my $contents = do { open my $fh, $FN; local $/ = <$fh>; };
+
+	is($contents, <<'DATA', 'print_xml works with lexical handle');
+<?xml version="1.0"?>
+<foo>
+	<bar/>
+</foo>
+DATA
+
+	unlink $FN;
+}
+
+SKIP: {
+	open my $file, '>', $FN
+		or skip "cannot write to temporary file.", 1;
+	$file->print_xml('<foo>  <bar>  </bar>  </foo>');
+	close $file;
+
+	my $contents = do { open my $fh, $FN; local $/ = <$fh>; };
+
+	is($contents, <<'DATA', 'print_xml works as method with lexical handle');
+<?xml version="1.0"?>
+<foo>
+	<bar/>
+</foo>
+DATA
+
+	unlink $FN;
+}
+