From: Dave Rolsky Date: Sun, 10 Apr 2011 20:29:16 +0000 (-0500) Subject: All TC objects (except unions) now have inlining code, and tests for all the variatio... X-Git-Tag: 2.0100~80 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=964294c1854e01a6dafe324c4f392acb528150a8;p=gitmo%2FMoose.git All TC objects (except unions) now have inlining code, and tests for all the variations on calling. Along the way, fixed the basic constraint generation for the various TC subclasses, which were not actually setting a proper constraint sub when they were created. --- diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index b07b5bb..3e370dc 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -133,7 +133,7 @@ sub _inline_check { 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 { diff --git a/lib/Moose/Meta/TypeConstraint/Class.pm b/lib/Moose/Meta/TypeConstraint/Class.pm index 0e8bae5..6c5d345 100644 --- a/lib/Moose/Meta/TypeConstraint/Class.pm +++ b/lib/Moose/Meta/TypeConstraint/Class.pm @@ -4,6 +4,7 @@ use strict; use warnings; use metaclass; +use B; use Scalar::Util 'blessed'; use Moose::Util::TypeConstraints (); @@ -13,11 +14,27 @@ __PACKAGE__->meta->add_attribute('class' => ( 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(); diff --git a/lib/Moose/Meta/TypeConstraint/DuckType.pm b/lib/Moose/Meta/TypeConstraint/DuckType.pm index 2878eed..4b3d0c6 100644 --- a/lib/Moose/Meta/TypeConstraint/DuckType.pm +++ b/lib/Moose/Meta/TypeConstraint/DuckType.pm @@ -4,6 +4,7 @@ use strict; use warnings; use metaclass; +use B; use Scalar::Util 'blessed'; use List::MoreUtils qw(all); use Moose::Util 'english_list'; @@ -16,10 +17,30 @@ __PACKAGE__->meta->add_attribute('methods' => ( 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); diff --git a/lib/Moose/Meta/TypeConstraint/Enum.pm b/lib/Moose/Meta/TypeConstraint/Enum.pm index 54b5581..2a7beb7 100644 --- a/lib/Moose/Meta/TypeConstraint/Enum.pm +++ b/lib/Moose/Meta/TypeConstraint/Enum.pm @@ -4,6 +4,7 @@ use strict; use warnings; use metaclass; +use B; use Moose::Util::TypeConstraints (); use base 'Moose::Meta::TypeConstraint'; @@ -12,10 +13,28 @@ __PACKAGE__->meta->add_attribute('values' => ( 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; @@ -33,6 +52,9 @@ sub new { } } + my %values = map { $_ => 1 } @{ $args{values} }; + $args{constraint} = sub { $values{ $_[0] } }; + my $self = $class->_new(\%args); $self->compile_type_constraint() diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm index 6f82a34..515a952 100644 --- a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm +++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm @@ -48,7 +48,7 @@ sub generate_inline_for { return unless $self->has_inline_generator; - return $self->inline_generator->( $type, $val ); + return $self->inline_generator->( $self, $type, $val ); } sub _parse_type_parameter { diff --git a/lib/Moose/Util/TypeConstraints/Builtins.pm b/lib/Moose/Util/TypeConstraints/Builtins.pm index 761bfd3..b595c4a 100644 --- a/lib/Moose/Util/TypeConstraints/Builtins.pm +++ b/lib/Moose/Util/TypeConstraints/Builtins.pm @@ -27,73 +27,73 @@ sub define_builtins { 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 @@ -104,16 +104,16 @@ sub define_builtins { } => 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' @@ -125,7 +125,7 @@ sub define_builtins { => 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' @@ -134,8 +134,8 @@ sub define_builtins { } => 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')} ); }; @@ -154,8 +154,9 @@ sub define_builtins { 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( @@ -182,8 +183,9 @@ sub define_builtins { 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 @@ -212,8 +214,9 @@ sub define_builtins { 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 @@ -241,6 +244,7 @@ sub define_builtins { }, inlined => sub {'1'}, inline_generator => sub { + my $self = shift; my $type_parameter = shift; my $val = shift; return diff --git a/t/type_constraints/util_std_type_constraints.t b/t/type_constraints/util_std_type_constraints.t index 461c453..4b4dc4b 100644 --- a/t/type_constraints/util_std_type_constraints.t +++ b/t/type_constraints/util_std_type_constraints.t @@ -6,7 +6,7 @@ use warnings; use Test::More; use IO::File; -use Moose::Util::TypeConstraints (); +use Moose::Util::TypeConstraints; use Scalar::Util qw( blessed openhandle ); my $ZERO = 0; @@ -649,8 +649,199 @@ my %tests = ( ); 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 @@ -660,11 +851,11 @@ for my $name ( sort keys %tests ) { 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), @@ -682,7 +873,7 @@ for my $name ( sort keys %tests ) { } } - for my $reject ( @{ $tests{$name}{reject} || [] } ) { + for my $reject ( @{ $tests->{reject} || [] } ) { my $described = describe($reject); ok( !$type->check($reject), @@ -701,43 +892,6 @@ for my $name ( sort keys %tests ) { } } -# 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; @@ -752,5 +906,7 @@ sub describe { return 'open filehandle' if openhandle $val && !blessed $val; - return ( ref $val ) . ' reference'; + return blessed $val + ? ( ref $val ) . ' object' + : ( ref $val ) . ' reference'; }