¿Cómo puedo aplicar el parche de mono a un método de instancia en Perl?
monkeypatching (8)
Estoy intentando parchear (pato-golpear :-) 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 llamada de subrutina que no es lvalue en [module] line [lineno].
Según recuerdo (de Programming Perl ), la búsqueda de despacho se realiza de forma dinámica en función del paquete bendecido ( ref($agent) , creo), así que no estoy seguro de cómo funcionaría el parche mono de instancia sin afectar el paquete bendecido.
Sé que puedo subclasificar al UserAgent , pero preferiría el enfoque más conciso de parche de mono. El consentimiento de los adultos y lo que tienes. ;-)
Perl cree que intentas llamar a la subrutina a la izquierda de la tarea, que es por lo que se queja. Creo que puedes 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 correctamente ese hechizo.
Según lo contestado por Fayland Lam , la sintaxis correcta es:
local *LWP::UserAgent::get_basic_credentials = sub {
return ( $username, $password );
};
Pero esto es parchear (con un alcance dinámico) toda la clase y no solo la instancia. Probablemente pueda salirse con la suya en su caso.
Si realmente desea afectar solo la instancia, use las subclases 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;
}
Si el alcance dinámico (utilizando local ) no es satisfactorio, puede automatizar la técnica de reclasificación de paquetes personalizada:
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
}
}
Ejemplo de uso:
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!
Siguiendo el espíritu de Perl de "hacer que las cosas difíciles sean posibles", aquí hay un ejemplo de cómo hacer parches de monos en un solo caso sin arruinar la herencia.
NO te recomiendo que hagas esto en ningún código que los demás tengan que admitir, depurar o depender (como dijiste, adultos que consienten):
#!/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}->(@_);
}
};
}
Sobre la base de la respuesta de John Siracusa ... 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 $_[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 por algunos parámetros $self y $oldFunction .
Esto nos permite invocar $self $oldFunction como de costumbre, pero decorar el código adicional a su alrededor.
Editar: Este fue un intento incorrecto de una solución que guardo 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 se parece a una invocación de método (que no sería un valor válido de l).
Todavía me gustaría saber cómo se enlaza / busca el método de instancia a través de esta sintaxis. TIA!
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á llamando a los subs en lugar de simplemente referirse 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 código "fijo" 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.
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 asignó 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;
El parche de mono es bastante malo, por supuesto, y no he visto cómo anular un método en una instancia singular de algo así.
Sin embargo, lo que puedes 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, alguien me corrige)
Si realmente necesita hacerlo en cada instancia, probablemente pueda hacer un poco de herencia de clase y simplemente crear una clase derivada en su lugar, y / o crear paquetes nuevos dinámicamente.