File Coverage

lib/Subclass/Of.pm

Criterion	Covered	Total	%
statement	238	273	87.1
branch	75	120	62.5
condition	24	49	48.9
subroutine	41	45	91.1
pod	2	2	100.0
total	380	489	77.7

use 5.008;
use strict;
use warnings;
no strict qw(refs);
no warnings qw(redefine prototype);

package Subclass::Of;

BEGIN {
	$Subclass::Of::AUTHORITY = 'cpan:TOBYINK';
	$Subclass::Of::VERSION   = '0.008';
}

use B qw(perlstring);
use Carp qw(carp croak);
use Module::Runtime qw(use_package_optimistically module_notional_filename);
use List::Util 1.33 qw(all);
use Scalar::Util qw(refaddr blessed weaken);
use Sub::Util qw(set_subname);
use namespace::clean;

our ($SUPER_PKG, $SUPER_SUB, $SUPER_ARG);
our @EXPORT = qw(subclass_of);

my $_v;
sub import
{
	my $me = shift;

	return $me->install(@_, -into => scalar caller) if @_;

	require Exporter::Tiny;
	our @ISA = "Exporter::Tiny";
	@_ = $me;
	goto \&Exporter::Tiny::import;
}

{
	my %i_made_this;
	sub install
	{
		my $me       = shift;
		my $base     = shift or croak "Subclass::Of what?";
		my %opts     = $me->_parse_opts(@_);

		my $caller   = $opts{-into}[0];
		my @aliases  = $opts{-as} ? @{$opts{-as}} : ($base =~ /(\w+)$/);

		my $constant;
		my $subclass;
		if ($opts{-lazy}) {
			my $current_sub;
			$constant = sub () {
				$subclass ||= do {
					my $built = $me->_build_subclass($base, \%opts);
					$i_made_this{refaddr($current_sub)} = $built;
					$built;
				};
			};
			weaken( $current_sub = $constant );
			$i_made_this{refaddr($constant)} = '(unknown package)';
		}
		else {
			$subclass = $me->_build_subclass($base, \%opts);
			$constant = eval sprintf(q/sub () { %s if $] }/, perlstring($subclass));
			$i_made_this{refaddr($constant)} = $subclass;
		}

		for my $a (@aliases)
		{
			if (exists &{"$caller\::$a"})
			{
				my $old = $i_made_this{refaddr(\&{"$caller\::$a"})};
				carp(
					$old
						? "Subclass::Of is overwriting alias '$a'"
							.($old eq '(unknown package)'?"":"; was '$old'")
							.($subclass?"; now '$subclass'":"")
						: "Subclass::Of is overwriting function '$a'",
				);
			}
			*{"$caller\::$a"} = $constant;
		}
		"namespace::clean"->import(-cleanee => $caller, @aliases);
	}

	sub _alias_to_package_name {
		shift unless ref $_[0]; # allow call as class method
		my @r = map $i_made_this{refaddr($_)}, @_;
		croak('_alias_to_package_name(LIST) returns a list')
			if @r != 1 and defined(wantarray) and !wantarray;
		wantarray ? @r : $r[0];
	}
}

sub subclass_of
{
	my $base     = shift or croak "Subclass::Of what?";
	my %opts     = __PACKAGE__->_parse_opts(@_);

	return __PACKAGE__->_build_subclass($base, \%opts);
}

sub _parse_opts
{
	shift;

	if (@_==1 and ref($_[0]) eq q(HASH))
	{
		return %{$_[0]};
	}

	my %opts;
	my $key = undef;
	while (@_)
	{
		$_ = shift;

		if (defined and !ref and /^-/) {
			$key = $_;
			$opts{$key} ||= [];
			next;
		}

		push @{$opts{$key}}, ref eq q(ARRAY) ? @$_ : $_;
	}

	return %opts;
}

{
	my %_detect_oo; # memoize
	sub _detect_oo
	{
		my $pkg = $_[0];

		return $_detect_oo{$pkg} if exists $_detect_oo{$pkg};

		# Use metaclass to determine the OO framework in use.
		#
		return $_detect_oo{$pkg} = ""
			unless $pkg->can("meta");
		return $_detect_oo{$pkg} = "Moo"
			if ref($pkg->meta) eq "Moo::HandleMoose::FakeMetaClass";
		return $_detect_oo{$pkg} = "Mouse"
			if $pkg->meta->isa("Mouse::Meta::Module");
		return $_detect_oo{$pkg} = "Moose"
			if $pkg->meta->isa("Moose::Meta::Class");
		return $_detect_oo{$pkg} = "Moose"
			if $pkg->meta->isa("Moose::Meta::Role");
		return $_detect_oo{$pkg} = "";
	}
}

{
	my %count;
	sub _build_subclass
	{
		my $me = shift;
		my ($parent, $opts) = @_;

		my $child = (
			$opts->{-package} ||= [ sprintf('%s::__SUBCLASS__::%04d', $parent, ++$count{$parent}) ]
		)->[0];

		my $oo = _detect_oo(use_package_optimistically($parent));

		my $subclasser_method = $oo ? lc "_build_subclass_$oo"   : "_build_subclass_raw";
		my $attributes_method = $oo ? lc "_apply_attributes_$oo" : "_apply_attributes_raw";

		$me->$subclasser_method($parent, $child, $opts);
		$me->$attributes_method($child, $opts);
		$me->_apply_methods($child, $opts);
		$me->_apply_roles($child, $opts);

		my $i = 0; $i++ while caller($i) eq __PACKAGE__;
		$INC{module_notional_filename($child)} = (caller($i))[1];

		return $child;
	}
}

sub _build_subclass_moose
{
	my $me = shift;
	my ($parent, $child, $opts) = @_;

#	"Moose::Meta::Class"->initialize($child, superclasses => [$parent]);

	eval sprintf(q{
		package %s;
		use Moose;
		extends %s;
		use namespace::clean;
	}, $child, perlstring($parent));
}

sub _build_subclass_mouse
{
	my $me = shift;
	my ($parent, $child, $opts) = @_;

	eval sprintf(q{
		package %s;
		use Mouse;
		extends %s;
		use namespace::clean;
	}, $child, perlstring($parent));
}

sub _build_subclass_moo
{
	my $me = shift;
	my ($parent, $child, $opts) = @_;

	eval sprintf(q{
		package %s;
		use Moo;
		extends %s;
		use namespace::clean;
	}, $child, perlstring($parent));
}

sub _build_subclass_raw
{
	my $me = shift;
	my ($parent, $child, $opts) = @_;

	@{"$child\::ISA"} = $parent;
}

sub _apply_attributes_moose
{
	my $me = shift;
	my ($child, $opts) = @_;

	return unless $opts->{-has};

	my $meta = $child->meta;
	my $has  = sub { $meta->add_attribute(@_) };

	$me->_apply_attributes_generic($has, $opts);
}

*_apply_attributes_mouse = \&_apply_attributes_moose;

sub _apply_attributes_moo
{
	my $me = shift;
	my ($child, $opts) = @_;

	return unless $opts->{-has};

	my $raw = eval sprintf(q{
		package %s;
		use Moo;
		my $sub = \&has;
		use namespace::clean;
		return $sub;
	}, $child);
	my $has = sub { $raw->($_[0], %{$_[1]}) };

	$me->_apply_attributes_generic($has, $opts);
}

my $fieldhash;
sub _apply_attributes_raw
{
	my $me = shift;
	my ($child, $opts) = @_;

	my $has = sub {
		my ($name, $opts) = @_;
		for my $key (sort keys %$opts)
		{
			croak "Option '$key' in attribute specification not supported"
				unless $key =~ /^(is|isa|default|lazy|fieldhash)$/;
		}
		if (exists $opts->{lazy} and not $opts->{lazy})
		{
			carp "Attribute '$name' will be lazy anyway.";
		}
		if (exists $opts->{is} and $opts->{is} !~ /^(ro|rw|lazy)$/)
		{
			croak "Option 'is' => '$opts->{is}' in attribute specification not supported"
		}
		if (exists $opts->{isa})
		{
			croak "Option 'isa' in attribute specification must be a blessed type constraint object with 'assert_valid' method"
				unless blessed $opts->{isa} && $opts->{isa}->can('assert_valid');
		}

		my $code;
		if (exists $opts->{fieldhash} and $opts->{fieldhash})
		{
			$fieldhash ||= do {
				my $impl;
				$impl ||= eval { require Hash::FieldHash;       'Hash::FieldHash' };
				$impl ||= do   { require Hash::Util::FieldHash; 'Hash::Util::FieldHash' };
				$impl->can('fieldhash');
			};
			my %data;
			$fieldhash->(\%data);

			$code = sub
			{
				my $self = shift;
				if (@_)
				{
					croak "read-only accessor" unless $opts->{is} eq 'rw';
					$opts->{isa}->assert_valid($_[0]) if $opts->{isa};
					$data{$self} = $_[0];
				}
				if (exists $opts->{default} and not exists $self->{$name})
				{
					my $tmp = ref($opts->{default}) eq q(CODE)
						? $opts->{default}->($self)
						: $opts->{default};
					$opts->{isa}->assert_valid($tmp) if $opts->{isa};
					$data{$self} = $tmp;
				}
				$data{$self};
			};
		}
		else
		{
			$code = sub
			{
				my $self = shift;
				if (@_)
				{
					croak "read-only accessor" unless $opts->{is} eq 'rw';
					$opts->{isa}->assert_valid($_[0]) if $opts->{isa};
					$self->{$name} = $_[0];
				}
				if (exists $opts->{default} and not exists $self->{$name})
				{
					my $tmp = ref($opts->{default}) eq q(CODE)
						? $opts->{default}->($self)
						: $opts->{default};
					$opts->{isa}->assert_valid($tmp) if $opts->{isa};
					$self->{$name} = $tmp;
				}
				$self->{$name};
			};
		}

		*{"$child\::$name"} = set_subname("$child\::$name", $code);
	};

	$me->_apply_attributes_generic($has, $opts);
}

sub _apply_attributes_generic
{
	my $me = shift;
	my ($has, $opts) = @_;

	my @attrs = @{ $opts->{-has} || [] };
	while (@attrs)
	{
		my $name = shift(@attrs);
		$name =~ /^\w+/ or croak("Not a valid attribute name: $name");

		my $spec =
			ref($attrs[0]) eq q(ARRAY) ? +{@{shift(@attrs)}} :
			ref($attrs[0]) eq q(HASH)  ? shift(@attrs) :
			ref($attrs[0]) eq q(CODE)  ? { is => "rw", default => shift(@attrs) } :
			{ is => "rw" };

		$has->($name, $spec);
	}
}

sub _apply_methods
{
	my $me = shift;
	my ($pkg, $opts) = @_;

	my $methods = $me->_make_method_hash($pkg, $opts);
	for my $name (sort keys %$methods)
	{
		*{"$pkg\::$name"} = $methods->{$name};
	}
}

sub _apply_roles
{
	my $me = shift;
	my ($pkg, $opts) = @_;
	my @roles = map use_package_optimistically($_), @{ $opts->{-with} || [] };

	return unless @roles;

	# All roles appear to be Role::Tiny; use Role::Tiny to
	# handle composition.
	#
	if (all { _detect_oo($_) eq "" } @roles)
	{
		require Role::Tiny;
		return "Role::Tiny"->apply_roles_to_package($pkg, @roles);
	}

	# Otherwise, role composition is determined by the OO framework
	# of the base class.
	#
	my $oo = _detect_oo($pkg);

	if ($oo eq "Moo")
	{
		return "Moo::Role"->apply_roles_to_package($pkg, @roles);
	}

	if ($oo eq "Moose")
	{
		return Moose::Util::apply_all_roles($pkg, @roles);
	}

	if ($oo eq "Mouse")
	{
		return Mouse::Util::apply_all_roles($pkg, @roles);
	}

	# If all else fails, try using Moo because it understands quite
	# a lot about Moose and Mouse.
	#
	require Moo::Role;
	"Moo::Role"->apply_roles_to_package($pkg, @roles);
}

sub _make_method_hash
{
	shift;

	my $pkg     = $_[0];
	my $r       = {};
	my @methods = @{ $_[1]{-methods} || [] };

	while (@methods)
	{
		my ($name, $code) = splice(@methods, 0, 2);

		$name =~ /^\w+/ or croak("Not a valid method name: $name");
		ref($code) eq q(CODE) or croak("Not a code reference: $code");

		$r->{$name} = set_subname "$pkg\::$name", sub {
			local $SUPER_PKG = $pkg;
			local $SUPER_SUB = $name;
			local $SUPER_ARG = \@_;
			$code->(@_);
		};
	}

	return $r;
}

sub ::SUPER
{
	eval { require mro } or do { require MRO::Compat };

	my ($super) =
		map   { \&{ "$_\::$SUPER_SUB" } }
		grep  { exists &{"$_\::$SUPER_SUB"} }
		grep  { $_ ne $SUPER_PKG }
		@{ mro::get_linear_isa($SUPER_PKG) };

	croak qq[Can't locate object method "$SUPER_SUB" via package "$SUPER_PKG"]
		unless $super;

	@_ = @$SUPER_ARG unless @_;
	goto $super;
}

1;

__END__