File Coverage

blib/lib/XML/LibXML/PrettyPrint.pm

Criterion	Covered	Total	%
statement	27	29	93.1
branch			n/a
condition			n/a
subroutine	10	10	100.0
pod			n/a
total	37	39	94.8

package XML::LibXML::PrettyPrint;

use 5.010;
use common::sense;
use constant { FALSE => 0, TRUE => 1 };
use constant { EL_BLOCK => 1, EL_COMPACT => 2, EL_INLINE => 3};
use utf8;

BEGIN
{
	$XML::LibXML::PrettyPrint::AUTHORITY = 'cpan:TOBYINK';
	$XML::LibXML::PrettyPrint::VERSION   = '0.004';
}

use Carp 0 qw(croak carp);
use IO::Handle 0 qw();
use Scalar::Util 0 qw(blessed refaddr);
use XML::LibXML 1.62 qw(:ns);

use parent 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 EL_BLOCK EL_COMPACT EL_INLINE);
	our %EXPORT_TAGS = (
		'all'       => \@EXPORT_OK,
		'default'   => \@EXPORT,
		'constants' => [qw(EL_BLOCK EL_COMPACT EL_INLINE)],
		);
}

our $Whitespace = qr/[\x20\t\r\n]/; # @@TODO need to check XML spec

sub new
{
	my ($class, %options) = @_;
	$options{element} //= delete $options{elements};
	if (defined $options{indent_string})
	{
		carp("Non-whitespace indent_string supplied")
			unless $options{indent_string} =~ /^$Whitespace*$/
	}
	bless \%options, $class;
}

{
	my @compact = qw[area audio base basefont bgsound br button canvas
	                 caption col command dd details dt embed figcaption
	                 frame h1 h2 h3 h4 h5 h6 hr iframe img input isindex
	                 keygen legend li link meta option p param summary td
	                 th title video];
	my @inline  = qw[a abbr b bdi bdo big cite code dfn em font i kbd label
	                 mark meter nobr progress q rp rt ruby s samp small span
	                 strike strong sub sup time tt u var wbr];
	my @block   = qw[address applet article aside blockquote body center
	                 colgroup datalist del dir div fieldset figure footer
	                 form frameset head header hgroup html ins listing map
	                 marquee menu nav noembed noframes noscript object ol
	                 optgroup select section source table tbody tfoot thead
	                 tr track ul dl];
	my @pre     = qw[plaintext output pre script style textarea xmp];

	my $rdfa_lit_content = sub
	{
		my ($el) = @_;
		return TRUE
			if ($el->hasAttribute('property') and not $el->hasAttribute('content'));
		return undef;
	};

	sub new_for_html
	{
		my ($class, %options) = @_;

		return $class->new(
			%options,
			element => {
				block    => [@block],
				compact  => [@compact],
				inline   => [@inline],
				preserves_whitespace => [@pre, $rdfa_lit_content],
				},
			);
	}
}

sub _ensure_self
{
	blessed($_[0]) ? $_[0] : $_[0]->new;
}

sub strip_whitespace
{
	my ($self, $node) = @_;
	$self = $self->_ensure_self;

	croak("First parameter must be an XML::LibXML::Node")
		unless blessed($node) && $node->isa('XML::LibXML::Node');

	if ($node->nodeName eq '#document')
	{
		return $self->strip_whitespace($node->documentElement);
	}
	elsif ($node->isa('XML::LibXML::Element'))
	{
		if ($self->element_preserves_whitespace($node))
		{
			return 0;
		}

		my $node_category = $self->element_category($node);

		$node->normalize;
		my @kids = $node->childNodes;
		my $activity = 0;

		for (my $i = 0; exists $kids[$i]; $i++)
		{
			my $kid  = $kids[$i];

			if ($kid->nodeName eq '#text')
			{
				my $prev = exists $kids[$i-1] ? $kids[$i-1] : undef;
				my $next = exists $kids[$i+1] ? $kids[$i+1] : undef;
				my $data = $kid->data;

				if ((defined $prev and $self->element_category($prev)==EL_INLINE)
				or  ($node_category==EL_INLINE and not defined $prev))
					{ $data =~ s/^$Whitespace+/ /; }
				else
					{ $data =~ s/^$Whitespace+//; }

				if ((defined $next and $self->element_category($next)==EL_INLINE)
				or  ($node_category==EL_INLINE and not defined $next))
					{ $data =~ s/$Whitespace+$/ /; }
				else
					{ $data =~ s/$Whitespace+$//; }

				$data =~ s/$Whitespace+/ /g;

				$activity++ if length $data ne length $kid->data;
				$node->removeChild($kid) unless length $data;
				$kid->setData($data);
			}
			else
			{
				$activity += $self->strip_whitespace($kid);
			}
		}

		return $activity;
	}
	else
	{
		carp(sprintf("Don't know how to handle %s object", ref $node))
			unless $node->nodeName eq '#comment'
			||     $node->isa('XML::LibXML::CDATASection')
			||     $node->isa('XML::LibXML::PI');
		return 0;
	}
}

sub indent
{
	my ($self, $node, $indent_level) = @_;
	$self = $self->_ensure_self;

	$indent_level //= 0;

	$self->indent($node->documentElement, $indent_level)
		if blessed($node) && $node->nodeName eq '#document';

	return unless blessed($node) && $node->isa('XML::LibXML::Element');

	return if $self->element_preserves_whitespace($node);

	my $node_category = $self->element_category($node);

	# EL_COMPACT nodes get treated as inline unless they contain a
	# block descendent.
	if ($node_category==EL_COMPACT)
	{
		$node_category = EL_INLINE;
		my $descs = $node->getElementsByTagName('*');
		DESC: while (my $desc = $descs->shift)
		{
			if ($self->element_category($desc) == EL_BLOCK)
			{
				$node_category = EL_BLOCK;
				last DESC;
			}
		}
	}

	if ($node_category==EL_BLOCK)
	{
		my $newline       = $self->new_line;
		my $indent_string = $self->indent_string($indent_level + 1);

		my @kids = $node->childNodes;
		$node->removeChildNodes;
		for (my $i = 0; exists $kids[$i]; $i++)
		{
			my $kid  = $kids[$i];
			my $did_indent = FALSE;

			if ($i==0)
			{
				$node->appendText($newline . $indent_string);
				$did_indent = TRUE;
			}
			elsif ($self->element_category($kid)==EL_BLOCK)
			{
				$node->appendText($newline . $indent_string);
				$did_indent = TRUE;
			}
			elsif ($self->element_category($kid)==EL_COMPACT)
			{
				$node->appendText($newline . $indent_string);
				$did_indent = TRUE;
			}
			elsif (defined $kids[$i-1])
			{
				my $prev_category = $self->element_category($kids[$i-1]);
				if (defined $prev_category
				and ($prev_category==EL_BLOCK or $prev_category==EL_COMPACT))
				{
					$node->appendText($newline . $indent_string);
					$did_indent = TRUE;
				}
			}

			if ($did_indent and $kid->nodeName eq '#text')
			{
				(my $data = $kid->data) =~ s/^ //;
				$kid->setData($data);
			}
			$node->appendChild($kid);
			$self->indent($kid, $indent_level + 1);
		}
		$node->appendText($newline . $self->indent_string($indent_level)) if @kids;
	}
}

sub pretty_print
{
	my ($self, $node, $indent_level) = @_;
	$self = $self->_ensure_self;

	$self->strip_whitespace($node);
	$self->indent($node, $indent_level);
	return $node;
}

sub _run_checks
{
	my ($self, $category, $node) = @_;

	return FALSE unless defined $self->{element}{$category};

	if (ref $self->{element}{$category} eq 'CODE'
	or !ref $self->{element}{$category})
	{
		$self->{element}{$category} = [$self->{element}{$category}];
	}

	if (ref $self->{element}{$category} eq 'ARRAY')
	{
		foreach my $check (@{$self->{element}{$category}})
		{
			if (!ref $check and $check =~ /^\{(.+)\}(.+)$/)
			{
				return TRUE if $node->namespaceURI eq $1 && $node->localname eq $2;
			}
			elsif (!ref $check)
			{
				return TRUE if $check eq $node->nodeName;
			}
			elsif (ref $check eq 'CODE')
			{
				my $return = $check->($node);
				return $return if defined $return;
			}
			else
			{
				carp(sprintf("Check for category '%s' ignored; is of type %s", $category, ref $check));
			}
		}
	}

	return FALSE;
}

sub indent_string
{
	my ($self, $level) = @_;
	$self = $self->_ensure_self;

	return ($self->{indent_string} // "\t") x $level;
}

sub new_line
{
	my ($self, $level) = @_;
	$self = $self->_ensure_self;

	return $self->{new_line} // "\n";
}

sub element_category
{
	my ($self, $node) = @_;
	$self = $self->_ensure_self;

	return undef unless blessed($node);

	return EL_BLOCK   if $self->_run_checks(block => $node);
	return EL_COMPACT if $self->_run_checks(compact => $node);
	return EL_INLINE  if $self->_run_checks(inline => $node);

	return EL_BLOCK   if $node->isa('XML::LibXML::Element');
	return EL_COMPACT if $node->nodeName eq '#comment';
	return EL_COMPACT if $node->isa('XML::LibXML::PI');

	return undef;
}

sub element_preserves_whitespace
{
	my ($self, $node) = @_;
	$self = $self->_ensure_self;

	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 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;

__END__