В Perl я могу вызвать метод перед выполнением каждой функции в пакете?

Ответ 1

Вы можете сделать это в Moose с помощью модификаторов метода:

package Example;

use Moose;

sub foo {
    print "foo\n";
}

before 'foo' => sub { print "about to call foo\n"; };

Обертка метода также возможна с атрибутами , но этот маршрут не используется в Perl и все еще развивается, поэтому я не рекомендовал бы это. Для обычных случаев использования я бы просто поместил общий код в другой метод и назвал его в верхней части каждой из ваших функций:

Package MyApp::Foo;
sub do_common_stuff { ... }

sub method_one
{
    my ($this, @args) = @_;
    $this->do_common_stuff();
    # ...
}

sub method_two
{
    my ($this, @args) = @_;
    $this->do_common_stuff();
    # ...
}

Ответ 2

И, если кто-то задается вопросом, как явно реализовать эффект модулей Hook * или Moose "до" (например, какой фактический механизм Perl можно использовать для этого), вот пример:

use strict; 
package foo;
sub call_before { print "BEFORE\n"; } # This will be called before any sub
my $call_after = sub { print "AFTER - $_[0]\n"; };   
sub fooBar { print "fooBar body\n\n"; }
sub fooBaz { print "fooBaz body\n\n"; }

no strict; # Wonder if we can get away without 'no strict'? Hate doing that!
foreach my $glob (keys %foo::) { # Iterate over symbol table of the package
    next if not defined *{$foo::{$glob}}{CODE}; # Only subroutines needed
    next if $glob eq "call_before" || $glob eq "import" || $glob =~ /^___OLD_/;
    *{"foo::___OLD_$glob"} = \&{"foo::$glob"}; # Save original sub reference
    *{"foo::$glob"} = sub {
        call_before(@_); &{"foo::___OLD_$glob"}(@_); &$call_after(@_);
    };
}
use strict;
1;

package main;
foo::fooBar();
foo::fooBaz();

Объяснение того, что мы исключаем через "следующую" строку:

• "call_before" - это, конечно же, имя, которое я дал нашему "до" примеру, - это нужно только в том случае, если оно фактически определено как реальный sub в том же пакете, а не анонимно или код из-за пределов пакета.

• import() имеет особое значение и цель и обычно должен быть исключен из сценария "запускать это перед каждым вспомогательным". YMMV.

• ___ OLD_ - префикс, который мы передадим "переименованным" старым подписчикам - вам не нужно включать его сюда, если вы не беспокоитесь о том, что этот цикл выполняется дважды. Лучше, чем сожалеть.

ОБНОВЛЕНИЕ: ниже раздел об обобщении больше не имеет значения - в конце ответа. Я вставил общий пакет "before_after", выполнив именно это!!! p >

Цикл выше, очевидно, может быть легко обобщен как отдельно упакованная подпрограмма, которая принимает в качестве аргументов:

• произвольный пакет

• код ref для произвольной подпрограммы "до" (или, как вы можете видеть, после)

• и список подзаголовков для исключения (или подрефиля, который проверяет, следует ли исключать имя), кроме стандартных, таких как "импорт" ).

• ... и/или список подзаголовков для включения (или подрефиля, который проверяет, следует ли включать имя), помимо стандартных, например "импорт" ). Mine просто берет ВСЕ субтитры в пакете.

ПРИМЕЧАНИЕ. Я не знаю, действительно ли Moose "before" делает это именно так. Я знаю, что я, очевидно, рекомендую перейти со стандартным модулем CPAN, чем мой собственный только что написанный фрагмент, , если:

• Лось или любой из модулей Hook не могут быть установлены и/или слишком тяжелы для вас

• Вы достаточно хороши с Perl, чтобы прочитать код выше и проанализировать его на наличие недостатков.

• Вам очень нравится этот код, и риск использования его по сравнению с CPAN файлом низкий IYHO:)

Я поставил его больше для информационных целей, "как это делается для основной работы", а не для практических "использования этого в вашей кодовой базе", хотя вы можете использовать его, если хотите:

UPDATE

Здесь приведена более общая версия, упомянутая ранее:

#######################################################################
package before_after;
# Generic inserter of before/after wrapper code to all subs in any package.
# See below package "foo" for example of how to use.

my $default_prefix = "___OLD_";
my %used_prefixes = (); # To prevent multiple calls from stepping on each other
sub insert_before_after {
    my ($package, $prefix, $before_code, $after_code
      , $before_filter, $after_filter) = @_;
    # filters are subs taking 2 args - subroutine name and package name.
    # How the heck do I get the caller package without import() for a defalut?
    $prefix ||= $default_prefix; # Also, default $before/after to sub {}     ?
    while ($used_prefixes{$prefix}) { $prefix = "_$prefix"; }; # Uniqueness
    no strict;
    foreach my $glob (keys %{$package . "::"}) {
        next if not defined *{$package. "::$glob"}{CODE};
        next if $glob =~ /import|__ANON__|BEGIN/; # Any otrher standard subs?
        next if $glob =~ /^$prefix/; # Already done.
        $before =  (ref($before_filter) ne "CODE"
                    || &$before_filter($glob, $package));
        $after  =  (ref($after_filter) ne "CODE"
                    || &$after_filter($glob, $package));
        *{$package."::$prefix$glob"} = \&{$package . "::$glob"};
        if ($before && $after) { # We do these ifs for performance gain only.
                                 # Else, could wrap before/after calls in "if"
            *{$package."::$glob"} = sub {
                my $retval;
                &$before_code(@_); # We don't save returns from before/after.
                if (wantarray) {
                    $retval = [ &{$package . "::$prefix$glob"}(@_) ];
                } else {
                    $retval = &{$package . "::$prefix$glob"}(@_);
                }
                &$after_code(@_);
                return (wantarray && ref $retval eq 'ARRAY')
                    ? @$retval : $retval;
            };
        } elsif ($before && !$after) {
            *{$package . "::$glob"} = sub {
                 &$before_code(@_);
                 &{$package . "::$prefix$glob"}(@_);
             };
        } elsif (!$before && $after) {
            *{$package . "::$glob"} = sub {
                my $retval;
                if (wantarray) {
                    $retval = [ &{$package . "::$prefix$glob"}(@_) ];
                } else {
                    $retval = &{$package . "::$prefix$glob"}(@_);
                }
                &$after_code(@_);
                return (wantarray && ref $retval eq 'ARRAY')
                    ? @$retval : $retval;
            };
        }
    }
    use strict;
}
# May be add import() that calls insert_before_after()?
# The caller will just need "use before_after qq(args)".
1;

#######################################################################

package foo;
use strict;
sub call_before { print "BEFORE - $_[0]\n"; };
my $call_after = sub { print "AFTER - $_[0]\n"; };
sub fooBar { print "fooBar body - $_[0]\n\n"; };
sub fooBaz { print "fooBaz body - $_[0]\n\n"; };
sub fooBazNoB { print "fooBazNoB body - $_[0]\n\n"; };
sub fooBazNoA { print "fooBazNoA body - $_[0]\n\n"; };
sub fooBazNoBNoA { print "fooBazNoBNoA body - $_[0]\n\n"; };
before_after::insert_before_after(__PACKAGE__, undef
            , \&call_before, $call_after
            , sub { return 0 if $_[0] eq "call_before"; $_[0] !~ /NoB(NoA)?$/ }
            , sub { return 0 if $_[0] eq "call_before"; $_[0] !~ /NoA$/ } );
1;
#######################################################################
package main;
use strict;
foo::fooBar("ARG1");
foo::fooBaz("ARG2");
foo::fooBazNoB("ARG3");
foo::fooBazNoA("ARG4");
foo::fooBazNoBNoA("ARG5");
#######################################################################

Ответ 3

См. пакет Aspect.pm в CPAN для аспектно-ориентированных вычислений.

до {   Class- > метод; } qr/^ Пакет::\w + $/;

Ответ 4

Если вы выполните поиск CPAN для 'hook', а затем откройте его, вы найдете несколько параметров, таких как

Hook::WrapSub
Hook::PrePostCall
Hook::LexWrap
Sub::Prepend

Здесь приведен пример использования Hook::LexWrap. У меня нет опыта работы с этим модулем, кроме отладки. Он отлично справился с этой задачей.

# In Frob.pm
package Frob;
sub new { bless {}, shift }
sub foo { print "foo()\n" }
sub bar { print "bar()\n" }
sub pre { print "pre()\n" }

use Hook::LexWrap qw(wrap);

my @wrappable_methods = qw(foo bar);

sub wrap_em {
    wrap($_, pre => \&pre) for @wrappable_methods;
}

# In script.pl
use Frob;
my $frob = Frob->new;

print "\nOrig:\n";
$frob->foo;
$frob->bar;

print "\nWrapped:\n";
Frob->wrap_em();
$frob->foo;
$frob->bar;