? 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;
}
Class::MOP::Method::Accessor
Class::MOP::Method::Constructor
Class::MOP::Method::Wrapped
+
+ Class::MOP::Method::Meta
/;
$_->meta->make_immutable(
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';
: 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;
$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};
--- /dev/null
+
+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<meta> methods
+
+=head1 DESCRIPTION
+
+This is a L<Class::MOP::Method> subclass which represents C<meta>
+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<Class::MOP::Method> object and
+a hash of options. The options accepted are identical to the ones
+accepted by L<Class::MOP::Method>, except that C<body> cannot be passed
+(it will be generated automatically).
+
+=back
+
+=head1 AUTHORS
+
+Jesse Luehrs E<lt>doy at tozt dot netE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2010 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
# 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;
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');
}
'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,
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,
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
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
projects / gitmo/Class-MOP.git / commitdiff