Permalink
Browse files

First pass at the Package::Butcher! Slice and dice at will.

  • Loading branch information...
0 parents commit c44c04d6625c32d1a0269950acf63d6ad60b0f06 @Ovid committed Feb 7, 2011
Showing with 1,186 additions and 0 deletions.
  1. +12 −0 .gitignore
  2. +18 −0 Build.PL
  3. +5 −0 Changes
  4. +14 −0 MANIFEST
  5. +1 −0 MANIFEST.SKIP
  6. +25 −0 META.yml
  7. +14 −0 Makefile.PL
  8. +302 −0 README
  9. +522 −0 lib/Package/Butcher.pm
  10. +107 −0 lib/Package/Butcher/Inflator.pm
  11. +10 −0 t/00-load.t
  12. +55 −0 t/boilerplate.t
  13. +37 −0 t/butcher.t
  14. +21 −0 t/lib/Dummy.pm
  15. +13 −0 t/manifest.t
  16. +18 −0 t/pod-coverage.t
  17. +12 −0 t/pod.t
@@ -0,0 +1,12 @@
+blib*
+Makefile
+Makefile.old
+Build
+Build.bat
+_build*
+pm_to_blib*
+*.tar.gz
+.lwpcookies
+cover_db
+pod2htm*.tmp
+Package-Butcher-*
@@ -0,0 +1,18 @@
+use strict;
+use warnings;
+use Module::Build;
+
+my $builder = Module::Build->new(
+ module_name => 'Package::Butcher',
+ license => 'perl',
+ dist_author => q{Curtis 'Ovid' Poe <ovid@cpan.org>},
+ dist_version_from => 'lib/Package/Butcher.pm',
+ build_requires => { 'Test::More' => 0, },
+ add_to_cleanup => ['Package-Butcher-*'],
+ create_makefile_pl => 'traditional',
+ meta_merge => {
+ resources => { repository => 'https://github.com/Ovid/Package-Butcher' }
+ },
+);
+
+$builder->create_build_script();
@@ -0,0 +1,5 @@
+Revision history for Package-Butcher
+
+0.01 Date/time
+ First version, released on an unsuspecting world.
+
@@ -0,0 +1,14 @@
+Build.PL
+Changes
+MANIFEST
+README
+lib/Package/Butcher.pm
+lib/Package/Butcher/Inflator.pm
+t/00-load.t
+t/butcher.t
+t/lib/Dummy.pm
+t/manifest.t
+t/pod-coverage.t
+t/pod.t
+Makefile.PL
+META.yml
@@ -0,0 +1 @@
+^MYMETA.yml$
@@ -0,0 +1,25 @@
+---
+abstract: 'When you absolutely B<have> to load that damned package.'
+author:
+ - "Curtis 'Ovid' Poe <ovid@cpan.org>"
+build_requires:
+ Test::More: 0
+configure_requires:
+ Module::Build: 0.36
+generated_by: 'Module::Build version 0.3607'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Package-Butcher
+provides:
+ Package::Butcher:
+ file: lib/Package/Butcher.pm
+ version: 0.01
+ Package::Butcher::Inflator:
+ file: lib/Package/Butcher/Inflator.pm
+ version: 0.01
+resources:
+ license: http://dev.perl.org/licenses/
+ repository: https://github.com/Ovid/Package-Butcher
+version: 0.01
@@ -0,0 +1,14 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.3607
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'PL_FILES' => {},
+ 'INSTALLDIRS' => 'site',
+ 'NAME' => 'Package::Butcher',
+ 'EXE_FILES' => [],
+ 'VERSION_FROM' => 'lib/Package/Butcher.pm',
+ 'PREREQ_PM' => {
+ 'Test::More' => 0
+ }
+)
+;
@@ -0,0 +1,302 @@
+=head1 NAME
+
+Package::Butcher - When you absolutely B<have> to load that damned package.
+
+=head1 ALPHA CODE
+
+You've been warned. It also has an embarrassingly poor test suite. It was
+hacked together in an emergency while sitting in a hospital waiting for my
+daughter to be born. Sue me.
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+=head1 SYNOPSIS
+
+ my $butcher = Package::Butcher->new(
+ {
+ package => 'Dummy',
+ do_not_load => [qw/Cannot::Load Cannot::Load2 NoSuch::List::MoreUtils/],
+ predeclare => 'uniq',
+ subs => {
+ this => sub { 7 },
+ that => sub { 3 },
+ existing => sub { 'replaced existing' },
+ },
+ method_chains => [
+ [
+ 'Cannot::Load' => qw/foo bar baz this that/ => sub {
+ my $args = join ', ' => @_;
+ return "end chain: $args";
+ },
+ ],
+ ],
+ }
+ );
+ $butcher->use(@optional_import_list);
+
+=head1 DESCRIPTION
+
+Sometimes you need to load a module which won't otherwise load. Unit testing
+is a good reason. Unfortunately, some modules are just very, very difficult to
+load. This module is a nasty hack with a name designed to make this clear.
+It's here to provide a standard set of tools to let you load these problem
+modules.
+
+=head1 USAGE
+
+To use this module, let's consider the following awful module:
+
+ package Dummy;
+
+ use strict;
+ use Cannot::Load;
+ use NoSuch::List::MoreUtils 'uniq';
+ use DBI;
+
+ use base 'Exporter';
+ our @EXPORT_OK = qw(existing);
+
+ sub existing { 'should never see this' }
+
+ # this strange construct forces a syntax error
+ sub filter {
+ uniq map {lc} split /\W+/, shift;
+ }
+
+ sub employees {
+ my @connect =
+ ( 'dbi:Pg:dbname=ourdb', '', '', { AutoCommit => 0 } );
+ return DBI->connect(@connect)
+ ->selectall_arrayref(
+ 'SELECT id, name, position FROM employees ORDER BY id');
+ }
+
+ sub recipes {
+ my @connect = ( 'dbi:Pg:dbname=ourdb', '', '', { AutoCommit => 0 } );
+ return DBI->connect(@connect)
+ ->selectall_arrayref('SELECT id, name FROM recipes');
+ }
+
+ 1;
+
+You probably cannot load this. You don't have C<Cannot::Load> or
+C<NoSuch::List::MoreUtils> available. What's worse, even if you try to stub
+them out and fake this, the C<employees> and C<recipes> methods might be
+frustrating. We'll use this as an example of how to use C<Package::Butcher>.
+
+=head1 METHODS
+
+=head2 C<new>
+
+The constructor for C<Package::Butcher> takes a hashref with several allowed
+keys. For example, the following will allow the C<Dummy> package above to
+load:
+
+ my $dummy = Package::Butcher->new({
+ package => 'Dummy',
+ do_not_load =>
+ [qw/Cannot::Load NoSuch::List::MoreUtils DBI/],
+ predeclare => 'uniq',
+ subs => {
+ existing => sub { 'replaced existing' },
+ reverse_string => sub {
+ my $arg = shift;
+ return scalar reverse $arg;
+ },
+ },
+ method_chains => [
+ [
+ 'Cannot::Load' => qw/foo bar baz this that/ => sub {
+ my $args = join ', ' => @_;
+ return "end chain: $args";
+ },
+ ],
+ [
+ 'DBI' => qw/connect selectall_arrayref/ => sub {
+ my $sql = shift;
+ return (
+ $sql =~ /\brecipes\b/
+ ? [
+ [qw/1 bob secretary/],
+ [qw/2 alice ceo/],
+ [qw/3 ovid idiot/],
+ ]
+ : [ [ 1, 'Tartiflette' ], [ 2, 'Eggs Benedict' ], ];
+ },
+ ],
+ ],
+ });
+
+Here are the allowed keys to the constructor:
+
+=over 4
+
+=item * C<package>
+
+The name of the package to be butchered.
+
+ package => 'Hard::To::Load::Package'
+
+=item * C<do_not_load>
+
+Packages which must not be loaded. This is useful when there are a bunch of
+C<use> or C<require> statements in the code which cause the target code to try
+and load packages which may not be loadable.
+
+ do_not_load => [
+ 'Apache::Never::Loads',
+ 'Module::I::Do::Not::Have::Installed',
+ 'Win32::Anything',
+ ]
+
+=item * C<predeclare>
+
+Sometimes you need to simply predeclare a method or subroutine to ensure it
+parses correctly, even if you don't need to execute that function (for
+example, if you're replacing a subroutine which contains the offending code).
+To do this, you can simply "predeclare a function or arrayref of functions
+with optional prototypes.
+
+ predeclare => [ 'uniq (@)', 'some_other_function' ]
+
+=item * C<subs>
+
+This should point to a hashref of subroutine names and sub bodies. These will
+be added to the package, overwriting any subroutines already there:
+
+ subs => {
+ existing => sub { 'replaced existing' },
+ reverse_string => sub {
+ my $arg = shift;
+ return scalar reverse $arg;
+ },
+ },
+
+Note that any subroutinine listed in the C<subs> section will automatically be
+predeclared.
+
+=item * C<method_chains>
+
+Method "chains" are frequent in bad code (and even in some good code). This is
+when you see a class with a list of chained methods getting called. For
+example:
+
+ return DBI->connect(@connect)
+ ->selectall_arrayref(
+ 'SELECT id, name, position FROM employees ORDER BY id');
+
+The butcher allows you to declare a method chain and a subref which will be
+executed. The structure is like this:
+
+ method_chains => [
+ [ $class1, @list_of_methods1, sub { @body } ],
+ [ $class2, @list_of_methods2, sub { @body } ],
+ [ $class3, @list_of_methods3, sub { @body } ],
+ ],
+
+For the DBI example above, assuming this was the only method chain in the
+code, you would have something like:
+
+ method_chains => [
+ [ 'DBI', qw/connect selectall_arrayref/, \&some_sub ],
+ ],
+
+See C<Package::Butcher::Inflator> code to see how this works.
+
+=item * C<import_on_use>
+
+This defaults to false and you should hopefully not need it.
+
+As a general rule, if you call C<< $butcher->use >>, the package's C<import>
+method will be called I<after> you use the class to allow us to inject the new
+code before importing. This means that if a class exports a 'foo' method and
+you've replaced it with your own, you are generally guaranteed to get your
+replacement when you call:
+
+ $butcher->use('foo');
+
+However, if you class requires that the C<import> method be called at the at
+time the class is "use"d, then you can specify this in the constructor:
+
+ import_on_use => 1,
+
+=back
+
+=head2 C<use>
+
+ my $butcher = Package::Butcher->new({ package ... });
+ $butcher->use(@import_list);
+
+Once constructed, this method will "use" the package in question. You may pass
+it the same import list that the package you're butchering takes. Note that if
+you override C<import>, you're on your own.
+
+=head2 C<require>
+
+ my $butcher = Package::Butcher->new({ package ... });
+ $butcher->require;
+
+Like use, but does a C<require>.
+
+=head1 AUTHOR
+
+Curtis 'Ovid' Poe, C<< <ovid at cpan.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-package-butcher at
+rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Butcher>. I will be
+notified, and then you'll automatically be notified of progress on your bug as
+I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Package::Butcher
+
+
+You can also look for information at:
+
+=over 4
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Butcher>
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Package-Butcher>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Package-Butcher>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Package-Butcher/>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+Flavio Glock for help with a parsing error.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright 2011 Curtis 'Ovid' Poe.
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See http://dev.perl.org/licenses/ for more information.
+
+=cut
+
+1;
Oops, something went wrong.

0 comments on commit c44c04d

Please sign in to comment.