File Coverage

blib/lib/XML/LibXML/Augment.pm

Criterion	Covered	Total	%
statement	25	27	92.5
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	34	36	94.4

package XML::LibXML::Augment;

use 5.010;
use strict;
use warnings;

use Carp qw//;
use Class::Inspector;
use match::simple qw/match/;
use Module::Runtime qw/module_notional_filename/;
use Scalar::Util qw/blessed/;
use XML::LibXML 1.95 qw/:libxml/;

my %Delegates;

BEGIN
{
	$XML::LibXML::Augment::AUTHORITY = 'cpan:TOBYINK';
	$XML::LibXML::Augment::VERSION   = '0.003';

	no strict 'refs';
	no warnings 'once';

	my @_CLASSES = qw/
		Node Document DocumentFragment Element Attr
		Text CDATASection Comment Dtd PI NodeList
	/;

	# It would be nice to not need to include this block,
	# but it's currently necessary for Dist::Inkt and the
	# PAUSE indexer...
	{
		package XML::LibXML::Augment::Node;
		package XML::LibXML::Augment::Document;
		package XML::LibXML::Augment::DocumentFragment;
		package XML::LibXML::Augment::Element;
		package XML::LibXML::Augment::Attr;
		package XML::LibXML::Augment::Text;
		package XML::LibXML::Augment::CDATASection;
		package XML::LibXML::Augment::Comment;
		package XML::LibXML::Augment::Dtd;
		package XML::LibXML::Augment::PI;
		package XML::LibXML::Augment::NodeList;
	}

	foreach my $class (@_CLASSES)
	{
		if (match $class, [qw/Comment CDATASection/])
		{
			# Comment and CDATASection inherit from Text
			push @{"XML::LibXML::Augment::${class}::ISA"},
				"XML::LibXML::Augment::Text";
		}
		elsif ($class ne 'Node' and $class ne 'NodeList')
		{
			# Everything inherits from Node
			push @{"XML::LibXML::Augment::${class}::ISA"},
				"XML::LibXML::Augment::Node";
		}

		# Inherit from XML::LibXML counterpart
		push @{"XML::LibXML::Augment::${class}::ISA"},
			"XML::LibXML::${class}";

		# $AUTHORITY and $VERSION
		${"XML::LibXML::Augment::${class}::AUTHORITY"} =
			$XML::LibXML::Augment::AUTHORITY;
		${"XML::LibXML::Augment::${class}::VERSION"} =
			$XML::LibXML::Augment::VERSION;

		# Trick "use".
		$INC{ module_notional_filename("XML::LibXML::Augment::${class}") }
			= __FILE__;

		# Create &rebless.
		my $our_rebless = sprintf('%s::%s::%s', __PACKAGE__, $class, 'rebless');
		*$our_rebless = sub
		{
			my $self = bless $_[1], $_[0];
			if (my $onbless = $self->can('BLESS'))
			{
				$self->$onbless;
			}
			return $self;
		};

		# Create stub functions mirroring the superclass.
		my $our_handler = sprintf('%s::%s', __PACKAGE__, '_handler');
		my $functions   = Class::Inspector->functions('XML::LibXML::'.$class);
		foreach my $fname (@$functions)
		{
			next if $fname =~ /^(_|DESTROY|AUTOLOAD)/;
			my $our_qname   = sprintf('%s::%s::%s', __PACKAGE__, $class, $fname);
			*$our_qname     = sub { unshift @_, $class, $fname; goto \&{$our_handler} };
		}
	}
}

sub import
{
	my ($class, %args) = @_;

	my $caller  = caller;
	my $type    = ucfirst lc(delete($args{'-type'}) || 'Element');
	my $names   = delete($args{'-names'});
	my $isa     = delete($args{'-isa'})
		|| ["XML::LibXML::Augment::$type"];

	if (keys %args)
	{
		my $args = join q{, }, map {"'$_'"} sort keys %args;
		Carp::croak(__PACKAGE__." does not support args: $args");
	}

	Carp::croak("-type argument must be 'Element', 'Attr' or 'Document'")
		unless match $type, [qw/Attr Document Element/];

	foreach my $n (@$names)
	{
		if (ref $Delegates{$type}{$n} eq 'ARRAY')
		{
			push @{ $Delegates{$type}{$n} }, $caller;
		}
		elsif (defined $Delegates{$type}{$n})
		{
			$Delegates{$type}{$n} = [$Delegates{$type}{$n}, $caller];
		}
		else
		{
			$Delegates{$type}{$n} = $caller;
		}
	}

	no strict 'refs';
	push @{"$caller\::ISA"}, @$isa;

	$class;
}

sub rebless
{
	my ($class, $object) = @_;
	my $ideal = $class->ideal_class_for_object($object);
	$ideal->rebless($object) if $ideal;
	return $object;
}

sub ideal_class_for_object
{
	my ($me, $object) = @_;
	return unless ref $object && blessed $object;
	my $nodeType = $object->can('nodeType') && $object->nodeType;
	$nodeType = -1 if $object->isa('XML::LibXML::NodeList');
	return unless $nodeType;

	my $ideal = {
		(-1)                      => 'NodeList',
		(XML_ELEMENT_NODE)        => 'Element',
		(XML_ATTRIBUTE_NODE)      => 'Attr',
		(XML_TEXT_NODE)           => 'Text',
		(XML_CDATA_SECTION_NODE)  => 'CDATASection',
		(XML_PI_NODE)             => 'PI',
		(XML_COMMENT_NODE)        => 'Comment',
		(XML_DOCUMENT_NODE)       => 'Document',
		(XML_DOCUMENT_FRAG_NODE)  => 'DocumentFragment',
		(XML_DTD_NODE)            => 'Dtd',
	}->{$nodeType};

	# This is where we get smart
	if ($ideal eq 'Element' or $ideal eq 'Attr' or $ideal eq 'Document')
	{
		my ($ns, $local);
		if ($ideal eq 'Document')
		{
			$ns = $object->documentElement->namespaceURI // '';
			$ns = sprintf('{%s}', $ns) if length $ns;
			$local = $object->documentElement->localname;
		}
		else
		{
			$ns = $object->namespaceURI // '';
			$ns = sprintf('{%s}', $ns) if length $ns;
			$local = $object->localname;
		}

		foreach my $clark (map { sprintf('%s%s', $ns, $_) } $local, '*')
		{
			if (my $i = $Delegates{$ideal}{$clark})
			{
				$Delegates{$ideal}{$clark} = $me->make_class(@{$i}) if ref $i;
				return $Delegates{$ideal}{$clark};
			}
		}
	}

	return sprintf('%s::%s', __PACKAGE__, $ideal) if defined $ideal;
	return;
}

sub make_class
{
	shift;
	state $COUNT = 0;
	state $NS    = (__PACKAGE__.'::_ANON_::');

	if (scalar @_ == 1)
	{
		return $_[0];
	}

	$COUNT++;
	no strict 'refs';

	my $newpkg = sprintf('%sCLS%04d', $NS, $COUNT);

	my @super;
	foreach my $x (@_)
	{
		if ($x =~ m{ ^ $NS }x)
		{
			push @super, @{"$x\::ISA"};
		}
		else
		{
			push @super, $x;
		}
	}
	@{"$newpkg\::ISA"} = @super;

	my @blesses = map { my $x = $_->can('BLESS'); $x ? ($x) : () } @super;
	*{"$newpkg\::BLESS"} = sub
	{
		my $self = shift;
		$self->$_ foreach @blesses;
	};

	return $newpkg;
}

sub _handler
{
	no strict 'refs';
	my $class   = shift;
	my $sub     = shift;
	my $coderef = "XML::LibXML::$class"->can($sub);

	if (!defined wantarray)
	{
		goto $coderef;
	}

	if (wantarray)
	{
		@_ = $coderef->(@_);
		goto \&upgrade;
	}

	@_ = (my $r = $coderef->(@_));
	goto \&upgrade;
}

sub upgrade
{
	for my $i (0 .. $#_)
	{
		if (blessed($_[$i]) and $_[$i]->isa('XML::LibXML::NodeList'))
		{
			my $me = __PACKAGE__->can('upgrade');
			$_[$i] = $_[$i]->foreach($me);
			next;
		}
		my $ideal = __PACKAGE__->ideal_class_for_object($_[$i]);
		$ideal->rebless($_[$i]) if defined $ideal;
	}

	wantarray ? @_ : $_[0]
}

__PACKAGE__
__END__