Test::Smoke::Patcher - OO interface to help patching the source-tree

    use Test::Smoke::Patcher;

    my $patcher = Test::Smoke::Patcher->new( single => {
        ddir  => $build_dir,
        pfile => $patch,
        popts => '-p1',
        v     => 1, # 0..2
    });
    $patcher->patch;

    my $patcher = Test::Smoke::Patcher->new( multi => {
        ddir  => $buildir,
        pfile => $patch_info,
        v     => 1, #0..2
    });
    $patcher->patch;

  * Abe Timmerman <abeltje@cpan.org>

package Test::Smoke::Patcher;
use strict;

# $Id: Patcher.pm 921 2005-12-18 11:27:57Z abeltje $
use vars qw( $VERSION @EXPORT );
$VERSION = '0.011';

use base 'Exporter';
use File::Spec;
use Cwd;

use Test::Smoke::Util qw( get_regen_headers );

@EXPORT = qw( &TRY_REGEN_HEADERS );

sub TRY_REGEN_HEADERS() { 1 }

my %CONFIG = (
    df_ddir     => File::Spec->rel2abs( cwd ),
    df_fdir     => undef,
    df_pfile    => undef,
    df_patchbin => 'patch',
    df_popts    => '',       # '-p1' is added in call_patch()
    df_flags    => 1,
    df_oldpatch => 0,
    df_v        => 0,

    valid_type => { single => 1, multi => 1 },
    single     => [qw( pfile patchbin popts flags oldpatch )],
    multi      => [qw( pfile patchbin popts flags oldpatch )],
);

sub new {
    my $proto = shift;
    my  $class = ref $proto || $proto;

    my $type = lc shift;
    unless ( $type && exists $CONFIG{valid_type}->{ $type } ) {
        defined $type or $type = 'undef';
        require Carp;
        Carp::croak( "Invalid Patcher-type: '$type'" );
    }

    my %args_raw = @_ ? UNIVERSAL::isa( $_[0], 'HASH' ) ? %{ $_[0] } : @_ : ();

    my %args = map {
        ( my $key = $_ ) =~ s/^-?(.+)$/lc $1/e;
        ( $key => $args_raw{ $_ } );
    } keys %args_raw;

    my %fields = map {
        my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
        ( $_ => $value )
    } ( v => ddir => fdir => @{ $CONFIG{ $type } } );
    $fields{pdir} = File::Spec->rel2abs( 
        defined $fields{fdir} ? $fields{fdir} : $fields{ddir}
    );
    $fields{ptype} = $type;

    bless { %fields }, $class;
}

sub config {
    my $dummy = shift;

    my $key = lc shift;

    if ( $key eq 'all_defaults' ) {
        my %default = map {
            my( $pass_key ) = $_ =~ /^df_(.+)/;
            ( $pass_key => $CONFIG{ $_ } );
        } grep /^df_/ => keys %CONFIG;
        return \%default;
    }

    return undef unless exists $CONFIG{ "df_$key" };

    $CONFIG{ "df_$key" } = shift if @_;

    return $CONFIG{ "df_$key" };
}

sub patch {
    my $self = shift;

    my $method = "patch_$self->{ptype}";
    my $ret = $self->$method( @_ );
    $ret &&= $self->perl_regen_headers;

    if ( $self->{fdir} ) { # This is a forest setup, re-sync
        require Test::Smoke::Syncer;
        my %options = (
            hdir => $self->{fdir},
            ddir => $self->{ddir},
            v    => $self->{v},
        );
        my $resync = Test::Smoke::Syncer->new( hardlink => %options );
        $resync->sync;
    }
    return $ret;
}

sub perl_regen_headers {
    my $self = shift;
    return 1 unless $self->{flags} & TRY_REGEN_HEADERS;

    my $regen_headers = get_regen_headers( $self->{pdir} );
    my $regen_perly = $self->{perly}
        ? qq|$^X "| . File::Spec->catfile( $self->{pdir}, 'regen_perly.pl' ).
          qq|"|
        : "";
    my @regens = grep $_ => ( $regen_headers, $regen_perly );
    for my $regen ( @regens ) {
        my $cwd = cwd;
        chdir $self->{pdir} or return;
        local *RUN_REGEN;
        if ( open RUN_REGEN, "$regen |" ) {
            $self->{v} and print "Started [$regen]\n";
            while ( <RUN_REGEN> ) {
                $self->{v} and print;
            }
            close RUN_REGEN or do {
                require Carp;
                Carp::carp( "Error while running [$regen]" );
                return;
            };
        } else {
            require Carp;
            Carp::carp( "Could not fork [$regen]" );
            return;
        }
        chdir $cwd;
    }
    return 1;
}

sub patch_single {
    my $self = shift;

    my $pfile = shift || $self->{pfile};

    local *PATCH;
    my $content;
    if ( ref $pfile eq 'SCALAR' ) {
        $content = $$pfile;
        $self->{pfinfo} ||= 'internal content';
    } elsif ( ref $pfile eq 'ARRAY' ) {
        $content = join "", @$pfile;
        $self->{pfinfo} ||= 'internal content';
    } elsif ( ref $pfile eq 'GLOB' ) {
        *PATCH = *$pfile;
        $content = do { local $/; <PATCH> };
        $self->{pfinfo} ||= 'file content';
    } else {
        my $full_name = File::Spec->file_name_is_absolute( $pfile ) 
            ? $pfile : File::Spec->rel2abs( $pfile, $self->{pdir} );

        $self->{pfinfo} = $full_name;
        open PATCH, "< $full_name" or do {
            require Carp;
            Carp::croak( "Cannot open '$full_name': $!" );
        };
        $content = do { local $/; <PATCH> };
        close PATCH;
    }

    $self->{v} and print "Get patch from $self->{pfinfo}\n";
    $self->call_patch( \$content, @_ );
}

sub patch_multi {
    my $self = shift;

    my $pfile = shift || $self->{pfile};

    local *PATCHES;
    my @patches;
    if ( ref $pfile eq 'SCALAR' ) {
        @patches = split /\n/, $$pfile;
        $self->{pfinfo} ||= 'internal content';
    } elsif ( ref $pfile eq 'ARRAY' ) {
        chomp( @patches = @$pfile );
        $self->{pfinfo} ||= 'internal content';
    } elsif ( ref $pfile eq 'GLOB' ) {
        *PATCHES = *$pfile;
        chomp( @patches = <PATCHES> );
        $self->{pfinfo} ||= 'file content';
    } else {
        my $full_name = File::Spec->file_name_is_absolute( $pfile ) 
            ? $pfile : File::Spec->rel2abs( $pfile, $self->{pdir} );
        $self->{pfinfo} = $full_name;
        open PATCHES, "< $full_name" or do {
            require Carp;
            Carp::croak( "Cannot open '$self->{pfile}': $!" );
        };
        chomp( @patches = <PATCHES> );
        close PATCHES;
    }

    $self->{v} and print "Get patchinfo from $self->{pfinfo}\n";

    my $ok = 1;
    foreach my $patch ( @patches ) {
        next if $patch =~ /^\s*[#]/;
        next if $patch =~ /^\s*$/;
        if ( $patch =~ /^\s*!\s*perly$/ ) {
            $self->{perly} = 1;
            next;
        }
        my( $filename, $switches, $descr ) = split /\s*;\s*/, $patch, 3;
        $descr = $descr ? $descr . " ($filename)" : $filename;
        eval { $self->patch_single( $filename, $switches, $descr ) };
        if ( $@ ) {
            require Carp;
            Carp::carp( "[$filename] $@" );
            $ok = 0;
        }
    }
    return $ok;
}

sub _make_opts {
    my $self = shift;
    @_ = grep defined $_ => @_;
    my $switches = @_ ? join " ", @_ : "";

    my $opts = $switches || $self->{popts} || "";
    $opts .= " -p1" unless $opts =~ /-[a-zA-Z]*p\d/;
#    $opts .= " -b" unless $opts =~ /-[a-zA-Z]*b/i;
    $opts .= " --verbose" if $self->{v} > 1 && !$self->{oldpatch};

    return $opts;
}

sub call_patch {
    my( $self, $ref_to_content, $switches, $descr ) = @_;

    local *PATCHBIN;

    my $opts = $self->_make_opts( $switches );

    my $redir = $self->{v} ? "" : ">" . File::Spec->devnull . " 2>&1";

    my $cwd = cwd();
    chdir $self->{pdir} or do {
        require Carp;
        Carp::croak( "Cannot chdir($self->{pdir}): $!" );
    };

    # patch is verbose enough if $self->{v} == 1
    $self->{v} > 1 and 
        print "[$self->{pfinfo}] | $self->{patchbin} $opts $redir\n";

    if ( open PATCHBIN, "| $self->{patchbin} $opts $redir" ) {
        binmode PATCHBIN;
        print PATCHBIN $$ref_to_content;
        close PATCHBIN or do {
            require Carp;
            Carp::croak( "Error while patching from '$self->{pfinfo}': $!" );
        };
    } else {
        require Carp;
        Carp::croak( "Cannot fork ($self->{patchbin}): $!" );
    }

    # Add a line to patchlevel.h if $descr
    if ( defined $descr ) {
        require Test::Smoke::Util;
        Test::Smoke::Util::set_local_patch( $self->{pdir}, $descr );
    }

    chdir $cwd or do {
        require Carp;
        Carp::croak( "Cannot chdir($cwd) back: $!" );
    };
}