File Coverage

blib/lib/Type/Library.pm

Criterion	Covered	Total	%
statement	220	220	100.0
branch	67	82	81.7
condition	45	59	76.2
subroutine	37	37	100.0
pod	11	11	100.0
total	380	409	92.9

package Type::Library;

use 5.008001;
use strict;
use warnings;

BEGIN {
	$Type::Library::AUTHORITY = 'cpan:TOBYINK';
	$Type::Library::VERSION   = '2.010001';
}

$Type::Library::VERSION =~ tr/_//d;

use Eval::TypeTiny qw< eval_closure set_subname type_to_coderef NICE_PROTOTYPES >;
use Scalar::Util qw< blessed refaddr >;
use Type::Tiny      ();
use Types::TypeTiny ();

require Exporter::Tiny;
our @ISA = 'Exporter::Tiny';

sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }

####
#### Hooks for Exporter::Tiny
####

# Handling for -base, -extends, and -utils tags.
#
sub _exporter_validate_opts {
	my ( $class, $opts ) = ( shift, @_ );

	$class->setup_type_library( @{$opts}{qw/ into utils extends /}, $opts )
		if $_[0]{base} || $_[0]{extends};

	return $class->SUPER::_exporter_validate_opts( @_ );
}

# In Exporter::Tiny, this method takes a sub name, a 'value' (i.e.
# potentially an options hashref for the export), and some global
# options, and returns a list of name+coderef pairs to actually
# export. We override it to provide some useful features.
#
sub _exporter_expand_sub {
	my ( $class, $name, $value, $globals ) = ( shift, @_ );

	# Handle exporting '+Type'.
	#
	# Note that this recurses, so if used in conjunction with the other
	# special cases handled by this method, will still work.
	#
	if ( $name =~ /^\+(.+)/ and $class->has_type( "$1" ) ) {
		my $type     = $class->get_type( "$1" );
		my $exported = $type->exportables;
		return map $class->_exporter_expand_sub(
			$_->{name},
			+{ %{ $value || {} } },
			$globals,
		), @$exported;
	}

	# Is the function being exported one which is associated with a
	# type constraint? If so, which one. If not, then forget the rest
	# and just use the superclass method.
	#
	if ( my $f = $class->meta->{'functions'}{$name}
	and  defined $class->meta->{'functions'}{$name}{'type'} ) {

		my $type      = $f->{type};
		my $tag       = $f->{tags}[0];
		my $typename  = $type->name;

		# If $value has `of` or `where` options, then this is a
		# custom type.
		#
		my $custom_type = 0;
		for my $param ( qw/ of where / ) {
			exists $value->{$param} or next;
			defined $value->{-as} or _croak( "Parameter '-as' not supplied" );
			$type = $type->$param( $value->{$param} );
			$name = $value->{-as};
			++$custom_type;
		}

		# If we're exporting a type itself, then export a custom
		# function if they customized the type or want a Moose/Mouse
		# type constraint.
		#
		if ( $tag eq 'types' ) {
			my $post_method = q();
			$post_method = '->mouse_type' if $globals->{mouse};
			$post_method = '->moose_type' if $globals->{moose};
			return ( $name => type_to_coderef( $type, post_method => $post_method ) )
				if $post_method || $custom_type;
		}

		# If they're exporting some other type of function, like
		# 'to', 'is', or 'assert', then find the correct exportable
		# by tag name, and return that.
		#
		# XXX: this will fail for tags like 'constants' where there
		# will be multiple exportables which match!
		#
		if ( $custom_type and $tag ne 'types' ) {
			my $exportable = $type->exportables_by_tag( $tag, $typename );
			return ( $value->{-as} || $exportable->{name}, $exportable->{code} );
		}
	}

	# In all other cases, the superclass method will work.
	#
	return $class->SUPER::_exporter_expand_sub( @_ );
}

# Mostly just rely on superclass to do the actual export, but add
# a couple of useful behaviours.
#
sub _exporter_install_sub {
	my ( $class, $name, $value, $globals, $sym ) = ( shift, @_ );

	my $into = $globals->{into};
	my $type = $class->meta->{'functions'}{$name}{'type'};
	my $tags = $class->meta->{'functions'}{$name}{'tags'};

	# Issue a warning if exporting a deprecated type constraint.
	#
	Exporter::Tiny::_carp(
		"Exporting deprecated type %s to %s",
		$type->qualified_name,
		ref( $into ) ? "reference" : "package $into",
	) if ( defined $type and $type->deprecated and not $globals->{allow_deprecated} );

	# If exporting a type constraint into a real package, then
	# add it to the package's type registry.
	#
	if ( !ref $into
	and  $into ne '-lexical'
	and  defined $type
	and  grep $_ eq 'types', @$tags ) {

		# If they're renaming it, figure out what name, and use that.
		# XXX: `-as` can be a coderef, and can be in $globals in that case.
		my ( $prefix ) = grep defined, $value->{-prefix}, $globals->{prefix}, q();
		my ( $suffix ) = grep defined, $value->{-suffix}, $globals->{suffix}, q();
		my $as         = $prefix . ( $value->{-as} || $name ) . $suffix;

		$INC{'Type/Registry.pm'}
			? 'Type::Registry'->for_class( $into )->add_type( $type, $as )
			: ( $Type::Registry::DELAYED{$into}{$as} = $type );
	}

	$class->SUPER::_exporter_install_sub( @_ );
} #/ sub _exporter_install_sub

sub _exporter_fail {
	my ( $class, $name, $value, $globals ) = ( shift, @_ );

	# Passing the `-declare` flag means that if a type isn't found, then
	# we export a placeholder function instead of failing.
	if ( $globals->{declare} ) {
		return (
			$name,
			type_to_coderef(
				undef,
				type_name    => $name,
				type_library => $globals->{into} || _croak( "Parameter 'into' not supplied" ),
			),
		);
	} #/ if ( $globals->{declare...})

	return $class->SUPER::_exporter_fail( @_ );
} #/ sub _exporter_fail

####
#### Type library functionality
####

sub setup_type_library {
	my ( $class, $type_library, $install_utils, $extends, $opts ) = ( shift, @_ );

	my @extends = ref( $extends ) ? @$extends : $extends ? $extends : ();
	unshift @extends, $class if $class ne __PACKAGE__;

	if ( not ref $type_library ) {
		no strict "refs";
		push @{"$type_library\::ISA"}, $class;
		( my $file = $type_library ) =~ s{::}{/}g;
		$INC{"$file.pm"} ||= __FILE__;
	}

	if ( $install_utils ) {
		require Type::Utils;
		'Type::Utils'->import(
			{ %$opts, into => $type_library },
			'-default',
		);
	}

	if ( @extends and not ref $type_library ) {
		require Type::Utils;
		my $wrapper = eval "sub { package $type_library; &Type::Utils::extends; }";
		$wrapper->( @extends );
	}
}

sub meta {
	no strict "refs";
	no warnings "once";
	return $_[0] if blessed $_[0];
	${"$_[0]\::META"} ||= bless {}, $_[0];
}

sub add_type {
	my $meta  = shift->meta;
	my $class = blessed( $meta ) ;

	_croak( 'Type library is immutable' ) if $meta->{immutable};

	my $type =
		ref( $_[0] ) =~ /^Type::Tiny\b/ ? $_[0] :
		blessed( $_[0] )                ? Types::TypeTiny::to_TypeTiny( $_[0] ) :
		ref( $_[0] ) eq q(HASH)         ? 'Type::Tiny'->new( library => $class, %{ $_[0] } ) :
		"Type::Tiny"->new( library => $class, @_ );
	my $name = $type->{name};

	if ( $meta->has_type( $name ) ) {
		my $existing = $meta->get_type( $name );
		return if $type->{uniq} == $existing->{uniq};
		_croak( 'Type %s already exists in this library', $name );
	}

	_croak( 'Type %s conflicts with coercion of same name', $name ) if $meta->has_coercion( $name );
	_croak( 'Cannot add anonymous type to a library' )              if $type->is_anon;
	$meta->{types} ||= {};
	$meta->{types}{$name} = $type;

	no strict "refs";
	no warnings "redefine", "prototype";

	for my $exportable ( @{ $type->exportables } ) {
		my $name = $exportable->{name};
		my $code = $exportable->{code};
		my $tags = $exportable->{tags};
		_croak( 'Function %s is provided by types %s and %s', $name, $meta->{'functions'}{$name}{'type'}->name, $type->name )
			if $meta->{'functions'}{$name};
		*{"$class\::$name"} = set_subname( "$class\::$name", $code );
		push @{"$class\::EXPORT_OK"}, $name;
		push @{ ${"$class\::EXPORT_TAGS"}{$_} ||= [] }, $name for @$tags;
		$meta->{'functions'}{$name} = { type => $type, tags => $tags };
	}

	$INC{'Type/Registry.pm'}
		? 'Type::Registry'->for_class( $class )->add_type( $type, $name )
		: ( $Type::Registry::DELAYED{$class}{$name} = $type );

	return $type;
} #/ sub add_type

# For Type::TinyX::Facets
# Only use this if you know what you're doing!
sub _remove_type {
	my $meta  = shift->meta;
	my $type  = $meta->get_type( $_[0] );
	my $class = ref $meta;

	_croak( 'Type library is immutable' ) if $meta->{immutable};

	delete $meta->{types}{$type->name};

	no strict "refs";
	no warnings "redefine", "prototype";

	my @clean;
	my $_scrub = sub {
		my ( $arr, $name ) = @_;
		@$arr = grep $_ ne $name, @$arr;
	};
	for my $exportable ( @{ $type->exportables } ) {
		my $name = $exportable->{name};
		push @clean, $name;
		&$_scrub( \@{"$class\::EXPORT_OK"}, $name );
		for my $t ( @{ $exportable->{tags} } ) {
			&$_scrub( ${"$class\::EXPORT_TAGS"}{$t} ||= [], $name );
		}
		delete $meta->{'functions'}{$name};
	}
	eval {
		require namespace::clean;
		'namespace::clean'->clean_subroutines( $class, @clean );
	};

	delete 'Type::Registry'->for_class( $class )->{$type->name}
		if $INC{'Type/Registry.pm'};
	delete $Type::Registry::DELAYED{$class}{$type->name};

	return $type;
} #/ sub _remove_type

sub get_type {
	my $meta = shift->meta;
	$meta->{types}{ $_[0] };
}

sub has_type {
	my $meta = shift->meta;
	exists $meta->{types}{ $_[0] };
}

sub type_names {
	my $meta = shift->meta;
	keys %{ $meta->{types} };
}

sub add_coercion {
	my $meta  = shift->meta;
	my $class = blessed( $meta );

	_croak( 'Type library is immutable' ) if $meta->{immutable};

	require Type::Coercion;
	my $c     = blessed( $_[0] ) ? $_[0] : "Type::Coercion"->new( @_ );
	my $name  = $c->name;

	_croak( 'Coercion %s already exists in this library', $name )   if $meta->has_coercion( $name );
	_croak( 'Coercion %s conflicts with type of same name', $name ) if $meta->has_type( $name );
	_croak( 'Cannot add anonymous type to a library' )              if $c->is_anon;

	$meta->{coercions} ||= {};
	$meta->{coercions}{$name} = $c;

	no strict "refs";
	no warnings "redefine", "prototype";

	*{"$class\::$name"} = type_to_coderef( $c );
	push @{"$class\::EXPORT_OK"}, $name;
	push @{ ${"$class\::EXPORT_TAGS"}{'coercions'} ||= [] }, $name;
	$meta->{'functions'}{$name} = { coercion => $c, tags => [ 'coercions' ] };

	return $c;
} #/ sub add_coercion

sub get_coercion {
	my $meta = shift->meta;
	$meta->{coercions}{ $_[0] };
}

sub has_coercion {
	my $meta = shift->meta;
	exists $meta->{coercions}{ $_[0] };
}

sub coercion_names {
	my $meta = shift->meta;
	keys %{ $meta->{coercions} };
}

sub make_immutable {
	my $meta  = shift->meta;
	my $class = ref( $meta );

	no strict "refs";
	no warnings "redefine", "prototype";

	for my $type ( values %{ $meta->{types} } ) {
		$type->coercion->freeze;
		next unless $type->has_coercion && $type->coercion->frozen;
		for my $e ( $type->exportables_by_tag( 'to' ) ) {
			my $qualified_name = $class . '::' . $e->{name};
			*$qualified_name = set_subname( $qualified_name, $e->{code} );
		}
	}

	$meta->{immutable} = 1;
}

1;

__END__