From: Jesse Luehrs Date: Thu, 23 Sep 2010 05:43:14 +0000 (-0500) Subject: factor out meta method generation X-Git-Tag: 1.09~18 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=59b510466ab075526c10a9c0555645b5f916ef02;p=gitmo%2FClass-MOP.git factor out meta method generation --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 40876f9..3cbe4c4 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -25,10 +25,6 @@ BEGIN { ? sub () { 0 } : sub () { 1 }; - *DEBUG_NO_META = ($ENV{DEBUG_NO_META}) - ? sub () { 1 } - : sub () { 0 }; - # this is either part of core or set up appropriately by MRO::Compat *check_package_cache_flag = \&mro::get_pkg_gen; } @@ -704,6 +700,8 @@ $_->meta->make_immutable( Class::MOP::Method::Accessor Class::MOP::Method::Constructor Class::MOP::Method::Wrapped + + Class::MOP::Method::Meta /; $_->meta->make_immutable( diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 2dbd9f2..a1fc198 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -8,6 +8,7 @@ use Class::MOP::Instance; use Class::MOP::Method::Wrapped; use Class::MOP::Method::Accessor; use Class::MOP::Method::Constructor; +use Class::MOP::Method::Meta; use Class::MOP::MiniTrait; use Carp 'confess'; @@ -124,6 +125,17 @@ sub _real_ref_name { : ref $self; } +sub _add_meta_method { + my $self = shift; + $self->add_method( + 'meta' => Class::MOP::Method::Meta->wrap( + name => 'meta', + package_name => $self->name, + associated_metaclass => $self, + ) + ); +} + sub _new { my $class = shift; @@ -518,18 +530,7 @@ sub create { $meta->_instantiate_module( $options{version}, $options{authority} ); - # FIXME totally lame - $meta->add_method('meta' => sub { - if (Class::MOP::DEBUG_NO_META()) { - my ($self) = @_; - if (my $meta = try { $self->SUPER::meta }) { - return $meta if $meta->isa('Class::MOP::Class'); - } - confess "'meta' method called by MOP internals" - if caller =~ /Class::MOP|metaclass/; - } - $class->initialize(ref($_[0]) || $_[0]); - }) unless $options{no_meta}; + $meta->_add_meta_method unless $options{no_meta}; $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; diff --git a/lib/Class/MOP/Method/Meta.pm b/lib/Class/MOP/Method/Meta.pm new file mode 100644 index 0000000..1a14fe4 --- /dev/null +++ b/lib/Class/MOP/Method/Meta.pm @@ -0,0 +1,101 @@ + +package Class::MOP::Method::Meta; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed'; + +our $VERSION = '1.08'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use constant DEBUG_NO_META => $ENV{DEBUG_NO_META}; + +use base 'Class::MOP::Method'; + +sub _generate_meta_method { + my $method_self = shift; + my $metaclass = shift; + sub { + # this will be compiled out if the env var wasn't set + if (DEBUG_NO_META) { + my ($self) = @_; + # it's okay if we installed a meta method in a subclass of a class + # with a legitimate meta method (we'll still die if we install a + # meta method in a subclass of a class we installed a meta method + # in, since this function is itself defined in Class::MOP) + #if (my $meta = try { $self->SUPER::meta }) { + #return $meta if $meta->isa('Class::MOP::Class'); + #} + # it's okay if the test itself calls ->meta, we only care about if + # the mop internals call ->meta + confess "'meta' method called by MOP internals" + if caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/; + } + # we must re-initialize so that it + # works as expected in subclasses, + # since metaclass instances are + # singletons, this is not really a + # big deal anyway. + $metaclass->initialize(blessed($_[0]) || $_[0]) + }; +} + +sub wrap { + my ($class, @args) = @_; + + unshift @args, 'body' if @args % 2 == 1; + my %params = @args; + confess "Overriding the body of meta methods is not allowed" + if $params{body}; + + my $metaclass_class = $params{associated_metaclass}->meta; + $params{body} = $class->_generate_meta_method($metaclass_class); + return $class->SUPER::wrap(%params); +} + +1; + +__END__ + +=pod + +=head1 NAME + +Class::MOP::Method::Meta - Method Meta Object for C methods + +=head1 DESCRIPTION + +This is a L subclass which represents C +methods installed into classes by Class::MOP. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> + +This is the constructor. It accepts a L object and +a hash of options. The options accepted are identical to the ones +accepted by L, except that C cannot be passed +(it will be generated automatically). + +=back + +=head1 AUTHORS + +Jesse Luehrs Edoy at tozt dot netE + +=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/lib/metaclass.pm b/lib/metaclass.pm index b688f26..192a664 100644 --- a/lib/metaclass.pm +++ b/lib/metaclass.pm @@ -43,22 +43,7 @@ sub import { # create a meta object so we can install &meta my $meta = $metaclass->initialize($package => %options); - $meta->add_method('meta' => sub { - # we must re-initialize so that it - # works as expected in subclasses, - # since metaclass instances are - # singletons, this is not really a - # big deal anyway. - if (Class::MOP::DEBUG_NO_META()) { - my ($self) = @_; - if (my $meta = try { $self->SUPER::meta }) { - return $meta if $meta->isa('Class::MOP::Class'); - } - confess "'meta' method called by MOP internals" - if caller =~ /Class::MOP|metaclass/; - } - $metaclass->initialize((blessed($_[0]) || $_[0])) - }) if $should_install_meta; + $meta->_add_meta_method if $should_install_meta; } 1; diff --git a/t/000_load.t b/t/000_load.t index e6abf02..f6b3ec4 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -20,6 +20,7 @@ BEGIN { use_ok('Class::MOP::Method::Generated'); use_ok('Class::MOP::Method::Accessor'); use_ok('Class::MOP::Method::Constructor'); + use_ok('Class::MOP::Method::Meta'); use_ok('Class::MOP::Instance'); use_ok('Class::MOP::Object'); } @@ -31,8 +32,8 @@ my %METAS = ( 'Class::MOP::Method::Inlined' => Class::MOP::Method::Inlined->meta, 'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->meta, 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, - 'Class::MOP::Method::Constructor' => - Class::MOP::Method::Constructor->meta, + 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta, + 'Class::MOP::Method::Meta' => Class::MOP::Method::Meta->meta, 'Class::MOP::Mixin' => Class::MOP::Mixin->meta, 'Class::MOP::Mixin::AttributeCore' => Class::MOP::Mixin::AttributeCore->meta, 'Class::MOP::Mixin::HasAttributes' => Class::MOP::Mixin::HasAttributes->meta, @@ -84,6 +85,7 @@ is_deeply( Class::MOP::Method::Constructor->meta, Class::MOP::Method::Generated->meta, Class::MOP::Method::Inlined->meta, + Class::MOP::Method::Meta->meta, Class::MOP::Method::Wrapped->meta, Class::MOP::Mixin->meta, Class::MOP::Mixin::AttributeCore->meta, @@ -115,6 +117,7 @@ is_deeply( Class::MOP::Method::Generated Class::MOP::Method::Inlined Class::MOP::Method::Wrapped + Class::MOP::Method::Meta Class::MOP::Module Class::MOP::Object Class::MOP::Package diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 7c0a962..93ac3c5 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -93,6 +93,7 @@ my @class_mop_class_methods = qw( find_method_by_name find_all_methods_by_name find_next_method_by_name add_before_method_modifier add_after_method_modifier add_around_method_modifier + _add_meta_method _attach_attribute _post_add_attribute