Permalink
Browse files

initial commit

  • Loading branch information...
dann committed Jan 18, 2009
1 parent 609a72b commit c46420e91c3c01cc775cf85e52e65385a42088ff
View
@@ -2,9 +2,11 @@ use inc::Module::Install;
name 'Class-Method-Modifiers-Fast';
all_from 'lib/Class/Method/Modifiers/Fast.pm';
-requires $_ for (qw/ /);
+requires 'Data::Util';
build_requires 'Test::More';
+build_requires 'Test::Exception';
+
use_test_base;
auto_include;
WriteAll;
@@ -1,30 +1,160 @@
package Class::Method::Modifiers::Fast;
-
use strict;
use warnings;
+use Data::Util;
our $VERSION = '0.01';
+use base 'Exporter';
+our @EXPORT = qw(before after around);
+our @EXPORT_OK = @EXPORT;
+our %EXPORT_TAGS = (
+ moose => [qw(before after around)],
+ all => \@EXPORT_OK,
+);
+
+use Carp 'confess';
+
+sub _install_modifier {
+ my $into = shift;
+ my $type = shift;
+ my $modifier = pop;
+ my @names = @_;
+
+ foreach my $name (@names) {
+ my $method = Data::Util::get_code_ref( $into, $name );
+
+ if ( !$method || !Data::Util::subroutine_modifier($method) ) {
+
+ unless ($method) {
+ $method = $into->can($name)
+ or confess
+ "The method '$name' isn't found in the inheritance hierarchy for the class $into";
+ }
+ $method = Data::Util::modify_subroutine( $method,
+ $type => [$modifier] );
+
+ no warnings 'redefine';
+ Data::Util::install_subroutine( $into, $name => $method );
+ }
+ else {
+ Data::Util::subroutine_modifier( $method, $type => $modifier );
+ }
+ }
+ return;
+}
+
+sub before {
+ _install_modifier( scalar(caller), 'before', @_ );
+}
+
+sub after {
+ _install_modifier( scalar(caller), 'after', @_ );
+}
+
+sub around {
+ _install_modifier( scalar(caller), 'around', @_ );
+}
+
1;
+
__END__
=head1 NAME
-Class::Method::Modifiers::Fast -
+Class::Method::Modifiers::Fast - provides Moose-like method modifiers
=head1 SYNOPSIS
- use Class::Method::Modifiers::Fast;
+ package Child;
+ use parent 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ sub new_method { }
+
+ before 'old_method' => sub {
+ carp "old_method is deprecated, use new_method";
+ };
+
+ around 'other_method' => sub {
+ my $orig = shift;
+ my $ret = $orig->(@_);
+ return $ret =~ /\d/ ? $ret : lc $ret;
+ };
=head1 DESCRIPTION
-Class::Method::Modifiers::Fast is
+Method modifiers are a powerful feature from the CLOS (Common Lisp Object
+System) world.
+
+C<Class::Method::Modifiers::Fast> provides three modifiers: C<before>, C<around>,
+and C<after>. C<before> and C<after> are run just before and after the method they
+modify, but can not really affect that original method. C<around> is run in
+place of the original method, with a hook to easily call that original method.
+See the C<MODIFIERS> section for more details on how the particular modifiers
+work.
+
+=head1 MODIFIERS
+
+=head2 before method(s) => sub { ... }
+
+C<before> is called before the method it is modifying. Its return value is
+totally ignored. It receives the same C<@_> as the the method it is modifying
+would have received. You can modify the C<@_> the original method will receive
+by changing C<$_[0]> and friends (or by changing anything inside a reference).
+This is a feature!
+
+=head2 after method(s) => sub { ... }
+
+C<after> is called after the method it is modifying. Its return value is
+totally ignored. It receives the same C<@_> as the the method it is modifying
+received, mostly. The original method can modify C<@_> (such as by changing
+C<$_[0]> or references) and C<after> will see the modified version. If you
+don't like this behavior, specify both a C<before> and C<after>, and copy the
+C<@_> during C<before> for C<after> to use.
+
+=head2 around method(s) => sub { ... }
+
+C<around> is called instead of the method it is modifying. The method you're
+overriding is passed in as the first argument (called C<$orig> by convention).
+Watch out for contextual return values of C<$orig>.
+
+You can use C<around> to:
+
+=over 4
+
+=item Pass C<$orig> a different C<@_>
+
+ around 'method' => sub {
+ my $orig = shift;
+ my $self = shift;
+ $orig->($self, reverse @_);
+ };
+
+=item Munge the return value of C<$orig>
+
+ around 'method' => sub {
+ my $orig = shift;
+ ucfirst $orig->(@_);
+ };
+
+=item Avoid calling C<$orig> -- conditionally
+
+ around 'method' => sub {
+ my $orig = shift;
+ return $orig->(@_) if time() % 2;
+ return "no dice, captain";
+ };
+
+=back
=head1 AUTHOR
Takatoshi Kitano E<lt>kitano.tk@gmail.comE<gt>
=head1 SEE ALSO
+L<Class::Method::Modifiers>
+
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
View
@@ -0,0 +1,23 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+do {
+ package Class;
+ use Class::Method::Modifiers::Fast;
+
+ sub foo { }
+
+ before foo => sub {
+ };
+
+ after foo => sub {
+ };
+
+ around foo => sub {
+ };
+};
+
+pass("loaded correctly");
+
View
@@ -0,0 +1,37 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+use Test::Exception;
+
+throws_ok {
+ package Class1;
+ use Class::Method::Modifiers::Fast;
+
+ before foo => sub {};
+
+} qr/The method 'foo' is not found in the inheritance hierarchy for class Class1/;
+
+throws_ok {
+ package Class2;
+ use Class::Method::Modifiers::Fast;
+
+ after foo => sub {};
+} qr/The method 'foo' is not found in the inheritance hierarchy for class Class2/;
+
+throws_ok {
+ package Class3;
+ use Class::Method::Modifiers::Fast;
+
+ around foo => sub {};
+} qr/The method 'foo' is not found in the inheritance hierarchy for class Class3/;
+
+throws_ok {
+ package Class4;
+ use Class::Method::Modifiers::Fast;
+
+ sub foo {}
+
+ around 'foo', 'bar' => sub {};
+} qr/The method 'bar' is not found in the inheritance hierarchy for class Class4/;
+
View
@@ -0,0 +1,90 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 6;
+
+my @calls;
+
+do {
+ package Parent;
+ use Class::Method::Modifiers::Fast;
+
+ sub original { push @calls, 'Parent::original' }
+ before original => sub { push @calls, 'before Parent::original' };
+ after original => sub { push @calls, 'after Parent::original' };
+};
+
+Parent->original;
+is_deeply([splice @calls], [
+ 'before Parent::original',
+ 'Parent::original',
+ 'after Parent::original',
+]);
+
+do {
+ package Parent;
+ use Class::Method::Modifiers::Fast;
+
+ before original => sub { push @calls, 'before before Parent::original' };
+ after original => sub { push @calls, 'after after Parent::original' };
+};
+
+Parent->original;
+is_deeply([splice @calls], [
+ 'before before Parent::original',
+ 'before Parent::original',
+ 'Parent::original',
+ 'after Parent::original',
+ 'after after Parent::original',
+]);
+
+do {
+ package Child;
+ BEGIN { our @ISA = 'Parent' }
+};
+
+Parent->original;
+is_deeply([splice @calls], [
+ 'before before Parent::original',
+ 'before Parent::original',
+ 'Parent::original',
+ 'after Parent::original',
+ 'after after Parent::original',
+]);
+
+Child->original;
+is_deeply([splice @calls], [
+ 'before before Parent::original',
+ 'before Parent::original',
+ 'Parent::original',
+ 'after Parent::original',
+ 'after after Parent::original',
+]);
+
+do {
+ package Child;
+ use Class::Method::Modifiers::Fast;
+
+ before original => sub { push @calls, 'before Child::original' };
+ after original => sub { push @calls, 'after Child::original' };
+};
+
+Parent->original;
+is_deeply([splice @calls], [
+ 'before before Parent::original',
+ 'before Parent::original',
+ 'Parent::original',
+ 'after Parent::original',
+ 'after after Parent::original',
+]);
+
+Child->original;
+is_deeply([splice @calls], [
+ 'before Child::original',
+ 'before before Parent::original',
+ 'before Parent::original',
+ 'Parent::original',
+ 'after Parent::original',
+ 'after after Parent::original',
+ 'after Child::original',
+]);
View
@@ -0,0 +1,61 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+my @calls;
+
+do {
+ package Class;
+ use Class::Method::Modifiers::Fast;
+
+ sub original { push @calls, 'Class::original' }
+ around original => sub { push @calls, 'around Class::original' };
+};
+
+Class->original;
+is_deeply([splice @calls], [
+ 'around Class::original',
+]);
+
+do {
+ package Parent;
+ use Class::Method::Modifiers::Fast;
+
+ sub original { push @calls, 'Parent::original' }
+ around original => sub {
+ my $orig = shift;
+ push @calls, 'around/before Parent::original';
+ $orig->(@_);
+ push @calls, 'around/after Parent::original';
+ };
+};
+
+Parent->original;
+is_deeply([splice @calls], [
+ 'around/before Parent::original',
+ 'Parent::original',
+ 'around/after Parent::original',
+]);
+
+do {
+ package Parent;
+ use Class::Method::Modifiers::Fast;
+
+ around original => sub {
+ my $orig = shift;
+ push @calls, '2 around/before Parent::original';
+ $orig->(@_);
+ push @calls, '2 around/after Parent::original';
+ };
+};
+
+Parent->original;
+is_deeply([splice @calls], [
+ '2 around/before Parent::original',
+ 'around/before Parent::original',
+ 'Parent::original',
+ 'around/after Parent::original',
+ '2 around/after Parent::original',
+]);
+
Oops, something went wrong.

0 comments on commit c46420e

Please sign in to comment.