From: Dave Rolsky Date: Thu, 16 Oct 2008 15:01:44 +0000 (+0000) Subject: Fix bug with -traits to Moose X-Git-Tag: 0.60~25 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=96bb13ea2de7708ef5c48714c0c0cb3abdfdc7ed;p=gitmo%2FMoose.git Fix bug with -traits to Moose --- diff --git a/Changes b/Changes index e72d2a9..3d7b7a0 100644 --- a/Changes +++ b/Changes @@ -1,9 +1,10 @@ Revision history for Perl extension Moose - * Tests - - Test bug causing exported methods to get the wrong caller when - the -traits option is passed, and traits are loaded from disk - (thus recursively calling Moose::Exporter). (t0m) +0.60 + * Moose::Exporter + - Passing "-traits" when loading Moose caused the Moose.pm + exports to be broken. Reported by t0m. (Dave Rolsky) + - Tests for this bug. (t0m) 0.59 Tue October 14, 2008 * Moose diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index b05fc77..58be754 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -161,103 +161,99 @@ sub _make_sub_exporter_params { return ( \%exports, \%is_removable ); } -{ - # This variable gets closed over in each export _generator_. Then - # in the generator we grab the value and close over it _again_ in - # the real export, so it gets captured each time the generator - # runs. - # - # In the meantime, we arrange for the import method we generate to - # set this variable to the caller each time it is called. - # - # This is all a bit confusing, but it works. - my $CALLER; - - sub _make_wrapped_sub { - shift; - my $fq_name = shift; - my $sub = shift; - my $export_recorder = shift; - - - # We need to set the package at import time, so that when - # package Foo imports has(), we capture "Foo" as the - # package. This lets other packages call Foo::has() and get - # the right package. This is done for backwards compatibility - # with existing production code, not because this is a good - # idea ;) - return sub { - my $caller = $CALLER; - - my $sub = Class::MOP::subname( $fq_name => sub { $sub->( $caller, @_ ) } ); +our $CALLER; - $export_recorder->{$sub} = 1; +sub _make_wrapped_sub { + shift; + my $fq_name = shift; + my $sub = shift; + my $export_recorder = shift; + + # We need to set the package at import time, so that when + # package Foo imports has(), we capture "Foo" as the + # package. This lets other packages call Foo::has() and get + # the right package. This is done for backwards compatibility + # with existing production code, not because this is a good + # idea ;) + return sub { + my $caller = $CALLER; - return $sub; - }; - } + my $sub + = Class::MOP::subname( $fq_name => sub { $sub->( $caller, @_ ) } ); - sub _make_import_sub { - shift; - my $exporting_package = shift; - my $exporter = shift; - my $exports_from = shift; - my $export_to_main = shift; - - return sub { - # I think we could use Sub::Exporter's collector feature - # to do this, but that would be rather gross, since that - # feature isn't really designed to return a value to the - # caller of the exporter sub. - # - # Also, this makes sure we preserve backwards compat for - # _get_caller, so it always sees the arguments in the - # expected order. - my $traits; - ($traits, @_) = Moose::Exporter::_strip_traits(@_); - - # Normally we could look at $_[0], but in some weird cases - # (involving goto &Moose::import), $_[0] ends as something - # else (like Squirrel). - my $class = $exporting_package; - - $CALLER = Moose::Exporter::_get_caller(@_); - - # this works because both pragmas set $^H (see perldoc - # perlvar) which affects the current compilation - - # i.e. the file who use'd us - which is why we don't need - # to do anything special to make it affect that file - # rather than this one (which is already compiled) - - strict->import; - warnings->import; - - # we should never export to main - if ( $CALLER eq 'main' && ! $export_to_main ) { - warn - qq{$class does not export its sugar to the 'main' package.\n}; - return; - } + $export_recorder->{$sub} = 1; - my $did_init_meta; - for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) { + return $sub; + }; +} - $c->init_meta( for_class => $CALLER ); - $did_init_meta = 1; - } +sub _make_import_sub { + shift; + my $exporting_package = shift; + my $exporter = shift; + my $exports_from = shift; + my $export_to_main = shift; - if ( $did_init_meta && @{$traits} ) { - _apply_meta_traits( $CALLER, $traits ); - } - elsif ( @{$traits} ) { - Moose->throw_error("Cannot provide traits when $class does not have an init_meta() method"); - } + return sub { - goto $exporter; - }; - } + # I think we could use Sub::Exporter's collector feature + # to do this, but that would be rather gross, since that + # feature isn't really designed to return a value to the + # caller of the exporter sub. + # + # Also, this makes sure we preserve backwards compat for + # _get_caller, so it always sees the arguments in the + # expected order. + my $traits; + ( $traits, @_ ) = _strip_traits(@_); + + # Normally we could look at $_[0], but in some weird cases + # (involving goto &Moose::import), $_[0] ends as something + # else (like Squirrel). + my $class = $exporting_package; + + $CALLER = _get_caller(@_); + + # this works because both pragmas set $^H (see perldoc + # perlvar) which affects the current compilation - + # i.e. the file who use'd us - which is why we don't need + # to do anything special to make it affect that file + # rather than this one (which is already compiled) + + strict->import; + warnings->import; + + # we should never export to main + if ( $CALLER eq 'main' && !$export_to_main ) { + warn + qq{$class does not export its sugar to the 'main' package.\n}; + return; + } + + my $did_init_meta; + for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) { + $c->init_meta( for_class => $CALLER ); + $did_init_meta = 1; + } + + if ( $did_init_meta && @{$traits} ) { + # The traits will use Moose::Role, which in turn uses + # Moose::Exporter, which in turn sets $CALLER, so we need + # to protect against that. + local $CALLER = $CALLER; + _apply_meta_traits( $CALLER, $traits ); + } + elsif ( @{$traits} ) { + Moose->throw_error( + "Cannot provide traits when $class does not have an init_meta() method" + ); + } + + goto $exporter; + }; } + sub _strip_traits { my $idx = first_index { $_ eq '-traits' } @_; diff --git a/t/050_metaclasses/013_metaclass_traits.t b/t/050_metaclasses/013_metaclass_traits.t index a78ea4c..9211f33 100644 --- a/t/050_metaclasses/013_metaclass_traits.t +++ b/t/050_metaclasses/013_metaclass_traits.t @@ -5,7 +5,7 @@ use warnings; use lib 't/lib', 'lib'; -use Test::More tests => 31; +use Test::More tests => 32; use Test::Exception; { @@ -191,29 +191,32 @@ is( Foo::Subclass->meta()->attr2(), 'something', 'Foo::Subclass->meta()->attr2() returns expected value' ); { + package Class::WithAlreadyPresentTrait; use Moose -traits => 'My::SimpleTrait'; - has an_attr => ( is => 'ro' ); + has an_attr => ( is => 'ro' ); } + lives_ok { - my $instance = Class::WithAlreadyPresentTrait->new(an_attr => 'value'); - is($instance->an_attr, 'value', 'Can get value'); -} 'Can create instance and access attributes'; + my $instance = Class::WithAlreadyPresentTrait->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); +} +'Can create instance and access attributes'; { + package Class::WhichLoadsATraitFromDisk; - use Moose -traits => 'Role::Parent'; # Any role you like here, the only important bit is that it - # gets loaded from disk and has not already been defined. - + + # Any role you like here, the only important bit is that it gets + # loaded from disk and has not already been defined. + use Moose -traits => 'Role::Parent'; + has an_attr => ( is => 'ro' ); } -TODO: { - local $TODO = 'Not working yet'; - lives_ok { - my $instance = Class::WhichLoadsATraitFromDisk->new(an_attr => 'value'); - is($instance->an_attr, 'value', 'Can get value'); - } 'Can create instance and access attributes'; +lives_ok { + my $instance = Class::WhichLoadsATraitFromDisk->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); } - +'Can create instance and access attributes';