什么时候应该使用子程序属性？

Question

我根本不了解 Perl 子例程属性。

我从未在实际代码中见过它们，perldoc perlsub 和 perldoc attributes 无法回答我的问题：

• 属性有什么用？
• 他们带来了 Perl 最佳实践中尚未出现的哪些内容？
• 是否有任何使用属性的 CPAN 模块（众所周知的或其他的）？

如果有人能整理出一个详细的属性示例，说明它们应该如何使用，那就太好了。

---

对于像我一样一无所知的人，属性是下面attributes SYNOPSIS示例中冒号后面的参数：

sub foo : method ;
my ($x,@y,%z) : Bent = 1;
my $s = sub : method { ... };

use attributes ();  # optional, to get subroutine declarations
my @attrlist = attributes::get(\&foo);

use attributes 'get'; # import the attributes::get subroutine
my @attrlist = get \&foo;

Answer 1

属性允许您注释变量以在幕后执行自动魔术。一个类似的概念是java annotations。这是一个可能有帮助的小例子。它使用Attribute::Handlers 创建loud 属性。

use Attribute::Handlers;

sub UNIVERSAL::loud : ATTR(CODE) {
    my ( $pkg, $sym, $code ) = @_;
    no warnings 'redefine';
    *{$sym} = sub {
        return uc $code->(@_);
    };
}

sub foo : loud {
    return "this is $_[0]";
}

say foo("a spoon");
say foo("a fork");

每当使用loud 属性声明子时，UNIVERSAL::loud 回调触发暴露子上的元信息。我重新定义了函数来实际调用一个匿名子，后者又调用原始子并将其传递给uc

这个输出：

THIS IS A SPOON
THIS IS A FORK

现在让我们看一个来自SYNOPSIS 的变量示例：

my ($x,@y,%z) : Bent = 1;

在不考虑我们拥有的属性的情况下将其分解为小的 perl 语句

my $x : Bent
$x = 1;

my @y : Bent
@y = 1;

my %Z : Bent
%z = 1;

我们现在可以看到，每个变量都以简洁的方式被赋予了 Bent 注释，同时还为所有变量分配了值 1。下面是一个可能更有趣的例子：

use Attribute::Handlers;
use Tie::Toggle;

sub UNIVERSAL::Toggle : ATTR(SCALAR) {
    my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
    my @data = ref $data eq 'ARRAY' ? @$data : $data;
    tie $$referent, 'Tie::Toggle', @data;
}

my $x : Toggle;

say "x is ", $x;
say "x is ", $x;
say "x is ", $x;

哪些输出：

x is 
x is 1
x is 

您可以使用它来进行日志记录、创建测试注释、将类型详细信息添加到变量、语法糖、做 moose-ish 角色组合和许多其他很酷的事情。

另请参阅此问题：How do Perl method attributes work?。

Answer 2

• 属性有什么用？

这是一种传递一些附加信息（属性）的方式 关于变量或子程序。

您可以将此信息（属性）作为字符串捕获（在编译时！） 并随心所欲地处理它。您可以生成其他代码， 修改 stash ...这取决于你。

• 他们带来了 Perl 最佳实践中尚未出现的哪些内容？

有时它让生活更轻松。请参见下面的示例。

有些人使用它。做一个：找到。 -name *.p[ml] | xargs grep '使用属性;' 在您的 perl 安装路径中查看使用属性的包。 Catalyst 广泛使用属性来处理基于给定路径的请求。

示例：

假设您喜欢按特定顺序执行子例程。你想告诉 必须执行的子程序（通过运行号 RUNNR ）。使用属性 实施可能是：

#!/usr/bin/env perl

use strict;
use warnings;

use Runner;     # immplements the attribute handling

# some subroutines to be scheduled :
# attibutes automatically filling @$Runner::schedule 
sub func_a : RUNNR(2) {return "You called func_a !"};
sub func_b : RUNNR(1) {return "You called func_b !"};
sub func_c : RUNNR(3) {return "You called func_c !"};

# run the subroutines according to the their RUNNR
sub run {
    # @$Runner::schedule holds the subroutine refs according
    # to their RUNNR
    foreach my $func (@$Runner::schedule) {
       if ( defined $func ) {
         print "Running : $func --> ", $func->(), "\n";
       }
    }
}

print "Starting ...\n\n";
run();
print "\nDone !\n";

属性处理在包 Runner 中使用 MODIFY_CODE_ATTRIBUTES 钩子。

package Runner;

use strict;
use warnings;

use attributes;

BEGIN {
    use Exporter ();                                                                 
    our (@ISA, @EXPORT);       

    @ISA         = qw(Exporter);                 
    @EXPORT      = qw(&MODIFY_CODE_ATTRIBUTES);    # needed for use attributes;    
}

# we have subroutines with attributes : <type> is CODE in MODIFY_<type>_ATTRIBUTES
# MODIFY_CODE_ATTRIBUTES is executed at COMPILE TIME ! try perl -c <prog_name> to prove it :-)

sub MODIFY_CODE_ATTRIBUTES {
    # for each subroutine of a package we get
    # the code ref to it and the attribute(s) as string
    my ($pckg, $code_ref, @attr) = @_;

    # whatever you like to do with the attributes of the sub ... do it
    foreach my $attr (@attr) {
        # here we parse the attribute string(s), extract the number and 
        # save the code ref of the subroutine
        # into $Runner::schedule array ref according to the given number
        # that is how we 'compile' the RUNNR of subroutines into 
        # a schedule
        if ( $attr =~ /^RUNNR\((\d+)\)$/ ) {    
            $Runner::schedule->[$1] = $code_ref;     
        }
    }
    return(); # ERROR if returning a non empty list
}

1;

输出将是：

Starting ...

Running : CODE(0x129c288) --> You called func_b !
Running : CODE(0x129c2b8) --> You called func_a !
Running : CODE(0x12ed460) --> You called func_c !

Done !

如果您真的想了解属性的作用以及发生的时间 必须'perldoc attributes'，逐步阅读并使用它。界面 很麻烦，但原则上你在编译时挂钩并处理 提供的信息。

Answer 3

您可以在创建时使用tie 变量的属性。请参阅愚蠢的模块Tie::Hash::Cannabinol，它可以让您这样做：

use Tie::Hash::Cannabinol;

my %hash;
tie %hash, 'Tie::Hash::Cannabinol';

## or ##

my %hash : Stoned;

编辑：经过深入研究，T::H::C (hehe) 也使用Attribute::Handlers（正如 JRideout 的回答已经暗示的那样），所以也许这是要看的地方。

Answer 4

这是我在 perl 5.26.1 上使用 Carp::Assert 运行的示例。 Perl 属性似乎为装饰器模式生成了很好的语法。虽然 b.c. 实施 MODIFY_CODE_ATTRIBUTES 有点痛苦。该死的 eval 和 Perl 的自动引用计数。

use strict;
use Carp::Assert;


# return true if `$func` is callable, false otherwise 
sub callable {
   my ($func) = @_;
   return defined(&$func);
}

# get the symbol table hash (stash) and the inverse of it the
# coderef table hash (crtash) where coderefs are keys and symbols are
# values. The return value is a pair of hashrefs ($stash, $crtash)
sub get_stash_and_crtash {
   my $stash = eval("\\%" . __PACKAGE__ . "::");
   my %coderef_to_sym;
   while (my ($k, $v) = each(%$stash)) {
      $coderef_to_sym{$v} = $k if (callable($v)); 
   }
   return ($stash, \%coderef_to_sym);
}

# return an eval string that inserts `$inner` as the first argument
# passed into the function call string `$outer`. For example, if
# `$inner` is "$foo" (the lvalue NAME, not the lvalue itself), and 
# `$outer` is "bar(1)", then the resulting eval string will be 
# "bar($foo, 1)"
sub insert_context {
   my ($inner, $outer) = @_;
   my $args_pat = qr/\((.*)\)$/;

   $outer .= '()' if ($outer !~ /\)$/);
   $outer =~ /$args_pat/;
   $1 ? 
      $outer =~ s/$args_pat/($inner, $1)/ : 
      $outer =~ s/$args_pat/($inner)/;
   return $outer;
}

# hook that gets called when appending attributes to functions.
# `$cls` is the package at the point of function declaration/definition,
# `$ref` is the coderef to the function being declared/defined,
# `@attrs` is a list to the attributes being added. Attributes are function
# call strings.
sub MODIFY_CODE_ATTRIBUTES {
   my ($cls, $ref, @attrs) = @_;

   assert($cls eq 'main');
   assert(ref($ref) eq 'CODE');
   for (@attrs) {
      assert(/^appender_d\(.*\)$/ || $_ eq 'upper_d');
   }

   my @non_decorators = grep { !/^\w+_d\b/ } @attrs;
   return @non_decorators if (@non_decorators);

   my ($stash, $crtash) = get_stash_and_crtash();

   my $sym = $crtash->{$ref};

   $stash->{$sym} = sub { 
      my $ref = $ref;
      my $curr = '$ref';

      for my $attr (@attrs) {
         $curr = insert_context($curr, $attr);
      }
      eval("${curr}->()");
   };

   return ();
}

sub appender_d {
   my ($func, $chars) = @_;
   return sub { $func->() . $chars };
}

sub upper_d {
   my ($func) = @_;
   return sub { uc($func->()) };
}

sub foo : upper_d appender_d('!') {
   return "foo";
}

sub main {
   print(foo());
}

main();