perl - 使用单个模块并获得 Moose 以及多个 MooseX 扩展

Question

假设我有一个包含 Moose 的代码库-based 类，我希望它们都使用一组通用的 MooseX::*扩展模块。但我不希望每个基于 Moose 的类(class)都必须像这样开始:

package My::Class;

use Moose;
use MooseX::Aliases;
use MooseX::HasDefaults::RO;
use MooseX::StrictConstructor;
...

相反，我希望每节课都像这样开始:

package MyClass;

use My::Moose;

并让它与上述完全等价。

我的第一次尝试是基于 Mason::Moose 使用的方法。 ( source):

package My::Moose;

use Moose;
use Moose::Exporter;
use MooseX::Aliases();
use MooseX::StrictConstructor();
use MooseX::HasDefaults::RO();
use Moose::Util::MetaRole;

Moose::Exporter->setup_import_methods(also => [ 'Moose' ]);

sub init_meta {
    my $class = shift;
    my %params = @_;

    my $for_class = $params{for_class};

    Moose->init_meta(@_);
    MooseX::Aliases->init_meta(@_);
    MooseX::StrictConstructor->init_meta(@_);
    MooseX::HasDefaults::RO->init_meta(@_);

    return $for_class->meta();
}

但是这种方法不被 irc.perl.org 上 #moose IRC channel 中的人们推荐，而且它并不总是有效，这取决于 MooseX::* 的组合。模块。例如，尝试使用 My::Moose类以上制作 My::Class像这样:

package My::Class;

use My::Moose;

has foo => (isa => 'Str');

加载类时导致以下错误:

Attribute (foo) of class My::Class has no associated methods (did you mean to provide an "is" argument?)
 at /usr/local/lib/perl5/site_perl/5.12.1/darwin-2level/Moose/Meta/Attribute.pm line 1020.
    Moose::Meta::Attribute::_check_associated_methods('Moose::Meta::Class::__ANON__::SERIAL::2=HASH(0x100bd6f00)') called at /usr/local/lib/perl5/site_perl/5.12.1/darwin-2level/Moose/Meta/Class.pm line 573
    Moose::Meta::Class::add_attribute('Moose::Meta::Class::__ANON__::SERIAL::1=HASH(0x100be2f10)', 'foo', 'isa', 'Str', 'definition_context', 'HASH(0x100bd2eb8)') called at /usr/local/lib/perl5/site_perl/5.12.1/darwin-2level/Moose.pm line 79
    Moose::has('Moose::Meta::Class::__ANON__::SERIAL::1=HASH(0x100be2f10)', 'foo', 'isa', 'Str') called at /usr/local/lib/perl5/site_perl/5.12.1/darwin-2level/Moose/Exporter.pm line 370
    Moose::has('foo', 'isa', 'Str') called at lib/My/Class.pm line 5
    require My/Class.pm called at t.pl line 1
    main::BEGIN() called at lib/My/Class.pm line 0
    eval {...} called at lib/My/Class.pm line 0

MooseX::HasDefaults::RO应该防止这个错误，但显然没有被要求完成它的工作。注释掉 MooseX::Aliases->init_meta(@_);行“修复”了问题，但是a)这是我想要使用的模块之一，并且b)只是进一步强调了这个解决方案的错误。 (特别是， init_meta() 应该只被调用一次。)

所以，我对建议持开放态度，完全忽略了我未能实现这一点的尝试。只要给出在这个问题开始时描述的结果，任何策略都是受欢迎的。

根据@Ether 的回答，我现在有以下内容(这也不起作用):

package My::Moose;

use Moose();
use Moose::Exporter;
use MooseX::Aliases();
use MooseX::StrictConstructor();
use MooseX::HasDefaults::RO();

my %class_metaroles = (
    class => [
        'MooseX::StrictConstructor::Trait::Class',
    ],

    attribute => [
        'MooseX::Aliases::Meta::Trait::Attribute', 
        'MooseX::HasDefaults::Meta::IsRO',
     ],
);

my %role_metaroles = (
    role =>
        [ 'MooseX::Aliases::Meta::Trait::Role' ],
    application_to_class =>
        [ 'MooseX::Aliases::Meta::Trait::Role::ApplicationToClass' ],
    application_to_role =>
        [ 'MooseX::Aliases::Meta::Trait::Role::ApplicationToRole' ],
);

if (Moose->VERSION >= 1.9900) {
    push(@{$class_metaroles{class}},
        'MooseX::Aliases::Meta::Trait::Class');

    push(@{$role_metaroles{applied_attribute}}, 
        'MooseX::Aliases::Meta::Trait::Attribute',
        'MooseX::HasDefaults::Meta::IsRO');
}
else {
    push(@{$class_metaroles{constructor}},
        'MooseX::StrictConstructor::Trait::Method::Constructor',
        'MooseX::Aliases::Meta::Trait::Constructor');
}

*alias = \&MooseX::Aliases::alias;

Moose::Exporter->setup_import_methods(
    also => [ 'Moose' ],
    with_meta => ['alias'],
    class_metaroles => \%class_metaroles,
    role_metaroles => \%role_metaroles,
);

使用这样的示例类:

package My::Class;

use My::Moose;

has foo => (isa => 'Str');

我收到此错误:

Attribute (foo) of class My::Class has no associated methods (did you mean to provide an "is" argument?) at ...

使用这样的示例类:

package My::Class;

use My::Moose;

has foo => (isa => 'Str', alias => 'bar');

我收到此错误:

Found unknown argument(s) passed to 'foo' attribute constructor in 'Moose::Meta::Attribute': alias at ...

Answer 1

我可能会因此而大发雷霆，但如有疑问，请撒谎:)

package MyMoose;                                                                                                                                                               

use strict;
use warnings;
use Carp 'confess';

sub import {
    my $caller = caller;
    eval <<"END" or confess("Loading MyMoose failed: $@");
    package $caller;
    use Moose;
    use MooseX::StrictConstructor;
    use MooseX::FollowPBP;
    1;
END
}

1;

通过这样做，您正在将 use 语句评估到调用包中。换句话说，您在向他们撒谎，告诉他们他们使用的是什么类。

在这里你声明你的人:

package MyPerson;                                                                                                                                                              
use MyMoose;

has first_name => ( is => 'ro', required => 1 );
has last_name  => ( is => 'rw', required => 1 );

1;

和测试!

use lib 'lib';                                                                                                                                                                 
use MyPerson;
use Test::Most;

throws_ok { MyPerson->new( first_name => 'Bob' ) }
qr/\QAttribute (last_name) is required/,
  'Required attributes should be required';

throws_ok {
    MyPerson->new(
        first_name => 'Billy',
        last_name  => 'Bob',
        what       => '?',
    );
}
qr/\Qunknown attribute(s) init_arg passed to the constructor: what/,
  '... and unknown keys should throw an error';

my $person;
lives_ok { $person = MyPerson->new( first_name => 'Billy', last_name => 'Bob' ) }
'Calling the constructor with valid arguments should succeed';

isa_ok $person, 'MyPerson';
can_ok $person, qw/get_first_name get_last_name set_last_name/;
ok !$person->can("set_first_name"),
  '... but we should not be able to set the first name';
done_testing;

以及测试结果:

ok 1 - Required attributes should be required
ok 2 - ... and unknown keys should throw an error
ok 3 - Calling the constructor with valid arguments should succeed
ok 4 - The object isa MyPerson
ok 5 - MyPerson->can(...)
ok 6 - ... but we should not be able to set the first name
1..6

让我们保守这个小 secret ，好吗？ :)