=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;