ex-monkeypatched-0.03/0000755000076500000240000000000011674661225013676 5ustar aaronstaffex-monkeypatched-0.03/Changes0000644000076500000240000000036211674661171015172 0ustar aaronstaffRevision 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 ex-monkeypatched-0.03/lib/0000755000076500000240000000000011674661224014443 5ustar aaronstaffex-monkeypatched-0.03/lib/ex/0000755000076500000240000000000011674661224015057 5ustar aaronstaffex-monkeypatched-0.03/lib/ex/monkeypatched.pm0000644000076500000240000001606111674661132020252 0ustar aaronstaffpackage ex::monkeypatched; use strict; use warnings; use Sub::Name qw; use Carp qw; 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; *$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 =item * And uses that new method in some other part of its own implementation. =back C 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 for more details. =head1 DESCRIPTION C injects methods when you C it. There are two ways to invoke it with C: one is easy but inflexible, and the other is more flexible but also more awkward. In the easy form, your C 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 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 CPAN distribution provides a class named C, but trying to C fails. In that situation, you can tell C 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 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) loads the class in question, so when you use them, C is unable to guarantee that all the target class's methods have been loaded at the point the new methods are injected. The C 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 to implement some of its methods, and doesn't also implement its own C method to accurately report which method names are autoloaded, C will incorrectly assume that an autoloaded method does not exist. The solution is to fix the broken class; implementing C but not C is always an error. =head1 AUTHOR Aaron Crane Earc@cpan.orgE =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 ex-monkeypatched-0.03/Makefile.PL0000644000076500000240000000200111625173061015631 0ustar aaronstaffuse 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 ', 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); ex-monkeypatched-0.03/MANIFEST0000644000076500000240000000062411674661225015031 0ustar aaronstaffChanges 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) ex-monkeypatched-0.03/META.yml0000664000076500000240000000123611674661225015153 0ustar aaronstaff--- #YAML:1.0 name: ex-monkeypatched version: 0.03 abstract: Experimental API for safe monkey-patching author: - Aaron Crane 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 ex-monkeypatched-0.03/README0000644000076500000240000000000011624727721014543 0ustar aaronstaffex-monkeypatched-0.03/t/0000755000076500000240000000000011674661224014140 5ustar aaronstaffex-monkeypatched-0.03/t/0_compile.t0000644000076500000240000000023611624740100016157 0ustar aaronstaff#! /usr/bin/perl use strict; use warnings; use Test::More 0.88; require ex::monkeypatched; pass('Successfully loaded ex::monkeypatched'); done_testing(); ex-monkeypatched-0.03/t/basic.t0000755000076500000240000000632511674652240015415 0ustar aaronstaff#! /usr/bin/perl use strict; use warnings; use File::Spec::Functions qw; 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); } { 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); 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); } { no_class_ok($_) for qw; 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"; } ex-monkeypatched-0.03/t/inject.t0000755000076500000240000000223311624752272015603 0ustar aaronstaff#! /usr/bin/perl use strict; use warnings; use File::Spec::Functions qw; 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); } { 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(); ex-monkeypatched-0.03/t/lib/0000755000076500000240000000000011674661224014706 5ustar aaronstaffex-monkeypatched-0.03/t/lib/Monkey/0000755000076500000240000000000011674661224016150 5ustar aaronstaffex-monkeypatched-0.03/t/lib/Monkey/A.pm0000644000076500000240000000020611624744106016660 0ustar aaronstaffpackage Monkey::A; sub new { bless {}, $_[0] } sub meth_a { 'in Monkey::A meth_a' } sub heritable { 'in Monkey::A heritable' } 1; ex-monkeypatched-0.03/t/lib/Monkey/B.pm0000644000076500000240000000022011624744112016652 0ustar aaronstaffpackage Monkey::B; sub new { bless {}, $_[0] } sub meth_b { 'in Monkey::B meth_b' } sub already_exists { 'in Monkey::B already_exists' } 1; ex-monkeypatched-0.03/t/lib/Monkey/C.pm0000644000076500000240000000006011456565755016676 0ustar aaronstaffpackage Monkey::C; use base qw; 1; ex-monkeypatched-0.03/t/lib/Monkey/D.pm0000644000076500000240000000013211674351440016661 0ustar aaronstaffpackage Monkey::D; sub new { bless {}, $_[0] } sub meth_d { 'in Monkey::D meth_d' } 1; ex-monkeypatched-0.03/t/lib/Monkey/False.pm0000644000076500000240000000013411625137265017535 0ustar aaronstaffpackage Monkey::False; # This does not end in a true value, so `require`-ing it will fail. ex-monkeypatched-0.03/t/lib/Monkey/Invalid.pm0000644000076500000240000000012311625161023020054 0ustar aaronstaffpackage Monkey::Invalid; # This is a syntax error: 'one term' 'then another'; 1; ex-monkeypatched-0.03/t/lib/Monkey/PatchA.pm0000644000076500000240000000032211624744131017635 0ustar aaronstaffpackage 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; ex-monkeypatched-0.03/t/lib/Monkey/PatchB.pm0000644000076500000240000000033211624744601017641 0ustar aaronstaffpackage 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; ex-monkeypatched-0.03/t/lib/Monkey/PatchC.pm0000644000076500000240000000032011624744606017644 0ustar aaronstaffpackage 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; ex-monkeypatched-0.03/t/lib/Monkey/PatchD.pm0000644000076500000240000000024611674351054017650 0ustar aaronstaffpackage Monkey::PatchD; use strict; use warnings; use ex::monkeypatched -norequire => 'Monkey::D' => ( monkey_d => sub { 'in Monkey::PatchD monkey_d' }, ); 1; ex-monkeypatched-0.03/t/lib/Monkey/Sys.pm0000644000076500000240000000060711674652116017267 0ustar aaronstaffpackage 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;