view release on metacpan or  search on metacpan

lib/Type/Nano.pm  view on Meta::CPAN

	);
}

sub enum {
	my $name   = ref($_[0]) ? '__ANON__' : shift;
	my @values = sort( ref($_[0]) ? @{+shift} : @_ );
	my $values = join "|", map quotemeta, @values;
	my $regexp = qr/\A(?:$values)\z/;
	$TYPES{ENUM}{$values} ||= __PACKAGE__->new(
		name         => $name,
		parent       => Str,
		constraint   => sub { $_ =~ $regexp },
		values       => \@values,
	);
}

sub union {
	my $name  = ref($_[0]) ? '__ANON__' : shift;
	my @types = ref($_[0]) ? @{+shift} : @_;
	__PACKAGE__->new(
		name         => $name,
		constraint   => sub { my $val = $_; $_->check($val) && return !!1 for @types; !!0 },
		types        => \@types,
	);
}

sub intersection {
	my $name  = ref($_[0]) ? '__ANON__' : shift;
	my @types = ref($_[0]) ? @{+shift} : @_;
	__PACKAGE__->new(
		name         => $name,
		constraint   => sub { my $val = $_; $_->check($val) || return !!0 for @types; !!1 },
		types        => \@types,
	);
}

sub type {
	my $name    = ref($_[0]) ? '__ANON__' : shift;
	my $coderef = shift;
	__PACKAGE__->new(
		name         => $name,
		constraint   => $coderef,
	);
}

# OO interface
#

sub DOES {
	my $proto = shift;
	my ($role) = @_;
	return !!1 if {
		'Type::API::Constraint'              => 1,
		'Type::API::Constraint::Constructor' => 1,
	}->{$role};
	"UNIVERSAL"->can("DOES") ? $proto->SUPER::DOES(@_) : $proto->isa(@_);
}

sub new { # Type::API::Constraint::Constructor
	my $class = ref($_[0]) ? ref(shift) : shift;
	my $self  = bless { @_ == 1 ? %{+shift} : @_ } => $class;
	
	$self->{constraint} ||= sub { !!1 };
	unless ($self->{name}) {
		require Carp;
		Carp::croak("Requires both `name` and `constraint`");
	}
	
	$self;
}

sub check { # Type::API::Constraint
	my $self = shift;
	my ($value) = @_;
	
	if ($self->{parent}) {
		return unless $self->{parent}->check($value);
	}
	
	local $_ = $value;
	$self->{constraint}->($value);
}

sub get_message { # Type::API::Constraint
	my $self = shift;
	my ($value) = @_;
	
	require B;
	!defined($value)
		? sprintf("Undef did not pass type constraint %s", $self->{name})
		: ref($value)
			? sprintf("Reference %s did not pass type constraint %s", $value, $self->{name})
			: sprintf("Value %s did not pass type constraint %s", B::perlstring($value), $self->{name});
}

# Overloading
#

{
	my $nil = sub {};
	sub _install_overloads
	{
		no strict 'refs';
		no warnings 'redefine', 'once';
		if ($] < 5.010) {
			require overload;
			push @_, fallback => 1;
			goto \&overload::OVERLOAD;
		};
		my $class = shift;
		*{$class . '::(('} = sub {};
		*{$class . '::()'} = sub {};
		*{$class . '::()'} = do { my $x = 1; \$x };
		while (@_)
		{
			my $f = shift;
			#*{$class . '::(' . $f} = $nil; # cargo culting overload.pm
			#*{$class . '::(' . $f} = shift;
			*{$class . '::(' . $f} = ref $_[0] ? shift : do { my $m = shift; sub { shift->$m(@_) } };
		}
	}