File Coverage

blib/lib/Types/LoadableClass.pm

Criterion	Covered	Total	%
statement	24	24	100.0
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	32	32	100.0

use 5.006001;
use strict;
use warnings;

package Types::LoadableClass;

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

use Type::Library
	-base,
	-declare => qw(
		ModuleName LoadableClass LoadableRole
		ClassIsa ClassDoes ClassCan
	);

use Type::Utils -all;
use Types::Standard qw( StrMatch RoleName );

use Module::Runtime qw($module_name_rx is_module_name);
use Class::Load qw(load_optional_class is_class_loaded);

declare ModuleName,
	as StrMatch[ qr/\A$module_name_rx\z/ ],
	message {
		"'$_' is not a valid module name";
	};

declare LoadableClass,
	as ModuleName,
	where {
		load_optional_class($_)
	}
	inline_as {
		(undef, "Class::Load::load_optional_class($_)");
	}
	message {
		ModuleName->validate($_) or "'$_' could not be loaded";
	};

declare LoadableRole,
	as intersection([ LoadableClass, RoleName ]),
	message {
		LoadableClass->validate($_) or "'$_' is not a loadable role";
	};

declare ClassIsa,
	as LoadableClass,
	constraint_generator => sub {
		my @bases = @_ or return ClassIsa;
		return sub {
			$_[0]->isa($_) && return !!1 for @bases;
			return !!0;
		};
	},
	inline_generator => sub {
		my @bases = @_;
		return sub {
			my $var = $_[1];
			return (
				undef,
				sprintf(
					'(%s)',
					join(
						' or ',
						map(sprintf('%s->isa(%s)', $var, B::perlstring($_)), @bases),
					),
				),
			);
		};
	};

declare ClassDoes,
	as LoadableClass,
	constraint_generator => sub {
		my @roles = @_ or return ClassDoes;
		return sub {
			$_[0]->DOES($_) || return !!0 for @roles;
			return !!1;
		};
	},
	inline_generator => sub {
		my @roles = @_;
		return sub {
			my $var = $_[1];
			return (
				undef,
				sprintf(
					'do { my $method = %s->can("DOES")||%s->can("isa"); %s } ',
					$var,
					$var,
					join(
						' and ',
						map(sprintf('%s->$method(%s)', $var, B::perlstring($_)), @roles),
					),
				),
			);
		};
	};

declare ClassCan,
	as LoadableClass,
	constraint_generator => sub {
		my @methods = @_ or return ClassCan;
		return sub {
			$_[0]->can($_) || return !!0 for @methods;
			return !!1;
		};
	},
	inline_generator => sub {
		my @methods = @_;
		return sub {
			my $var = $_[1];
			return (
				undef,
				map(sprintf('%s->can(%s)', $var, B::perlstring($_)), @methods),
			);
		};
	};

__PACKAGE__->meta->add_coercion({
	name               => 'ExpandPrefix',
	type_constraint    => ModuleName,
	coercion_generator => sub {
		my ($self, $target, $prefix) = @_;
		Types::TypeTiny::StringLike->assert_valid($prefix);
		return (
			StrMatch[qr{\A-.+}],
			qq{ do { (my \$tmp = \$_) =~ s{\\A-}{$prefix\::}; \$tmp } },
		);
	}
});

1;

__END__