<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Type::Registry;

use 5.006001;
use strict;
use warnings;

BEGIN {
	$Type::Registry::AUTHORITY = 'cpan:TOBYINK';
	$Type::Registry::VERSION   = '1.002001';
}

use Exporter::Tiny qw( mkopt );
use Scalar::Util qw( refaddr );
use Type::Parser qw( eval_type );
use Types::TypeTiny qw( CodeLike ArrayLike to_TypeTiny );

our @ISA = 'Exporter::Tiny';
our @EXPORT_OK = qw(t);

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

sub _exporter_expand_sub
{
	my $class = shift;
	my ($name, $value, $globals, $permitted) = @_;
	
	if ($name eq "t")
	{
		my $caller = $globals-&gt;{into};
		my $reg = $class-&gt;for_class(
			ref($caller) ? sprintf('HASH(0x%08X)', refaddr($caller)) : $caller
		);
		return t =&gt; sub (;$) { @_ ? $reg-&gt;lookup(@_) : $reg };
	}
	
	return $class-&gt;SUPER::_exporter_expand_sub(@_);
}

sub new
{
	my $class = shift;
	ref($class) and _croak("Not an object method");
	bless {}, $class;
}

{
	my %registries;
	
	sub for_class
	{
		my $class = shift;
		my ($for) = @_;
		$registries{$for} ||= $class-&gt;new;
	}
	
	sub for_me
	{
		my $class = shift;
		my $for   = caller;
		$registries{$for} ||= $class-&gt;new;
	}
}

sub add_types
{
	my $self = shift;
	my $opts = mkopt(\@_);
	for my $opt (@$opts)
	{
		my ($library, $types) = @_;
		$library =~ s/^-/Types::/;
		
		{
			local $SIG{__DIE__} = sub {};
			eval "require $library";
		};
		
		my %hash;
		
		if ($library-&gt;isa("Type::Library") or $library eq 'Types::TypeTiny')
		{
			$types ||= [qw/-types/];
			ArrayLike-&gt;check($types)
				or _croak("Expected arrayref following '%s'; got %s", $library, $types);
			
			$library-&gt;import({into =&gt; \%hash}, @$types);
			$hash{$_} = &amp;{$hash{$_}}() for keys %hash;
		}
		elsif ($library-&gt;isa("MooseX::Types::Base"))
		{
			$types ||= [];
			ArrayLike-&gt;check($types) &amp;&amp; (@$types == 0)
				or _croak("Library '%s' is a MooseX::Types type constraint library. No import options currently supported", $library);
			
			require Moose::Util::TypeConstraints;
			my $moosextypes = $library-&gt;type_storage;
			for my $name (sort keys %$moosextypes)
			{
				my $tt = to_TypeTiny(
					Moose::Util::TypeConstraints::find_type_constraint($moosextypes-&gt;{$name})
				);
				$hash{$name} = $tt;
			}
		}
		elsif ($library-&gt;isa("MouseX::Types::Base"))
		{
			$types ||= [];
			ArrayLike-&gt;check($types) &amp;&amp; (@$types == 0)
				or _croak("Library '%s' is a MouseX::Types type constraint library. No import options currently supported", $library);
			
			require Mouse::Util::TypeConstraints;
			my $moosextypes = $library-&gt;type_storage;
			for my $name (sort keys %$moosextypes)
			{
				my $tt = to_TypeTiny(
					Mouse::Util::TypeConstraints::find_type_constraint($moosextypes-&gt;{$name})
				);
				$hash{$name} = $tt;
			}
		}
		else
		{
			_croak("%s is not a type library", $library);
		}
		
		for my $key (sort keys %hash)
		{
			exists($self-&gt;{$key})
				and $self-&gt;{$key}{uniq} != $hash{$key}{uniq}
				and _croak("Duplicate type name: %s", $key);
			$self-&gt;{$key} = $hash{$key};
		}
	}
	$self;
}

sub add_type
{
	my $self = shift;
	my ($type, $name) = @_;
	$type = to_TypeTiny($type);
	$name ||= do {
		$type-&gt;is_anon
			and _croak("Expected named type constraint; got anonymous type constraint");
		$type-&gt;name;
	};
	
	exists($self-&gt;{$name})
		and $self-&gt;{$name}{uniq} != $type-&gt;{uniq}
		and _croak("Duplicate type name: %s", $name);
	
	$self-&gt;{$name} = $type;
	$self;
}

sub alias_type
{
	my $self = shift;
	my ($old, @new) = @_;
	my $lookup = eval { $self-&gt;lookup($old) }
		or _croak("Expected existing type constraint name; got '$old'");
	$self-&gt;{$_} = $lookup for @new;
	$self;
}

sub simple_lookup
{
	my $self = shift;
	
	my ($tc) = @_;
	$tc =~ s/(^\s+|\s+$)//g;
	
	if (exists $self-&gt;{$tc})
	{
		return $self-&gt;{$tc};
	}
	
	return;
}

sub foreign_lookup
{
	my $self = shift;
	
	return $_[1] ? () : $self-&gt;simple_lookup($_[0], 1)
		unless $_[0] =~ /^(.+)::(\w+)$/;
	
	my $library  = $1;
	my $typename = $2;
	
	{
		local $SIG{__DIE__} = sub {};
		eval "require $library;";
	};
	
	if ( $library-&gt;isa('MooseX::Types::Base') )
	{
		require Moose::Util::TypeConstraints;
		my $type = Moose::Util::TypeConstraints::find_type_constraint(
			$library-&gt;get_type($typename)
		) or return;
		return to_TypeTiny($type);
	}
	
	if ( $library-&gt;isa('MouseX::Types::Base') )
	{
		require Mouse::Util::TypeConstraints;
		my $sub  = $library-&gt;can($typename) or return;
		my $type = Mouse::Util::TypeConstraints::find_type_constraint($sub-&gt;()) or return;
		return to_TypeTiny($type);
	}
	
	if ( $library-&gt;can("get_type") )
	{
		my $type = $library-&gt;get_type($typename);
		return to_TypeTiny($type);
	}
	
	return;
}

sub lookup
{
	my $self = shift;
	
	$self-&gt;simple_lookup(@_) or eval_type($_[0], $self);
}

sub make_union
{
	my $self = shift;
	my (@types) = @_;
	
	require Type::Tiny::Union;
	return "Type::Tiny::Union"-&gt;new(type_constraints =&gt; \@types);
}

sub make_intersection
{
	my $self = shift;
	my (@types) = @_;
	
	require Type::Tiny::Intersection;
	return "Type::Tiny::Intersection"-&gt;new(type_constraints =&gt; \@types);
}

sub make_class_type
{
	my $self = shift;
	my ($class) = @_;
	
	require Type::Tiny::Class;
	return "Type::Tiny::Class"-&gt;new(class =&gt; $class);
}

sub make_role_type
{
	my $self = shift;
	my ($role) = @_;
	
	require Type::Tiny::Role;
	return "Type::Tiny::Role"-&gt;new(role =&gt; $role);
}

sub AUTOLOAD
{
	my $self = shift;
	my ($method) = (our $AUTOLOAD =~ /(\w+)$/);
	my $type = $self-&gt;simple_lookup($method);
	return $type if $type;
	_croak(q[Can't locate object method "%s" via package "%s"], $method, ref($self));
}

# Prevent AUTOLOAD being called for DESTROY!
sub DESTROY
{
	return;
}

DELAYED: {
	our %DELAYED;
	for my $package (sort keys %DELAYED)
	{
		my $reg   = __PACKAGE__-&gt;for_class($package);
		my $types = $DELAYED{$package};
		
		for my $name (sort keys %$types)
		{
			$reg-&gt;add_type($types-&gt;{$name}, $name);
		}
	}
}

1;

__END__

=pod

=encoding utf-8

=for stopwords optlist

=head1 NAME

Type::Registry - a glorified hashref for looking up type constraints

=head1 SYNOPSIS

=for test_synopsis no warnings qw(misc);

   package Foo::Bar;
   
   use Type::Registry;
   
   my $reg = "Type::Registry"-&gt;for_me;  # a registry for Foo::Bar
   
   # Register all types from Types::Standard
   $reg-&gt;add_types(-Standard);
   
   # Register just one type from Types::XSD
   $reg-&gt;add_types(-XSD =&gt; ["NonNegativeInteger"]);
   
   # Register all types from MyApp::Types
   $reg-&gt;add_types("MyApp::Types");
   
   # Create a type alias
   $reg-&gt;alias_type("NonNegativeInteger" =&gt; "Count");
   
   # Look up a type constraint
   my $type = $reg-&gt;lookup("ArrayRef[Count]");
   
   $type-&gt;check([1, 2, 3.14159]);  # croaks

Alternatively:

   package Foo::Bar;
   
   use Type::Registry qw( t );
   
   # Register all types from Types::Standard
   t-&gt;add_types(-Standard);
   
   # Register just one type from Types::XSD
   t-&gt;add_types(-XSD =&gt; ["NonNegativeInteger"]);
   
   # Register all types from MyApp::Types
   t-&gt;add_types("MyApp::Types");
   
   # Create a type alias
   t-&gt;alias_type("NonNegativeInteger" =&gt; "Count");
   
   # Look up a type constraint
   my $type = t("ArrayRef[Count]");
   
   $type-&gt;check([1, 2, 3.14159]);  # croaks

=head1 STATUS

This module is covered by the
L&lt;Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY"&gt;.

=head1 DESCRIPTION

A type registry is basically just a hashref mapping type names to type
constraint objects.

=head2 Constructors

=over

=item C&lt;&lt; new &gt;&gt;

Create a new glorified hashref.

=item C&lt;&lt; for_class($class) &gt;&gt;

Create or return the existing glorified hashref associated with the given
class.

Note that any type constraint you have imported from Type::Library-based
type libraries will be automatically available in your class' registry.

=item C&lt;&lt; for_me &gt;&gt;

Create or return the existing glorified hashref associated with the caller.

=back

=head2 Methods

=over

=item C&lt;&lt; add_types(@libraries) &gt;&gt;

The libraries list is treated as an "optlist" (a la L&lt;Data::OptList&gt;).

Strings are the names of type libraries; if the first character is a
hyphen, it is expanded to the "Types::" prefix. If followed by an
arrayref, this is the list of types to import from that library.
Otherwise, imports all types from the library.

   use Type::Registry qw(t);
   
   t-&gt;add_types(-Standard);  # OR: t-&gt;add_types("Types::Standard");
   
   t-&gt;add_types(
      -TypeTiny =&gt; ['HashLike'],
      -Standard =&gt; ['HashRef' =&gt; { -as =&gt; 'RealHash' }],
   );

L&lt;MooseX::Types&gt; (and experimentally, L&lt;MouseX::Types&gt;) libraries can
also be added this way, but I&lt;&lt; cannot be followed by an arrayref of
types to import &gt;&gt;.

=item C&lt;&lt; add_type($type, $name) &gt;&gt;

The long-awaited singular form of C&lt;add_types&gt;. Given a type constraint
object, adds it to the registry with a given name. The name may be
omitted, in which case C&lt;&lt; $type-&gt;name &gt;&gt; is called, and Type::Registry
will throw an error if C&lt;&lt; $type &gt;&gt; is anonymous. If a name is explicitly
given, Type::Registry cares not one wit whether the type constraint is
anonymous.

This method can even add L&lt;MooseX::Types&gt; and L&lt;MouseX::Types&gt; type
constraints; indeed anything that can be handled by L&lt;Types::TypeTiny&gt;'s
C&lt;to_TypeTiny&gt; function. (Bear in mind that to_TypeTiny I&lt;always&gt; results
in an anonymous type constraint, so C&lt;&lt; $name &gt;&gt; will be required.)

=item C&lt;&lt; alias_type($oldname, $newname) &gt;&gt;

Create an alias for an existing type.

=item C&lt;&lt; simple_lookup($name) &gt;&gt;

Look up a type in the registry by name. 

Returns undef if not found.

=item C&lt;&lt; foreign_lookup($name) &gt;&gt;

Like C&lt;simple_lookup&gt;, but if the type name contains "::", will attempt
to load it from a type library. (And will attempt to load that module.)

=item C&lt;&lt; lookup($name) &gt;&gt;

Look up by name, with a DSL.

   t-&gt;lookup("Int|ArrayRef[Int]")

The DSL can be summed up as:

   X               type from this registry
   My::Lib::X      type from a type library
   ~X              complementary type
   X | Y           union
   X &amp; Y           intersection
   X[...]          parameterized type
   slurpy X        slurpy type
   Foo::Bar::      class type

Croaks if not found.

=item C&lt;&lt; make_union(@constraints) &gt;&gt;,
C&lt;&lt; make_intersection(@constraints) &gt;&gt;,
C&lt;&lt; make_class_type($class) &gt;&gt;,
C&lt;&lt; make_role_type($role) &gt;&gt;

Convenience methods for creating certain common type constraints.

=item C&lt;&lt; AUTOLOAD &gt;&gt;

Overloaded to call C&lt;lookup&gt;.

   $registry-&gt;Str;  # like $registry-&gt;lookup("Str")

=back

=head2 Functions

=over

=item C&lt;&lt; t &gt;&gt;

This class can export a function C&lt;&lt; t &gt;&gt; which acts like
C&lt;&lt; "Type::Registry"-&gt;for_class($importing_class) &gt;&gt;.

=back

=head1 BUGS

Please report any bugs to
L&lt;http://rt.cpan.org/Dist/Display.html?Queue=Type-Tiny&gt;.

=head1 SEE ALSO

L&lt;Type::Library&gt;.

=head1 AUTHOR

Toby Inkster E&lt;lt&gt;tobyink@cpan.orgE&lt;gt&gt;.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2013-2014, 2017 by Toby Inkster.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=head1 DISCLAIMER OF WARRANTIES

THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.

</pre></body></html>