From: Stevan Little Date: Mon, 28 Aug 2006 16:37:07 +0000 (+0000) Subject: no-more-blessed-subs X-Git-Tag: 0_35~13^2~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7855ddba257d675899620452f97912ccf69efb77;p=gitmo%2FClass-MOP.git no-more-blessed-subs --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index ef130fc..0ef8e87 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -178,28 +178,30 @@ Class::MOP::Class->meta->add_attribute( Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('%:methods' => ( - reader => { - # NOTE: - # as with the $VERSION and $AUTHORITY above - # sometimes we don't/can't store directly - # inside the instance, so we need the accessor - # to just DWIM - 'get_method_map' => sub { - my $self = shift; - # FIXME: - # there is a faster/better way - # to do this, I am sure :) - return +{ - map { - $_ => $self->get_method($_) - } grep { - $self->has_method($_) - } $self->list_all_package_symbols - }; - } - }, - init_arg => '!............( DO NOT DO THIS )............!', - default => sub { \undef } + #reader => 'get_method_map', + #reader => { + # # NOTE: + # # as with the $VERSION and $AUTHORITY above + # # sometimes we don't/can't store directly + # # inside the instance, so we need the accessor + # # to just DWIM + # 'get_method_map' => sub { + # my $self = shift; + # # FIXME: + # # there is a faster/better way + # # to do this, I am sure :) + # return +{ + # map { + # $_ => $self->method_metaclass->wrap($self->get_package_symbol('&' . $_)) + # } grep { + # $self->has_package_symbol('&' . $_) + # } $self->list_all_package_symbols + # }; + # } + #}, + #init_arg => '!............( DO NOT DO THIS )............!', + #default => sub { \undef } + default => sub { {} } )) ); diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 3dd162c..332f832 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -91,8 +91,8 @@ sub construct_class_instance { '$:version' => \undef, '$:authority' => \undef, # defined in Class::MOP::Class - '%:methods' => \undef, + '%:methods' => {}, '%:attributes' => {}, '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute', '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method', @@ -262,18 +262,20 @@ sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} } sub method_metaclass { $_[0]->{'$:method_metaclass'} } sub instance_metaclass { $_[0]->{'$:instance_metaclass'} } -sub get_method_map { +sub get_method_map { my $self = shift; - # FIXME: - # there is a faster/better way - # to do this, I am sure :) - return +{ - map { - $_ => $self->get_method($_) - } grep { - $self->has_method($_) - } $self->list_all_package_symbols - }; + my $map = $self->{'%:methods'}; + + foreach my $symbol (grep { $self->has_package_symbol('&' . $_) } $self->list_all_package_symbols) { + next if exists $map->{$symbol} && + $map->{$symbol}->body == $self->get_package_symbol('&' . $symbol); + + $map->{$symbol} = $self->method_metaclass->wrap( + $self->get_package_symbol('&' . $symbol) + ); + } + + return $map; } # Instance Construction & Cloning @@ -376,15 +378,31 @@ sub add_method { (defined $method_name && $method_name) || confess "You must define a method name"; # use reftype here to allow for blessed subs ... - ('CODE' eq (reftype($method) || '')) - || confess "Your code block must be a CODE reference"; - my $full_method_name = ($self->name . '::' . $method_name); - - # FIXME: - # dont bless subs, its bad mkay - $method = $self->method_metaclass->wrap($method) unless blessed($method); - $self->add_package_symbol("&${method_name}" => subname $full_method_name => $method); + my $body; + + if (blessed($method)) { + + $body = $method->body; + + ('CODE' eq (reftype($body) || '')) + || confess "Your code block must be a CODE reference"; + + $self->get_method_map->{$method_name} = $method; + } + else { + + $body = $method; + + ('CODE' eq (reftype($body) || '')) + || confess "Your code block must be a CODE reference"; + + $self->get_method_map->{$method_name} = $self->method_metaclass->wrap($body); + + } + + my $full_method_name = ($self->name . '::' . $method_name); + $self->add_package_symbol("&${method_name}" => subname $full_method_name => $body); } { @@ -455,20 +473,30 @@ sub alias_method { my ($self, $method_name, $method) = @_; (defined $method_name && $method_name) || confess "You must define a method name"; - # use reftype here to allow for blessed subs ... - ('CODE' eq (reftype($method) || '')) - || confess "Your code block must be a CODE reference"; - # FIXME: - # dont bless subs, its bad mkay - $method = $self->method_metaclass->wrap($method) unless blessed($method); - - $self->add_package_symbol("&${method_name}" => $method); -} + my $body; -sub find_method_by_name { - my ($self, $method_name) = @_; - return $self->name->can($method_name); + if (blessed($method)) { + + $body = $method->body; + + ('CODE' eq (reftype($body) || '')) + || confess "Your code block must be a CODE reference"; + + $self->get_method_map->{$method_name} = $method; + } + else { + + $body = $method; + + ('CODE' eq (reftype($body) || '')) + || confess "Your code block must be a CODE reference"; + + $self->get_method_map->{$method_name} = $self->method_metaclass->wrap($body); + + } + + $self->add_package_symbol("&${method_name}" => $body); } sub has_method { @@ -476,14 +504,13 @@ sub has_method { (defined $method_name && $method_name) || confess "You must define a method name"; - return 0 if !$self->has_package_symbol("&${method_name}"); - my $method = $self->get_package_symbol("&${method_name}"); - return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name && - (svref_2object($method)->GV->NAME || '') ne '__ANON__'; - - # FIXME: - # dont bless subs, its bad mkay - $self->method_metaclass->wrap($method) unless blessed($method); + my $method_map = $self->get_method_map; + + return 0 unless exists $self->get_method_map->{$method_name}; + + my $method = $method_map->{$method_name}; + return 0 if ($method->package_name || '') ne $self->name && + ($method->name || '') ne '__ANON__'; return 1; } @@ -492,10 +519,10 @@ sub get_method { my ($self, $method_name) = @_; (defined $method_name && $method_name) || confess "You must define a method name"; - + return unless $self->has_method($method_name); - return $self->get_package_symbol("&${method_name}"); + return $self->get_method_map->{$method_name}; } sub remove_method { @@ -508,12 +535,21 @@ sub remove_method { $self->remove_package_symbol("&${method_name}") if defined $removed_method; + delete $self->get_method_map->{$method_name} + if exists $self->get_method_map->{$method_name}; + return $removed_method; } sub get_method_list { my $self = shift; - grep { $self->has_method($_) } $self->list_all_package_symbols; + return grep { $self->has_method($_) } keys %{$self->get_method_map}; +} + +sub find_method_by_name { + my ($self, $method_name) = @_; + # FIXME + return $self->name->can($method_name); } sub compute_all_applicable_methods { diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index ac966f9..386a8a1 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -11,6 +11,9 @@ use B 'svref_2object'; our $VERSION = '0.03'; our $AUTHORITY = 'cpan:STEVAN'; +use overload '&{}' => sub { $_[0]->{body} }, + fallback => 1; + # introspection sub meta { @@ -25,29 +28,33 @@ sub wrap { my $code = shift; ('CODE' eq (reftype($code) || '')) || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")"; - bless $code => blessed($class) || $class; + bless { + body => $code + } => blessed($class) || $class; } +sub body { (shift)->{body} } + # informational sub package_name { - my $code = shift; - (blessed($code)) - || confess "Can only ask the package name of a blessed CODE"; + my $code = shift->{body}; +# (blessed($code)) +# || confess "Can only ask the package name of a blessed CODE"; svref_2object($code)->GV->STASH->NAME; } sub name { - my $code = shift; - (blessed($code)) - || confess "Can only ask the package name of a blessed CODE"; + my $code = shift->{body}; +# (blessed($code)) +# || confess "Can only ask the package name of a blessed CODE"; svref_2object($code)->GV->NAME; } sub fully_qualified_name { my $code = shift; - (blessed($code)) - || confess "Can only ask the package name of a blessed CODE"; +# (blessed($code)) +# || confess "Can only ask the package name of a blessed CODE"; $code->package_name . '::' . $code->name; } @@ -125,14 +132,14 @@ sub wrap { my $class = shift; my $code = shift; (blessed($code) && $code->isa('Class::MOP::Method')) - || confess "Can only wrap blessed CODE"; + || confess "Can only wrap blessed CODE"; my $modifier_table = { cache => undef, orig => $code, before => [], after => [], around => { - cache => $code, + cache => $code->body, methods => [], }, }; @@ -155,8 +162,8 @@ sub add_before_modifier { || confess "You must first wrap your method before adding a modifier"; (blessed($code)) || confess "Can only ask the package name of a blessed CODE"; - ('CODE' eq (reftype($code) || '')) - || confess "You must supply a CODE reference for a modifier"; + #('CODE' eq (reftype($code) || '')) + # || confess "You must supply a CODE reference for a modifier"; unshift @{$MODIFIERS{$code}->{before}} => $modifier; $_build_wrapped_method->($MODIFIERS{$code}); } @@ -168,8 +175,8 @@ sub add_after_modifier { || confess "You must first wrap your method before adding a modifier"; (blessed($code)) || confess "Can only ask the package name of a blessed CODE"; - ('CODE' eq (reftype($code) || '')) - || confess "You must supply a CODE reference for a modifier"; + #('CODE' eq (reftype($code) || '')) + # || confess "You must supply a CODE reference for a modifier"; push @{$MODIFIERS{$code}->{after}} => $modifier; $_build_wrapped_method->($MODIFIERS{$code}); } @@ -196,8 +203,8 @@ sub add_after_modifier { || confess "You must first wrap your method before adding a modifier"; (blessed($code)) || confess "Can only ask the package name of a blessed CODE"; - ('CODE' eq (reftype($code) || '')) - || confess "You must supply a CODE reference for a modifier"; + #('CODE' eq (reftype($code) || '')) + # || confess "You must supply a CODE reference for a modifier"; unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier; $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->( @{$MODIFIERS{$code}->{around}->{methods}}, @@ -258,6 +265,8 @@ This simply blesses the C<&code> reference passed to it. =over 4 +=item B + =item B =item B diff --git a/t/003_methods.t b/t/003_methods.t index 2b0b527..4d46a68 100644 --- a/t/003_methods.t +++ b/t/003_methods.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 56; +use Test::More tests => 64; use Test::Exception; use Scalar::Util qw/reftype/; @@ -64,14 +64,16 @@ lives_ok { $Foo->add_method('foo' => $foo); } '... we added the method successfully'; -isa_ok($foo, 'Class::MOP::Method'); +my $foo_method = $Foo->get_method('foo'); -is($foo->name, 'foo', '... got the right name for the method'); -is($foo->package_name, 'Foo', '... got the right package name for the method'); +isa_ok($foo_method, 'Class::MOP::Method'); + +is($foo_method->name, 'foo', '... got the right name for the method'); +is($foo_method->package_name, 'Foo', '... got the right package name for the method'); ok($Foo->has_method('foo'), '... Foo->has_method(foo) (defined with Sub::Name)'); -is($Foo->get_method('foo'), $foo, '... Foo->get_method(foo) == \&foo'); +is($Foo->get_method('foo')->body, $foo, '... Foo->get_method(foo) == \&foo'); is(Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"'); # now check all our other items ... @@ -97,16 +99,20 @@ is( reftype($bar), "CODE", "the returned value is a code ref" ); # calling get_method blessed them all -isa_ok($_, 'Class::MOP::Method') for ( - \&Foo::FOO_CONSTANT, - \&Foo::bar, - \&Foo::baz, - \&Foo::floob, - \&Foo::blah, - \&Foo::bling, - \&Foo::bang, - \&Foo::evaled_foo, - ); +for my $method_name (qw/FOO_CONSTANT + bar + baz + floob + blah + bling + bang + evaled_foo/) { + isa_ok($Foo->get_method($method_name), 'Class::MOP::Method'); + { + no strict 'refs'; + is($Foo->get_method($method_name)->body, \&{'Foo::' . $method_name}, '... body matches CODE ref in package'); + } +} { package Foo::Aliasing; @@ -137,7 +143,7 @@ is_deeply( { name => $_, class => 'Foo', - code => $Foo->get_method($_) + code => $Foo->get_method($_) } } qw( FOO_CONSTANT @@ -153,7 +159,7 @@ is_deeply( ], '... got the right list of applicable methods for Foo'); -is($Foo->remove_method('foo'), $foo, '... removed the foo method'); +is($Foo->remove_method('foo')->body, $foo, '... removed the foo method'); ok(!$Foo->has_method('foo'), '... !Foo->has_method(foo) we just removed it'); dies_ok { Foo->foo } '... cannot call Foo->foo because it is not there'; @@ -207,18 +213,18 @@ is_deeply( { name => 'bang', class => 'Foo', - code => $Foo->get_method('bang') + code => $Foo->get_method('bang') }, { name => 'bar', class => 'Bar', - code => $Bar->get_method('bar') + code => $Bar->get_method('bar') }, (map { { name => $_, class => 'Foo', - code => $Foo->get_method($_) + code => $Foo->get_method($_) } } qw( baz @@ -230,12 +236,12 @@ is_deeply( { name => 'foo', class => 'Bar', - code => $Bar->get_method('foo') + code => $Bar->get_method('foo') }, { name => 'meta', class => 'Bar', - code => $Bar->get_method('meta') + code => $Bar->get_method('meta') } ], '... got the right list of applicable methods for Bar'); diff --git a/t/004_advanced_methods.t b/t/004_advanced_methods.t index 4a091d3..360f58d 100644 --- a/t/004_advanced_methods.t +++ b/t/004_advanced_methods.t @@ -78,13 +78,13 @@ is_deeply( { name => 'BUILD', class => 'Foo', - code => \&Foo::BUILD + code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') }, { name => 'foo', class => 'Foo', - code => \&Foo::foo - }, + code => Class::MOP::Class->initialize('Foo')->get_method('foo') + }, ], '... got the right list of applicable methods for Foo'); @@ -94,17 +94,17 @@ is_deeply( { name => 'BUILD', class => 'Bar', - code => \&Bar::BUILD + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') }, { name => 'bar', class => 'Bar', - code => \&Bar::bar + code => Class::MOP::Class->initialize('Bar')->get_method('bar') }, { name => 'foo', class => 'Foo', - code => \&Foo::foo + code => Class::MOP::Class->initialize('Foo')->get_method('foo') }, ], '... got the right list of applicable methods for Bar'); @@ -116,22 +116,22 @@ is_deeply( { name => 'BUILD', class => 'Bar', - code => \&Bar::BUILD + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') }, { name => 'bar', class => 'Bar', - code => \&Bar::bar + code => Class::MOP::Class->initialize('Bar')->get_method('bar') }, { name => 'baz', class => 'Baz', - code => \&Baz::baz + code => Class::MOP::Class->initialize('Baz')->get_method('baz') }, { name => 'foo', class => 'Baz', - code => \&Baz::foo + code => Class::MOP::Class->initialize('Baz')->get_method('foo') }, ], '... got the right list of applicable methods for Baz'); @@ -142,22 +142,22 @@ is_deeply( { name => 'BUILD', class => 'Foo::Bar', - code => \&Foo::Bar::BUILD + code => Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD') }, { name => 'bar', class => 'Bar', - code => \&Bar::bar + code => Class::MOP::Class->initialize('Bar')->get_method('bar') }, { name => 'foo', class => 'Foo', - code => \&Foo::foo + code => Class::MOP::Class->initialize('Foo')->get_method('foo') }, { name => 'foobar', class => 'Foo::Bar', - code => \&Foo::Bar::foobar + code => Class::MOP::Class->initialize('Foo::Bar')->get_method('foobar') }, ], '... got the right list of applicable methods for Foo::Bar'); @@ -168,27 +168,27 @@ is_deeply( { name => 'BUILD', class => 'Foo::Bar::Baz', - code => \&Foo::Bar::Baz::BUILD + code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('BUILD') }, { name => 'bar', class => 'Foo::Bar::Baz', - code => \&Foo::Bar::Baz::bar + code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('bar') }, { name => 'baz', class => 'Baz', - code => \&Baz::baz + code => Class::MOP::Class->initialize('Baz')->get_method('baz') }, { name => 'foo', class => 'Foo', - code => \&Foo::foo + code => Class::MOP::Class->initialize('Foo')->get_method('foo') }, { name => 'foobarbaz', class => 'Foo::Bar::Baz', - code => \&Foo::Bar::Baz::foobarbaz + code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('foobarbaz') }, ], '... got the right list of applicable methods for Foo::Bar::Baz'); @@ -201,17 +201,17 @@ is_deeply( { name => 'BUILD', class => 'Foo::Bar', - code => \&Foo::Bar::BUILD + code => Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD') }, { name => 'BUILD', class => 'Foo', - code => \&Foo::BUILD + code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') }, { name => 'BUILD', class => 'Bar', - code => \&Bar::BUILD + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') } ], '... got the right list of BUILD methods for Foo::Bar'); @@ -222,17 +222,17 @@ is_deeply( { name => 'BUILD', class => 'Foo::Bar::Baz', - code => \&Foo::Bar::Baz::BUILD + code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('BUILD') }, { name => 'BUILD', class => 'Foo', - code => \&Foo::BUILD + code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') }, { name => 'BUILD', class => 'Bar', - code => \&Bar::BUILD + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') }, ], '... got the right list of BUILD methods for Foo::Bar::Baz'); \ No newline at end of file diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index b102c2d..447898d 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -85,7 +85,7 @@ foreach my $method_name (@class_mop_class_methods) { ok($class_mop_class_meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')'); { no strict 'refs'; - is($class_mop_class_meta->get_method($method_name), + is($class_mop_class_meta->get_method($method_name)->body, \&{'Class::MOP::Class::' . $method_name}, '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name); } @@ -99,7 +99,7 @@ foreach my $method_name (@class_mop_package_methods) { ok($class_mop_package_meta->has_method($method_name), '... Class::MOP::Package->has_method(' . $method_name . ')'); { no strict 'refs'; - is($class_mop_package_meta->get_method($method_name), + is($class_mop_package_meta->get_method($method_name)->body, \&{'Class::MOP::Package::' . $method_name}, '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name); } @@ -113,7 +113,7 @@ foreach my $method_name (@class_mop_module_methods) { ok($class_mop_module_meta->has_method($method_name), '... Class::MOP::Module->has_method(' . $method_name . ')'); { no strict 'refs'; - is($class_mop_module_meta->get_method($method_name), + is($class_mop_module_meta->get_method($method_name)->body, \&{'Class::MOP::Module::' . $method_name}, '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name); }