use 5.8.0;
use strict;
use warnings;
use B qw(class svref_2object);
use UNIVERSAL 'isa'; # see UNIVERSAL::isa on CPAN.

=pod
 {
     my %k = (foo=>'bar');
     my $x = 42;
     my $y = 32;
     my @f = qw(perl monks);
     *closure = sub { print "$x $y @f",%k,"\n"; };
 }
 rebind_closure( \&closure,
    '@f' => [ '@f' ],
    '$x' => '$x',
    '$y' => '$y',
    '%k' => { ('%k') x 2 } );
  closure();

Prints "$x $y @f%k%k" instead of "42 32 perl monksfoobar"

=cut

sub rebind_closure {
    my $sub = shift;
    my @replacement_pairs = @_;
    if ( @replacement_pairs % 2 ) {
        die "Rules must be an even numbered list: @replacement_pairs";
    }

    my ($names,@values) =
        svref_2object( $sub )->PADLIST->ARRAY;
    my @names = @{$names->object_2svref};

    my @rules = @replacement_pairs[grep !($_ & 1), 0 .. $#replacement_pairs];
    my @replacements =
        @replacement_pairs[grep $_ & 1, 0 .. $#replacement_pairs];
    
    for my $ix ( 0 .. $#rules ) {
        my $rule = $rules[$ix];
        my $replacement  = $replacements[$ix];

        for ( 1 .. $#names ) {
            if ( rule_matches( $rule, $names[$_] ) ) {
                my $sigil = substr $names[$_], 0, 1;
                if ( $sigil eq '$' ) {
                    ${($values[0]->ARRAY)[$_]->object_2svref} = $replacement;
                } elsif ( $sigil eq '@' ) {
                    @{($values[0]->ARRAY)[$_]->object_2svref} = @$replacement;
                } elsif ( $sigil eq '%' ) {
                    %{($values[0]->ARRAY)[$_]->object_2svref} = %$replacement;
                } elsif ( $sigil eq '*' or
                          $sigil eq '&' ) {
                    warn "$names[$_] cannot be rebound because it is not a scalar, array or hash";
                } else {
                    warn "Unknown sigil $sigil";
                }
            }
        }
    }
}

sub rule_matches {
    my $rule = shift;
    my $name = shift;

    return unless $name;
    return
        !!
        isa( $rule, 'CODE' ) ? $rule->( $name ) :
        ref( $rule ) ? $name =~ $rule   :
        $name eq $rule;
}