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 ($username, $password);
}

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

This isn't the right syntax -- it yields:

Can't modify non-lvalue subroutine call at [module] line [lineno].

As I recall (from Programming Perl), dispatch lookup is performed dynamically based on the blessed package (ref($agent), I believe), so I'm not sure how instance monkey patching would even work without affecting the blessed package.

I know that I can subclass the UserAgent, but I would prefer the more concise monkey-patched approach. Consenting adults and what have you. ;-)

Answer 1

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 2

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 3

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 4

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.

Answer 5

As answered by Fayland Lam, the correct syntax is:

    local *LWP::UserAgent::get_basic_credentials = sub {
        return ( $username, $password );
    };

But this is patching (dynamically scoped) the whole class and not just the instance. You can probably get away with this in your case.

If you really want to affect just the instance, use the subclassing you described. This can be done 'on the fly' like this:

{
   package My::LWP::UserAgent;
   our @ISA = qw/LWP::UserAgent/;
   sub get_basic_credentials {
      return ( $username, $password );
   };

   # ... and rebless $agent into current package
   $agent = bless $agent;
}

Answer 6

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 7

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!