From: Dave Rolsky Date: Fri, 10 Sep 2010 01:32:29 +0000 (-0500) Subject: Inline the does method. X-Git-Tag: 1.13~19 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=948cd1899aaa1b6e1d53b77346c609f332c3e1a3;p=gitmo%2FMoose.git Inline the does method. Added tests for ->does, both mutable & immutable --- diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 7e1788a..2fb4c67 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -22,6 +22,7 @@ use Moose::Error::Default; use Moose::Meta::Class::Immutable::Trait; use Moose::Meta::Method::Constructor; use Moose::Meta::Method::Destructor; +use Moose::Meta::Method::Does; use base 'Class::MOP::Class'; @@ -52,6 +53,11 @@ __PACKAGE__->meta->add_attribute('destructor_class' => ( default => 'Moose::Meta::Method::Destructor', )); +__PACKAGE__->meta->add_attribute('does_class' => ( + accessor => 'does_class', + default => 'Moose::Meta::Method::Does', +)); + __PACKAGE__->meta->add_attribute('error_class' => ( accessor => 'error_class', default => 'Moose::Error::Default', @@ -69,19 +75,6 @@ sub initialize { ); } -sub _immutable_options { - my ( $self, @args ) = @_; - - $self->SUPER::_immutable_options( - inline_destructor => 1, - - # Moose always does this when an attribute is created - inline_accessors => 0, - - @args, - ); -} - sub create { my ($class, $package_name, %options) = @_; @@ -146,6 +139,7 @@ sub reinitialize { instance_metaclass constructor_class destructor_class + does_class error_class ); @@ -653,6 +647,53 @@ sub _process_inherited_attribute { } } +## Immutability + +sub _immutable_options { + my ( $self, @args ) = @_; + + $self->SUPER::_immutable_options( + inline_destructor => 1, + inline_does => 1, + + # Moose always does this when an attribute is created + inline_accessors => 0, + + @args, + ); +} + +sub _install_inlined_code { + my ( $self, %args ) = @_; + + $self->SUPER::_install_inlined_code(%args); + + $self->_inline_does(%args) if $args{inline_does}; +} + +sub _inline_does { + my ( $self, %args ) = @_; + + if ( $self->has_method('does') ) { + my $class = $self->name; + warn "Not inlining a does method for $class since it defines" + . " its own does().\n"; + return; + } + + my $does = $self->does_class->new( + options => \%args, + metaclass => $self, + is_inline => 1, + package_name => $self->name, + ); + + return unless $does->can_be_inlined; + + $self->add_method( 'does' => $does ); + $self->_add_inlined_method($does); +} + ## ------------------------------------------------- our $error_level; @@ -840,10 +881,13 @@ be provided as a hash reference. =item B<< $metaclass->destructor_class($class_name) >> -These are the names of classes used when making a class -immutable. These default to L and -L respectively. These accessors are -read-write, so you can use them to change the class name. +=item B<< $metaclass->does_class($class_name) >> + +These are the names of classes used when making a class immutable. These +default to L, +L, and L +respectively. These accessors are read-write, so you can use them to change +the class name. =item B<< $metaclass->error_class($class_name) >> diff --git a/lib/Moose/Meta/Method/Does.pm b/lib/Moose/Meta/Method/Does.pm new file mode 100644 index 0000000..25c5b25 --- /dev/null +++ b/lib/Moose/Meta/Method/Does.pm @@ -0,0 +1,119 @@ +package Moose::Meta::Method::Does; + +use strict; +use warnings; + +use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr'; + +our $VERSION = '1.12'; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method', + 'Class::MOP::Method::Inlined'; + +sub new { + my $class = shift; + my %options = @_; + + my $meta = $options{metaclass}; + + ( ref $options{options} eq 'HASH' ) + || $class->throw_error( "You must pass a hash of options", + data => $options{options} ); + + $options{package_name} + || $class->throw_error( + "You must supply the package_name parameter" ); + + my $self = bless { + 'body' => undef, + 'package_name' => $options{package_name}, + 'name' => 'does', + 'options' => $options{options}, + 'associated_metaclass' => $meta, + '_expected_method_class' => $options{_expected_method_class} + || 'Moose::Object', + } => $class; + + weaken( $self->{'associated_metaclass'} ); + + $self->_initialize_body; + + return $self; +} + +sub _initialize_body { + my $self = shift; + + my $source = 'sub {'; + $source + .= "\n" + . 'defined $_[1] || ' + . $self->_inline_throw_error( + q{"You must supply a role name to does()"}); + $source .= ";\n" . 'my $name = Scalar::Util::blessed( $_[1] ) ? $_[1]->name : $_[1]'; + $source .= ";\n" . 'return $does{$name} || 0'; + $source .= ";\n" . '}'; + + my %does + = map { $_->name => 1 } $self->associated_metaclass->calculate_all_roles; + + my ( $code, $e ) = $self->_compile_code( + code => $source, + environment => { + '%does' => \%does, + '$meta' => \$self, + }, + ); + + $self->throw_error( + "Could not eval the does method :\n\n$source\n\nbecause :\n\n$e", + error => $e, + data => $source, + ) if $e; + + $self->{'body'} = $code; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::Meta::Method::Constructor - Method Meta Object for constructors + +=head1 DESCRIPTION + +This class is a subclass of L that +provides additional Moose-specific functionality + +To understand this class, you should read the the +L documentation as well. + +=head1 INHERITANCE + +C is a subclass of +L I L. + +=head1 BUGS + +See L for details on reporting bugs. + +=head1 AUTHORS + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2010 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/t/010_basics/021-moose-object-does.t b/t/010_basics/021-moose-object-does.t new file mode 100644 index 0000000..1a58786 --- /dev/null +++ b/t/010_basics/021-moose-object-does.t @@ -0,0 +1,142 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package Role::A; + + use Moose::Role +} + +{ + package Role::B; + + use Moose::Role +} + +{ + package Foo; + + use Moose; +} + +{ + package Bar; + + use Moose; + + with 'Role::A'; +} + +{ + package Baz; + + use Moose; + + with qw( Role::A Role::B ); +} + +with_immutable { + + for my $thing ( 'Foo', Foo->new ) { + my $name = ref $thing ? 'Foo object' : 'Foo class'; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + !$thing->does('Role::A'), + "$name does not do Role::A" + ); + ok( + !$thing->does('Role::B'), + "$name does not do Role::B" + ); + + ok( + !$thing->does( Role::A->meta ), + "$name does not do Role::A (passed as object)" + ); + ok( + !$thing->does( Role::B->meta ), + "$name does not do Role::B (passed as object)" + ); + + ok( + !$thing->DOES('Role::A'), + "$name does not do Role::A (using DOES)" + ); + ok( + !$thing->DOES('Role::B'), + "$name does not do Role::B (using DOES)" + ); + } + + for my $thing ( 'Bar', Bar->new ) { + my $name = ref $thing ? 'Bar object' : 'Bar class'; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + $thing->does('Role::A'), + "$name does Role::A" + ); + ok( + !$thing->does('Role::B'), + "$name does not do Role::B" + ); + + ok( + $thing->does( Role::A->meta ), + "$name does Role::A (passed as object)" + ); + ok( + !$thing->does( Role::B->meta ), + "$name does not do Role::B (passed as object)" + ); + + ok( + $thing->DOES('Role::A'), + "$name does Role::A (using DOES)" + ); + ok( + !$thing->DOES('Role::B'), + "$name does not do Role::B (using DOES)" + ); + } + + for my $thing ( 'Baz', Baz->new ) { + my $name = ref $thing ? 'Baz object' : 'Baz class'; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + $thing->does('Role::A'), + "$name does Role::A" + ); + ok( + $thing->does('Role::B'), + "$name does Role::B" + ); + + ok( + $thing->does( Role::A->meta ), + "$name does Role::A (passed as object)" + ); + ok( + $thing->does( Role::B->meta ), + "$name does Role::B (passed as object)" + ); + + ok( + $thing->DOES('Role::A'), + "$name does Role::A (using DOES)" + ); + ok( + $thing->DOES('Role::B'), + "$name does Role::B (using DOES)" + ); + } + +} +qw( Foo Bar Baz ); + +done_testing;