Moose::Cookbook::Recipe4 - subtype -

• Moose::Cookbook::Recipe4 - Subtypes, and modeling a simple Company class hierarchy - metacpan.org

ソースコード

少しテストを加えてます。

package Address;

use Moose;
use Moose::Util::TypeConstraints;

use Locale::US;
use Regexp::Common qw(zip);

my $STATES = Locale::US->new;

subtype 'USState' => as 'Str' => where {
    (exists $STATES->{code2state}{uc($_)} || 
     exists $STATES->{state2code}{uc($_)})
};

subtype 'USZipCode' => as 'Value' => where {
    /^$RE{zip}{US}{-extends => 'allow'}$/;
};

has 'street' => ( is => 'rw', isa => 'Str' );
has 'city' => ( is => 'rw', isa => 'Str' );
has 'state' => ( is => 'rw', isa => 'USState' );
has 'zip_code' => ( is => 'rw', isa => 'USZipCode' );

package Company;

use Moose;
use Moose::Util::TypeConstraints;

has 'name' => ( is => 'rw', isa => 'Str', required => 1 );
has 'address' => ( is => 'rw', isa => 'Address' );
has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' );

sub BUILD {
    my ($self, $params) = @_;
    if ($params->{employees}) {
        for my $employee (@{$params->{employees}}) {
            $employee->company($self);
        }
    }
}

after 'employees' => sub {
    my ($self, $employees) = @_;
    if (defined $employees) {
        for my $employee (@${employees}) {
            $employee->company($self);
        }
    }
};

package Person;

use Moose;

has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 );
has 'last_name' => ( is => 'rw', isa => 'Str', required => 1 );
has 'middle_initial' => ( is => 'rw', isa => 'Str', predicate => 'has_middle_initial' );
has 'address' => ( is => 'rw', isa => 'Address' );

sub full_name {
    my $self = shift;
    return 
        $self->first_name . 
        (($self->has_middle_initial) ?
            ' ' . $self->middle_initial . '. ' :
            ' ') . 
        $self->last_name;
}

package Employee;

use Moose;

extends 'Person';

has 'title' => ( is => 'rw', isa => 'Str', required => 1 );
has 'company' => ( is => 'rw', isa => 'Company', weak_ref => 1 );

override 'full_name' => sub {
    my $self = shift;
    super() . ', ' . $self->title;
};

package main;

use Test::More qw(no_plan);

{
    # Address
    my $addr = Address->new();

    eval {
        $addr->state('KANAGAWA');
    };
    if (my $err = $@) {
        ok($err, 'USState constraint');
        undef $@;
    }

    $addr->state('CA');
    is($addr->state, 'CA', 'Valid USState');

    eval {
        $addr->zip_code('232-0061');
    };
    if (my $err = $@) {
        ok($err, 'USZipCode constraint');
        undef $@;
    }

    $addr->zip_code(95472);
    is($addr->zip_code, 95472, 'valid zip_code');
}

{
    # Person
    eval {
        my $person = Person->new();
    };
    if (my $err = $@) {
        ok($@, 'required attributes constraint');
    }

    my $person = Person->new(first_name => 'ZIGOROu', last_name => 'Masuda');
    is($person->first_name, 'ZIGOROu', 'first_name');
    is($person->last_name, 'Masuda', 'last_name');
    is($person->full_name, 'ZIGOROu Masuda', 'full_name');
}

{
    # Employee
    eval {
        my $employee = Employee->new();
    };
    if (my $err = $@) {
        ok($err, 'required constraint');
        undef $@;
    }

    eval {
        my $employee = Employee->new(title => 'Chief Nijikai Officer');
    };
    if (my $err = $@) {
        ok($err, 'required constraint defined parent class');
        undef $@;
    }

    my $employee = Employee->new( first_name => 'ZIGOROu', last_name => 'Masuda', title => 'Chief Nijikai Officer' );
    is($employee->title, 'Chief Nijikai Officer', 'title');
    is($employee->full_name, 'ZIGOROu Masuda, Chief Nijikai Officer', 'full_name');
    
}

{
    my $company = Company->new( name => 'sakusaku' );

    eval {
        $company->employees([0..10]);
    };
    if (my $err = $@) {
        ok($err, 'employee arrayref constraint');
        undef($@);
    }

    $company->employees([
        Employee->new( first_name => 'ZIGOROu', last_name => 'Masuda', title => 'Chief Nijikai Officer' ),
        Employee->new( first_name => 'Hitoshi', last_name => 'Amano', title => 'IT Warrior' ),
        Employee->new( first_name => 'Hirokazu', last_name => 'Nishio', title => 'moelement' )
    ]);

    is(scalar(@{$company->employees}), 3, 'employees size');
    for my $employee (@{$company->employees}) {
        is($employee->company, $company, 'after employee modifier');
    }
}

解説

subtype

ベースとなる型を指定して、新たなる型を定義出来るのが subtype です。

my $STATES = Locale::US->new;

subtype 'USState' => as 'Str' => where {
    (exists $STATES->{code2state}{uc($_)} || 
     exists $STATES->{state2code}{uc($_)})
};

subtype 'USZipCode' => as 'Value' => where {
    /^$RE{zip}{US}{-extends => 'allow'}$/;
};

だいぶ直感的なので特に解説は要らないくらいですね。USState は文字列の subtype ですが、US の州コードか州の名前でなければなりません。
さらに USZipCode は Value の subtype で、US の zip コードじゃないとダメって事ですね。

こうして定義した subtype を isa 制約に指定出来ます。

レシピの解説でもありますが、

subtype DateTime => as Object => where { $_->isa("DateTime") };
||<　

としたい場合、subtypeの第一引数には Bare Word を使っているので、use DateTime が必要ですが、

>|perl|
subtype 'DateTime' => as Object => where { $_->isa("DateTime") };

ならば問題ありません。

ArrayRef 型制約

has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' );

employees 属性は Employee オブジェクトの配列リファレンスじゃないとダメって事ですな。