理清子程序属性

2016年6月29日 by David Farrell

子程序属性是可选的标签，可以包含在子程序声明中。这是一个奇特的功能，具有笨拙的界面和极少的文档。它们似乎使用不多，但很难想到它们的合法用途。在我看来，子程序属性最酷的地方是它们在编译时运行。这意味着你可以在主程序运行之前执行自定义代码，而且由于Perl提供了对符号表的访问，你基本上可以做到魔法般的事情。

lvalue技巧

Perl有几个内置的子程序属性。其中一个有用的属性是lvalue，它告诉Perl该子程序引用一个在单个调用之后持续存在的变量。一个常见的用例是使用它们作为方法获取器/设置器。

package Foo;

sub new { bless {}, shift }

sub bar :lvalue {
  my $self = shift;

  # must return the variable for lvalue-ness
  $self->{bar};
}

package main;

my $foo = Foo->new();

$foo->bar = "dogma"; # not $foo->bar("dogma");
print $foo->bar;

通过将属性:lvalue添加到bar子程序中，我可以用它像变量一样使用，获取、设置和替换等。

自定义属性

要在包中使用自定义属性，你必须提供一个名为MODIFY_CODE_ATTRIBUTES的子程序。如果Perl在编译期间找到任何自定义子程序属性，它将调用此子程序。对于每个具有自定义属性的子程序，它只会被调用一次。MODIFY_CODE_ATTRIBUTES接收包名称、子程序的引用和它声明的属性列表。

package Sub::Attributes;

sub MODIFY_CODE_ATTRIBUTES {
  my ($package, $coderef, @attributes) = @_;
  return ();
}

sub _internal_function :Private {
  ...
}
1;

我已经创建了一个包含所需子程序的新包 - 它只返回一个空列表。然后我声明了一个名为_internal_function的空子程序，它具有自定义属性Private。我想在Perl中实现真正的私有子程序，使得具有Private属性的任何子程序只能由其自己的包调用。但如果我拼错了Private怎么办？如果我们收到了我们不认识的属性，MODIFY_CODE_ATTRIBUTES可以将它们添加到列表中，Perl将在编译时抛出错误。

package Sub::Attributes;

sub MODIFY_CODE_ATTRIBUTES {
  my ($package, $coderef, @attributes, @disallowed) = @_;

  push @disallowed, grep { $_ ne 'Private' } @attributes;

  return @disallowed;
}

sub _internal_function :Private {
  ...
}
1;

我已经更新了代码以声明和返回@disallowed - 一个包含任何未识别子程序属性的数组。尽管它是在子程序的第一行声明的，但它始终为空，因为@attributes会吞噬传递给子程序的所有剩余参数。然后我通过grep遍历接收到的属性列表，如果任何一个不匹配“Private”，我就将它添加到不允许的数组中。

添加编译时行为

现在包中的任何子程序都可以使用属性Private，但它没有任何作用。我需要添加一些行为！

package Sub::Attributes;
use B 'svref_2object';

sub MODIFY_CODE_ATTRIBUTES {
  my ($package, $coderef, @attributes, @disallowed) = @_;

  my $subroutine_name = svref_2object($coderef)->GV->NAME;

  my %allowed = (
    Private => sub {
        my ($coderef, @args) = @_;
        my ($calling_package, $filename, $line, $sub) = caller(2);
        croak 'Only the object may call this sub' unless $sub && $sub =~ /^Sub\:\:Attributes\:\:/;
        $coderef->(@args);
      },
  );

  for my $attribute (@attributes) {
    # parse the attribute into name and value

    # attribute not known, compile error
    push(@disallowed, $attribute) && next unless exists $allowed{$attribute};

    # override subroutine with attribute coderef
    my $overrider = $allowed{$attribute};
    my $old_coderef = $coderef;
    $coderef = sub { $overrider->($old_coderef, @_) };
    *{"Sub:\:Attributes:\:$subroutine_name"} = $coderef;
  }
  return @disallowed;
}

sub _internal_function :Private {
  ...
}

sub call_internal_function {
  _internal_function();
}
1;

此代码从B模块导入svref_2object函数。这个有用的函数接受一个引用并返回一个包含Perl内部数据的对象。在这种情况下，传递一个引用返回一个B::CV对象。我使用它来获取子程序名称并在以后覆盖子程序。

我创建了一个名为%allowed的哈希，我可以在这里声明任何允许的自定义属性及其相关代码。对于Private，我创建了一个检查调用者是否在同一个包中的coderef，如果不是则发出错误，否则将调用它。

接下来，我遍历接收到的任何属性，并检查它们是否存在于%attributes中。如果不存在，我将它们推入@disallowed并跳到下一个属性。如果属性存在，我将coderef分配给$overrider并声明一个新的coderef，它将调用$overrider并将要调用的旧coderef作为参数传递。

最后，我使用新的coderef覆盖了Private子程序

*{"Sub:\:Attributes:\:$subroutine_name"} = $coderef;

这是如何使用类型全局符来覆盖子例程的方法（《精通Perl》一书中有一整章专门介绍这类特性，强烈推荐）。但是，在冒号中间的那个反斜杠 :\: 是什么意思呢？这个转义符对于代码在Perl 5.16至5.18版本上运行是必要的（感谢Andreas König调试这个问题）。

如果你想知道我为什么要创建$old_coderef，那是因为一个子例程可以具有多个嵌套的新行为属性。

现在任何对_internal_function的调用，除非它们来自Sub::Attributes内部，否则都会崩溃。

use Sub::Attributes;

Sub::Attributes::call_internal_function(); # ok
Sub::Attributes::_internal_function(); # croak!

使其可重用

如果创建自定义属性并在同一代码的其它地方验证这些属性看起来很笨，那么请加入我们。要充分利用这个系统，你必须使你的自定义属性可重用。幸运的是，只需要进行一些改动。

package Sub::Attributes;
use B 'svref_2object';

sub MODIFY_CODE_ATTRIBUTES {
  my ($package, $coderef, @attributes, @disallowed) = @_;

  my $subroutine_name = svref_2object($coderef)->GV->NAME;

  my %allowed = (
    Private =>
      sub {
        my $package = shift;
        return sub {
          my ($coderef, @args) = @_;
          my ($calling_package, $filename, $line, $sub) = caller(2);
          croak 'Only the object may call this sub' unless $sub && $sub =~ /^$package\:\:/;
          $coderef->(@args);
        }
      },
  );

  for my $attribute (@attributes) {
    # parse the attribute into name and value

    # attribute not known, compile error
    push(@disallowed, $attribute) && next unless exists $allowed{$attribute};

    # execute compile time code
    my $overrider = $allowed{$attribute}->($package);
    next unless $overrider;

    # override the subroutine if necessary
    my $old_coderef = $coderef;
    $coderef = sub { $overrider->($old_coderef, @_) };
    *{"$package:\:$subroutine_name"} = $coderef;
  }

  $Sub::Attributes::attributes{$package}{$subroutine_name} = \@attributes;
  return @disallowed;
};
1;

而不是硬编码包名，我使其变为动态的。这里的关键变化是将Private的coderef更改为返回另一个coderef的coderef。现在我可以在编译时执行一些任意代码，并可选地生成一个使用编译时信息的新的coderef。对于Private，我想传递私有子例程的包名，这样我就可以在之后检查调用者是否来自同一个包。

为什么可选地返回一个coderef？想象一下，如果我创建了一个名为After的属性，它的行为类似于Class::Method::Modifiers中的after函数。在这种情况下，具有私有属性的子例程将引用另一个不同的子例程。这可能看起来像这样：

sub foo { }

sub logger :After(foo) {
  print "foo() was called!\n";
}

在这里，应该在foo之后执行logger。所以logger本身永远不会改变，也不需要被覆盖。

我在Sub::Attributes的符号表中存储子例程的属性，而不是将它们添加到包的符号表中，因为可能会意外地覆盖其他东西，所以我将数据保持在Sub::Attributes命名空间内。

$Sub::Attributes::attributes{$package}{$subroutine_name} = \@attributes;

为什么没有FETCH_CODE_ATTRIBUTES？

属性文档中提到了另一个子例程，名为FETCH_CODE_ATTRIBUTES，它给定一个coderef，应该返回引用子例程的属性。当调用attributes::get时，它传递声明包的类，即Sub::Attributes。

# $class == "Sub::Attributes"
sub FETCH_CODE_ATTRIBUTES {
  my ($class, $coderef) = @_;
  my $cv = svref_2object($coderef);
  # $class should be subclass name, not Sub::Attributes
  return @{$Sub::Attributes::attributes{$class}{ $cv->GV->NAME }};
}

我看不出找到原始子例程包名的方法。FETCH_CODE_ATTRIBUTTES不是必需的，如果没有它，Perl在调用attributes::get时不会抛出异常。相反，我提供了sub_attributes方法，这个方法是有效的。

sub sub_attributes {
  my ($package) = @_;
  my $class_name = ref $package || $package;
  return $Sub::Attributes::attributes{ $class_name };
}

这返回存储在包中的属性。如果其他包想要检查包的子例程的属性，这可能很有用。它可以作为对象方法或类方法调用。

package Foo;
use base 'Sub::Attributes';

...

Foo->sub_attributes(); # works
$foo->sub_attributes(); # works also

消除警告

通常，使用strict和warnings约定来帮助我们检测代码中的问题是个好习惯。然而，到目前为止的代码将发出一些警告，如果我们像这样添加这些约定，它将抛出异常。此代码将添加这些约定，但将使Perl忽略违规行为。

use strict;
no strict 'refs';
use warnings;
no warnings qw(reserved redefine);

特别值得注意的是reserved警告。这可能是由于使用了自定义子例程属性而引起的，所以无论如何，你都会想将其关闭。重定义是在覆盖子例程时发出的警告；严格引用意味着在符号表查找中不插值变量名；我们需要这些功能，以便可以像这样动态地修补子例程。

*{"$class:\:$subroutine"} = $coderef

使其可扩展

如果你已经为可继承的自定义属性设置了代码，为什么不使其可扩展呢？这样，消费包可以添加它们自己的自定义属性。

package Sub::Attributes;
use strict;
no strict 'refs';
use warnings;
no warnings qw(reserved redefine);

use B 'svref_2object';

BEGIN {
  our %allowed = (
    Private =>
      sub {
        my $package = shift;
        return sub {
          my ($coderef, @args) = @_;
          my ($calling_package, $filename, $line, $sub) = caller(2);
          croak 'Only the object may call this sub' unless $sub && $sub =~ /^$package\:\:/;
          $coderef->(@args);
        }
      },
    # compile time override, run a coderef after running the subroutine
    After => sub {
      my ($package, $value, $coderef) = @_;

      # full name of the sub to override
      my $fq_sub = "$package:\:$value";

      my $target_coderef = \&{$fq_sub};
      *{$fq_sub} = sub {
        my @rv = $target_coderef->(@_);
        $coderef->(@_);
        return wantarray ? @rv : $rv[0];
      };

      # we didn't change the method with the attribute
      # so we return undef as we have no runtime changes
      return undef;
    },
  );
}

sub MODIFY_CODE_ATTRIBUTES {
  my ($package, $coderef, @attributes, @disallowed) = @_;

  my $subroutine_name = svref_2object($coderef)->GV->NAME;

  for my $attribute (@attributes) {
    # parse the attribute into name and value
    my ($name, $value) = $attribute =~ qr/^ (\w+) (?:\((\S+?)\))? $/x;

    # attribute not known, compile error
    push(@disallowed, $name) && next unless exists $Sub::Attributes::allowed{$name};

    # execute compile time code
    my $overrider = $Sub::Attributes::allowed{$name}->($package, $value, $coderef);
    next unless $overrider;

    # override the subroutine if necessary
    my $old_coderef = $coderef;
    $coderef = sub { $overrider->($old_coderef, @_) };
    *{"$package:\:$subroutine_name"} = $coderef;
  }

  $Sub::Attributes::attributes{$package}{$subroutine_name} = \@attributes;
  return @disallowed;
};

sub sub_attributes {
  my ($package) = @_;
  my $class_name = ref $package || $package;
  return $Sub::Attributes::attributes{ $class_name };
}
1;

我已经将%allowed散列移动到BEGIN块中 - 这必须在编译时声明，以便用于MODIFY_CODE_ATTRIBUTES。现在可以通过修改%Sub::Attributes::attributes来添加新的自定义属性。我还添加了一个新的自定义属性After，它会使子程序在另一个子程序之后被调用，如下所示

sub foo { }

sub bar :After(foo) {
  print "foo() was called!\n";
}

我添加了一个正则表达式，用于在传递属性时捕获属性名和值（因此对于After(foo)，“After”是名称，“foo”是值）。现在$value和$coderef被传递到自定义属性的子程序中，以允许在编译时覆盖其他子程序。

资源

  • attributes是关于属性的官方文档。
  • Sub::Attributes是我实现上述代码的模块，并添加了一些自定义属性。
  • perldata有关于类型全局变量和符号表的内容。
  • 《精通Perl》第二版第7章和第8章详细介绍了符号表和覆盖子程序。
  • perlsub有关于lvalue子程序的信息。
  • mascip在可能的用途和何时使用子程序属性上发表了两个有用的博客帖子。
  • Attribute::Handlers提供了一种通过属性调用子程序的方法。


本文最初发布在PerlTricks.com上。

标签

开发
属性
符号表
类型全局变量
lvalue

David Farrell

David是一位职业程序员，他经常推文并博客关于代码和编程艺术。

浏览他们的文章

反馈

这篇文章有什么问题吗？请通过在GitHub上打开问题或拉取请求来帮助我们。