Initial Commit
This commit is contained in:
Riley Schneider
331
database/perl/vendor/lib/Class/MOP/Method/Wrapped.pm
vendored
Normal file
331
database/perl/vendor/lib/Class/MOP/Method/Wrapped.pm
vendored
Normal file
@@ -0,0 +1,331 @@
|
||||
package Class::MOP::Method::Wrapped;
|
||||
our $VERSION = '2.2014';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Scalar::Util 'blessed';
|
||||
use Sub::Name 'subname';
|
||||
|
||||
use parent 'Class::MOP::Method';
|
||||
|
||||
# NOTE:
|
||||
# this ugly beast is the result of trying
|
||||
# to micro optimize this as much as possible
|
||||
# while not completely loosing maintainability.
|
||||
# At this point it's "fast enough", after all
|
||||
# you can't get something for nothing :)
|
||||
my $_build_wrapped_method = sub {
|
||||
my $modifier_table = shift;
|
||||
my ($before, $after, $around) = (
|
||||
$modifier_table->{before},
|
||||
$modifier_table->{after},
|
||||
$modifier_table->{around},
|
||||
);
|
||||
if (@$before && @$after) {
|
||||
$modifier_table->{cache} = sub {
|
||||
for my $c (@$before) { $c->(@_) };
|
||||
my @rval;
|
||||
((defined wantarray) ?
|
||||
((wantarray) ?
|
||||
(@rval = $around->{cache}->(@_))
|
||||
:
|
||||
($rval[0] = $around->{cache}->(@_)))
|
||||
:
|
||||
$around->{cache}->(@_));
|
||||
for my $c (@$after) { $c->(@_) };
|
||||
return unless defined wantarray;
|
||||
return wantarray ? @rval : $rval[0];
|
||||
}
|
||||
}
|
||||
elsif (@$before) {
|
||||
$modifier_table->{cache} = sub {
|
||||
for my $c (@$before) { $c->(@_) };
|
||||
return $around->{cache}->(@_);
|
||||
}
|
||||
}
|
||||
elsif (@$after) {
|
||||
$modifier_table->{cache} = sub {
|
||||
my @rval;
|
||||
((defined wantarray) ?
|
||||
((wantarray) ?
|
||||
(@rval = $around->{cache}->(@_))
|
||||
:
|
||||
($rval[0] = $around->{cache}->(@_)))
|
||||
:
|
||||
$around->{cache}->(@_));
|
||||
for my $c (@$after) { $c->(@_) };
|
||||
return unless defined wantarray;
|
||||
return wantarray ? @rval : $rval[0];
|
||||
}
|
||||
}
|
||||
else {
|
||||
$modifier_table->{cache} = $around->{cache};
|
||||
}
|
||||
};
|
||||
|
||||
sub wrap {
|
||||
my ( $class, $code, %params ) = @_;
|
||||
|
||||
(blessed($code) && $code->isa('Class::MOP::Method'))
|
||||
|| $class->_throw_exception( CanOnlyWrapBlessedCode => params => \%params,
|
||||
class => $class,
|
||||
code => $code
|
||||
);
|
||||
|
||||
my $modifier_table = {
|
||||
cache => undef,
|
||||
orig => $code->body,
|
||||
before => [],
|
||||
after => [],
|
||||
around => {
|
||||
cache => $code->body,
|
||||
methods => [],
|
||||
},
|
||||
};
|
||||
$_build_wrapped_method->($modifier_table);
|
||||
|
||||
# get these from the original unless explicitly overridden
|
||||
my $pkg_name = $params{package_name} || $code->package_name;
|
||||
my $method_name = $params{name} || $code->name;
|
||||
|
||||
return $class->SUPER::wrap(
|
||||
sub {
|
||||
my $wrapped = subname "${pkg_name}::_wrapped_${method_name}" => $modifier_table->{cache};
|
||||
return $wrapped->(@_) ;
|
||||
},
|
||||
package_name => $pkg_name,
|
||||
name => $method_name,
|
||||
original_method => $code,
|
||||
modifier_table => $modifier_table,
|
||||
);
|
||||
}
|
||||
|
||||
sub _new {
|
||||
my $class = shift;
|
||||
return Class::MOP::Class->initialize($class)->new_object(@_)
|
||||
if $class ne __PACKAGE__;
|
||||
|
||||
my $params = @_ == 1 ? $_[0] : {@_};
|
||||
|
||||
return bless {
|
||||
# inherited from Class::MOP::Method
|
||||
'body' => $params->{body},
|
||||
'associated_metaclass' => $params->{associated_metaclass},
|
||||
'package_name' => $params->{package_name},
|
||||
'name' => $params->{name},
|
||||
'original_method' => $params->{original_method},
|
||||
|
||||
# defined in this class
|
||||
'modifier_table' => $params->{modifier_table}
|
||||
} => $class;
|
||||
}
|
||||
|
||||
sub get_original_method {
|
||||
my $code = shift;
|
||||
$code->original_method;
|
||||
}
|
||||
|
||||
sub add_before_modifier {
|
||||
my $code = shift;
|
||||
my $modifier = shift;
|
||||
unshift @{$code->{'modifier_table'}->{before}} => $modifier;
|
||||
$_build_wrapped_method->($code->{'modifier_table'});
|
||||
}
|
||||
|
||||
sub before_modifiers {
|
||||
my $code = shift;
|
||||
return @{$code->{'modifier_table'}->{before}};
|
||||
}
|
||||
|
||||
sub add_after_modifier {
|
||||
my $code = shift;
|
||||
my $modifier = shift;
|
||||
push @{$code->{'modifier_table'}->{after}} => $modifier;
|
||||
$_build_wrapped_method->($code->{'modifier_table'});
|
||||
}
|
||||
|
||||
sub after_modifiers {
|
||||
my $code = shift;
|
||||
return @{$code->{'modifier_table'}->{after}};
|
||||
}
|
||||
|
||||
{
|
||||
# NOTE:
|
||||
# this is another possible candidate for
|
||||
# optimization as well. There is an overhead
|
||||
# associated with the currying that, if
|
||||
# eliminated might make around modifiers
|
||||
# more manageable.
|
||||
my $compile_around_method = sub {{
|
||||
my $f1 = pop;
|
||||
return $f1 unless @_;
|
||||
my $f2 = pop;
|
||||
push @_, sub { $f2->( $f1, @_ ) };
|
||||
redo;
|
||||
}};
|
||||
|
||||
sub add_around_modifier {
|
||||
my $code = shift;
|
||||
my $modifier = shift;
|
||||
unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
|
||||
$code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
|
||||
@{$code->{'modifier_table'}->{around}->{methods}},
|
||||
$code->{'modifier_table'}->{orig}
|
||||
);
|
||||
$_build_wrapped_method->($code->{'modifier_table'});
|
||||
}
|
||||
}
|
||||
|
||||
sub around_modifiers {
|
||||
my $code = shift;
|
||||
return @{$code->{'modifier_table'}->{around}->{methods}};
|
||||
}
|
||||
|
||||
sub _make_compatible_with {
|
||||
my $self = shift;
|
||||
my ($other) = @_;
|
||||
|
||||
# XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped
|
||||
# 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 ::Wrapped into a role that gets applied to
|
||||
# whatever the method_metaclass happens to be and get rid of
|
||||
# wrapped_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 methods with before/after/around modifiers
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.2014
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a L<Class::MOP::Method> subclass which implements before,
|
||||
after, and around method modifiers.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 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 are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * name
|
||||
|
||||
The method name (without a package name). This will be taken from the
|
||||
provided L<Class::MOP::Method> object if it is not provided.
|
||||
|
||||
=item * package_name
|
||||
|
||||
The package name for the method. This will be taken from the provided
|
||||
L<Class::MOP::Method> object if it is not provided.
|
||||
|
||||
=item * associated_metaclass
|
||||
|
||||
An optional L<Class::MOP::Class> object. This is the metaclass for the
|
||||
method's class.
|
||||
|
||||
=back
|
||||
|
||||
=head2 $metamethod->get_original_method
|
||||
|
||||
This returns the L<Class::MOP::Method> object that was passed to the
|
||||
constructor.
|
||||
|
||||
=head2 $metamethod->add_before_modifier($code)
|
||||
|
||||
=head2 $metamethod->add_after_modifier($code)
|
||||
|
||||
=head2 $metamethod->add_around_modifier($code)
|
||||
|
||||
These methods all take a subroutine reference and apply it as a
|
||||
modifier to the original method.
|
||||
|
||||
=head2 $metamethod->before_modifiers
|
||||
|
||||
=head2 $metamethod->after_modifiers
|
||||
|
||||
=head2 $metamethod->around_modifiers
|
||||
|
||||
These methods all return a list of subroutine references which are
|
||||
acting as the specified type of modifier.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Stevan Little <stevan@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=item *
|
||||
|
||||
Jesse Luehrs <doy@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Shawn M Moore <sartak@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
|
||||
=item *
|
||||
|
||||
Hans Dieter Pearcey <hdp@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Chris Prather <chris@prather.org>
|
||||
|
||||
=item *
|
||||
|
||||
Matt S Trout <mstrout@cpan.org>
|
||||
|
||||
=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
|
||||
Reference in New Issue
Block a user