Как я могу обезопасить метод экземпляра в Perl?
https://stackoverflow.com/questions/449690
-
19-08-2019 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianВопрос
Я пытаюсь установить патч (duck-punch :-) для экземпляра LWP::UserAgent, например, так:
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;
Это неправильный синтаксис - он дает:
Невозможно изменить функцию без значения позвоните по [модульной] линии [бельё].
Насколько я помню (из Programming Perl ), поиск диспетчеризации выполняется динамически на основе благословенного пакета (я думаю, ref($agent)), поэтому я не уверен, каким образом исправление экземпляра обезьяны могло бы даже работать, не затрагивая благословенный пакет.
Я знаю, что могу создать подкласс UserAgent, но я бы предпочел более лаконичный подход с исправлениями обезьян. Согласие взрослых и то, что ты. ; -)
Решение
Если динамическая область действия (с использованием local) неудовлетворительная, вы можете автоматизировать пользовательскую технику отбрасывания пакетов:
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
}
}
Пример использования:
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!
Другие советы
Как ответил Фейланд Лам , правильный синтаксис:
local *LWP::UserAgent::get_basic_credentials = sub {
return ( $username, $password );
};
Но это исправление (динамически ограниченное пространство) всего класса, а не только экземпляра. Вероятно, вы можете избежать неприятностей с этим в вашем случае.
Если вы действительно хотите повлиять только на экземпляр, используйте описанные вами подклассы. Это можно сделать «на лету» следующим образом:
{
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;
}
В духе Perl &, позволяющего делать сложные вещи &, вот пример того, как сделать исправление обезьяны в одном экземпляре без использования наследования.
Я НЕ рекомендую, чтобы вы действительно делали это в любом коде, от которого кто-либо другой должен будет поддерживать, отлаживать или зависеть (как вы сказали, соглашающиеся взрослые):
#!/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}->(@_);
}
};
}
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;
У вас здесь не 1, а 2 проблемы, потому что это то, что вы делаете:
( $agent->get_basic_credentials() ) = _user_agent_get_basic_credentials_patch();
В обоих случаях вы вызываете подпрограммы, а не просто ссылаетесь на них.
assign the result of
'_user_agent_get_basic_credentials_patch'
to the value that was returned from
'get_basic_credentials';
Эквивалентная логика:
{
package FooBar;
sub foo(){
return 5;
}
1;
}
my $x = bless( {}, "FooBar" );
sub baz(){
return 1;
}
$x->foo() = baz();
# 5 = 1;
Так что неудивительно, что он жалуется.
Ваш " исправлен " Код в вашем ответе также неверен, по той же причине, с другой проблемой, которую вы можете не осознавать:
$agent->{get_basic_credentials} = _user_agent_get_basic_credentials_patch;
Это довольно некорректная логика, которая думает, что работает так, как вы думаете.
Что он на самом деле делает, это:
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
Вы не назначали никакой функции вообще.
{
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;
Исправление обезьян - это, конечно, зло, и я сам не видел, как переопределить метод в единственном экземпляре чего-то подобного.
Однако вы можете сделать следующее:
{
no strict 'refs';
*{'LWP::UserAgent::get_basic_credentials'} = sub {
# code here
};
}
Что глобально заменит поведение разделов кода get_basic_credentials (возможно, я немного ошибаюсь, кто-то меня поправит)
Если вам действительно нужно сделать это для каждого отдельного экземпляра, вы, вероятно, могли бы немного наследовать классы и просто создать вместо этого производный класс и / или динамически создавать новые пакеты.
Perl считает, что вы пытаетесь вызвать подпрограмму слева от назначения, поэтому он жалуется. Я думаю, что вы можете ударить таблицу символов Perl напрямую (используя *LWP::UserAgent::get_basic_credentials или что-то в этом роде), но мне не хватает Perl-fu, чтобы правильно сделать это заклинание.
Опираясь на ответ Джона Сиракузы & # 8230; Я обнаружил, что я все еще хотел ссылку на оригинальную функцию. Итак, я сделал это:
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;
});
Это так же, как в исходном ответе, за исключением того, что я передаю некоторые параметры $self и $oldFunction.
Это позволяет нам вызывать <=> <=> как обычно, но украшать дополнительный код вокруг него.
Изменить . Это была неправильная попытка найти решение, которое я оставлю для потомков. Посмотрите на одобренные / принятые ответы. : -)
Ах, я только что понял, что синтаксис нуждается в небольшой корректировке:
$agent->{get_basic_credentials} = _user_agent_get_basic_credentials_patch;
Без разделителей {} это выглядит как вызов метода (который не может быть допустимым l-значением).
Я все еще хотел бы знать, как метод экземпляра связывается / просматривается с помощью этого синтаксиса. ТИА!
