File Coverage

blib/lib/Class/XSConstructor.pm

Criterion	Covered	Total	%
statement	82	89	92.1
branch	23	32	71.8
condition	5	12	41.6
subroutine	14	15	93.3
pod	0	3	0.0
total	124	151	82.1

use 5.008008;
use strict;
use warnings;
use XSLoader ();

package Class::XSConstructor;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.008';

use Exporter::Tiny 1.000000 qw( mkopt );
use Ref::Util 0.100 qw( is_plain_arrayref is_plain_hashref is_blessed_ref is_coderef );
use List::Util 1.45 qw( uniq );

sub import {
	my $class  = shift;
	my $caller = our($SETUP_FOR) || caller;

	if (our $REDEFINE) {
		no warnings 'redefine';
		install_constructor("$caller\::new");
	}
	else {
		install_constructor("$caller\::new");
	}
	inheritance_stuff($caller);

	my ($HAS, $REQUIRED, $ISA, $BUILDALL) = get_vars($caller);
	$$BUILDALL = undef;

	for my $pair (@{ mkopt \@_ }) {
		my ($name, $thing) = @$pair;
		my %spec;

		if (is_plain_arrayref($thing)) {
			%spec = @$thing;
		}
		elsif (is_plain_hashref($thing)) {
			%spec = %$thing;
		}
		elsif (is_blessed_ref($thing) and $thing->can('compiled_check')) {
			%spec = (isa => $thing->compiled_check);
		}
		elsif (is_blessed_ref($thing) and $thing->can('check')) {
			# Support it for compatibility with more basic Type::API::Constraint
			# implementations, but this will be slowwwwww!
			%spec = (isa => sub { !! $thing->check($_[0]) });
		}
		elsif (is_coderef($thing)) {
			%spec = (isa => $thing);
		}
		elsif (defined $thing) {
			Exporter::Tiny::_croak("What is %s???", $thing);
		}

		if ($name =~ /\A(.*)\!\z/) {
			$name = $1;
			$spec{required} = !!1;
		}

		my @unknown_keys = sort grep !/\A(isa|required|is)\z/, keys %spec;
		if (@unknown_keys) {
			Exporter::Tiny::_croak("Unknown keys in spec: %d", join ", ", @unknown_keys);
		}

		push @$HAS, $name;
		push @$REQUIRED, $name if $spec{required};
		$ISA->{$name} = $spec{isa} if $spec{isa};
	}
}

sub get_vars {
	my $caller = shift;
	no strict 'refs';
	(
		\@{"$caller\::__XSCON_HAS"},
		\@{"$caller\::__XSCON_REQUIRED"},
		\%{"$caller\::__XSCON_ISA"},
		\${"$caller\::__XSCON_BUILD"},
	);
}

sub inheritance_stuff {
	my $caller = shift;

	require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" );

	my @isa = reverse @{ mro::get_linear_isa($caller) };
	pop @isa;  # discard $caller itself
	return unless @isa;

	my ($HAS, $REQUIRED, $ISA) = get_vars($caller);
	foreach my $parent (@isa) {
		my ($pHAS, $pREQUIRED, $pISA) = get_vars($parent);
		@$HAS      = uniq(@$HAS, @$pHAS);
		@$REQUIRED = uniq(@$REQUIRED, @$pREQUIRED);
		$ISA->{$_} = $pISA->{$_} for keys %$pISA;
	}
}

sub populate_build {
	my $caller = ref($_[0]) || $_[0];
	my (undef, undef, undef, $BUILDALL) = get_vars($caller);

	if (!$caller->can('BUILD')) {
		$$BUILDALL = 0;
		return;
	}

	require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" );
	no strict 'refs';

	$$BUILDALL  = [
		map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
		map { "$_\::BUILD" } reverse @{ mro::get_linear_isa($caller) }
	];

	return;
}

__PACKAGE__->XSLoader::load($VERSION);

1;

__END__