die 'Cannot inline a type constraint check for ' . $self->name
unless $self->has_inlined_type_constraint;
- return $self->inlined()->(@_);
+ return $self->inlined->( $self, @_ );
}
sub assert_valid {
use warnings;
use metaclass;
+use B;
use Scalar::Util 'blessed';
use Moose::Util::TypeConstraints ();
reader => 'class',
));
+my $inliner = sub {
+ my $self = shift;
+ my $val = shift;
+
+ return
+ "Scalar::Util::blessed($val) && $val->isa("
+ . B::perlstring( $self->class ) . ')';
+};
+
sub new {
my ( $class, %args ) = @_;
- $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
- my $self = $class->_new(\%args);
+ $args{parent}
+ = Moose::Util::TypeConstraints::find_type_constraint('Object');
+
+ my $class_name = $args{class};
+ $args{constraint} = sub { $_[0]->isa($class_name) };
+
+ $args{inlined} = $inliner;
+
+ my $self = $class->_new( \%args );
$self->_create_hand_optimized_type_constraint;
$self->compile_type_constraint();
use warnings;
use metaclass;
+use B;
use Scalar::Util 'blessed';
use List::MoreUtils qw(all);
use Moose::Util 'english_list';
accessor => 'methods',
));
+my $inliner = sub {
+ my $self = shift;
+ my $val = shift;
+
+ return
+ "Scalar::Util::blessed($val)"
+ . qq{&& Scalar::Util::blessed($val) ne 'Regexp'}
+ . "&& &List::MoreUtils::all( sub { $val->can(\$_) }, "
+ . ( join ', ', map { B::perlstring($_) } @{ $self->methods } ) . ' )';
+};
+
sub new {
my ( $class, %args ) = @_;
- $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
+ $args{parent}
+ = Moose::Util::TypeConstraints::find_type_constraint('Object');
+
+ my @methods = @{ $args{methods} };
+ $args{constraint} = sub {
+ blessed( $_[0] ) ne 'Regexp'
+ && all { $_[0]->can($_) } @methods;
+ };
+
+ $args{inlined} = $inliner;
my $self = $class->_new(\%args);
use warnings;
use metaclass;
+use B;
use Moose::Util::TypeConstraints ();
use base 'Moose::Meta::TypeConstraint';
accessor => 'values',
));
+our %ENUMS;
+
+my $inliner = sub {
+ my $self = shift;
+ my $val = shift;
+
+ my $name = $self->name();
+ $ENUMS{$name} ||= { map { $_ => 1 } @{ $self->values() } };
+
+ return
+ "defined $val && " . '$'
+ . __PACKAGE__
+ . '::ENUMS{'
+ . B::perlstring($name)
+ . "}{ $val }";
+};
+
sub new {
my ( $class, %args ) = @_;
$args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Str');
+ $args{inlined} = $inliner;
if ( scalar @{ $args{values} } < 2 ) {
require Moose;
}
}
+ my %values = map { $_ => 1 } @{ $args{values} };
+ $args{constraint} = sub { $values{ $_[0] } };
+
my $self = $class->_new(\%args);
$self->compile_type_constraint()
return unless $self->has_inline_generator;
- return $self->inline_generator->( $type, $val );
+ return $self->inline_generator->( $self, $type, $val );
}
sub _parse_type_parameter {
subtype 'Undef'
=> as 'Item'
=> where { !defined($_) }
- => inline_as { "! defined $_[0]" };
+ => inline_as { "! defined $_[1]" };
subtype 'Defined'
=> as 'Item'
=> where { defined($_) }
- => inline_as { "defined $_[0]" };
+ => inline_as { "defined $_[1]" };
subtype 'Bool'
=> as 'Item'
=> where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }
- => inline_as { qq{!defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" 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 $_[0] && ! ref $_[0]" };
+ => inline_as { "defined $_[1] && ! ref $_[1]" };
subtype 'Ref'
=> as 'Defined'
=> where { ref($_) }
=> optimize_as( \&_Ref )
- => inline_as { "ref $_[0]" };
+ => inline_as { "ref $_[1]" };
subtype 'Str'
=> as 'Value'
=> where { ref(\$_) eq 'SCALAR' }
=> optimize_as( \&_Str )
=> inline_as {
- return ( qq{defined $_[0]}
- . qq{&& ( ref(\\ $_[0] ) eq 'SCALAR'}
- . qq{ || ref(\\(my \$value = $_[0])) eq 'SCALAR')} );
+ return ( qq{defined $_[1]}
+ . qq{&& ( ref(\\ $_[1] ) eq 'SCALAR'}
+ . qq{ || ref(\\(my \$value = $_[1])) eq 'SCALAR')} );
};
subtype 'Num'
=> as 'Str'
=> where { Scalar::Util::looks_like_number($_) }
=> optimize_as( \&_Num )
- => inline_as { "!ref $_[0] && Scalar::Util::looks_like_number($_[0])" };
+ => 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 $_[0]}
- . qq{&& ! ref $_[0]}
- . qq{&& ( my \$value = $_[0] ) =~ /\\A-?[0-9]+\\z/} );
+ return ( qq{defined $_[1]}
+ . qq{&& ! ref $_[1]}
+ . qq{&& ( my \$value = $_[1] ) =~ /\\A-?[0-9]+\\z/} );
};
subtype 'CodeRef'
=> as 'Ref'
=> where { ref($_) eq 'CODE' }
=> optimize_as( \&_CodeRef )
- => inline_as { qq{ref $_[0] eq 'CODE'} };
+ => inline_as { qq{ref $_[1] eq 'CODE'} };
subtype 'RegexpRef'
=> as 'Ref'
=> where( \&_RegexpRef )
=> optimize_as( \&_RegexpRef )
- => inline_as { "Moose::Util::TypeConstraints::Builtins::_RegexpRef( $_[0] )" };
+ => inline_as { "Moose::Util::TypeConstraints::Builtins::_RegexpRef( $_[1] )" };
subtype 'GlobRef'
=> as 'Ref'
=> where { ref($_) eq 'GLOB' }
=> optimize_as( \&_GlobRef )
- => inline_as { qq{ref $_[0] eq 'GLOB'} };
+ => inline_as { qq{ref $_[1] eq 'GLOB'} };
# NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a
# filehandle
}
=> optimize_as( \&_FileHandle )
=> inline_as {
- return ( qq{ref $_[0] eq 'GLOB'}
- . qq{&& Scalar::Util::openhandle( $_[0] )}
- . qq{or Scalar::Util::blessed( $_[0] ) && $_[0]->isa("IO::Handle")} );
+ 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( $_[0] )" };
+ => inline_as { "Scalar::Util::blessed( $_[1] )" };
# This type is deprecated.
subtype 'Role'
=> as 'Str'
=> where { Class::MOP::is_class_loaded($_) }
=> optimize_as( \&_ClassName )
- => inline_as { "Class::MOP::is_class_loaded( $_[0] )" };
+ => inline_as { "Class::MOP::is_class_loaded( $_[1] )" };
subtype 'RoleName'
=> as 'ClassName'
}
=> optimize_as( \&_RoleName )
=> inline_as {
- return ( qq{Class::MOP::is_class_loaded( $_[0] )}
- . qq{&& ( Class::MOP::class_of( $_[0] ) || return )}
+ return ( qq{Class::MOP::is_class_loaded( $_[1] )}
+ . qq{&& ( Class::MOP::class_of( $_[1] ) || return )}
. qq{ ->isa('Moose::Meta::Role')} );
};
return $check->( ${$_} );
};
},
- inlined => sub {qq{ref $_[0] eq 'SCALAR' || ref $_[0] eq 'REF'}},
+ 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(
1;
}
},
- inlined => sub {qq{ref $_[0] eq 'ARRAY'}},
+ inlined => sub {qq{ref $_[1] eq 'ARRAY'}},
inline_generator => sub {
+ my $self = shift;
my $type_parameter = shift;
my $val = shift;
return
1;
}
},
- inlined => sub {qq{ref $_[0] eq 'HASH'}},
+ inlined => sub {qq{ref $_[1] eq 'HASH'}},
inline_generator => sub {
+ my $self = shift;
my $type_parameter = shift;
my $val = shift;
return
},
inlined => sub {'1'},
inline_generator => sub {
+ my $self = shift;
my $type_parameter = shift;
my $val = shift;
return
use Test::More;
use IO::File;
-use Moose::Util::TypeConstraints ();
+use Moose::Util::TypeConstraints;
use Scalar::Util qw( blessed openhandle );
my $ZERO = 0;
);
for my $name ( sort keys %tests ) {
- my $type = Moose::Util::TypeConstraints::find_type_constraint($name)
- or BAIL_OUT("No such type $name!");
+ test_constraint( $name, $tests{$name} );
+}
+
+{
+ my $class_tc = class_type('Thing');
+
+ test_constraint(
+ $class_tc, {
+ accept => [
+ ( bless {}, 'Thing' ),
+ ],
+ reject => [
+ 'Thing',
+ $ZERO,
+ $ONE,
+ $INT,
+ $NEG_INT,
+ $NUM,
+ $NEG_NUM,
+ $EMPTY_STRING,
+ $STRING,
+ $NUM_IN_STRING,
+ $SCALAR_REF,
+ $SCALAR_REF_REF,
+ $ARRAY_REF,
+ $HASH_REF,
+ $CODE_REF,
+ $GLOB,
+ $GLOB_REF,
+ $FH,
+ $FH_OBJECT,
+ $REGEX,
+ $REGEX_OBJ,
+ $OBJECT,
+ $UNDEF,
+ ],
+ }
+ );
+}
+
+{
+ package Duck;
+
+ sub quack {}
+ sub flap {}
+}
+
+{
+ package DuckLike;
+
+ sub quack {}
+ sub flap {}
+}
+
+{
+ package Bird;
+
+ sub flap {}
+}
+
+{
+ my @methods = qw( quack flap );
+ duck_type 'Duck' => @methods;
+
+ test_constraint(
+ 'Duck', {
+ accept => [
+ ( bless {}, 'Duck' ),
+ ( bless {}, 'DuckLike' ),
+ ],
+ reject => [
+ 'Thing',
+ $ZERO,
+ $ONE,
+ $INT,
+ $NEG_INT,
+ $NUM,
+ $NEG_NUM,
+ $EMPTY_STRING,
+ $STRING,
+ $NUM_IN_STRING,
+ $SCALAR_REF,
+ $SCALAR_REF_REF,
+ $ARRAY_REF,
+ $HASH_REF,
+ $CODE_REF,
+ $GLOB,
+ $GLOB_REF,
+ $FH,
+ $FH_OBJECT,
+ $REGEX,
+ $REGEX_OBJ,
+ $OBJECT,
+ ( bless {}, 'Bird' ),
+ $UNDEF,
+ ],
+ }
+ );
+}
+
+{
+ my @allowed = qw( bar baz quux );
+ enum 'Enumerated' => @allowed;
+
+ test_constraint(
+ 'Enumerated', {
+ accept => \@allowed,
+ reject => [
+ 'Thing',
+ $ZERO,
+ $ONE,
+ $INT,
+ $NEG_INT,
+ $NUM,
+ $NEG_NUM,
+ $EMPTY_STRING,
+ $STRING,
+ $NUM_IN_STRING,
+ $SCALAR_REF,
+ $SCALAR_REF_REF,
+ $ARRAY_REF,
+ $HASH_REF,
+ $CODE_REF,
+ $GLOB,
+ $GLOB_REF,
+ $FH,
+ $FH_OBJECT,
+ $REGEX,
+ $REGEX_OBJ,
+ $OBJECT,
+ $UNDEF,
+ ],
+ }
+ );
+}
+
+{
+ package DoesRole;
+
+ use Moose;
+
+ with 'Role';
+}
+
+# Test how $_ is used in XS implementation
+{
+ local $_ = qr/./;
+ ok(
+ Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
+ '$_ is RegexpRef'
+ );
+ ok(
+ !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
+ '$_ is not read when param provided'
+ );
+
+ $_ = bless qr/./, 'Blessed';
+
+ ok(
+ Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
+ '$_ is RegexpRef'
+ );
+
+ $_ = 42;
+ ok(
+ !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
+ '$_ is not RegexpRef'
+ );
+ ok(
+ Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
+ '$_ is not read when param provided'
+ );
+}
+
+close $FH
+ or warn "Could not close the filehandle $0 for test";
+$FH_OBJECT->close
+ or warn "Could not close the filehandle $0 for test";
+
+done_testing;
+
+sub test_constraint {
+ my $type = shift;
+ my $tests = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ unless ( blessed $type ) {
+ $type = Moose::Util::TypeConstraints::find_type_constraint($type)
+ or BAIL_OUT("No such type $type!");
+ }
+
+ my $name = $type->name;
my $unoptimized
= $type->has_parent
my $inlined;
if ( $type->has_inlined_type_constraint ) {
local $@;
- $inlined = eval 'sub { ( ' . $type->inlined->('$_[0]') . ' ) }';
+ $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
die $@ if $@;
}
- for my $accept ( @{ $tests{$name}{accept} || [] } ) {
+ for my $accept ( @{ $tests->{accept} || [] } ) {
my $described = describe($accept);
ok(
$type->check($accept),
}
}
- for my $reject ( @{ $tests{$name}{reject} || [] } ) {
+ for my $reject ( @{ $tests->{reject} || [] } ) {
my $described = describe($reject);
ok(
!$type->check($reject),
}
}
-# Test how $_ is used in XS implementation
-{
- local $_ = qr/./;
- ok(
- Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
- '$_ is RegexpRef'
- );
- ok(
- !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
- '$_ is not read when param provided'
- );
-
- $_ = bless qr/./, 'Blessed';
-
- ok(
- Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
- '$_ is RegexpRef'
- );
-
- $_ = 42;
- ok(
- !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
- '$_ is not RegexpRef'
- );
- ok(
- Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
- '$_ is not read when param provided'
- );
-}
-
-close $FH
- or warn "Could not close the filehandle $0 for test";
-$FH_OBJECT->close
- or warn "Could not close the filehandle $0 for test";
-
-done_testing;
-
sub describe {
my $val = shift;
return 'open filehandle'
if openhandle $val && !blessed $val;
- return ( ref $val ) . ' reference';
+ return blessed $val
+ ? ( ref $val ) . ' object'
+ : ( ref $val ) . ' reference';
}
projects / gitmo/Moose.git / commitdiff