Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

initial commit

  • Loading branch information...
commit c46420e91c3c01cc775cf85e52e65385a42088ff 1 parent 609a72b
@dann authored
Showing with 1,884 additions and 24 deletions.
  1. +3 −1 Makefile.PL
  2. +134 −4 lib/Class/Method/Modifiers/Fast.pm
  3. +23 −0 t/000-load.t
  4. +37 −0 t/001-error.t
  5. +90 −0 t/003-basic.t
  6. +61 −0 t/004-around.t
  7. +29 −0 t/005-return.t
  8. +0 −4 t/00_compile.t
  9. +37 −0 t/010-before-args.t
  10. +38 −0 t/011-after-args.t
  11. +41 −0 t/012-around-args.t
  12. +110 −0 t/020-multiple-inheritance.t
  13. +37 −0 t/030-multiple-before.t
  14. +37 −0 t/031-multiple-after.t
  15. +43 −0 t/032-multiple-around.t
  16. +73 −0 t/034-multiple-everything.t
  17. +122 −0 t/035-multiple-everything-twice.t
  18. +21 −0 t/040-twice-orig.t
  19. +51 −0 t/041-modify-parent.t
  20. +44 −0 t/051-undef-list-ctxt.t
  21. +58 −0 t/060-caller.t
  22. +26 −0 t/070-modify-multiple-at-once.t
  23. +87 −0 t/080-multiple-modifiers.t
  24. +167 −0 t/081-sub-and-modifier.t
  25. +30 −0 t/090-diamond.t
  26. +69 −0 t/100-class-mop-method-modifiers.t
  27. +133 −0 t/101-bank-account.t
  28. +0 −4 t/author/dependency.t
  29. +0 −5 t/author/perlcritic.t
  30. +0 −4 t/author/pod.t
  31. +0 −2  t/perlcriticrc
  32. +50 −0 tools/bench.txt
  33. +233 −0 tools/benchmark.pl
View
4 Makefile.PL
@@ -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;
View
138 lib/Class/Method/Modifiers/Fast.pm
@@ -1,23 +1,151 @@
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
@@ -25,6 +153,8 @@ 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
23 t/000-load.t
@@ -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
37 t/001-error.t
@@ -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
90 t/003-basic.t
@@ -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
61 t/004-around.t
@@ -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',
+]);
+
View
29 t/005-return.t
@@ -0,0 +1,29 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+do {
+ package Fib;
+ sub onacci { (1, 1, 2) }
+};
+
+is_deeply([Fib->onacci], [1, 1, 2]);
+
+do {
+ package Fib;
+ use Class::Method::Modifiers::Fast;
+
+ before onacci => sub {};
+};
+
+is_deeply([Fib->onacci], [1, 1, 2]);
+
+do {
+ package Fib;
+ use Class::Method::Modifiers::Fast;
+
+ after onacci => sub {};
+};
+
+is_deeply([Fib->onacci], [1, 1, 2]);
View
4 t/00_compile.t
@@ -1,4 +0,0 @@
-use strict;
-use Test::More tests => 1;
-
-BEGIN { use_ok 'Class::Method::Modifiers::Fast' }
View
37 t/010-before-args.t
@@ -0,0 +1,37 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my $storage = "Foo";
+
+my $child = Child->new();
+is($child->orig($storage), "before foo", "before affected orig's args a little");
+
+BEGIN
+{
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ my $self = shift;
+ return lc shift;
+ }
+}
+
+BEGIN
+{
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ before 'orig' => sub
+ {
+ my $self = shift;
+ $_[0] = 'Before ' . $_[0];
+
+ my $discard = shift;
+ $discard = "will never be seen";
+ return ["lc on an arrayref? ha ha ha"];
+ };
+}
View
38 t/011-after-args.t
@@ -0,0 +1,38 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+my $after_saw_orig_args = 0;
+
+my $storage = "Foo";
+my $child = Child->new();
+is($child->orig($storage), "orig", "after didn't affect orig's return");
+ok($after_saw_orig_args, "after saw original arguments");
+
+BEGIN
+{
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ my $self = shift;
+ $_[0] =~ s/Foo/bAR/;
+ return "orig";
+ }
+}
+
+BEGIN
+{
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ after 'orig' => sub
+ {
+ my $self = shift;
+ my $arg = shift;
+ $after_saw_orig_args = $arg eq "bAR";
+ return sub { die "somehow a closure was executed" };
+ };
+}
View
41 t/012-around-args.t
@@ -0,0 +1,41 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+my $child = Child->new();
+my @words = split ' ', $child->orig("param");
+is($words[0], "before");
+is($words[1], "PARAM-orig");
+is($words[2], "after");
+
+BEGIN
+{
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ my $self = shift;
+ my $arg = shift;
+ return "$arg-orig";
+ }
+}
+
+BEGIN
+{
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ around 'orig' => sub
+ {
+ my $orig = shift;
+ my $self = shift;
+ my $arg = shift;
+
+ join ' ',
+ "before",
+ $orig->($self, uc $arg),
+ "after";
+ };
+}
View
110 t/020-multiple-inheritance.t
@@ -0,0 +1,110 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 18;
+
+# inheritance tree looks like:
+#
+# SuperL SuperR
+# \ /
+# MiddleL MiddleR
+# \ /
+# -Child-
+
+# the Child and MiddleR modules use modifiers
+# Child will modify a method in SuperL (sl_c)
+# Child will modify a method in SuperR (sr_c)
+# Child will modify a method in SuperR already modified by MiddleR (sr_m_c)
+# SuperL and MiddleR will both have a method of the same name, doing different
+# things (called 'conflict' and 'cnf_mod')
+
+# every method and modifier will just return <Class:Method:STUFF>
+
+my $SuperL = SuperL->new();
+my $SuperR = SuperR->new();
+my $MiddleL = MiddleL->new();
+my $MiddleR = MiddleR->new();
+my $Child = Child->new();
+
+is($SuperL->superl, "<SuperL:superl>", "SuperL loaded correctly");
+is($SuperR->superr, "<SuperR:superr>", "SuperR loaded correctly");
+is($MiddleL->middlel, "<MiddleL:middlel>", "MiddleL loaded correctly");
+is($MiddleR->middler, "<MiddleR:middler>", "MiddleR loaded correctly");
+is($Child->child, "<Child:child>", "Child loaded correctly");
+
+is($SuperL->sl_c, "<SuperL:sl_c>", "SuperL->sl_c on SuperL");
+is($Child->sl_c, "<Child:sl_c:<SuperL:sl_c>>", "SuperL->sl_c wrapped by Child's around");
+
+is($SuperR->sr_c, "<SuperR:sr_c>", "SuperR->sr_c on SuperR");
+is($Child->sr_c, "<Child:sr_c:<SuperR:sr_c>>", "SuperR->sr_c wrapped by Child's around");
+
+is($SuperR->sr_m_c, "<SuperR:sr_m_c>", "SuperR->sr_m_c on SuperR");
+is($MiddleR->sr_m_c, "<MiddleR:sr_m_c:<SuperR:sr_m_c>>", "SuperR->sr_m_c wrapped by MiddleR's around");
+is($Child->sr_m_c, "<Child:sr_m_c:<MiddleR:sr_m_c:<SuperR:sr_m_c>>>", "MiddleR->sr_m_c's wrapping wrapped by Child's around");
+
+is($SuperL->conflict, "<SuperL:conflict>", "SuperL->conflict on SuperL");
+is($MiddleR->conflict, "<MiddleR:conflict>", "MiddleR->conflict on MiddleR");
+is($Child->conflict, "<SuperL:conflict>", "SuperL->conflict on Child");
+
+is($SuperL->cnf_mod, "<SuperL:cnf_mod>", "SuperL->cnf_mod on SuperL");
+is($MiddleR->cnf_mod, "<MiddleR:cnf_mod>", "MiddleR->cnf_mod on MiddleR");
+is($Child->cnf_mod, "<Child:cnf_mod:<SuperL:cnf_mod>>", "SuperL->cnf_mod wrapped by Child's around");
+
+BEGIN
+{
+ {
+ package SuperL;
+
+ sub new { bless {}, shift }
+ sub superl { "<SuperL:superl>" }
+ sub conflict { "<SuperL:conflict>" }
+ sub cnf_mod { "<SuperL:cnf_mod>" }
+ sub sl_c { "<SuperL:sl_c>" }
+ }
+
+ {
+ package SuperR;
+
+ sub new { bless {}, shift }
+ sub superr { "<SuperR:superr>" }
+ sub sr_c { "<SuperR:sr_c>" }
+ sub sr_m_c { "<SuperR:sr_m_c>" }
+ }
+
+ {
+ package MiddleL;
+ our @ISA = 'SuperL';
+
+ sub middlel { "<MiddleL:middlel>" }
+ }
+
+ {
+ package MiddleR;
+ our @ISA = 'SuperR';
+ use Class::Method::Modifiers::Fast;
+
+ sub middler { "<MiddleR:middler>" }
+ sub conflict { "<MiddleR:conflict>" }
+ sub cnf_mod { "<MiddleR:cnf_mod>" }
+ around sr_m_c => sub {
+ my $orig = shift;
+ return "<MiddleR:sr_m_c:".$orig->(@_).">"
+ };
+ }
+
+ {
+ package Child;
+ our @ISA = ('MiddleL', 'MiddleR');
+ use Class::Method::Modifiers::Fast;
+
+ sub child { "<Child:child>" }
+ around cnf_mod => sub { "<Child:cnf_mod:".shift->(@_).">" };
+ around sl_c => sub { "<Child:sl_c:".shift->(@_).">" };
+ around sr_c => sub { "<Child:sr_c:".shift->(@_).">" };
+ around sr_m_c => sub {
+ my $orig = shift;
+ return "<Child:sr_m_c:".$orig->(@_).">"
+ };
+ }
+}
+
View
37 t/030-multiple-before.t
@@ -0,0 +1,37 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my @seen;
+my @expected = ("before 2", "before 1", "orig");
+
+my $child = Child->new; $child->orig;
+
+is_deeply(\@seen, \@expected, "multiple befores called in the right order");
+
+BEGIN {
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ push @seen, "orig";
+ }
+}
+
+BEGIN {
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ before orig => sub
+ {
+ push @seen, "before 1";
+ };
+
+ before orig => sub
+ {
+ push @seen, "before 2";
+ };
+}
+
View
37 t/031-multiple-after.t
@@ -0,0 +1,37 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my @seen;
+my @expected = ("orig", "after 1", "after 2");
+
+my $child = Child->new; $child->orig;
+
+is_deeply(\@seen, \@expected, "multiple afters called in the right order");
+
+BEGIN {
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ push @seen, "orig";
+ }
+}
+
+BEGIN {
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ after orig => sub
+ {
+ push @seen, "after 1";
+ };
+
+ after orig => sub
+ {
+ push @seen, "after 2";
+ };
+}
+
View
43 t/032-multiple-around.t
@@ -0,0 +1,43 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my @seen;
+my @expected = ("around 2 before", "around 1 before", "orig", "around 1 after", "around 2 after");
+
+my $child = Child->new; $child->orig;
+
+is_deeply(\@seen, \@expected, "multiple arounds called in the right order");
+
+BEGIN {
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ push @seen, "orig";
+ }
+}
+
+BEGIN {
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ around orig => sub
+ {
+ my $orig = shift;
+ push @seen, "around 1 before";
+ $orig->();
+ push @seen, "around 1 after";
+ };
+
+ around orig => sub
+ {
+ my $orig = shift;
+ push @seen, "around 2 before";
+ $orig->();
+ push @seen, "around 2 after";
+ };
+}
+
View
73 t/034-multiple-everything.t
@@ -0,0 +1,73 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my @seen;
+my @expected = ("before 2",
+ "before 1",
+ "around 2 before",
+ "around 1 before",
+ "orig",
+ "around 1 after",
+ "around 2 after",
+ "after 1",
+ "after 2",
+ );
+
+my $child = Child->new; $child->orig;
+
+is_deeply(\@seen, \@expected, "multiple afters called in the right order");
+
+BEGIN {
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ push @seen, "orig";
+ }
+}
+
+BEGIN {
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ before orig => sub
+ {
+ push @seen, "before 1";
+ };
+
+ before orig => sub
+ {
+ push @seen, "before 2";
+ };
+
+ around orig => sub
+ {
+ my $orig = shift;
+ push @seen, "around 1 before";
+ $orig->();
+ push @seen, "around 1 after";
+ };
+
+ around orig => sub
+ {
+ my $orig = shift;
+ push @seen, "around 2 before";
+ $orig->();
+ push @seen, "around 2 after";
+ };
+
+ after orig => sub
+ {
+ push @seen, "after 1";
+ };
+
+ after orig => sub
+ {
+ push @seen, "after 2";
+ };
+
+}
+
View
122 t/035-multiple-everything-twice.t
@@ -0,0 +1,122 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my @seen;
+my @expected = ("before 4",
+ "before 3",
+ "around 4 before",
+ "around 3 before",
+ "before 2",
+ "before 1",
+ "around 2 before",
+ "around 1 before",
+ "orig",
+ "around 1 after",
+ "around 2 after",
+ "after 1",
+ "after 2",
+ "around 3 after",
+ "around 4 after",
+ "after 3",
+ "after 4",
+ );
+
+my $child = Grandchild->new; $child->orig;
+
+is_deeply(\@seen, \@expected, "multiple afters called in the right order");
+
+BEGIN {
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ push @seen, "orig";
+ }
+}
+
+BEGIN {
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ before orig => sub
+ {
+ push @seen, "before 1";
+ };
+
+ before orig => sub
+ {
+ push @seen, "before 2";
+ };
+
+ around orig => sub
+ {
+ my $orig = shift;
+ push @seen, "around 1 before";
+ $orig->();
+ push @seen, "around 1 after";
+ };
+
+ around orig => sub
+ {
+ my $orig = shift;
+ push @seen, "around 2 before";
+ $orig->();
+ push @seen, "around 2 after";
+ };
+
+ after orig => sub
+ {
+ push @seen, "after 1";
+ };
+
+ after orig => sub
+ {
+ push @seen, "after 2";
+ };
+}
+
+BEGIN {
+ package Grandchild;
+ our @ISA = 'Child';
+ use Class::Method::Modifiers::Fast;
+
+ before orig => sub
+ {
+ push @seen, "before 3";
+ };
+
+ before orig => sub
+ {
+ push @seen, "before 4";
+ };
+
+ around orig => sub
+ {
+ my $orig = shift;
+ push @seen, "around 3 before";
+ $orig->();
+ push @seen, "around 3 after";
+ };
+
+ around orig => sub
+ {
+ my $orig = shift;
+ push @seen, "around 4 before";
+ $orig->();
+ push @seen, "around 4 after";
+ };
+
+ after orig => sub
+ {
+ push @seen, "after 3";
+ };
+
+ after orig => sub
+ {
+ push @seen, "after 4";
+ };
+}
+
View
21 t/040-twice-orig.t
@@ -0,0 +1,21 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 1;
+my @seen;
+
+eval { ChildCMM->new->orig() };
+is_deeply(\@seen, ["orig", "orig"], "CMM: calling orig twice in one around works");
+
+BEGIN
+{
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig { push @seen, "orig" }
+
+ package ChildCMM;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+ around 'orig' => sub { my $orig = shift; $orig->(); $orig->(); };
+}
+
View
51 t/041-modify-parent.t
@@ -0,0 +1,51 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+my @calls;
+
+do {
+ package Parent;
+ sub foo { push @calls, 'Parent::foo' }
+
+ package Child;
+ use Class::Method::Modifiers::Fast;
+ our @ISA = 'Parent';
+
+ around foo => sub {
+ push @calls, 'before Child::foo';
+ shift->(@_);
+ push @calls, 'after Child::foo';
+ };
+};
+
+Child->foo;
+is_deeply([splice @calls], [
+ 'before Child::foo',
+ 'Parent::foo',
+ 'after Child::foo',
+]);
+
+do {
+ package Parent;
+ use Class::Method::Modifiers::Fast;
+ around foo => sub {
+ push @calls, 'before Parent::foo';
+ shift->(@_);
+ push @calls, 'after Parent::foo';
+ };
+};
+
+Child->foo;
+
+TODO: {
+ local $TODO = "pending discussion with stevan";
+ is_deeply([splice @calls], [
+ 'before Child::foo',
+ 'before Parent::foo',
+ 'Parent::foo',
+ 'after Parent::foo',
+ 'after Child::foo',
+ ]);
+}
View
44 t/051-undef-list-ctxt.t
@@ -0,0 +1,44 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 6;
+
+my ($after_called, $orig_called) = (0, 0);
+my $child = Child->new();
+my @results = $child->orig();
+
+ok($orig_called, "original method called");
+ok($after_called, "after-modifier called");
+is(@results, 0, "list context with after doesn't screw up 'return'");
+
+($after_called, $orig_called) = (0, 0);
+my $result = $child->orig();
+
+ok($orig_called, "original method called");
+ok($after_called, "after-modifier called");
+is($result, undef, "scalar context with after doesn't screw up 'return'");
+
+BEGIN
+{
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ my $self = shift;
+ $orig_called = 1;
+ return;
+ }
+}
+
+BEGIN
+{
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ after 'orig' => sub
+ {
+ $after_called = 1;
+ };
+}
+
View
58 t/060-caller.t
@@ -0,0 +1,58 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 5;
+
+my ($parent_caller, $before_caller, $around_caller, $after_caller);
+
+my $parent = Parent->new();
+$parent->orig();
+
+is($parent_caller, 'main', "parent with no modifiers sees 'main' as caller");
+
+my $child = Child->new();
+$child->orig();
+
+TODO:
+{
+ local $TODO = "caller magic not implemented yet";
+
+ is($parent_caller, 'main', "parent with modifiers sees 'main' as caller");
+ is($before_caller, 'main', "before modifiers sees 'main' as caller");
+ is($around_caller, 'main', "around modifiers sees 'main' as caller");
+ is($after_caller, 'main', "after modifiers sees 'main' as caller");
+}
+
+BEGIN
+{
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ $parent_caller = caller;
+ }
+}
+
+BEGIN
+{
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ before 'orig' => sub
+ {
+ $before_caller = caller;
+ };
+
+ after 'orig' => sub
+ {
+ $after_caller = caller;
+ };
+
+ around 'orig' => sub
+ {
+ my $orig = shift;
+ $around_caller = caller;
+ $orig->();
+ };
+}
View
26 t/070-modify-multiple-at-once.t
@@ -0,0 +1,26 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 2;
+my @seen;
+
+package Parent;
+sub new { bless {}, shift }
+sub left { push @seen, "orig-left" }
+sub right { push @seen, "orig-right" }
+
+package Child;
+our @ISA = 'Parent';
+use Class::Method::Modifiers::Fast;
+before 'left', 'right' => sub { push @seen, 'before' };
+
+package main;
+
+my $child = Child->new();
+$child->left;
+is_deeply(\@seen, [qw/before orig-left/], "correct 'left' results");
+
+@seen = ();
+$child->right;
+is_deeply(\@seen, [qw/before orig-right/], "correct 'right' results");
+
View
87 t/080-multiple-modifiers.t
@@ -0,0 +1,87 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+my @seen;
+
+my @expected = qw/ before
+ around-before
+ orig
+ around-after
+ after /;
+
+my $child = Child->new();
+$child->orig();
+is_deeply(\@seen, \@expected, "multiple modifiers in one class");
+
+@seen = ();
+@expected = qw/ beforer around-beforer
+ before around-before
+ orig
+ around-after after
+ around-afterer afterer /;
+
+my $childer = Childer->new();
+$childer->orig();
+is_deeply(\@seen, \@expected, "multiple modifiers subclassed with multiple modifiers");
+
+BEGIN
+{
+ package Parent;
+ sub new { bless {}, shift }
+ sub orig
+ {
+ push @seen, 'orig';
+ }
+}
+
+BEGIN
+{
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ after 'orig' => sub
+ {
+ push @seen, 'after';
+ };
+
+ around 'orig' => sub
+ {
+ my $orig = shift;
+ push @seen, 'around-before';
+ $orig->();
+ push @seen, 'around-after';
+ };
+
+ before 'orig' => sub
+ {
+ push @seen, 'before';
+ };
+}
+
+BEGIN
+{
+ package Childer;
+ our @ISA = 'Child';
+ use Class::Method::Modifiers::Fast;
+
+ after 'orig' => sub
+ {
+ push @seen, 'afterer';
+ };
+
+ around 'orig' => sub
+ {
+ my $orig = shift;
+ push @seen, 'around-beforer';
+ $orig->();
+ push @seen, 'around-afterer';
+ };
+
+ before 'orig' => sub
+ {
+ push @seen, 'beforer';
+ };
+}
View
167 t/081-sub-and-modifier.t
@@ -0,0 +1,167 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 28;
+
+my @seen;
+my $class = Parent->new();
+$class->orig("hi");
+is(@seen, 5);
+is($seen[0], "before-orig:hi");
+is($seen[1], "around-before-orig:hi");
+is($seen[2], "orig:hi");
+is($seen[3], "around-after-orig:hi");
+is($seen[4], "after-orig:hi");
+
+@seen = ();
+
+$class = Child->new();
+$class->orig("yo");
+is(@seen, 9);
+is($seen[0], "Cbefore-orig:yo");
+is($seen[1], "Caround-before-orig:yo");
+is($seen[2], "before-orig:yo");
+is($seen[3], "around-before-orig:yo");
+is($seen[4], "orig:yo");
+is($seen[5], "around-after-orig:yo");
+is($seen[6], "after-orig:yo");
+is($seen[7], "Caround-after-orig:yo");
+is($seen[8], "Cafter-orig:yo");
+
+@seen = ();
+
+$class = Childer->new();
+$class->orig("oy");
+is(@seen, 5);
+is($seen[0], "CCbefore-orig:oy");
+is($seen[1], "CCaround-before-orig:oy");
+is($seen[2], "CCorig:oy");
+is($seen[3], "CCaround-after-orig:oy");
+is($seen[4], "CCafter-orig:oy");
+
+@seen = ();
+
+$class = Parent2->new();
+$class->orig("bye");
+is(@seen, 5);
+is($seen[0], "before-orig:bye");
+is($seen[1], "around-before-orig:bye");
+is($seen[2], "orig:bye");
+is($seen[3], "around-after-orig:bye");
+is($seen[4], "after-orig:bye");
+
+BEGIN
+{
+ package Parent;
+ use Class::Method::Modifiers::Fast;
+
+ sub new { bless {}, shift }
+
+ sub orig
+ {
+ push @seen, "orig:$_[1]";
+ }
+
+ before 'orig' => sub
+ {
+ push @seen, "before-orig:$_[1]";
+ };
+
+ around 'orig' => sub
+ {
+ my $orig = shift;
+ push @seen, "around-before-orig:$_[1]";
+ $orig->(@_);
+ push @seen, "around-after-orig:$_[1]";
+ };
+
+ after 'orig' => sub
+ {
+ push @seen, "after-orig:$_[1]";
+ };
+}
+
+BEGIN
+{
+ package Child;
+ our @ISA = 'Parent';
+ use Class::Method::Modifiers::Fast;
+
+ before 'orig' => sub
+ {
+ push @seen, "Cbefore-orig:$_[1]";
+ };
+
+ around 'orig' => sub
+ {
+ my $orig = shift;
+ push @seen, "Caround-before-orig:$_[1]";
+ $orig->(@_);
+ push @seen, "Caround-after-orig:$_[1]";
+ };
+
+ after 'orig' => sub
+ {
+ push @seen, "Cafter-orig:$_[1]";
+ };
+}
+
+BEGIN
+{
+ package Childer;
+ our @ISA = 'Child';
+ use Class::Method::Modifiers::Fast;
+
+ sub orig
+ {
+ push @seen, "CCorig:$_[1]";
+ }
+
+ before 'orig' => sub
+ {
+ push @seen, "CCbefore-orig:$_[1]";
+ };
+
+ around 'orig' => sub
+ {
+ my $orig = shift;
+ push @seen, "CCaround-before-orig:$_[1]";
+ $orig->(@_);
+ push @seen, "CCaround-after-orig:$_[1]";
+ };
+
+ after 'orig' => sub
+ {
+ push @seen, "CCafter-orig:$_[1]";
+ };
+}
+BEGIN
+{
+ package Parent2;
+ use Class::Method::Modifiers::Fast;
+
+ sub new { bless {}, shift }
+
+ around 'orig' => sub
+ {
+ my $orig = shift;
+ push @seen, "around-before-orig:$_[1]";
+ $orig->(@_);
+ push @seen, "around-after-orig:$_[1]";
+ };
+
+ before 'orig' => sub
+ {
+ push @seen, "before-orig:$_[1]";
+ };
+
+ after 'orig' => sub
+ {
+ push @seen, "after-orig:$_[1]";
+ };
+
+ sub orig
+ {
+ push @seen, "orig:$_[1]";
+ }
+}
View
30 t/090-diamond.t
@@ -0,0 +1,30 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my $D = D->new();
+is($D->orig, "DBA", "C not called");
+
+BEGIN
+{
+ package A;
+ sub new { bless {}, shift }
+ sub orig { "A" }
+
+ package B;
+ use Class::Method::Modifiers::Fast;
+ our @ISA = ('A');
+ around orig => sub { "B" . shift->() };
+
+ package C;
+ use Class::Method::Modifiers::Fast;
+ our @ISA = ('A');
+ around orig => sub { "C" . shift->() };
+
+ package D;
+ use Class::Method::Modifiers::Fast;
+ our @ISA = ('B', 'C');
+ around orig => sub { "D" . shift->() };
+}
+
View
69 t/100-class-mop-method-modifiers.t
@@ -0,0 +1,69 @@
+#!/usr/bin/perl
+
+# taken from Class::MOP's test suite, cut down to the interesting bits I haven't
+# necessarily tested yet
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+my @tracelog;
+
+package GreatGrandParent;
+sub new { bless {}, shift }
+sub method { 4 }
+sub wrapped { push @tracelog => 'primary' }
+
+package GrandParent;
+use Class::Method::Modifiers::Fast;
+our @ISA = 'GreatGrandParent';
+around method => sub { (3, $_[0]->()) };
+
+package Parent;
+use Class::Method::Modifiers::Fast;
+our @ISA = 'GrandParent';
+around method => sub { (2, $_[0]->()) };
+
+package Child;
+use Class::Method::Modifiers::Fast;
+our @ISA = 'Parent';
+around method => sub { (1, $_[0]->()) };
+
+package GrandChild;
+use Class::Method::Modifiers::Fast;
+our @ISA = 'Child';
+around method => sub { (0, $_[0]->()) };
+
+before wrapped => sub { push @tracelog => 'before 1' };
+before wrapped => sub { push @tracelog => 'before 2' };
+before wrapped => sub { push @tracelog => 'before 3' };
+
+around wrapped => sub { push @tracelog => 'around 1'; $_[0]->() };
+around wrapped => sub { push @tracelog => 'around 2'; $_[0]->() };
+around wrapped => sub { push @tracelog => 'around 3'; $_[0]->() };
+
+after wrapped => sub { push @tracelog => 'after 1' };
+after wrapped => sub { push @tracelog => 'after 2' };
+after wrapped => sub { push @tracelog => 'after 3' };
+
+package main;
+
+my $gc = GrandChild->new();
+is_deeply(
+ [ $gc->method() ],
+ [ 0, 1, 2, 3, 4 ],
+ '... got the right results back from the around methods (in list context)');
+
+is(scalar $gc->method(), 4, '... got the right results back from the around methods (in scalar context)');
+
+$gc->wrapped();
+is_deeply(
+ \@tracelog,
+ [
+ 'before 3', 'before 2', 'before 1', # last-in-first-out order
+ 'around 3', 'around 2', 'around 1', # last-in-first-out order
+ 'primary',
+ 'after 1', 'after 2', 'after 3', # first-in-first-out order
+ ],
+ '... got the right tracelog from all our before/around/after methods');
+
View
133 t/101-bank-account.t
@@ -0,0 +1,133 @@
+#!perl -T
+use strict;
+use warnings;
+use Test::More qw/no_plan/;
+use Carp;
+
+# another test file stolen from Class::MOP
+
+# no need to bring in Test::Exception .. >_>
+sub lives_ok (&$)
+{
+ my ($code, $name) = @_;
+
+ eval { $code->() };
+ ok(!$@, $name);
+}
+
+sub dies_ok (&$)
+{
+ my ($code, $name) = @_;
+
+ eval { $code->() };
+ ok($@, $name);
+}
+
+{
+ package BankAccount;
+
+ use strict;
+ use warnings;
+
+ sub new {
+ my $class = shift;
+ my $self = {};
+ bless $self, $class;
+ $self->BUILD(@_);
+ return $self;
+ }
+
+ sub BUILD {
+ my $self = shift;
+ my %args = @_;
+ $self->{balance} = delete $args{balance} || 0;
+ }
+
+ sub balance {
+ my $self = shift;
+ $self->{balance} = shift if @_;
+ return $self->{balance};
+ }
+
+ sub deposit {
+ my ($self, $amount) = @_;
+ $self->balance($self->balance + $amount);
+ }
+
+ sub withdraw {
+ my ($self, $amount) = @_;
+ my $current_balance = $self->balance();
+ ($current_balance >= $amount)
+ || Carp::confess "Account overdrawn";
+ $self->balance($current_balance - $amount);
+ }
+
+ package CheckingAccount;
+
+ use strict;
+ use warnings;
+ our @ISA = 'BankAccount';
+ use Class::Method::Modifiers::Fast;
+
+ sub BUILD {
+ my $self = shift;
+ my %args = @_;
+ $self->{overdraft_account} = delete $args{overdraft} || 0;
+ $self->SUPER::BUILD(%args);
+ }
+
+ sub overdraft_account {
+ my $self = shift;
+ $self->{overdraft_account} = shift if @_;
+ return $self->{overdraft_account};
+ }
+
+ before 'withdraw' => sub {
+ my ($self, $amount) = @_;
+ my $overdraft_amount = $amount - $self->balance();
+ if ($overdraft_amount > 0) {
+ $self->overdraft_account->withdraw($overdraft_amount);
+ $self->deposit($overdraft_amount);
+ }
+ };
+}
+
+my $savings_account = BankAccount->new(balance => 250);
+isa_ok($savings_account, 'BankAccount');
+
+is($savings_account->balance, 250, '... got the right savings balance');
+lives_ok {
+ $savings_account->withdraw(50);
+} '... withdrew from savings successfully';
+is($savings_account->balance, 200, '... got the right savings balance after withdrawl');
+dies_ok {
+ $savings_account->withdraw(250);
+} '... could not withdraw from savings successfully';
+
+
+$savings_account->deposit(150);
+is($savings_account->balance, 350, '... got the right savings balance after deposit');
+
+my $checking_account = CheckingAccount->new(
+ balance => 100,
+ overdraft => $savings_account
+ );
+isa_ok($checking_account, 'CheckingAccount');
+isa_ok($checking_account, 'BankAccount');
+
+is($checking_account->overdraft_account, $savings_account, '... got the right overdraft account');
+
+is($checking_account->balance, 100, '... got the right checkings balance');
+
+lives_ok {
+ $checking_account->withdraw(50);
+} '... withdrew from checking successfully';
+is($checking_account->balance, 50, '... got the right checkings balance after withdrawl');
+is($savings_account->balance, 350, '... got the right savings balance after checking withdrawl (no overdraft)');
+
+lives_ok {
+ $checking_account->withdraw(200);
+} '... withdrew from checking successfully';
+is($checking_account->balance, 0, '... got the right checkings balance after withdrawl');
+is($savings_account->balance, 200, '... got the right savings balance after overdraft withdrawl');
+
View
4 t/author/dependency.t
@@ -1,4 +0,0 @@
-use Test::Dependencies
- exclude => [qw/Test::Dependencies Test::Base Test::Perl::Critic Class::Method::Modifiers::Fast/],
- style => 'light';
-ok_dependencies();
View
5 t/author/perlcritic.t
@@ -1,5 +0,0 @@
-use strict;
-use Test::More;
-eval { use Test::Perl::Critic -profile => 't/author/perlcriticrc' };
-plan skip_all => "Test::Perl::Critic is not installed." if $@;
-all_critic_ok('lib');
View
4 t/author/pod.t
@@ -1,4 +0,0 @@
-use Test::More;
-eval "use Test::Pod 1.00";
-plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
-all_pod_files_ok();
View
2  t/perlcriticrc
@@ -1,2 +0,0 @@
-[TestingAndDebugging::ProhibitNoStrict]
-allow=refs
View
50 tools/bench.txt
@@ -0,0 +1,50 @@
+
+BEFORE
+Benchmark: running ClassMethodModifiers, ClassMethodModifiersFast, Moose for at least 5 CPU seconds...
+ClassMethodModifiers: 5.55378 wallclock secs ( 5.37 usr + 0.00 sys = 5.37 CPU) @ 382244.69/s (n=2052654)
+ClassMethodModifiersFast: 5.19569 wallclock secs ( 5.15 usr + 0.00 sys = 5.15 CPU) @ 721696.50/s (n=3716737)
+ Moose: 5.37193 wallclock secs ( 5.35 usr + 0.00 sys = 5.35 CPU) @ 289563.74/s (n=1549166)
+ Rate Moose ClassMethodModifiers ClassMethodModifiersFast
+Moose 289564/s -- -24% -60%
+ClassMethodModifiers 382245/s 32% -- -47%
+ClassMethodModifiersFast 721697/s 149% 89% --
+
+AFTER
+Benchmark: running ClassMethodModifiers, ClassMethodModifiersFast, Moose for at least 5 CPU seconds...
+ClassMethodModifiers: 5.42181 wallclock secs ( 5.29 usr + 0.00 sys = 5.29 CPU) @ 273605.67/s (n=1447374)
+ClassMethodModifiersFast: 5.434 wallclock secs ( 5.36 usr + -0.01 sys = 5.35 CPU) @ 721437.01/s (n=3859688)
+ Moose: 5.48908 wallclock secs ( 5.45 usr + 0.00 sys = 5.45 CPU) @ 276198.17/s (n=1505280)
+ Rate ClassMethodModifiers Moose ClassMethodModifiersFast
+ClassMethodModifiers 273606/s -- -1% -62%
+Moose 276198/s 1% -- -62%
+ClassMethodModifiersFast 721437/s 164% 161% --
+
+AROUND
+Benchmark: running ClassMethodModifiers, ClassMethodModifiersFast, Moose for at least 5 CPU seconds...
+ClassMethodModifiers: 5.4439 wallclock secs ( 5.52 usr + 0.00 sys = 5.52 CPU) @ 377432.25/s (n=2083426)
+ClassMethodModifiersFast: 5.15217 wallclock secs ( 5.12 usr + 0.00 sys = 5.12 CPU) @ 393749.80/s (n=2015999)
+ Moose: 5.97819 wallclock secs ( 5.90 usr + 0.00 sys = 5.90 CPU) @ 305241.86/s (n=1800927)
+ Rate Moose ClassMethodModifiers ClassMethodModifiersFast
+Moose 305242/s -- -19% -22%
+ClassMethodModifiers 377432/s 24% -- -4%
+ClassMethodModifiersFast 393750/s 29% 4% --
+
+ALL THREE
+Benchmark: running ClassMethodModifiers, ClassMethodModifiersFast, Moose for at least 5 CPU seconds...
+ClassMethodModifiers: 5.08047 wallclock secs ( 5.00 usr + 0.00 sys = 5.00 CPU) @ 136121.20/s (n=680606)
+ClassMethodModifiersFast: 5.57851 wallclock secs ( 5.45 usr + -0.01 sys = 5.44 CPU) @ 264608.82/s (n=1439472)
+ Moose: 5.27847 wallclock secs ( 5.28 usr + 0.00 sys = 5.28 CPU) @ 131580.11/s (n=694743)
+ Rate Moose ClassMethodModifiers ClassMethodModifiersFast
+Moose 131580/s -- -3% -50%
+ClassMethodModifiers 136121/s 3% -- -49%
+ClassMethodModifiersFast 264609/s 101% 94% --
+
+INSTALL AROUND
+Benchmark: running ClassMethodModifiers, ClassMethodModifiersFast, Moose for at least 5 CPU seconds...
+ClassMethodModifiers: 5.3693 wallclock secs ( 1.81 usr + 3.33 sys = 5.14 CPU) @ 50794.75/s (n=261085)
+ClassMethodModifiersFast: 6.12176 wallclock secs ( 1.57 usr + 4.30 sys = 5.87 CPU) @ 45358.43/s (n=266254)
+ Moose: 21.7701 wallclock secs (21.19 usr + 0.29 sys = 21.48 CPU) @ 86.87/s (n=1866)
+ Rate Moose ClassMethodModifiersFast ClassMethodModifiers
+Moose 86.9/s -- -100% -100%
+ClassMethodModifiersFast 45358/s 52113% -- -11%
+ClassMethodModifiers 50795/s 58371% 12% --
View
233 tools/benchmark.pl
@@ -0,0 +1,233 @@
+#!/usr/bin/env perl
+
+use FindBin::libs;
+use Benchmark qw(cmpthese);
+use Benchmark ':hireswallclock';
+
+### MODULES
+
+{
+
+ package PlainParent;
+ sub new { bless {} => shift }
+ sub method {"P"}
+}
+
+{
+
+ package MooseParent;
+ use Moose;
+ sub method {"P"}
+}
+
+## before
+{
+
+ package CMMChild::Before;
+ use Class::Method::Modifiers;
+ use base 'PlainParent';
+
+ before method => sub {"B"};
+}
+
+{
+
+ package CMMFChild::Before;
+ use Class::Method::Modifiers::Fast;
+ use base 'PlainParent';
+
+ before method => sub {"B"};
+}
+
+{
+
+ package MooseBefore;
+ use Moose;
+ extends 'MooseParent';
+
+ before method => sub {"B"};
+}
+
+## after
+{
+
+ package CMMChild::After;
+ use Class::Method::Modifiers;
+ use base 'PlainParent';
+
+ after method => sub {"B"};
+}
+
+{
+
+ package CMMFChild::After;
+ use Class::Method::Modifiers::Fast;
+ use base 'PlainParent';
+
+ after method => sub {"B"};
+}
+
+{
+
+ package MooseAfter;
+ use Moose;
+ extends 'MooseParent';
+
+ after method => sub {"B"};
+}
+
+## around
+{
+
+ package CMMChild::Around;
+ use Class::Method::Modifiers;
+ use base 'PlainParent';
+
+ around method => sub { shift->() . "A" };
+}
+{
+
+ package CMMFChild::Around;
+ use Class::Method::Modifiers::Fast;
+ use base 'PlainParent';
+
+ around method => sub { shift->() . "A" };
+}
+{
+
+ package MooseAround;
+ use Moose;
+ extends 'MooseParent';
+
+ around method => sub { shift->() . "A" };
+}
+
+# AllThree
+{
+
+ package CMMChild::AllThree;
+ use Class::Method::Modifiers;
+ use base 'PlainParent';
+
+ before method => sub {"B"};
+ around method => sub { shift->() . "A" };
+ after method => sub {"Z"};
+}
+{
+
+ package CMMFChild::AllThree;
+ use Class::Method::Modifiers::Fast;
+ use base 'PlainParent';
+
+ before method => sub {"B"};
+ around method => sub { shift->() . "A" };
+ after method => sub {"Z"};
+}
+{
+
+ package MooseAllThree;
+ use Moose;
+ extends 'MooseParent';
+
+ before method => sub {"B"};
+ around method => sub { shift->() . "A" };
+ after method => sub {"Z"};
+}
+{
+
+ package CMM::Install;
+ use Class::Method::Modifiers;
+ use base 'PlainParent';
+}
+{
+
+ package CMMF::Install;
+ use Class::Method::Modifiers::Fast;
+ use base 'PlainParent';
+}
+{
+
+ package Moose::Install;
+ use Moose;
+ extends 'MooseParent';
+}
+
+my $rounds = -5;
+
+my $cmm_before = CMMChild::Before->new();
+my $cmm_after = CMMChild::After->new();
+my $cmm_around = CMMChild::Around->new();
+my $cmm_allthree = CMMChild::AllThree->new();
+
+my $cmmf_before = CMMFChild::Before->new();
+my $cmmf_after = CMMFChild::After->new();
+my $cmmf_around = CMMFChild::Around->new();
+my $cmmf_allthree = CMMFChild::AllThree->new();
+
+my $moose_before = MooseBefore->new();
+my $moose_after = MooseAfter->new();
+my $moose_around = MooseAround->new();
+my $moose_allthree = MooseAllThree->new();
+
+print "\nBEFORE\n";
+cmpthese(
+ $rounds,
+ { Moose => sub { $moose_before->method() },
+ ClassMethodModifiers => sub { $cmm_before->method() },
+ ClassMethodModifiersFast => sub { $cmmf_before->method() },
+ },
+ 'noc'
+);
+
+print "\nAFTER\n";
+cmpthese(
+ $rounds,
+ { Moose => sub { $moose_after->method() },
+ ClassMethodModifiers => sub { $cmm_after->method() },
+ ClassMethodModifiersFast => sub { $cmmf_after->method() },
+ },
+ 'noc'
+);
+
+print "\nAROUND\n";
+cmpthese(
+ $rounds,
+ { Moose => sub { $moose_around->method() },
+ ClassMethodModifiers => sub { $cmm_around->method() },
+ ClassMethodModifiersFast => sub { $cmmf_around->method() },
+ },
+ 'noc'
+);
+
+print "\nALL THREE\n";
+cmpthese(
+ $rounds,
+ { Moose => sub { $moose_allthree->method() },
+ ClassMethodModifiers => sub { $cmm_allthree->method() },
+ ClassMethodModifiersFast => sub { $cmmf_allthree->method() },
+ },
+ 'noc'
+);
+
+print "\nINSTALL AROUND\n";
+cmpthese(
+ $rounds,
+ { Moose => sub {
+
+ package Moose::Install;
+ Moose::Install::around( method => sub { } );
+ },
+ ClassMethodModifiers => sub {
+
+ package CMM::Install;
+ CMM::Install::around( method => sub { } );
+ },
+ ClassMethodModifiersFast => sub {
+
+ package CMMF::Install;
+ CMM::Install::around( method => sub { } );
+ },
+ },
+ 'noc'
+);
+
Please sign in to comment.
Something went wrong with that request. Please try again.