2

假设我已经拥有了Childpackage 和Parentpackage 以及几个子例程。这两个包通过聚合组合在一起，就像在perltoot：

use warnings;
use strict;

package Child;

sub new {
    my ($class, %arg) = @_;
    return bless { %arg }, $class;
}

sub method_x {
    warn 'call method x';
}

sub method_y {
    warn 'call method y';
}

sub method_z {
    warn 'call method z';
}

1;


package Parent;

sub new {
    my ($class, %arg) = @_;
    return bless {
        child => undef,
        %arg,
    }, $class;
}

sub child { shift->{child} }
sub x { shift->child->method_x(@_) }
sub y { shift->child->method_y(@_) }
sub z { shift->child->method_z(@_) }

sub _callback {
    warn "I want to kick this callback after every child methods.";
}

1;


package main;

my $p = Parent->new(
    child => Child->new,
);

$p->x;
$p->y;
$p->z;

1;

过了一会儿，我想为 each 的方法踢球_callback，Child我惊呆了，我试图将这个回调添加到每个包装器方法（x// y）z中。

我可以更优雅地完成这项工作吗？我是否必须在一开始就为包装提供更大的灵活性？如何？

任何建议表示赞赏。

4

2 回答 2

6

一种可能性是使用由Moose或Moo等对象系统提供的方法修饰符：

use strict; use warnings;

package Child {
  use Moose;

  sub method_x { warn "call method_x" }
  sub method_y { warn "call method_y" }
  sub method_z { warn "call method_z" }
}

package Parent {
  use Moose;

  has child => (is => 'rw');

  sub x { shift->child->method_x(@_) }
  sub y { shift->child->method_y(@_) }
  sub z { shift->child->method_z(@_) }

  # A method modifier in action
  after [qw/ x y z /] => sub {
    warn "called after every Parent (!) invocation";
  };
}

my $p = Parent->new(child => Child->new);

$p->x; $p->y; $p->z;

输出：

call method_x at - line 7.
called after every Parent (!) invocation at - line 23.
call method_y at - line 8.
called after every Parent (!) invocation at - line 23.
call method_z at - line 9.
called after every Parent (!) invocation at - line 23.

如果您真的希望包装的所有方法Child，请使用子类：

package WrappedChild {
  use Moose;
  extends 'Child';

  # the /(?=)/ regex matches always
  after qr/(?=)/ => sub {
    warn "called after each method in Child";
  };
}


my $p = Parent->new(child => WrappedChild->new);

$p->x; $p->y; $p->z;

这产生

called after each method in Child at - line 32.
called after each method in Child at - line 32.
called after each method in Child at - line 32.
called after each method in Child at - line 32.
called after each method in Child at - line 32.
called after each method in Child at - line 32.
call method_x at - line 7.
called after each method in Child at - line 32.
called after every Parent (!) invocation at - line 22.
call method_y at - line 8.
called after each method in Child at - line 32.
called after every Parent (!) invocation at - line 22.
call method_z at - line 9.
called after each method in Child at - line 32.
called after every Parent (!) invocation at - line 22.
called after each method in Child at - line 32.
called after each method in Child at - line 32.
called after each method in Child at - line 32.

这可能有点过分。坚持使用明确的名称可能更可取。

有关Moose::Manual::MethodModifiers更多信息，请参阅。

如果您不想使用任何模块，您可以通过丛林符号表：

for my $name (qw/method_x method_y method_z/) {
  no strict 'refs';
  no warnings 'redefine';
  my $orig = \&{"Child::$name"};
  *{"Child::$name} = sub {
    my @return_values = wantarray ? $orig->() : scalar $orig->();
    warn "called after each method";
    return wantarray ? @return_values : $return_values[0];
  };
}

输出：

call method_x at - line 7.
called after each method at - line 31.
call method_y at - line 8.
called after each method at - line 31.
call method_z at - line 9.
called after each method at - line 31.
于 2013-11-05T17:46:22.360 回答
4 
package Wrapper;

use strict;
use warnings;

use Carp qw( );

sub wrap {
   my ($cb, $o) = @_;
   return bless({
      o  => $o,
      cb => $cb,
   });
}

sub AUTOLOAD {
   my $self = shift;
   my $o  = $self->{o};
   my $cb = $self->{cb};

   my ($method) = our $AUTOLOAD =~ /^.*::(.*)\z/;
   my $sub = ;
   if (!$o->can($method) && !$o->can("AUTOLOAD")) {
      my $package = ref($o);
      Carp::croak("Can't locate object method \"$method\" via package \"$pkg\"");
   }

   if (wantarray) {
      my @rv = $object->$method(@_);
      $cb->($method, @_);
      return @rv;
   }
   elsif (defined(wantarray)) {
      my $rv = $object->$method(@_);
      $cb->($method, @_);
      return $rv;
   }
   else {
      $object->$method(@_);
      $cb->($method, @_);
      return;
   }
}


my $w = wrap(sub { warn "Returning from $_[0]\n" }, Child->new);
$w->x; $w->y; $w->z;
于 2013-11-05T18:02:14.527 回答