[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 {
            '!defined(' . $_[1] . ') '
              . '|| ' . $_[1] . ' eq "" '
              . '|| "' . $_[1] . '" eq "1" '
              . '|| "' . $_[1] . '" eq "0"'
        };

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

    subtype 'Ref'
        => as 'Defined'
        => where { ref($_) }
        => inline_as { 'ref(' . $_[1] . ')' };

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

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

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

    subtype 'CodeRef'
        => as 'Ref'
        => where { ref($_) eq 'CODE' }
        => inline_as { 'ref(' . $_[1] . ') eq "CODE"' };

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

    subtype 'GlobRef'
        => as 'Ref'
        => where { ref($_) eq 'GLOB' }
        => inline_as { 'ref(' . $_[1] . ') eq "GLOB"' };

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

    subtype 'Object'
        => as 'Ref'
        => where { blessed($_) }
        => inline_as { 'Scalar::Util::blessed(' . $_[1] . ')' };

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

    subtype 'ClassName'
        => as 'Str'
        => where { Class::MOP::is_class_loaded($_) }
        => inline_as { 'Class::MOP::is_class_loaded(' . $_[1] . ')' };

    subtype 'RoleName'
        => as 'ClassName'
        => where {
            (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
        }
        => inline_as {
            'Class::MOP::is_class_loaded(' . $_[1] . ') '
              . '&& do {'
                  . 'my $meta = Class::MOP::class_of(' . $_[1] . ');'
                  . '$meta && $meta->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' },
            constraint_generator => sub {
                my $type_parameter = shift;
                my $check = $type_parameter->_compiled_type_constraint;
                return sub {
                    return $check->( ${$_} );
                };
            },
            inlined => sub {
                'ref(' . $_[1] . ') eq "SCALAR" '
                  . '|| ref(' . $_[1] . ') eq "REF"'
            },
            inline_generator => sub {
                my $self           = shift;
                my $type_parameter = shift;
                my $val            = shift;
                '(ref(' . $val . ') eq "SCALAR" || ref(' . $val . ') eq "REF") '
                  . '&& ' . $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' },
            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 { 'ref(' . $_[1] . ') eq "ARRAY"' },
            inline_generator => sub {
                my $self           = shift;
                my $type_parameter = shift;
                my $val            = shift;

                'do {'
                    . 'my $check = ' . $val . ';'
                    . 'ref($check) eq "ARRAY" '
                        . '&& &List::MoreUtils::all('
                            . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
                            . '@{$check}'
                        . ')'
                . '}';
            },
        )
    );

    $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' },
            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 { 'ref(' . $_[1] . ') eq "HASH"' },
            inline_generator => sub {
                my $self           = shift;
                my $type_parameter = shift;
                my $val            = shift;

                'do {'
                    . 'my $check = ' . $val . ';'
                    . 'ref($check) eq "HASH" '
                        . '&& &List::MoreUtils::all('
                            . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
                            . 'values %{$check}'
                        . ')'
                . '}';
            },
        )
    );

    $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;
                '!defined(' . $val . ') '
                  . '|| (' . $type_parameter->_inline_check($val) . ')'
            },
        )
    );
}

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($_) }
3975b592	30	=> inline_as { '!defined(' . $_[1] . ')' };
4e36cf24	31
	32	subtype 'Defined'
	33	=> as 'Item'
	34	=> where { defined($_) }
3975b592	35	=> inline_as { 'defined(' . $_[1] . ')' };
06d02aac	36
	37	subtype 'Bool'
	38	=> as 'Item'
4e36cf24	39	=> where { !defined($_) \|\| $_ eq "" \|\| "$_" eq '1' \|\| "$_" eq '0' }
3975b592	40	=> inline_as {
	41	'!defined(' . $_[1] . ') '
	42	. '\|\| ' . $_[1] . ' eq "" '
	43	. '\|\| "' . $_[1] . '" eq "1" '
	44	. '\|\| "' . $_[1] . '" eq "0"'
	45	};
06d02aac	46
	47	subtype 'Value'
	48	=> as 'Defined'
	49	=> where { !ref($_) }
3975b592	50	=> inline_as { 'defined(' . $_[1] . ') && !ref(' . $_[1] . ')' };
06d02aac	51
	52	subtype 'Ref'
	53	=> as 'Defined'
	54	=> where { ref($_) }
3975b592	55	=> inline_as { 'ref(' . $_[1] . ')' };
06d02aac	56
	57	subtype 'Str'
	58	=> as 'Value'
a79639df	59	=> where { ref(\$_) eq 'SCALAR' \|\| ref(\(my $val = $_)) eq 'SCALAR' }
4e36cf24	60	=> inline_as {
3975b592	61	'defined(' . $_[1] . ') '
3975b592	62	. '&& (ref(\\' . $_[1] . ') eq "SCALAR"'
e6fff671	63	. '\|\| ref(\\(my $val = ' . $_[1] . ')) eq "SCALAR" )'
4e36cf24	64	};
06d02aac	65
	66	subtype 'Num'
	67	=> as 'Str'
	68	=> where { Scalar::Util::looks_like_number($_) }
3975b592	69	=> inline_as {
	70	'!ref(' . $_[1] . ') '
	71	. '&& Scalar::Util::looks_like_number(' . $_[1] . ')'
	72	};
06d02aac	73
	74	subtype 'Int'
	75	=> as 'Num'
a79639df	76	=> where { (my $val = $_) =~ /\A-?[0-9]+\z/ }
4e36cf24	77	=> inline_as {
3975b592	78	'defined(' . $_[1] . ') '
3975b592	79	. '&& !ref(' . $_[1] . ') '
e6fff671	80	. '&& (my $val = ' . $_[1] . ') =~ /\A-?[0-9]+\z/'
4e36cf24	81	};
06d02aac	82
	83	subtype 'CodeRef'
	84	=> as 'Ref'
	85	=> where { ref($_) eq 'CODE' }
3975b592	86	=> inline_as { 'ref(' . $_[1] . ') eq "CODE"' };
06d02aac	87
	88	subtype 'RegexpRef'
	89	=> as 'Ref'
9882ca98	90	=> where( \&_RegexpRef )
3975b592	91	=> inline_as {
	92	'Moose::Util::TypeConstraints::Builtins::_RegexpRef(' . $_[1] . ')'
	93	};
06d02aac	94
	95	subtype 'GlobRef'
	96	=> as 'Ref'
	97	=> where { ref($_) eq 'GLOB' }
3975b592	98	=> inline_as { 'ref(' . $_[1] . ') eq "GLOB"' };
06d02aac	99
	100	# NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a
	101	# filehandle
	102	subtype 'FileHandle'
94ab1609	103	=> as 'Ref'
06d02aac	104	=> where {
188ba420	105	(ref($_) eq "GLOB" && Scalar::Util::openhandle($_))
188ba420	106	\|\| (blessed($_) && $_->isa("IO::Handle"));
06d02aac	107	}
4e36cf24	108	=> inline_as {
3975b592	109	'(ref(' . $_[1] . ') eq "GLOB" '
	110	. '&& Scalar::Util::openhandle(' . $_[1] . ')) '
	111	. '\|\| (Scalar::Util::blessed(' . $_[1] . ') '
	112	. '&& ' . $_[1] . '->isa("IO::Handle"))'
4e36cf24	113	};
06d02aac	114
	115	subtype 'Object'
	116	=> as 'Ref'
	117	=> where { blessed($_) }
3975b592	118	=> inline_as { 'Scalar::Util::blessed(' . $_[1] . ')' };
06d02aac	119
	120	# This type is deprecated.
	121	subtype 'Role'
	122	=> as 'Object'
43837b8a	123	=> where { $_->can('does') };
06d02aac	124
	125	subtype 'ClassName'
	126	=> as 'Str'
	127	=> where { Class::MOP::is_class_loaded($_) }
3975b592	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	=> inline_as {
3975b592	136	'Class::MOP::is_class_loaded(' . $_[1] . ') '
d6874ac6	137	. '&& do {'
	138	. 'my $meta = Class::MOP::class_of(' . $_[1] . ');'
	139	. '$meta && $meta->isa("Moose::Meta::Role");'
	140	. '}'
4e36cf24	141	};
06d02aac	142
	143	$registry->add_type_constraint(
	144	Moose::Meta::TypeConstraint::Parameterizable->new(
	145	name => 'ScalarRef',
	146	package_defined_in => __PACKAGE__,
	147	parent =>
	148	Moose::Util::TypeConstraints::find_type_constraint('Ref'),
	149	constraint => sub { ref($_) eq 'SCALAR' \|\| ref($_) eq 'REF' },
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	},
3975b592	157	inlined => sub {
	158	'ref(' . $_[1] . ') eq "SCALAR" '
	159	. '\|\| ref(' . $_[1] . ') eq "REF"'
	160	},
7fb4b360	161	inline_generator => sub {
964294c1	162	my $self = shift;
7fb4b360	163	my $type_parameter = shift;
7fb4b360	164	my $val = shift;
3975b592	165	'(ref(' . $val . ') eq "SCALAR" \|\| ref(' . $val . ') eq "REF") '
3975b592	166	. '&& ' . $type_parameter->_inline_check('${(' . $val . ')}')
7fb4b360	167	},
06d02aac	168	)
	169	);
	170
	171	$registry->add_type_constraint(
	172	Moose::Meta::TypeConstraint::Parameterizable->new(
	173	name => 'ArrayRef',
	174	package_defined_in => __PACKAGE__,
	175	parent =>
	176	Moose::Util::TypeConstraints::find_type_constraint('Ref'),
	177	constraint => sub { ref($_) eq 'ARRAY' },
06d02aac	178	constraint_generator => sub {
	179	my $type_parameter = shift;
	180	my $check = $type_parameter->_compiled_type_constraint;
	181	return sub {
	182	foreach my $x (@$_) {
	183	( $check->($x) ) \|\| return;
	184	}
	185	1;
	186	}
7fb4b360	187	},
3975b592	188	inlined => sub { 'ref(' . $_[1] . ') eq "ARRAY"' },
7fb4b360	189	inline_generator => sub {
964294c1	190	my $self = shift;
7fb4b360	191	my $type_parameter = shift;
7fb4b360	192	my $val = shift;
d6874ac6	193
	194	'do {'
	195	. 'my $check = ' . $val . ';'
	196	. 'ref($check) eq "ARRAY" '
	197	. '&& &List::MoreUtils::all('
	198	. 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
	199	. '@{$check}'
	200	. ')'
	201	. '}';
7fb4b360	202	},
06d02aac	203	)
	204	);
	205
	206	$registry->add_type_constraint(
	207	Moose::Meta::TypeConstraint::Parameterizable->new(
	208	name => 'HashRef',
	209	package_defined_in => __PACKAGE__,
	210	parent =>
	211	Moose::Util::TypeConstraints::find_type_constraint('Ref'),
	212	constraint => sub { ref($_) eq 'HASH' },
06d02aac	213	constraint_generator => sub {
	214	my $type_parameter = shift;
	215	my $check = $type_parameter->_compiled_type_constraint;
	216	return sub {
	217	foreach my $x ( values %$_ ) {
	218	( $check->($x) ) \|\| return;
	219	}
	220	1;
	221	}
7fb4b360	222	},
3975b592	223	inlined => sub { 'ref(' . $_[1] . ') eq "HASH"' },
7fb4b360	224	inline_generator => sub {
964294c1	225	my $self = shift;
7fb4b360	226	my $type_parameter = shift;
7fb4b360	227	my $val = shift;
d6874ac6	228
	229	'do {'
	230	. 'my $check = ' . $val . ';'
	231	. 'ref($check) eq "HASH" '
	232	. '&& &List::MoreUtils::all('
	233	. 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
	234	. 'values %{$check}'
	235	. ')'
	236	. '}';
7fb4b360	237	},
06d02aac	238	)
	239	);
	240
	241	$registry->add_type_constraint(
	242	Moose::Meta::TypeConstraint::Parameterizable->new(
	243	name => 'Maybe',
	244	package_defined_in => __PACKAGE__,
	245	parent =>
	246	Moose::Util::TypeConstraints::find_type_constraint('Item'),
	247	constraint => sub {1},
	248	constraint_generator => sub {
	249	my $type_parameter = shift;
	250	my $check = $type_parameter->_compiled_type_constraint;
	251	return sub {
	252	return 1 if not( defined($_) ) \|\| $check->($_);
	253	return;
	254	}
7fb4b360	255	},
	256	inlined => sub {'1'},
	257	inline_generator => sub {
964294c1	258	my $self = shift;
7fb4b360	259	my $type_parameter = shift;
7fb4b360	260	my $val = shift;
3975b592	261	'!defined(' . $val . ') '
3975b592	262	. '\|\| (' . $type_parameter->_inline_check($val) . ')'
7fb4b360	263	},
06d02aac	264	)
	265	);
	266	}
	267
	268	1;