[gitmo/Moose.git] / lib / Moose / Util / TypeConstraints / Builtins.pm

package Moose::Util::TypeConstraints::Builtins;

use strict;
use warnings;

use List::MoreUtils ();
use Scalar::Util qw( blessed looks_like_number reftype );

sub type { goto &Moose::Util::TypeConstraints::type }
sub subtype { goto &Moose::Util::TypeConstraints::subtype }
sub as { goto &Moose::Util::TypeConstraints::as }
sub where (&) { goto &Moose::Util::TypeConstraints::where }
sub optimize_as (&) { goto &Moose::Util::TypeConstraints::optimize_as }
sub inline_as (&) { goto &Moose::Util::TypeConstraints::inline_as }

sub define_builtins {
    my $registry = shift;

    type 'Any'    # meta-type including all
        => where {1}
        => inline_as { '1' };

    subtype 'Item'  # base-type
        => as 'Any'
        => inline_as { '1' };

    subtype 'Undef'
        => as 'Item'
        => where { !defined($_) }
        => inline_as { "! defined $_[1]" };

    subtype 'Defined'
        => as 'Item'
        => where { defined($_) }
        => inline_as { "defined $_[1]" };

    subtype 'Bool'
        => as 'Item'
        => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }
        => inline_as { qq{!defined($_[1]) || $_[1] eq "" || "$_[1]" eq '1' || "$_[1]" eq '0'} };

    subtype 'Value'
        => as 'Defined'
        => where { !ref($_) }
        => optimize_as( \&_Value )
        => inline_as { "defined $_[1] && ! ref $_[1]" };

    subtype 'Ref'
        => as 'Defined'
        => where { ref($_) }
        => optimize_as( \&_Ref )
        => inline_as { "ref $_[1]" };

    subtype 'Str'
        => as 'Value'
        => where { ref(\$_) eq 'SCALAR' }
        => optimize_as( \&_Str )
        => inline_as {
            return (  qq{defined $_[1]}
                    . qq{&& (   ref(\\             $_[1] ) eq 'SCALAR'}
                    . qq{    || ref(\\(my \$str_value = $_[1])) eq 'SCALAR')} );
        };

    subtype 'Num'
        => as 'Str'
        => where { Scalar::Util::looks_like_number($_) }
        => optimize_as( \&_Num )
        => inline_as { "!ref $_[1] && Scalar::Util::looks_like_number($_[1])" };

    subtype 'Int'
        => as 'Num'
        => where { "$_" =~ /^-?[0-9]+$/ }
        => optimize_as( \&_Int )
        => inline_as {
            return (  qq{defined $_[1]}
                    . qq{&& ! ref $_[1]}
                    . qq{&& ( my \$int_value = $_[1] ) =~ /\\A-?[0-9]+\\z/} );
        };

    subtype 'CodeRef'
        => as 'Ref'
        => where { ref($_) eq 'CODE' }
        => optimize_as( \&_CodeRef )
        => inline_as { qq{ref $_[1] eq 'CODE'} };

    subtype 'RegexpRef'
        => as 'Ref'
        => where( \&_RegexpRef )
        => optimize_as( \&_RegexpRef )
        => inline_as { "Moose::Util::TypeConstraints::Builtins::_RegexpRef( $_[1] )" };

    subtype 'GlobRef'
        => as 'Ref'
        => where { ref($_) eq 'GLOB' }
        => optimize_as( \&_GlobRef )
        => inline_as { qq{ref $_[1] eq 'GLOB'} };

    # NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a
    # filehandle
    subtype 'FileHandle'
        => as 'Ref'
        => where {
            Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") );
        }
        => optimize_as( \&_FileHandle )
        => inline_as {
            return (  qq{ref $_[1] eq 'GLOB'}
                    . qq{&& Scalar::Util::openhandle( $_[1] )}
                    . qq{or Scalar::Util::blessed( $_[1] ) && $_[1]->isa("IO::Handle")} );
        };

    subtype 'Object'
        => as 'Ref'
        => where { blessed($_) }
        => optimize_as( \&_Object )
        => inline_as { "Scalar::Util::blessed( $_[1] )" };

    # This type is deprecated.
    subtype 'Role'
        => as 'Object'
        => where { $_->can('does') }
        => optimize_as( \&_Role );

    subtype 'ClassName'
        => as 'Str'
        => where { Class::MOP::is_class_loaded($_) }
        => optimize_as( \&_ClassName )
        => inline_as { "Class::MOP::is_class_loaded( $_[1] )" };

    subtype 'RoleName'
        => as 'ClassName'
        => where {
            (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
        }
        => optimize_as( \&_RoleName )
        => inline_as {
            return (  qq{Class::MOP::is_class_loaded( $_[1] )}
                    . qq{&& ( Class::MOP::class_of( $_[1] ) || return )}
                    . qq{       ->isa('Moose::Meta::Role')} );
        };

    $registry->add_type_constraint(
        Moose::Meta::TypeConstraint::Parameterizable->new(
            name               => 'ScalarRef',
            package_defined_in => __PACKAGE__,
            parent =>
                Moose::Util::TypeConstraints::find_type_constraint('Ref'),
            constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' },
            optimized            => \&_ScalarRef,
            constraint_generator => sub {
                my $type_parameter = shift;
                my $check = $type_parameter->_compiled_type_constraint;
                return sub {
                    return $check->( ${$_} );
                };
            },
            inlined => sub {qq{ref $_[1] eq 'SCALAR' || ref $_[1] eq 'REF'}},
            inline_generator => sub {
                my $self           = shift;
                my $type_parameter = shift;
                my $val            = shift;
                return $type_parameter->_inline_check(
                    '${ (' . $val . ') }' );
            },
        )
    );

    $registry->add_type_constraint(
        Moose::Meta::TypeConstraint::Parameterizable->new(
            name               => 'ArrayRef',
            package_defined_in => __PACKAGE__,
            parent =>
                Moose::Util::TypeConstraints::find_type_constraint('Ref'),
            constraint => sub { ref($_) eq 'ARRAY' },
            optimized => \&_ArrayRef,
            constraint_generator => sub {
                my $type_parameter = shift;
                my $check = $type_parameter->_compiled_type_constraint;
                return sub {
                    foreach my $x (@$_) {
                        ( $check->($x) ) || return;
                    }
                    1;
                    }
            },
            inlined          => sub {qq{ref $_[1] eq 'ARRAY'}},
            inline_generator => sub {
                my $self           = shift;
                my $type_parameter = shift;
                my $val            = shift;
                return
                      '&List::MoreUtils::all( sub { '
                    . $type_parameter->_inline_check('$_')
                    . " }, \@{$val} )";
            },
        )
    );

    $registry->add_type_constraint(
        Moose::Meta::TypeConstraint::Parameterizable->new(
            name               => 'HashRef',
            package_defined_in => __PACKAGE__,
            parent =>
                Moose::Util::TypeConstraints::find_type_constraint('Ref'),
            constraint => sub { ref($_) eq 'HASH' },
            optimized => \&_HashRef,
            constraint_generator => sub {
                my $type_parameter = shift;
                my $check = $type_parameter->_compiled_type_constraint;
                return sub {
                    foreach my $x ( values %$_ ) {
                        ( $check->($x) ) || return;
                    }
                    1;
                    }
            },
            inlined          => sub {qq{ref $_[1] eq 'HASH'}},
            inline_generator => sub {
                my $self           = shift;
                my $type_parameter = shift;
                my $val            = shift;
                return
                      '&List::MoreUtils::all( sub { '
                    . $type_parameter->_inline_check('$_')
                    . " }, values \%{$val} )";
            },
        )
    );

    $registry->add_type_constraint(
        Moose::Meta::TypeConstraint::Parameterizable->new(
            name               => 'Maybe',
            package_defined_in => __PACKAGE__,
            parent =>
                Moose::Util::TypeConstraints::find_type_constraint('Item'),
            constraint           => sub {1},
            constraint_generator => sub {
                my $type_parameter = shift;
                my $check = $type_parameter->_compiled_type_constraint;
                return sub {
                    return 1 if not( defined($_) ) || $check->($_);
                    return;
                    }
            },
            inlined          => sub {'1'},
            inline_generator => sub {
                my $self           = shift;
                my $type_parameter = shift;
                my $val            = shift;
                return
                    "(! defined $val) || ("
                    . $type_parameter->_inline_check($val) . ')';
            },
        )
    );
}

sub _Value { defined($_[0]) && !ref($_[0]) }

sub _Ref { ref($_[0]) }

# We might need to use a temporary here to flatten LVALUEs, for instance as in
# Str(substr($_,0,255)).
sub _Str {
    defined($_[0])
      && (   ref(\             $_[0] ) eq 'SCALAR'
          || ref(\(my $value = $_[0])) eq 'SCALAR')
}

sub _Num { !ref($_[0]) && looks_like_number($_[0]) }

# using a temporary here because regex matching promotes an IV to a PV,
# and that confuses some things (like JSON.pm)
sub _Int {
    my $value = $_[0];
    defined($value) && !ref($value) && $value =~ /\A-?[0-9]+\z/
}

sub _ScalarRef { ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' }
sub _ArrayRef  { ref($_[0]) eq 'ARRAY'  }
sub _HashRef   { ref($_[0]) eq 'HASH'   }
sub _CodeRef   { ref($_[0]) eq 'CODE'   }
sub _GlobRef   { ref($_[0]) eq 'GLOB'   }

# RegexpRef is implemented in Moose.xs

sub _FileHandle {
    ref( $_[0] ) eq 'GLOB' && Scalar::Util::openhandle( $_[0] )
        or blessed( $_[0] ) && $_[0]->isa("IO::Handle");
}

sub _Object { blessed($_[0]) }

sub _Role {
    Moose::Deprecated::deprecated(
        feature => 'Role type',
        message =>
            'The Role type has been deprecated. Maybe you meant to create a RoleName type? This type be will be removed in Moose 2.0200.'
    );
    blessed( $_[0] ) && $_[0]->can('does');
}

sub _ClassName {
    return Class::MOP::is_class_loaded( $_[0] );
}

sub _RoleName {
    _ClassName( $_[0] )
        && ( Class::MOP::class_of( $_[0] ) || return )
        ->isa('Moose::Meta::Role');
}

1;
Commit	Line	Data
06d02aac	1	package Moose::Util::TypeConstraints::Builtins;
	2
	3	use strict;
	4	use warnings;
	5
7fb4b360	6	use List::MoreUtils ();
9882ca98	7	use Scalar::Util qw( blessed looks_like_number reftype );
06d02aac	8
	9	sub type { goto &Moose::Util::TypeConstraints::type }
	10	sub subtype { goto &Moose::Util::TypeConstraints::subtype }
	11	sub as { goto &Moose::Util::TypeConstraints::as }
	12	sub where (&) { goto &Moose::Util::TypeConstraints::where }
	13	sub optimize_as (&) { goto &Moose::Util::TypeConstraints::optimize_as }
4e36cf24	14	sub inline_as (&) { goto &Moose::Util::TypeConstraints::inline_as }
06d02aac	15
	16	sub define_builtins {
	17	my $registry = shift;
	18
4e36cf24	19	type 'Any' # meta-type including all
	20	=> where {1}
	21	=> inline_as { '1' };
06d02aac	22
4e36cf24	23	subtype 'Item' # base-type
94ab1609	24	=> as 'Any'
94ab1609	25	=> inline_as { '1' };
4e36cf24	26
	27	subtype 'Undef'
	28	=> as 'Item'
	29	=> where { !defined($_) }
964294c1	30	=> inline_as { "! defined $_[1]" };
4e36cf24	31
	32	subtype 'Defined'
	33	=> as 'Item'
	34	=> where { defined($_) }
964294c1	35	=> inline_as { "defined $_[1]" };
06d02aac	36
	37	subtype 'Bool'
	38	=> as 'Item'
4e36cf24	39	=> where { !defined($_) \|\| $_ eq "" \|\| "$_" eq '1' \|\| "$_" eq '0' }
964294c1	40	=> inline_as { qq{!defined($_[1]) \|\| $_[1] eq "" \|\| "$_[1]" eq '1' \|\| "$_[1]" eq '0'} };
06d02aac	41
	42	subtype 'Value'
	43	=> as 'Defined'
	44	=> where { !ref($_) }
4e36cf24	45	=> optimize_as( \&_Value )
964294c1	46	=> inline_as { "defined $_[1] && ! ref $_[1]" };
06d02aac	47
	48	subtype 'Ref'
	49	=> as 'Defined'
	50	=> where { ref($_) }
4e36cf24	51	=> optimize_as( \&_Ref )
964294c1	52	=> inline_as { "ref $_[1]" };
06d02aac	53
	54	subtype 'Str'
	55	=> as 'Value'
	56	=> where { ref(\$_) eq 'SCALAR' }
4e36cf24	57	=> optimize_as( \&_Str )
4e36cf24	58	=> inline_as {
964294c1	59	return ( qq{defined $_[1]}
964294c1	60	. qq{&& ( ref(\\ $_[1] ) eq 'SCALAR'}
ff1687ca	61	. qq{ \|\| ref(\\(my \$str_value = $_[1])) eq 'SCALAR')} );
4e36cf24	62	};
06d02aac	63
	64	subtype 'Num'
	65	=> as 'Str'
	66	=> where { Scalar::Util::looks_like_number($_) }
4e36cf24	67	=> optimize_as( \&_Num )
964294c1	68	=> inline_as { "!ref $_[1] && Scalar::Util::looks_like_number($_[1])" };
06d02aac	69
	70	subtype 'Int'
	71	=> as 'Num'
	72	=> where { "$_" =~ /^-?[0-9]+$/ }
4e36cf24	73	=> optimize_as( \&_Int )
4e36cf24	74	=> inline_as {
964294c1	75	return ( qq{defined $_[1]}
964294c1	76	. qq{&& ! ref $_[1]}
ff1687ca	77	. qq{&& ( my \$int_value = $_[1] ) =~ /\\A-?[0-9]+\\z/} );
4e36cf24	78	};
06d02aac	79
	80	subtype 'CodeRef'
	81	=> as 'Ref'
	82	=> where { ref($_) eq 'CODE' }
4e36cf24	83	=> optimize_as( \&_CodeRef )
964294c1	84	=> inline_as { qq{ref $_[1] eq 'CODE'} };
06d02aac	85
	86	subtype 'RegexpRef'
	87	=> as 'Ref'
9882ca98	88	=> where( \&_RegexpRef )
4e36cf24	89	=> optimize_as( \&_RegexpRef )
964294c1	90	=> inline_as { "Moose::Util::TypeConstraints::Builtins::_RegexpRef( $_[1] )" };
06d02aac	91
	92	subtype 'GlobRef'
	93	=> as 'Ref'
	94	=> where { ref($_) eq 'GLOB' }
4e36cf24	95	=> optimize_as( \&_GlobRef )
964294c1	96	=> inline_as { qq{ref $_[1] eq 'GLOB'} };
06d02aac	97
	98	# NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a
	99	# filehandle
	100	subtype 'FileHandle'
94ab1609	101	=> as 'Ref'
06d02aac	102	=> where {
	103	Scalar::Util::openhandle($_) \|\| ( blessed($_) && $_->isa("IO::Handle") );
	104	}
4e36cf24	105	=> optimize_as( \&_FileHandle )
4e36cf24	106	=> inline_as {
964294c1	107	return ( qq{ref $_[1] eq 'GLOB'}
	108	. qq{&& Scalar::Util::openhandle( $_[1] )}
	109	. qq{or Scalar::Util::blessed( $_[1] ) && $_[1]->isa("IO::Handle")} );
4e36cf24	110	};
06d02aac	111
	112	subtype 'Object'
	113	=> as 'Ref'
	114	=> where { blessed($_) }
4e36cf24	115	=> optimize_as( \&_Object )
964294c1	116	=> inline_as { "Scalar::Util::blessed( $_[1] )" };
06d02aac	117
	118	# This type is deprecated.
	119	subtype 'Role'
	120	=> as 'Object'
	121	=> where { $_->can('does') }
4e36cf24	122	=> optimize_as( \&_Role );
06d02aac	123
	124	subtype 'ClassName'
	125	=> as 'Str'
	126	=> where { Class::MOP::is_class_loaded($_) }
4e36cf24	127	=> optimize_as( \&_ClassName )
964294c1	128	=> inline_as { "Class::MOP::is_class_loaded( $_[1] )" };
06d02aac	129
	130	subtype 'RoleName'
	131	=> as 'ClassName'
	132	=> where {
	133	(Class::MOP::class_of($_) \|\| return)->isa('Moose::Meta::Role');
	134	}
4e36cf24	135	=> optimize_as( \&_RoleName )
4e36cf24	136	=> inline_as {
964294c1	137	return ( qq{Class::MOP::is_class_loaded( $_[1] )}
964294c1	138	. qq{&& ( Class::MOP::class_of( $_[1] ) \|\| return )}
4e36cf24	139	. qq{ ->isa('Moose::Meta::Role')} );
4e36cf24	140	};
06d02aac	141
	142	$registry->add_type_constraint(
	143	Moose::Meta::TypeConstraint::Parameterizable->new(
	144	name => 'ScalarRef',
	145	package_defined_in => __PACKAGE__,
	146	parent =>
	147	Moose::Util::TypeConstraints::find_type_constraint('Ref'),
	148	constraint => sub { ref($_) eq 'SCALAR' \|\| ref($_) eq 'REF' },
9882ca98	149	optimized => \&_ScalarRef,
06d02aac	150	constraint_generator => sub {
	151	my $type_parameter = shift;
	152	my $check = $type_parameter->_compiled_type_constraint;
	153	return sub {
	154	return $check->( ${$_} );
	155	};
7fb4b360	156	},
964294c1	157	inlined => sub {qq{ref $_[1] eq 'SCALAR' \|\| ref $_[1] eq 'REF'}},
7fb4b360	158	inline_generator => sub {
964294c1	159	my $self = shift;
7fb4b360	160	my $type_parameter = shift;
	161	my $val = shift;
	162	return $type_parameter->_inline_check(
	163	'${ (' . $val . ') }' );
	164	},
06d02aac	165	)
	166	);
	167
	168	$registry->add_type_constraint(
	169	Moose::Meta::TypeConstraint::Parameterizable->new(
	170	name => 'ArrayRef',
	171	package_defined_in => __PACKAGE__,
	172	parent =>
	173	Moose::Util::TypeConstraints::find_type_constraint('Ref'),
	174	constraint => sub { ref($_) eq 'ARRAY' },
9882ca98	175	optimized => \&_ArrayRef,
06d02aac	176	constraint_generator => sub {
	177	my $type_parameter = shift;
	178	my $check = $type_parameter->_compiled_type_constraint;
	179	return sub {
	180	foreach my $x (@$_) {
	181	( $check->($x) ) \|\| return;
	182	}
	183	1;
	184	}
7fb4b360	185	},
964294c1	186	inlined => sub {qq{ref $_[1] eq 'ARRAY'}},
7fb4b360	187	inline_generator => sub {
964294c1	188	my $self = shift;
7fb4b360	189	my $type_parameter = shift;
	190	my $val = shift;
	191	return
	192	'&List::MoreUtils::all( sub { '
	193	. $type_parameter->_inline_check('$_')
	194	. " }, \@{$val} )";
	195	},
06d02aac	196	)
	197	);
	198
	199	$registry->add_type_constraint(
	200	Moose::Meta::TypeConstraint::Parameterizable->new(
	201	name => 'HashRef',
	202	package_defined_in => __PACKAGE__,
	203	parent =>
	204	Moose::Util::TypeConstraints::find_type_constraint('Ref'),
	205	constraint => sub { ref($_) eq 'HASH' },
9882ca98	206	optimized => \&_HashRef,
06d02aac	207	constraint_generator => sub {
	208	my $type_parameter = shift;
	209	my $check = $type_parameter->_compiled_type_constraint;
	210	return sub {
	211	foreach my $x ( values %$_ ) {
	212	( $check->($x) ) \|\| return;
	213	}
	214	1;
	215	}
7fb4b360	216	},
964294c1	217	inlined => sub {qq{ref $_[1] eq 'HASH'}},
7fb4b360	218	inline_generator => sub {
964294c1	219	my $self = shift;
7fb4b360	220	my $type_parameter = shift;
	221	my $val = shift;
	222	return
	223	'&List::MoreUtils::all( sub { '
	224	. $type_parameter->_inline_check('$_')
	225	. " }, values \%{$val} )";
	226	},
06d02aac	227	)
	228	);
	229
	230	$registry->add_type_constraint(
	231	Moose::Meta::TypeConstraint::Parameterizable->new(
	232	name => 'Maybe',
	233	package_defined_in => __PACKAGE__,
	234	parent =>
	235	Moose::Util::TypeConstraints::find_type_constraint('Item'),
	236	constraint => sub {1},
	237	constraint_generator => sub {
	238	my $type_parameter = shift;
	239	my $check = $type_parameter->_compiled_type_constraint;
	240	return sub {
	241	return 1 if not( defined($_) ) \|\| $check->($_);
	242	return;
	243	}
7fb4b360	244	},
	245	inlined => sub {'1'},
	246	inline_generator => sub {
964294c1	247	my $self = shift;
7fb4b360	248	my $type_parameter = shift;
	249	my $val = shift;
	250	return
	251	"(! defined $val) \|\| ("
	252	. $type_parameter->_inline_check($val) . ')';
	253	},
06d02aac	254	)
	255	);
	256	}
	257
9882ca98	258	sub _Value { defined($_[0]) && !ref($_[0]) }
	259
	260	sub _Ref { ref($_[0]) }
	261
	262	# We might need to use a temporary here to flatten LVALUEs, for instance as in
	263	# Str(substr($_,0,255)).
	264	sub _Str {
	265	defined($_[0])
	266	&& ( ref(\ $_[0] ) eq 'SCALAR'
	267	\|\| ref(\(my $value = $_[0])) eq 'SCALAR')
	268	}
	269
	270	sub _Num { !ref($_[0]) && looks_like_number($_[0]) }
	271
	272	# using a temporary here because regex matching promotes an IV to a PV,
	273	# and that confuses some things (like JSON.pm)
	274	sub _Int {
	275	my $value = $_[0];
	276	defined($value) && !ref($value) && $value =~ /\A-?[0-9]+\z/
	277	}
	278
	279	sub _ScalarRef { ref($_[0]) eq 'SCALAR' \|\| ref($_[0]) eq 'REF' }
	280	sub _ArrayRef { ref($_[0]) eq 'ARRAY' }
	281	sub _HashRef { ref($_[0]) eq 'HASH' }
	282	sub _CodeRef { ref($_[0]) eq 'CODE' }
	283	sub _GlobRef { ref($_[0]) eq 'GLOB' }
	284
	285	# RegexpRef is implemented in Moose.xs
	286
	287	sub _FileHandle {
	288	ref( $_[0] ) eq 'GLOB' && Scalar::Util::openhandle( $_[0] )
	289	or blessed( $_[0] ) && $_[0]->isa("IO::Handle");
	290	}
	291
	292	sub _Object { blessed($_[0]) }
	293
	294	sub _Role {
	295	Moose::Deprecated::deprecated(
	296	feature => 'Role type',
	297	message =>
	298	'The Role type has been deprecated. Maybe you meant to create a RoleName type? This type be will be removed in Moose 2.0200.'
	299	);
	300	blessed( $_[0] ) && $_[0]->can('does');
	301	}
	302
	303	sub _ClassName {
	304	return Class::MOP::is_class_loaded( $_[0] );
	305	}
	306
	307	sub _RoleName {
4e36cf24	308	_ClassName( $_[0] )
9882ca98	309	&& ( Class::MOP::class_of( $_[0] ) \|\| return )
	310	->isa('Moose::Meta::Role');
	311	}
	312
06d02aac	313	1;