[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' }
        => 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 { "$_" =~ /\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 {
            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] . ') '
              . '&& (Class::MOP::class_of(' . $_[1] . ') || return)->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;
                'ref(' . $val . ') eq "ARRAY" '
                  . '&& &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' },
            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;
                'ref(' . $val . ') eq "HASH" '
                  . '&& &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;
                '!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'
	59	=> where { ref(\$_) eq 'SCALAR' }
4e36cf24	60	=> inline_as {
3975b592	61	'defined(' . $_[1] . ') '
	62	. '&& (ref(\\' . $_[1] . ') eq "SCALAR"'
	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'
743ec002	76	=> where { "$_" =~ /\A-?[0-9]+\z/ }
4e36cf24	77	=> inline_as {
3975b592	78	'defined(' . $_[1] . ') '
	79	. '&& !ref(' . $_[1] . ') '
	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 {
	105	Scalar::Util::openhandle($_) \|\| ( blessed($_) && $_->isa("IO::Handle") );
	106	}
4e36cf24	107	=> inline_as {
3975b592	108	'(ref(' . $_[1] . ') eq "GLOB" '
	109	. '&& Scalar::Util::openhandle(' . $_[1] . ')) '
	110	. '\|\| (Scalar::Util::blessed(' . $_[1] . ') '
	111	. '&& ' . $_[1] . '->isa("IO::Handle"))'
4e36cf24	112	};
06d02aac	113
	114	subtype 'Object'
	115	=> as 'Ref'
	116	=> where { blessed($_) }
3975b592	117	=> inline_as { 'Scalar::Util::blessed(' . $_[1] . ')' };
06d02aac	118
	119	# This type is deprecated.
	120	subtype 'Role'
	121	=> as 'Object'
43837b8a	122	=> where { $_->can('does') };
06d02aac	123
	124	subtype 'ClassName'
	125	=> as 'Str'
	126	=> where { Class::MOP::is_class_loaded($_) }
3975b592	127	=> inline_as { 'Class::MOP::is_class_loaded(' . $_[1] . ')' };
06d02aac	128
	129	subtype 'RoleName'
	130	=> as 'ClassName'
	131	=> where {
	132	(Class::MOP::class_of($_) \|\| return)->isa('Moose::Meta::Role');
	133	}
4e36cf24	134	=> inline_as {
3975b592	135	'Class::MOP::is_class_loaded(' . $_[1] . ') '
	136	. '&& (Class::MOP::class_of(' . $_[1] . ') \|\| return)->isa('
	137	. '"Moose::Meta::Role"'
	138	. ')'
4e36cf24	139	};
06d02aac	140
	141	$registry->add_type_constraint(
	142	Moose::Meta::TypeConstraint::Parameterizable->new(
	143	name => 'ScalarRef',
	144	package_defined_in => __PACKAGE__,
	145	parent =>
	146	Moose::Util::TypeConstraints::find_type_constraint('Ref'),
	147	constraint => sub { ref($_) eq 'SCALAR' \|\| ref($_) eq 'REF' },
06d02aac	148	constraint_generator => sub {
	149	my $type_parameter = shift;
	150	my $check = $type_parameter->_compiled_type_constraint;
	151	return sub {
	152	return $check->( ${$_} );
	153	};
7fb4b360	154	},
3975b592	155	inlined => sub {
	156	'ref(' . $_[1] . ') eq "SCALAR" '
	157	. '\|\| ref(' . $_[1] . ') eq "REF"'
	158	},
7fb4b360	159	inline_generator => sub {
964294c1	160	my $self = shift;
7fb4b360	161	my $type_parameter = shift;
7fb4b360	162	my $val = shift;
3975b592	163	'(ref(' . $val . ') eq "SCALAR" \|\| ref(' . $val . ') eq "REF") '
3975b592	164	. '&& ' . $type_parameter->_inline_check('${(' . $val . ')}')
7fb4b360	165	},
06d02aac	166	)
	167	);
	168
	169	$registry->add_type_constraint(
	170	Moose::Meta::TypeConstraint::Parameterizable->new(
	171	name => 'ArrayRef',
	172	package_defined_in => __PACKAGE__,
	173	parent =>
	174	Moose::Util::TypeConstraints::find_type_constraint('Ref'),
	175	constraint => sub { ref($_) eq 'ARRAY' },
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	},
3975b592	186	inlined => sub { 'ref(' . $_[1] . ') eq "ARRAY"' },
7fb4b360	187	inline_generator => sub {
964294c1	188	my $self = shift;
7fb4b360	189	my $type_parameter = shift;
7fb4b360	190	my $val = shift;
3975b592	191	'ref(' . $val . ') eq "ARRAY" '
	192	. '&& &List::MoreUtils::all('
	193	. 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
	194	. '@{' . $val . '}'
	195	. ')'
7fb4b360	196	},
06d02aac	197	)
	198	);
	199
	200	$registry->add_type_constraint(
	201	Moose::Meta::TypeConstraint::Parameterizable->new(
	202	name => 'HashRef',
	203	package_defined_in => __PACKAGE__,
	204	parent =>
	205	Moose::Util::TypeConstraints::find_type_constraint('Ref'),
	206	constraint => sub { ref($_) eq 'HASH' },
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	},
3975b592	217	inlined => sub { 'ref(' . $_[1] . ') eq "HASH"' },
7fb4b360	218	inline_generator => sub {
964294c1	219	my $self = shift;
7fb4b360	220	my $type_parameter = shift;
7fb4b360	221	my $val = shift;
3975b592	222	'ref(' . $val . ') eq "HASH" '
	223	. '&& &List::MoreUtils::all('
	224	. 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
	225	. 'values %{' . $val . '}'
	226	. ')'
7fb4b360	227	},
06d02aac	228	)
	229	);
	230
	231	$registry->add_type_constraint(
	232	Moose::Meta::TypeConstraint::Parameterizable->new(
	233	name => 'Maybe',
	234	package_defined_in => __PACKAGE__,
	235	parent =>
	236	Moose::Util::TypeConstraints::find_type_constraint('Item'),
	237	constraint => sub {1},
	238	constraint_generator => sub {
	239	my $type_parameter = shift;
	240	my $check = $type_parameter->_compiled_type_constraint;
	241	return sub {
	242	return 1 if not( defined($_) ) \|\| $check->($_);
	243	return;
	244	}
7fb4b360	245	},
	246	inlined => sub {'1'},
	247	inline_generator => sub {
964294c1	248	my $self = shift;
7fb4b360	249	my $type_parameter = shift;
7fb4b360	250	my $val = shift;
3975b592	251	'!defined(' . $val . ') '
3975b592	252	. '\|\| (' . $type_parameter->_inline_check($val) . ')'
7fb4b360	253	},
06d02aac	254	)
	255	);
	256	}
	257
	258	1;