How can I monkey-patch an instance method in Perl?

Question

I\'m trying to monkey-patch (duck-punch :-) a LWP::UserAgent instance, like so:

sub _user_agent_get_basic_credentials_patch {
  return ($usernam         


        

Answer 1

Perl thinks you're trying to call the subroutine on the left of the assignment, which is why it's complaining. I think you may be able to whack the Perl symbol table directly (using *LWP::UserAgent::get_basic_credentials or something), but I lack the Perl-fu to correctly make that incantation.

Answer 2

In the spirit of Perl's "making hard things possible", here's an example of how to do single-instance monkey patching without mucking with the inheritance.

I DO NOT recommend you actually doing this in any code that anyone else will have to support, debug or depend on (like you said, consenting adults):

#!/usr/bin/perl

use strict;
use warnings;
{

    package Monkey;

    sub new { return bless {}, shift }
    sub bar { return 'you called ' . __PACKAGE__ . '::bar' }
}

use Scalar::Util qw(refaddr);

my $f = Monkey->new;
my $g = Monkey->new;
my $h = Monkey->new;

print $f->bar, "\n";    # prints "you called Monkey::bar"

monkey_patch( $f, 'bar', sub { "you, sir, are an ape" } );
monkey_patch( $g, 'bar', sub { "you, also, are an ape" } );

print $f->bar, "\n";    # prints "you, sir, are an ape"
print $g->bar, "\n";    # prints "you, also, are an ape"
print $h->bar, "\n";    # prints "you called Monkey::bar"

my %originals;
my %monkeys;

sub monkey_patch {
    my ( $obj, $method, $new ) = @_;
    my $package = ref($obj);
    $originals{$method} ||= $obj->can($method) or die "no method $method in $package";
    no strict 'refs';
    no warnings 'redefine';
    $monkeys{ refaddr($obj) }->{$method} = $new;
    *{ $package . '::' . $method } = sub {
        if ( my $monkey_patch = $monkeys{ refaddr( $_[0] ) }->{$method} ) {
            return $monkey_patch->(@_);
        } else {
            return $originals{$method}->(@_);
        }
    };
}

Answer 3

Edit: This was an incorrect attempt at a solution that I'm keeping for posterity. Look at the upvoted/accepted answers. :-)

Ah, I just realized that the syntax needs a little bit of adjustment:

$agent->{get_basic_credentials} = _user_agent_get_basic_credentials_patch;

Without the {} delimiters it looks like a method invocation (which would not be a valid l-value).

I'd still like to know how the instance method gets bound/looked up via this syntax. TIA!

Answer 4

http://www.google.com/codesearch/p?hl=en#tgg5_3LXifM/Authen-Simple-HTTP-0.1/lib/Authen/Simple/HTTP.pm&q=get_basic_credentials

Answer 5

If dynamic scope (using local) isn't satisfactory, you can automate the custom package reblessing technique:

MONKEY_PATCH_INSTANCE:
{
  my $counter = 1; # could use a state var in perl 5.10

  sub monkey_patch_instance
  {
    my($instance, $method, $code) = @_;
    my $package = ref($instance) . '::MonkeyPatch' . $counter++;
    no strict 'refs';
    @{$package . '::ISA'} = (ref($instance));
    *{$package . '::' . $method} = $code;
    bless $_[0], $package; # sneaky re-bless of aliased argument
  }
}

Example usage:

package Dog;
sub new { bless {}, shift }
sub speak { print "woof!\n" }

...

package main;

my $dog1 = Dog->new;
my $dog2 = Dog->new;

monkey_patch_instance($dog2, speak => sub { print "yap!\n" });

$dog1->speak; # woof!
$dog2->speak; # yap!

Answer 6

sub _user_agent_get_basic_credentials_patch {
  return ($username, $password);
}

my $agent = LWP::UserAgent->new();
$agent->get_basic_credentials = _user_agent_get_basic_credentials_patch;

You have not 1, but 2 problems here, because this is what you are doing:

( $agent->get_basic_credentials() ) = _user_agent_get_basic_credentials_patch(); 

on both sides cases, you're calling the subs instead of simply referring to them.

assign the result of 
              '_user_agent_get_basic_credentials_patch' 
to the value that was returned from
              'get_basic_credentials';

Equivalent logic :

{
   package FooBar; 
   sub foo(){ 
         return 5; 
   }
   1;
}
my $x =  bless( {}, "FooBar" ); 
sub baz(){ 
      return 1; 
}
$x->foo() = baz(); 
#   5 = 1;  

So its no wonder its complaining.

Your "fixed" code in your answer is also wrong, for the same reason, with another problem you may not realise:

 $agent->{get_basic_credentials} = _user_agent_get_basic_credentials_patch;

This is rather flawed logic thinking it works like you think it does.

What it is really doing, is:

1. Dereference $agent, which is a HashRef
2. Set the hash-key 'get_basic_credentials' to the result from _user_agent_get_basic_credentials_patch

You didn't assign any function at all.

{
package FooBar; 
sub foo(){ 
     return 5; 
} 
1;
}
my $x =  bless( {}, "FooBar" ); 
sub baz(){ 
  return 1; 
}
$x->{foo} = baz(); 
#  $x is now  = ( bless{ foo => 1 }, "FooBar" ); 
#  $x->foo(); # still returns 5
#  $x->{foo}; # returns 1; 

Monkey patching is rather evil of course, and I have not myself seen how to override a method on a singular instance of something like that.

However, what you can do is this:

  {
     no strict 'refs'; 
     *{'LWP::UserAgent::get_basic_credentials'} = sub { 
         # code here 

     }; 
  }

Which will globally replace the get_basic_credentials code sections behaviour ( I might be wrong somewhat, somebody correct me )

If you really need to do it on a per-instance basis you could probably do a bit of class inheritance and just build a derived class instead, and/or dynamically create new packages.