创建自定义 Moose 属性类型答案

【问题标题】：Create custom Moose attribute type创建自定义 Moose 属性类型
【发布时间】：2018-04-07 14:28:23
【问题描述】：

我正在尝试为我的Moose 类简化一个属性类的定义。例如，考虑可以标记为private 的一类属性，下面是一个此类属性的示例：

package MyPkg;
use Moose;

has some_attribute => (
    is       => 'ro',
    isa      => 'Str',
    lazy     => 1,
    init_arg => undef, # prevent from being set by constructor
    builder  => "_set_some_attribute"
);

sub _set_some_attribute {
    my ( $self ) = @_;

    return "value_of_some_attribute";
}

sub some_method_that_uses_some_attribute {
    my ( $self ) = @_;

    return "The value of some attribute: " . $self->some_attribute;
}

package main;

use feature qw(say);
use strict;
use warnings;

my $o = MyPkg->new();    
say $o->some_method_that_uses_some_attribute;

假设MyPkg 类的属性some_attribute 属于一组可以标记为private 的属性，其中所有类型为private 的属性例如为lazy，并且不能由构造函数。也就是说，我想简化：

package MyPkg;
use Moose;
has some_attribute => (
    is       => 'ro',
    isa      => 'Str',
    lazy     => 1,
    init_arg => undef, # prevent from being set by constructor
    builder  => "_set_some_attribute"
);

这样的事情

package MyPkg;
use Moose;
use MyMooseAttributeExtensions; # <-- some Moose extension that I have to write
has some_attribute => (is => 'ro', isa => 'Str', private => 1 );

Moose 可以做到这一点吗？

【问题讨论】：

我通常走低魔法路线并定义一个单独的函数，然后依次调用 Moose 提供的“has”函数。例如。 sub has_private ($name, %args) { has $name => (init_arg => undef, builder => "_set_$name", lazy => 1,%args) }.

标签： perl moose

【解决方案1】：

根据Moose::Manual::Attribute：

如果您有许多仅在名称上有所不同的属性，您可以一次性声明它们：
package Point;  
use Moose;

has [ 'x', 'y' ] => ( is => 'ro', isa => 'Int' );
另外，因为has只是一个函数调用，所以可以循环调用：
for my $name ( qw( x y ) ) {  
    my $builder = '_build_' . $name;  
    has $name => ( is => 'ro', isa => 'Int', builder => $builder );
}

还有一个lazy_build 属性，参见Moose::Meta::Attribute，但文档说：“请注意，强烈建议不要使用此功能”

最后一个选择是使用扩展包。我想这已经存在于 CPAN 的某个地方，但我找不到它，所以这是我尝试实现 Moose 扩展：

package MyMooseAttributeExtensions;
use strict;
use warnings;

our %orig_has;  # save original 'has' sub routines here

sub import {
    my $callpkg = caller 0;
    {
        no strict 'refs';
        no warnings 'redefine';
        $orig_has{$callpkg} = *{$callpkg."::has"}{CODE};
        *{$callpkg."::has"} = \&private_has;
    }
    return;
}

sub private_has {
    my ($attr, %args) = @_;

    my $callpkg = caller 0;
    if (exists $args{private} ) {
        delete $args{private};
        %args = (
            %args,
            lazy     => 1,
            init_arg => undef, # prevent from being set by constructor
            builder  => "_set_$attr"
        );
    }
    $orig_has{$callpkg}->($attr, %args);
}

1;

【讨论】：