¿Cómo puedo parchear un método de instancia en Perl?

Question

Estoy tratando de parchear (duck-punch :-) una instancia de LWP :: UserAgent , así:

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;

Esta no es la sintaxis correcta: produce:

  

No se puede modificar la subrutina no lvalue   llame a la línea [módulo] [lineno].

Según recuerdo (de Programación Perl ), la búsqueda de despacho se realiza dinámicamente en función del paquete bendecido ( ref ($ agent) , creo), así que yo ' No estoy seguro de cómo funcionaría incluso la aplicación de parches de mono sin afectar el bendito paquete.

Sé que puedo subclasificar el UserAgent , pero preferiría el enfoque más conciso con parches de mono. Consentimiento de adultos y lo que tienes. ;-)

Answer 1

Si el alcance dinámico (usando local ) no es satisfactorio, puede automatizar la técnica de reblessing de paquetes personalizados:

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 
 Si el alcance dinámico (usando  local ) no es satisfactorio, puede automatizar la técnica de reblessing de paquetes personalizados: 

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!


 Ejemplo de uso: 

<*>[0], $package; # sneaky re-bless of aliased argument
  }
}

Ejemplo de uso:

<*>

Answer 2

Como respondió Fayland Lam , la sintaxis correcta es:

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

Pero esto es parchear (de forma dinámica) toda la clase y no solo la instancia. Probablemente pueda salirse con la suya en su caso.

Si realmente quiere afectar solo la instancia, use la subclase que describió. Esto se puede hacer 'sobre la marcha' de esta manera:

{
   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 3

En el espíritu de Perl '' haciendo posible las cosas difíciles '', aquí hay un ejemplo de cómo hacer parches de mono de una sola instancia sin perder la herencia.

Yo NO te recomiendo que hagas esto en cualquier código que cualquier otra persona tendrá que respaldar, depurar o depender (como dijiste, consentir a los adultos):

#!/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( 
 En el espíritu de Perl '' haciendo posible las cosas difíciles '', aquí hay un ejemplo de cómo hacer parches de mono de una sola instancia sin perder la herencia. 

 Yo  NO  te recomiendo que hagas esto en cualquier código que cualquier otra persona tendrá que respaldar, depurar o depender (como dijiste, consentir a los adultos): 

<*>[0] ) }->{$method} ) {
            return $monkey_patch->(@_);
        } else {
            return $originals{$method}->(@_);
        }
    };
}

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;

No tiene 1, sino 2 problemas aquí, porque esto es lo que está haciendo:

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

en ambos casos, estás llamando a los subs en lugar de simplemente referirte a ellos.

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

Lógica equivalente:

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

Así que no es de extrañar que se esté quejando.

Su " fijo " el código en su respuesta también es incorrecto, por la misma razón, con otro problema que puede no darse cuenta:

 $agent->{get_basic_credentials} = _user_agent_get_basic_credentials_patch;

Esta es una lógica bastante defectuosa pensando que funciona como crees que funciona.

Lo que realmente está haciendo es:

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

No asignaste ninguna función en absoluto.

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

Los parches de mono son bastante malos, por supuesto, y yo mismo no he visto cómo anular un método en una instancia singular de algo así.

Sin embargo, lo que puede hacer es esto:

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

     }; 
  }

Que reemplazará globalmente el comportamiento de las secciones del código get_basic_credentials (podría estar equivocado de alguna manera, alguien me corrija)

Si realmente necesita hacerlo por instancia, probablemente podría hacer un poco de herencia de clase y simplemente construir una clase derivada en su lugar, y / o crear dinámicamente nuevos paquetes.

Answer 5

Perl cree que estás tratando de llamar a la subrutina a la izquierda de la tarea, por eso se queja. Creo que puede golpear la tabla de símbolos de Perl directamente (usando * LWP :: UserAgent :: get_basic_credentials o algo así), pero me falta el Perl-fu para hacer ese encantamiento correctamente.

Answer 6

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 7

Basándose en la respuesta de John Siracusa & # 8230; Descubrí que todavía quería una referencia a la función original. Entonces hice esto:

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';
    my $oldFunction = \&{ref($instance).'::'.$method};
    @{$package . '::ISA'} = (ref($instance));
    *{$package . '::' . $method} = sub {
        my ($self, @args) = @_;
        $code->($self, $oldFunction, @args);
    };
    bless 
 Basándose en  la respuesta de John Siracusa  & # 8230; Descubrí que todavía quería una referencia a la función original. Entonces hice esto: 

<*>

 Es lo mismo que en la respuesta original, excepto que paso algunos parámetros  $ self  y  $ oldFunction . 

 Esto nos permite invocar la  $ self  ' $ oldFunction  como de costumbre, pero decorar código adicional a su alrededor. 
[0], $package; # sneaky re-bless of aliased argument
  }
}

# let's say you have a database handle, $dbh
# but you want to add code before and after $dbh->prepare("SELECT 1");

monkey_patch_instance($dbh, prepare => sub {
    my ($self, $oldFunction, @args) = @_;

    print "Monkey patch (before)\n";
    my $output = $oldFunction->(($self, @args));
    print "Monkey patch (after)\n";

    return $output;
    });

Es lo mismo que en la respuesta original, excepto que paso algunos parámetros $ self y $ oldFunction .

Esto nos permite invocar la $ self ' $ oldFunction como de costumbre, pero decorar código adicional a su alrededor.

Answer 8

Editar: Este fue un intento incorrecto de una solución que mantengo para la posteridad. Mire las respuestas votadas / aceptadas. :-)

Ah, me acabo de dar cuenta de que la sintaxis necesita un poco de ajuste:

$agent->{get_basic_credentials} = _user_agent_get_basic_credentials_patch;

Sin los delimitadores {} parece una invocación de método (que no sería un valor l válido).

Todavía me gustaría saber cómo se vincula / busca el método de instancia a través de esta sintaxis. TIA!