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

    subtype 'Defined'
        => as 'Item'
        => where { defined($_) }
        => inline_as {
            $_[0]->parent()->_inline_check($_[1])
            . ' && defined(' . $_[1] . ')'
        };

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

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

    subtype 'Ref'
        => as 'Defined'
        => where { ref($_) }
            # no need to call parent - ref also checks for definedness
        => inline_as { 'ref(' . $_[1] . ')' };

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

    my $value_type = Moose::Util::TypeConstraints::find_type_constraint('Value');
    subtype 'Num'
        => as 'Str'
        => where { Scalar::Util::looks_like_number($_) }
        => inline_as {
            # the long Str tests are redundant here
            $value_type->_inline_check($_[1])
            . ' && Scalar::Util::looks_like_number(' . $_[1] . ')'
        };

    subtype 'Int'
        => as 'Num'
        => where { (my $val = $_) =~ /\A-?[0-9]+\z/ }
        => inline_as {
            $value_type->_inline_check($_[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($_) }
            # the long Str tests are redundant here
        => inline_as { 'Class::MOP::is_class_loaded(' . $_[1] . ')' };

    subtype 'RoleName'
        => as 'ClassName'
        => where {
            (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
        }
        => inline_as {
            $_[0]->parent()->_inline_check($_[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;

__END__

=pod

=for pod_coverage_needs_some_pod

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