Import libex-monkeypatched-perl_0.03.orig.tar.gz

[dgit import orig libex-monkeypatched-perl_0.03.orig.tar.gz]

20 files changed, 594 insertions, 0 deletions

diff --git a/Changes b/Changes
new file mode 100644
index 0000000..df97238
--- /dev/null
+++ b/Changes
@@ -0,0 +1,11 @@
+Revision history for Perl module ex::monkeypatched
+
+0.03, 2011-12-22
+  * Fix broken dist (new test files missing)
+
+0.02, 2011-12-22
+  * New `-norequire` feature
+  * Optional new API with more flexibility
+
+0.01, 2011-08-25
+  * Initial release
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..475e1bc
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,20 @@
+Changes
+Makefile.PL
+MANIFEST
+README
+lib/ex/monkeypatched.pm
+t/0_compile.t
+t/basic.t
+t/inject.t
+t/lib/Monkey/A.pm
+t/lib/Monkey/B.pm
+t/lib/Monkey/C.pm
+t/lib/Monkey/D.pm
+t/lib/Monkey/False.pm
+t/lib/Monkey/Invalid.pm
+t/lib/Monkey/PatchA.pm
+t/lib/Monkey/PatchB.pm
+t/lib/Monkey/PatchC.pm
+t/lib/Monkey/PatchD.pm
+t/lib/Monkey/Sys.pm
+META.yml                                 Module meta-data (added by MakeMaker)
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..4aa8a0e
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,26 @@
+--- #YAML:1.0
+name:               ex-monkeypatched
+version:            0.03
+abstract:           Experimental API for safe monkey-patching
+author:
+    - Aaron Crane <arc@cpan.org>
+license:            perl
+distribution_type:  module
+configure_requires:
+    ExtUtils::MakeMaker:  0
+build_requires:
+    Test::Exception:  0
+    Test::More:       0.88
+requires:
+    perl:       5.008
+    Sub::Name:  0
+resources:
+    repository:  https://github.com/arc/p5-ex-monkeypatched
+no_index:
+    directory:
+        - t
+        - inc
+generated_by:       ExtUtils::MakeMaker version 6.56
+meta-spec:
+    url:      http://module-build.sourceforge.net/META-spec-v1.4.html
+    version:  1.4
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..92024c8
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,34 @@
+use 5.008;
+use ExtUtils::MakeMaker;
+
+my $file = 'lib/ex/monkeypatched.pm';
+my %data = (
+    NAME                  => 'ex::monkeypatched',
+    LICENSE               => 'perl',
+    MIN_PERL_VERSION      => '5.008',
+    META_MERGE            => {
+        resources         => {
+            repository    => 'https://github.com/arc/p5-ex-monkeypatched',
+        },
+    },
+    VERSION_FROM          => $file,
+    ABSTRACT_FROM         => $file,
+    AUTHOR                => 'Aaron Crane <arc@cpan.org>',
+    BUILD_REQUIRES        => {
+        'Test::More'      => '0.88',
+        'Test::Exception' => 0,
+    },
+    PREREQ_PM             => {
+        'Sub::Name'       => 0,
+    },
+);
+
+for ($ExtUtils::MakeMaker::VERSION) {
+    delete $data{MIN_PERL_VERSION} if $_ < 6.48;
+    delete $data{META_MERGE}       if $_ < 6.46;
+    delete $data{LICENSE}          if $_ < 6.31;
+    $data{PREREQ_PM} = { %{ $data{PREREQ_PM} }, %{ delete $data{BUILD_REQUIRES} } }
+                                   if $_ < 6.5503;
+}
+
+WriteMakefile(%data);
diff --git a/README b/README
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/README
diff --git a/lib/ex/monkeypatched.pm b/lib/ex/monkeypatched.pm
new file mode 100644
index 0000000..329efe8
--- /dev/null
+++ b/lib/ex/monkeypatched.pm
@@ -0,0 +1,237 @@
+package ex::monkeypatched;
+
+use strict;
+use warnings;
+
+use Sub::Name qw<subname>;
+use Carp qw<croak>;
+
+our $VERSION = '0.03';
+
+sub import {
+    my $invocant = shift;
+    my $norequire = @_ && $_[0] && $_[0] eq '-norequire' && shift;
+    if (@_) {
+        my @injections = _parse_injections(@_)
+            or croak "Usage: use $invocant \$class => %methods
+or:    use $invocant (class => \$class, methods => \\%methods)
+or:    use $invocant (method => \$name, implementations => \\%impl)";
+        _require(map { $_->[0] } @injections)
+            if !$norequire;
+        _inject_methods(@injections);
+    }
+}
+
+sub _require {
+    for (@_) {
+        (my $as_file = $_) =~ s{::|'}{/}g;
+        require "$as_file.pm";  # dies if no such file is found
+    }
+}
+
+sub _parse_injections {
+
+    if (@_ == 1 && ref $_[0] eq 'HASH') {
+        my $opt = shift;
+        if (defined $opt->{class} && ref $opt->{methods} eq 'HASH') {
+            return map { [$opt->{class}, $_, $opt->{methods}{$_}] }
+                keys %{ $opt->{methods} };
+        }
+        elsif (defined $opt->{method} && ref $opt->{implementations} eq 'HASH') {
+            return map { [$_, $opt->{method}, $opt->{implementations}{$_}] }
+                keys %{ $opt->{implementations} };
+        }
+    }
+    elsif (@_ % 2) {
+        my @injections;
+        my $target = shift;
+        push @injections, [$target, splice @_, 0, 2]
+            while @_;
+        return @injections;
+    }
+
+    return;
+}
+
+sub inject {
+    my $invocant = shift;
+    my @injections = _parse_injections(@_)
+        or croak "Usage: $invocant->inject(\$class, %methods)
+or:    $invocant->inject({ class => \$class, methods => \\%methods })
+or:    $invocant->inject({ method => \$name, implementations => \\%impl })";
+    _inject_methods(@injections);
+}
+
+sub _inject_methods {
+    for (@_) {
+        my ($target, $name, undef) = @$_;
+        croak qq[Can't monkey-patch: $target already has a method "$name"]
+            if $target->can($name);
+    }
+    _install_subroutine(@$_) for @_;
+}
+
+sub _install_subroutine {
+    my ($target, $name, $code) = @_;
+    my $full_name = "$target\::$name";
+    my $renamed_code = subname($full_name, $code);
+    no strict qw<refs>;
+    *$full_name = $renamed_code;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+ex::monkeypatched - Experimental API for safe monkey-patching
+
+=head1 SYNOPSIS
+
+    use ex::monkeypatched 'Third::Party::Class' => (
+        clunk => sub { ... },
+        eth   => sub { ... },
+    );
+
+    use Foo::TopLevel; # provides Foo::Bar, which isn't a module
+    use ex::monkeypatched -norequire => 'Foo::Bar' => (
+        thwapp => sub { ... },
+        urkk   => sub { ... },
+    );
+
+=head1 BACKGROUND
+
+The term "monkey patching" describes injecting additional methods into a
+class whose implementation you don't control.  If done without care, this is
+dangerous; the problematic case arises when:
+
+=over 4
+
+=item *
+
+You add a method to a class;
+
+=item *
+
+A newer version of the monkey-patched class adds another method I<of the
+same name>
+
+=item *
+
+And uses that new method in some other part of its own implementation.
+
+=back
+
+C<ex::monkeypatched> lets you do this sort of monkey-patching safely: before
+it injects a method into the target class, it checks whether the class
+already has a method of the same name.  If it finds such a method, it throws
+an exception (at compile-time with respect to the code that does the
+injection).
+
+See L<http://aaroncrane.co.uk/talks/monkey_patching_subclassing/> for more
+details.
+
+=head1 DESCRIPTION
+
+C<ex::monkeypatched> injects methods when you C<use> it.  There are two ways
+to invoke it with C<use>: one is easy but inflexible, and the other is more
+flexible but also more awkward.
+
+In the easy form, your C<use> call should supply the name of a class to
+patch, and a listified hash from method names to code references
+implementing those methods:
+
+    use ex::monkeypatched 'Some::Class' => (
+        m1 => sub { ... },  # $x->m1 on Some::Class will now run this
+        m2 => sub { ... },  # $x->m2 on Some::Class will now run this
+    );
+
+In the flexible form, your C<use> call supplies a single hashref saying what
+methods to create.  That last example can be done exactly like this:
+
+    use ex::monkeypatched { class => 'Some::Class', methods => {
+        m1 => sub { ... },  # $x->m1 on Some::Class will now run this
+        m2 => sub { ... },  # $x->m2 on Some::Class will now run this
+    } };
+
+However, this flexible form also lets you add a method of a single name to
+several classes at once:
+
+    use ex::monkeypatched { method => 'm3', implementations => {
+        'Some::BaseClass'     => sub { ... },
+        'Some::Subclass::One' => sub { ... }
+        'Some::Subclass::Two' => sub { ... },
+    } };
+
+This is helpful when you want to provide a method for several related
+classes, with a different implementation in each of them.
+
+The classes to be patched will normally be loaded automatically before any
+patching is done (thus ensuring that all their base classes are also
+loaded).
+
+That doesn't work when you're trying to modify a class which can't be loaded
+directly; for example, the L<XML::LibXML> CPAN distribution provides a class
+named C<XML::LibXML::Node>, but trying to C<use XML::LibXML::Node> fails.
+In that situation, you can tell C<ex::monkeypatched> not to load the
+original class:
+
+    use ex::monkeypatched -norequire => 'XML::LibXML::Node' => (
+        clunk => sub { ... },
+        eth   => sub { ... },
+    );
+
+    # Equivalently:
+    use ex::monkeypatched -norequire => {
+        class   => 'XML::LibXML::Node',
+        methods => {
+            clunk => sub { ... },
+            eth   => sub { ... },
+        },
+    };
+
+Alternatively, you can inject methods after a class has already been loaded,
+using the C<inject> method:
+
+    use ex::monkeypatched;
+
+    ex::monkeypatched->inject('XML::LibXML::Node' => (
+        clunk => sub { ... },
+        eth   => sub { ... },
+    );
+
+    # Equivalently:
+    ex::monkeypatched->inject({ class => 'XML::LibXML::Node', methods => {
+        clunk => sub { ... },
+        eth   => sub { ... },
+    }});
+
+Neither of these approaches (C<-norequire> and C<inject>) loads the class in
+question, so when you use them, C<ex::monkeypatched> is unable to guarantee
+that all the target class's methods have been loaded at the point the new
+methods are injected.
+
+The C<ex::> prefix on the name of this module indicates that its API is
+still considered experimental.  However, the underlying code has been in use
+in production for an extended period, and seems to be reliable.
+
+=head1 CAVEATS
+
+If the class you're monkeying around in uses C<AUTOLOAD> to implement some
+of its methods, and doesn't also implement its own C<can> method to
+accurately report which method names are autoloaded, C<ex::monkeypatched>
+will incorrectly assume that an autoloaded method does not exist.  The
+solution is to fix the broken class; implementing C<AUTOLOAD> but not C<can>
+is always an error.
+
+=head1 AUTHOR
+
+Aaron Crane E<lt>arc@cpan.orgE<gt>
+
+=head1 LICENCE
+
+This library is free software; you can redistribute it and/or modify it
+under the terms of either the GNU General Public License version 2 or, at
+your option, the Artistic License.
+
+=cut
diff --git a/t/0_compile.t b/t/0_compile.t
new file mode 100644
index 0000000..9ed5a70
--- /dev/null
+++ b/t/0_compile.t
@@ -0,0 +1,11 @@
+#! /usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 0.88;
+
+require ex::monkeypatched;
+
+pass('Successfully loaded ex::monkeypatched');
+done_testing();
diff --git a/t/basic.t b/t/basic.t
new file mode 100755
index 0000000..cc2939e
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,102 @@
+#! /usr/bin/perl
+
+use strict;
+use warnings;
+
+use File::Spec::Functions qw<splitpath catdir catpath>;
+
+use lib do {
+    my ($vol, $dir, undef) = splitpath(__FILE__);
+    catpath($vol, catdir($dir, 'lib'), '');
+};
+
+use Test::More 0.88;
+use Test::Exception;
+
+{
+    no_class_ok('Monkey::A');
+    require_ok('Monkey::PatchA');
+    my $obj = new_ok('Monkey::A', [], 'monkey-patched version');
+    can_ok($obj, qw<meth_a monkey_a1 monkey_a2>);
+}
+
+{
+    no_class_ok('Monkey::B');
+    throws_ok { require Monkey::PatchB }
+        qr/^Can't monkey-patch: Monkey::B already has a method "\w+"/,
+        'Correctly refuse to override a statically-defined method';
+}
+
+{
+    no_class_ok('Monkey::C');
+    throws_ok { require Monkey::PatchC }
+        qr/^Can't monkey-patch: Monkey::C already has a method "heritable"/,
+        'Correctly refuse to override an inherited method';
+}
+
+{
+    no_class_ok('Monkey::D');
+    require_ok('Monkey::PatchD');
+    can_ok('Monkey::D', qw<monkey_d>);
+    throws_ok { 'Monkey::D'->new }
+        qr/^Can't locate object method "new" via package "Monkey::D"/,
+        '-norequire option does not load target package';
+    require_ok('Monkey::D');
+    my $obj = new_ok('Monkey::D', [], 'monkey-patched version');
+    can_ok($obj, qw<meth_d monkey_d>);
+}
+
+{
+    no_class_ok($_) for qw<Monkey::Sys Monkey::Sys::A Monkey::Sys::B Monkey::Sys::C>;
+    require_ok('Monkey::Sys');
+    can_ok('Monkey::Sys::A', 'sys_a_1');
+    lives_ok {
+        eval q{
+            use ex::monkeypatched -norequire => { method => 'foo', implementations => {
+                'Monkey::Sys::A' => sub { 'in Monkey::Sys::A foo' },
+                'Monkey::Sys::B' => sub { 'in Monkey::Sys::B foo' },
+            } };
+            1
+        } or die $@;
+    } 'name+implementations lives';
+    my $obj = new_ok('Monkey::Sys::B', [], 'monkey-patched version');
+    can_ok($obj, 'foo')
+        and is($obj->foo, 'in Monkey::Sys::B foo', 'name+implementations gets right method');
+}
+
+{
+    can_ok('Monkey::Sys::C', 'sys_c_1');
+    lives_ok {
+        eval q{
+            use ex::monkeypatched -norequire => { class => 'Monkey::Sys::C', methods => {
+                foo => sub { 'in Monkey::Sys::C foo' },
+                bar => sub { 'in Monkey::Sys::C bar' },
+            } };
+            1
+        } or die $@;
+    } 'class+methods lives';
+    my $obj = new_ok('Monkey::Sys::C', [], 'monkey-patched version');
+    can_ok($obj, 'foo')
+        and is($obj->foo, 'in Monkey::Sys::C foo', 'class+methods gets right method');
+}
+
+throws_ok { ex::monkeypatched->import('Monkey::False', f => sub {}) }
+    qr{^Monkey/False\.pm did not return a true value},
+    'Exception propagated from require for false module';
+
+throws_ok { ex::monkeypatched->import('Monkey::Invalid', f => sub {}) }
+    qr{^syntax error at .*Monkey/Invalid\.pm line },
+    'Exception propagated from require for invalid module';
+
+throws_ok { eval q{use ex::monkeypatched 'Monkey::Q1', 'meth'; 1} or die $@ }
+    qr{^Usage: use ex::monkeypatched \$class => %methods},
+    'Argument validation: missing method body';
+
+done_testing();
+
+sub no_class_ok {
+    my ($class, $msg) = @_;
+    throws_ok { my $obj = $class->new }
+        qr/^Can't locate object method "new" via package "\Q$class\E"/,
+        $msg || "no class $class exists";
+}
diff --git a/t/inject.t b/t/inject.t
new file mode 100755
index 0000000..3ce7175
--- /dev/null
+++ b/t/inject.t
@@ -0,0 +1,46 @@
+#! /usr/bin/perl
+
+use strict;
+use warnings;
+
+use File::Spec::Functions qw<splitpath catdir catpath>;
+
+use lib do {
+    my ($vol, $dir, undef) = splitpath(__FILE__);
+    catpath($vol, catdir($dir, 'lib'), '');
+};
+
+use Test::More 0.88;
+use Test::Exception;
+
+use ex::monkeypatched;
+
+{
+    my $class = 'Monkey::A';
+    require_ok($class);
+    ex::monkeypatched->inject($class => (
+        m1 => sub { 'in patched Monkey::A m1' },
+        m2 => sub { 'in patched Monkey::A m2' },
+    ));
+    my $obj = new_ok('Monkey::A', [], 'monkey-patched version');
+    can_ok($obj, qw<meth_a m1 m2>);
+}
+
+{
+    my $class = 'Monkey::B';
+    require_ok($class);
+    throws_ok { ex::monkeypatched->inject($class => (
+        already_exists => sub { 'will fail' },
+    )) } qr/^Can't monkey-patch: Monkey::B already has a method "\w+"/,
+        'Refuse to post-hoc override a statically-defined method';
+}
+
+{
+    my $class = 'Monkey::Nonexistent';
+    ex::monkeypatched->inject($class, m3 => sub { 'in nonexistent m3' });
+    throws_ok { my $obj = $class->new }
+        qr/^Can't locate object method "new" via package "\Q$class\E"/,
+            '->inject does not load the class';
+}
+
+done_testing();
diff --git a/t/lib/Monkey/A.pm b/t/lib/Monkey/A.pm
new file mode 100644
index 0000000..e617c56
--- /dev/null
+++ b/t/lib/Monkey/A.pm
@@ -0,0 +1,9 @@
+package Monkey::A;
+
+sub new { bless {}, $_[0] }
+
+sub meth_a { 'in Monkey::A meth_a' }
+
+sub heritable { 'in Monkey::A heritable' }
+
+1;
diff --git a/t/lib/Monkey/B.pm b/t/lib/Monkey/B.pm
new file mode 100644
index 0000000..7371ccd
--- /dev/null
+++ b/t/lib/Monkey/B.pm
@@ -0,0 +1,9 @@
+package Monkey::B;
+
+sub new { bless {}, $_[0] }
+
+sub meth_b { 'in Monkey::B meth_b' }
+
+sub already_exists { 'in Monkey::B already_exists' }
+
+1;
diff --git a/t/lib/Monkey/C.pm b/t/lib/Monkey/C.pm
new file mode 100644
index 0000000..dda473d
--- /dev/null
+++ b/t/lib/Monkey/C.pm
@@ -0,0 +1,5 @@
+package Monkey::C;
+
+use base qw<Monkey::A>;
+
+1;
diff --git a/t/lib/Monkey/D.pm b/t/lib/Monkey/D.pm
new file mode 100644
index 0000000..3e2741b
--- /dev/null
+++ b/t/lib/Monkey/D.pm
@@ -0,0 +1,7 @@
+package Monkey::D;
+
+sub new { bless {}, $_[0] }
+
+sub meth_d { 'in Monkey::D meth_d' }
+
+1;
diff --git a/t/lib/Monkey/False.pm b/t/lib/Monkey/False.pm
new file mode 100644
index 0000000..ac151a0
--- /dev/null
+++ b/t/lib/Monkey/False.pm
@@ -0,0 +1,3 @@
+package Monkey::False;
+
+# This does not end in a true value, so `require`-ing it will fail.
diff --git a/t/lib/Monkey/Invalid.pm b/t/lib/Monkey/Invalid.pm
new file mode 100644
index 0000000..4b15dfc
--- /dev/null
+++ b/t/lib/Monkey/Invalid.pm
@@ -0,0 +1,7 @@
+package Monkey::Invalid;
+
+# This is a syntax error:
+'one term'
+'then another';
+
+1;
diff --git a/t/lib/Monkey/PatchA.pm b/t/lib/Monkey/PatchA.pm
new file mode 100644
index 0000000..bfd4bd6
--- /dev/null
+++ b/t/lib/Monkey/PatchA.pm
@@ -0,0 +1,11 @@
+package Monkey::PatchA;
+
+use strict;
+use warnings;
+
+use ex::monkeypatched 'Monkey::A' => (
+    monkey_a1 => sub { 'in Monkey::PatchA monkey_a1' },
+    monkey_a2 => sub { 'in Monkey::PatchA monkey_a2' },
+);
+
+1;
diff --git a/t/lib/Monkey/PatchB.pm b/t/lib/Monkey/PatchB.pm
new file mode 100644
index 0000000..09b9998
--- /dev/null
+++ b/t/lib/Monkey/PatchB.pm
@@ -0,0 +1,11 @@
+package Monkey::PatchB;
+
+use strict;
+use warnings;
+
+use ex::monkeypatched 'Monkey::B' => (
+    monkey_b => sub { 'in Monkey::PatchB monkey_b' },
+    already_exists => sub { 'in Monkey::PatchB already_exists' },
+);
+
+1;
diff --git a/t/lib/Monkey/PatchC.pm b/t/lib/Monkey/PatchC.pm
new file mode 100644
index 0000000..7e91085
--- /dev/null
+++ b/t/lib/Monkey/PatchC.pm
@@ -0,0 +1,11 @@
+package Monkey::PatchC;
+
+use strict;
+use warnings;
+
+use ex::monkeypatched 'Monkey::C' => (
+    monkey_b => sub { 'in Monkey::PatchC monkey_c' },
+    heritable => sub { 'in Monkey::PatchC heritable' },
+);
+
+1;
diff --git a/t/lib/Monkey/PatchD.pm b/t/lib/Monkey/PatchD.pm
new file mode 100644
index 0000000..36e9bbd
--- /dev/null
+++ b/t/lib/Monkey/PatchD.pm
@@ -0,0 +1,10 @@
+package Monkey::PatchD;
+
+use strict;
+use warnings;
+
+use ex::monkeypatched -norequire => 'Monkey::D' => (
+    monkey_d => sub { 'in Monkey::PatchD monkey_d' },
+);
+
+1;
diff --git a/t/lib/Monkey/Sys.pm b/t/lib/Monkey/Sys.pm
new file mode 100644
index 0000000..3076f03
--- /dev/null
+++ b/t/lib/Monkey/Sys.pm
@@ -0,0 +1,24 @@
+package Monkey::Sys;
+
+use strict;
+use warnings;
+
+{
+    package Monkey::Sys::A;
+    sub new { bless {}, shift }
+    sub sys_a_1 { 'in Monkey::Sys::A sys_a_1' }
+}
+
+{
+    package Monkey::Sys::B;
+    sub new { bless {}, shift }
+    sub sys_b_1 { 'in Monkey::Sys::B sys_b_1' }
+}
+
+{
+    package Monkey::Sys::C;
+    sub new { bless {}, shift }
+    sub sys_c_1 { 'in Monkey::Sys::C sys_c_1' }
+}
+
+1;