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

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

use strict;
use warnings;

use Class::Load qw( is_class_loaded );
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 {
            $_[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] . ')' };

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