diff options
| author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-06 17:50:16 +0000 |
|---|---|---|
| committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-06 17:50:16 +0000 |
| commit | 5ac2026f7eed78958d69d051e7a8e993dcf51205 (patch) | |
| tree | 298c3d2f08bdfe5689998b11892d72a897985be1 /lib/Class/MOP/Method/Meta.pm | |
| download | Moose-tarball-5ac2026f7eed78958d69d051e7a8e993dcf51205.tar.gz | |
Moose-2.1405HEADMoose-2.1405master
Diffstat (limited to 'lib/Class/MOP/Method/Meta.pm')
| -rw-r--r-- | lib/Class/MOP/Method/Meta.pm | 169 |
1 files changed, 169 insertions, 0 deletions
diff --git a/lib/Class/MOP/Method/Meta.pm b/lib/Class/MOP/Method/Meta.pm new file mode 100644 index 0000000..23b3567 --- /dev/null +++ b/lib/Class/MOP/Method/Meta.pm @@ -0,0 +1,169 @@ +package Class::MOP::Method::Meta; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken'; + +use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0; + +use parent 'Class::MOP::Method'; + +sub _is_caller_mop_internal { + my $self = shift; + my ($caller) = @_; + return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/; +} + +sub _generate_meta_method { + my $method_self = shift; + my $metaclass = shift; + weaken($metaclass); + + sub { + # this will be compiled out if the env var wasn't set + if (DEBUG_NO_META) { + confess "'meta' method called by MOP internals" + # it's okay to call meta methods on metaclasses, since we + # explicitly ask for them + if !$_[0]->isa('Class::MOP::Object') + && !$_[0]->isa('Class::MOP::Mixin') + # it's okay if the test itself calls ->meta, we only care about + # if the mop internals call ->meta + && $method_self->_is_caller_mop_internal(scalar caller); + } + # 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; + $class->_throw_exception( CannotOverrideBodyOfMetaMethods => params => \%params, + class => $class + ) + if $params{body}; + + my $metaclass_class = $params{associated_metaclass}->meta; + $params{body} = $class->_generate_meta_method($metaclass_class); + return $class->SUPER::wrap(%params); +} + +sub _make_compatible_with { + my $self = shift; + my ($other) = @_; + + # XXX: this is pretty gross. the issue here is that CMOP::Method::Meta + # objects are subclasses of CMOP::Method, but when we get to moose, they'll + # need to be compatible with Moose::Meta::Method, which isn't possible. the + # right solution here is to make ::Meta into a role that gets applied to + # whatever the method_metaclass happens to be and get rid of + # _meta_method_metaclass entirely, but that's not going to happen until + # we ditch cmop and get roles into the bootstrapping, so. i'm not + # maintaining the previous behavior of turning them into instances of the + # new method_metaclass because that's equally broken, and at least this way + # any issues will at least be detectable and potentially fixable. -doy + return $self unless $other->_is_compatible_with($self->_real_ref_name); + + return $self->SUPER::_make_compatible_with(@_); +} + +1; + +# ABSTRACT: Method Meta Object for C<meta> methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Meta - Method Meta Object for C<meta> methods + +=head1 VERSION + +version 2.1405 + +=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 + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut |