bump version to 1.07
[gitmo/Class-MOP.git] / lib / Class / MOP / Method / Wrapped.pm
index 3c02017..6764882 100644 (file)
@@ -5,10 +5,10 @@ use strict;
 use warnings;
 
 use Carp         'confess';
-use Scalar::Util 'reftype', 'blessed';
-use Sub::Name    'subname';
+use Scalar::Util 'blessed';
 
-our $VERSION   = '0.02';
+our $VERSION   = '1.07';
+$VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Class::MOP::Method';
@@ -20,119 +20,161 @@ use base 'Class::MOP::Method';
 # 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 @{$before};
-                       my @rval;
-                       ((defined wantarray) ?
-                               ((wantarray) ?
-                                       (@rval = $around->{cache}->(@_))
-                                       :
-                                       ($rval[0] = $around->{cache}->(@_)))
-                               :
-                               $around->{cache}->(@_));
-                       $_->(@_) for @{$after};
-                       return unless defined wantarray;
-                       return wantarray ? @rval : $rval[0];
-               }
-       }
-       elsif (@$before && !@$after) {
-               $modifier_table->{cache} = sub {
-                       $_->(@_) for @{$before};
-                       return $around->{cache}->(@_);
-               }
-       }
-       elsif (@$after && !@$before) {
-               $modifier_table->{cache} = sub {
-                       my @rval;
-                       ((defined wantarray) ?
-                               ((wantarray) ?
-                                       (@rval = $around->{cache}->(@_))
-                                       :
-                                       ($rval[0] = $around->{cache}->(@_)))
-                               :
-                               $around->{cache}->(@_));
-                       $_->(@_) for @{$after};
-                       return unless defined wantarray;
-                       return wantarray ? @rval : $rval[0];
-               }
-       }
-       else {
-               $modifier_table->{cache} = $around->{cache};
-       }
+    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 && !@$after) {
+        $modifier_table->{cache} = sub {
+            for my $c (@$before) { $c->(@_) };
+            return $around->{cache}->(@_);
+        }
+    }
+    elsif (@$after && !@$before) {
+        $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 = shift;
-       my $code  = shift;
-       (blessed($code) && $code->isa('Class::MOP::Method'))
-               || confess "Can only wrap blessed CODE";
-       my $modifier_table = {
-               cache  => undef,
-               orig   => $code,
-               before => [],
-               after  => [],
-               around => {
-                       cache   => $code->body,
-                       methods => [],
-               },
-       };
-       $_build_wrapped_method->($modifier_table);
-       my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
-       $method->{'%!modifier_table'} = $modifier_table;
-       $method;
+    my ( $class, $code, %params ) = @_;
+
+    (blessed($code) && $code->isa('Class::MOP::Method'))
+        || confess "Can only wrap blessed CODE";
+
+    my $modifier_table = {
+        cache  => undef,
+        orig   => $code,
+        before => [],
+        after  => [],
+        around => {
+            cache   => $code->body,
+            methods => [],
+        },
+    };
+    $_build_wrapped_method->($modifier_table);
+    return $class->SUPER::wrap(
+        sub { $modifier_table->{cache}->(@_) },
+        # get these from the original
+        # unless explicitly overriden
+        package_name   => $params{package_name} || $code->package_name,
+        name           => $params{name}         || $code->name,
+
+        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->{'%!modifier_table'}->{orig};
+    my $code = shift;
+    $code->{'modifier_table'}->{orig};
 }
 
 sub add_before_modifier {
-       my $code     = shift;
-       my $modifier = shift;
-       unshift @{$code->{'%!modifier_table'}->{before}} => $modifier;
-       $_build_wrapped_method->($code->{'%!modifier_table'});
+    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'});
+    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}->body
-               );
-               $_build_wrapped_method->($code->{'%!modifier_table'});
-       }
+    # 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}->body
+        );
+        $_build_wrapped_method->($code->{'modifier_table'});
+    }
+}
+
+sub around_modifiers {
+    my $code = shift;
+    return @{$code->{'modifier_table'}->{around}->{methods}};
 }
 
 1;
@@ -143,35 +185,67 @@ __END__
 
 =head1 NAME
 
-Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers
-
-=head1 SYNOPSIS
-
-  # ... more to come later maybe
+Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers
 
 =head1 DESCRIPTION
 
+This is a L<Class::MOP::Method> subclass which implements before,
+after, and around method modifiers.
+
 =head1 METHODS
 
 =head2 Construction
 
 =over 4
 
-=item B<wrap (&code)>
+=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
 
-=item B<get_original_method>
+This is the constructor. It accepts a L<Class::MOP::Method> object and
+a hash of options.
+
+The options are:
+
+=over 8
+
+=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 Modifiers
+=item B<< $metamethod->get_original_method >>
 
-=over 4
+This returns the L<Class::MOP::Method> object that was passed to the
+constructor.
+
+=item B<< $metamethod->add_before_modifier($code) >>
+
+=item B<< $metamethod->add_after_modifier($code) >>
+
+=item B<< $metamethod->add_around_modifier($code) >>
+
+These methods all take a subroutine reference and apply it as a
+modifier to the original method.
+
+=item B<< $metamethod->before_modifiers >>
 
-=item B<add_before_modifier ($code)>
+=item B<< $metamethod->after_modifiers >>
 
-=item B<add_after_modifier ($code)>
+=item B<< $metamethod->around_modifiers >>
 
-=item B<add_around_modifier ($code)>
+These methods all return a list of subroutine references which are
+acting as the specified type of modifier.
 
 =back
 
@@ -181,7 +255,7 @@ Stevan Little E<lt>stevan@iinteractive.comE<gt>
 
 =head1 COPYRIGHT AND LICENSE
 
-Copyright 2006, 2007 by Infinity Interactive, Inc.
+Copyright 2006-2010 by Infinity Interactive, Inc.
 
 L<http://www.iinteractive.com>