File Coverage

blib/lib/Scalar/Does.pm

Criterion	Covered	Total	%
statement	88	95	92.6
branch	24	32	75.0
condition	10	11	90.9
subroutine	25	26	96.1
pod	4	4	100.0
total	151	168	89.8

package Scalar::Does;

use 5.008;
use strict;
use warnings;
use if $] < 5.010, 'UNIVERSAL::DOES';

METADATA:
{
	$Scalar::Does::AUTHORITY = 'cpan:TOBYINK';
	$Scalar::Does::VERSION   = '0.202';
}

UTILITY_CLASS:
{
	package Scalar::Does::RoleChecker;
	$Scalar::Does::RoleChecker::AUTHORITY = 'cpan:TOBYINK';
	$Scalar::Does::RoleChecker::VERSION   = '0.202';
	use base "Type::Tiny";
	sub new {
		my $class = shift;
		my ($name, $coderef);
		for my $p (@_)
		{
			if (Scalar::Does::does($p, 'CODE'))  { $coderef = $p }
			if (Scalar::Does::does($p, 'HASH'))  { $coderef = $p->{where} }
			if (Scalar::Does::does($p, 'Regexp')){ $coderef = sub { $_[0] =~ $p } }
			if (not ref $p)                      { $name    = $p }
		}
		Carp::confess("Cannot make role without checker coderef or regexp") unless $coderef;
		$class->SUPER::new(display_name => $name, constraint => $coderef);
	}
	sub code { shift->constraint };
}

PRIVATE_STUFF:
{
	sub _lu {
		require lexical::underscore;
		goto \&lexical::underscore;
	}

	use constant MISSING_ROLE_MESSAGE => (
		"Please supply a '-role' argument when exporting custom functions, died"
	);

	use Carp 0 qw( confess );
	use Types::Standard 0.004 qw( -types );
}

use namespace::clean 0.19;

DEFINE_CONSTANTS:
{
	our %_CONSTANTS = (
		BOOLEAN    => q[bool],
		STRING     => q[""],
		NUMBER     => q[0+],
		REGEXP     => q[qr],
		SMARTMATCH => q[~~],
		map {; $_ => $_ } qw(
			SCALAR ARRAY HASH CODE REF GLOB
			LVALUE FORMAT IO VSTRING
		)
	);
	require constant;
	constant->import(\%_CONSTANTS);
}

EXPORTER:
{
	use base "Exporter::Tiny";

	our %_CONSTANTS;
	our @EXPORT    = ( "does" );
	our @EXPORT_OK = (
		qw( does overloads blessed reftype looks_like_number make_role where custom ),
		keys(%_CONSTANTS),
	);
	our %EXPORT_TAGS = (
		constants      => [ "does", keys(%_CONSTANTS) ],
		only_constants => [ keys(%_CONSTANTS) ],
		make           => [ qw( make_role where ) ],
	);

	sub _exporter_validate_opts
	{
		require B;
		my $class = shift;
		$_[0]{exporter} ||= sub {
			my $into = $_[0]{into};
			my ($name, $sym) = @{ $_[1] };
			for (grep ref, $into->can($name))
			{
				B::svref_2object($_)->STASH->NAME eq $into
					and _croak("Refusing to overwrite local sub '$name' with export from $class");
			}
			"namespace::clean"->import(-cleanee => $_[0]{into}, $name);
			no strict qw(refs);
			no warnings qw(redefine prototype);
			*{"$into\::$name"} = $sym;
		}
	}
}

ROLES:
{
	no warnings;

	my $io = "Type::Tiny"->new(
		display_name => "IO",
		constraint   => sub { require IO::Detect; IO::Detect::is_filehandle($_) },
	);

	our %_ROLES = (
		SCALAR   => ( ScalarRef() | Ref->parameterize('SCALAR')  | Overload->parameterize('${}') ),
		ARRAY    => ( ArrayRef()  | Ref->parameterize('ARRAY')   | Overload->parameterize('@{}') ),
		HASH     => ( HashRef()   | Ref->parameterize('HASH')    | Overload->parameterize('%{}') ),
		CODE     => ( CodeRef()   | Ref->parameterize('CODE')    | Overload->parameterize('&{}') ),
		REF      => ( Ref->parameterize('REF') ),
		GLOB     => ( GlobRef()   | Ref->parameterize('GLOB')    | Overload->parameterize('*{}') ),
		LVALUE   => ( Ref->parameterize('LVALUE') ),
		FORMAT   => ( Ref->parameterize('FORMAT') ),
		IO       => $io,
		VSTRING  => ( Ref->parameterize('VSTRING') ),
		Regexp   => ( RegexpRef() | Ref->parameterize('Regexp')  | Overload->parameterize('qr') ),
		bool     => ( Value() | Overload->complementary_type | Overload->parameterize('bool') ),
		q[""]    => ( Value() | Overload->complementary_type | Overload->parameterize('""') ),
		q[0+]    => ( Value() | Overload->complementary_type | Overload->parameterize('0+') ),
		q[<>]    => ( Overload->parameterize('<>') | $io ),
		q[~~]    => ( Overload->parameterize('~~') | Object->complementary_type ),
		q[${}]   => 'SCALAR',
		q[@{}]   => 'ARRAY',
		q[%{}]   => 'HASH',
		q[&{}]   => 'CODE',
		q[*{}]   => 'GLOB',
		q[qr]    => 'Regexp',
	);

	while (my ($k, $v) = each %_ROLES) { $_ROLES{$k} = $_ROLES{$v} unless ref $v }
}

PUBLIC_FUNCTIONS:
{
	use Scalar::Util 1.24 qw( blessed reftype looks_like_number );

	sub overloads ($;$)
	{
		unshift @_, ${+_lu} if @_ == 1;
		return unless blessed $_[0];
		goto \&overload::Method;
	}

	sub does ($;$)
	{
		unshift @_, ${+_lu} if @_ == 1;
		my ($thing, $role) = @_;

		no warnings;
		our %_ROLES;
		if (my $test = $_ROLES{$role})
		{
			return !! $test->check($thing);
		}

		if (blessed $role and $role->can('check'))
		{
			return !! $role->check($thing);
		}

		if (blessed $thing && $thing->can('DOES'))
		{
			return !! 1 if $thing->DOES($role);
		}
		elsif (UNIVERSAL::can($thing, 'can') && $thing->can('DOES'))
		{
			my $class = $thing;
			return '0E0' if $class->DOES($role);
		}

		return;
	}

	sub _generate_custom
	{
		my ($class, $name, $arg) = @_;
		my $role = $arg->{ -role } or confess MISSING_ROLE_MESSAGE;

		return sub (;$) {
			push @_, $role;
			goto \&does;
		}
	}

	sub make_role
	{
		return "Scalar::Does::RoleChecker"->new(@_);
	}

	sub where (&)
	{
		return +{ where => $_[0] };
	}
}

"it does"
__END__