From: Yuval Kogman Date: Sun, 18 May 2008 10:46:43 +0000 (+0000) Subject: Remove Sub::Name as a requirement form the code (not from tests yet) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ecbccf95a3414c8a604ce31f42f14f75375803e5;p=gitmo%2FClass-MOP.git Remove Sub::Name as a requirement form the code (not from tests yet) --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index db6e3a7..9cb52e9 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -33,6 +33,17 @@ BEGIN { } } +# sub subname { $_[1] } + +BEGIN { + local $@; + if ( eval { require Sub::Name } ) { + *subname = \&Sub::Name::subname; + } else { + *subname = sub { $_[1] }; + } +} + { # Metaclasses are singletons, so we cache them here. # there is no need to worry about destruction though @@ -782,6 +793,10 @@ In Perl 5.10 or greater, this flag is package specific. However in versions prior to 5.10, this will use the C variable which is not package specific. +=item B + +If L is available uses that, if not it just returns C<$code>. + =item B This function returns two values, the name of the package the C<$code> diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index c3d760b..b717b36 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -304,7 +304,7 @@ sub process_accessors { (reftype($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref"; my ($name, $method) = %{$accessor}; - $method = $self->accessor_metaclass->wrap($method); + $method = $self->accessor_metaclass->wrap($method, name => $name, package_name => $self->associated_class->name ); $self->associate_method($method); return ($name, $method); } @@ -316,6 +316,8 @@ sub process_accessors { attribute => $self, is_inline => $inline_me, accessor_type => $type, + package_name => $self->associated_class->name, + name => $accessor, ); }; confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@; diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index fb65c44..91f6be0 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -10,7 +10,6 @@ use Class::MOP::Method::Wrapped; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken', 'refaddr'; -use Sub::Name 'subname'; our $VERSION = '0.31'; our $AUTHORITY = 'cpan:STEVAN'; @@ -315,26 +314,30 @@ sub get_method_map { my $class_name = $self->name; my $method_metaclass = $self->method_metaclass; - %$map = map { - my $symbol = $_; + my %map; + foreach my $symbol ( $self->list_all_package_symbols('CODE') ) { my $code = $self->get_package_symbol('&' . $symbol); my $method = $map->{$symbol}; my ($pkg, $name) = Class::MOP::get_code_info($code); - - if ( !$method and ($pkg || '') ne $class_name && ($name || '') ne '__ANON__' ) { - (); - } else { - if ( !$method or refaddr($method->body) != refaddr($code) ) { - $method = $method_metaclass->wrap($code); - } - $symbol => $method; + no warnings 'uninitialized'; + + next if ($pkg || '') ne $class_name && + ($name || '') ne '__ANON__'; + + if ( !$method or refaddr($method->body) != refaddr($code) ) { + #warn "Regenerating $method" if $method; + # FIXME preserve name if $method, doesn't seem like it ever happens + $method = $method_metaclass->wrap($code); } - } $self->list_all_package_symbols('CODE'); + $map{$symbol} = $method; + }; + + %$map = %map; return $map; } @@ -558,22 +561,23 @@ sub class_precedence_list { sub add_method { my ($self, $method_name, $method) = @_; (defined $method_name && $method_name) - || confess "You must define a method name"; + || confess "You must define a method name"; # FIXME default to $method->name ? my $body; if (blessed($method)) { $body = $method->body; + # FIXME clone method and change package_name/name } else { $body = $method; ('CODE' eq (reftype($body) || '')) || confess "Your code block must be a CODE reference"; - $method = $self->method_metaclass->wrap($body); + $method = $self->method_metaclass->wrap($body, package_name => $self->name, name => $method_name); } $self->get_method_map->{$method_name} = $method; my $full_method_name = ($self->name . '::' . $method_name); - $self->add_package_symbol("&${method_name}" => subname $full_method_name => $body); + $self->add_package_symbol("&${method_name}" => Class::MOP::subname($full_method_name => $body) ); $self->update_package_cache_flag; } @@ -608,7 +612,7 @@ sub add_method { (defined $method_name && $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_before_modifier(subname ':before' => $method_modifier); + $method->add_before_modifier(Class::MOP::subname(':before' => $method_modifier)); } sub add_after_method_modifier { @@ -616,7 +620,7 @@ sub add_method { (defined $method_name && $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_after_modifier(subname ':after' => $method_modifier); + $method->add_after_modifier(Class::MOP::subname(':after' => $method_modifier)); } sub add_around_method_modifier { @@ -624,7 +628,7 @@ sub add_method { (defined $method_name && $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_around_modifier(subname ':around' => $method_modifier); + $method->add_around_modifier(Class::MOP::subname(':around' => $method_modifier)); } # NOTE: diff --git a/lib/Class/MOP/Immutable.pm b/lib/Class/MOP/Immutable.pm index 284949a..c8e453c 100644 --- a/lib/Class/MOP/Immutable.pm +++ b/lib/Class/MOP/Immutable.pm @@ -8,7 +8,6 @@ use Class::MOP::Method::Constructor; use Carp 'confess'; use Scalar::Util 'blessed'; -use Sub::Name 'subname'; our $VERSION = '0.06'; our $AUTHORITY = 'cpan:STEVAN'; diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index b726e7c..d241582 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -20,12 +20,14 @@ use overload '&{}' => sub { $_[0]->body }, fallback => 1; # construction sub wrap { - my $class = shift; - my $code = shift; + my ( $class, $code, %params ) = @_; + ('CODE' eq (reftype($code) || '')) || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")"; bless { - '&!body' => $code + '&!body' => $code, + '$!package_name' => $params{package_name} || (Class::MOP::get_code_info($code))[0], + '$!name' => $params{name} || (Class::MOP::get_code_info($code))[1], } => blessed($class) || $class; } @@ -40,11 +42,11 @@ sub body { (shift)->{'&!body'} } # NOTE: # this may not be the same name # as the class you got it from -# This gets the package stash name +# This is the package stash name # associated with the actual CODE-ref -sub package_name { - my $code = (shift)->body; - (Class::MOP::get_code_info($code))[0]; +# meaning the package it was defined in +sub package_name { + (shift)->{'$!package_name'}; } # NOTE: @@ -53,8 +55,7 @@ sub package_name { # with. This gets the name associated # with the actual CODE-ref sub name { - my $code = (shift)->body; - (Class::MOP::get_code_info($code))[1]; + (shift)->{'$!name'}; } sub fully_qualified_name { diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 62eaab8..e0acd43 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -32,6 +32,8 @@ sub new { '$!attribute' => $options{attribute}, '$!is_inline' => ($options{is_inline} || 0), '$!accessor_type' => $options{accessor_type}, + '$!package_name' => $options{package_name}, + '$!name' => $options{name}, } => $class; # we don't want this creating diff --git a/lib/Class/MOP/Method/Wrapped.pm b/lib/Class/MOP/Method/Wrapped.pm index c32b506..48626cd 100644 --- a/lib/Class/MOP/Method/Wrapped.pm +++ b/lib/Class/MOP/Method/Wrapped.pm @@ -6,7 +6,6 @@ use warnings; use Carp 'confess'; use Scalar::Util 'reftype', 'blessed'; -use Sub::Name 'subname'; our $VERSION = '0.02'; our $AUTHORITY = 'cpan:STEVAN'; diff --git a/t/003_methods.t b/t/003_methods.t index 9dfcb9e..b836875 100644 --- a/t/003_methods.t +++ b/t/003_methods.t @@ -8,6 +8,8 @@ use Test::Exception; use Scalar::Util qw/reftype/; +use Sub::Name (); + BEGIN { use_ok('Class::MOP'); use_ok('Class::MOP::Class'); @@ -50,8 +52,8 @@ BEGIN { { no strict 'refs'; *{'Foo::bling'} = sub { '$$Bling$$' }; - *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub { '!BANG!' }; - *{'Foo::boom'} = Sub::Name::subname 'boom' => sub { '!BOOM!' }; + *{'Foo::bang'} = Sub::Name::subname('Foo::bang' => sub { '!BANG!' }); + *{'Foo::boom'} = Sub::Name::subname('boom' => sub { '!BOOM!' }); eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }"; }