Hatena::ブログ(Diary)

Yet Another Hackadelic

2008-06-23 どう見ても二日酔いです

around, BUILD, MooseX::Object::Pluggable のメモ

私的なメモです。

around

before, after, augment の汎用版かつ、引数や戻り値を変更出来るのがaround

before っぽく使う場合は、

around 'run' => sub {
  my $orig = shift;
  my ($self, @args) = @_;
  ### process before run
  ### ここになんか書く
  $orig->($self, @args);
};

みたいに書く。特徴的なのは第一引数に元のCodeRefが入ってる所。なんでオリジナルを呼び出す際に、$orig->($self, @args) のように書く。

また$origの呼び出しを明示的に書けるので、当然渡してる引数を操作すれば元のメソッド呼び出しに反映されるし、戻り値に関しても同じように操作出来る。つまり、

around 'calc' => sub {
  my $orig = shift;
  my ($self, @args) = @_;
  my $result = $orig->($self, @args);
  return $result * 1.05;
};

と言う Role を作って with すると、calcの計算結果は本来の計算結果に1.05倍した物が取れる。

BUILD

ほぼコンストラクタとして考えて良い。但し単なるプロパティの初期化なら default ないしは builder を使う。

package BuildSample;
use Moose;
use Perl6::Say;
use Data::Dump qw(dump);

has 'foo' => ( is => 'rw', isa => 'Int', required => 1, builder => 'init_foo' );
has 'bar' => ( is => 'rw', isa => 'Str', default => sub { say("init bar"); return ""; } );

sub init_foo {
    my $self = shift;
    say("init foo");
    $self->foo(12);
}

sub BUILD {
    my ($self, $args) = @_;
    say "[BUILD args] " . dump $args;
}

__PACKAGE__->meta->make_immutable;

package main;
use Perl6::Say;

my $sample1 = BuildSample->new( foo => 1, bar => "hoge" );

say("-" x 20);

my $sample2 = BuildSample->new();

BUILD の第二引数に new で渡したパラメータがハッシュリファレンスとして格納されてるみたい。

MooseX::Object::Pluggable

このモジュールの使い道は g:dann:id:dann さんお勧めの Devel::REPL を見るのが手っ取り早い。

そもそも MooseX::Object::Pluggable のやってる事ってのは、こんなソースですぐに分かると思う。

#!/usr/bin/perl

package Foo;

use Moose;
use Perl6::Say;
with 'MooseX::Object::Pluggable';

sub run {
    say("run");
}

package Foo::Plugin::BeforeAction;

use Moose::Role;
use Perl6::Say;

around 'run' => sub {
    my $orig = shift;
    my ($self) = @_;
    say("BeforeAction");
    $orig->($self);
};

package main;

use Perl6::Say;
use Data::Dump qw(dump);

my $foo = Foo->new;
$foo->load_plugin("+Foo::Plugin::BeforeAction");
$foo->run;

プラグインは Role として定義しておき、load_plugin ってのはこの例では、Foo に with 'Foo::Plugin::BeforeAction' するのと同じ事。$foo->meta->roles で確認出来る。

2008-06-11 nicovideo++

Moose::Cookbook::Recipe10 - role, requires, with -

Perl OOP に interface, abstract の概念を持ち込む role, requires, with の話です。

ソースコード

ちょっと変えてあります。

package Equivalent;

use Moose::Role;

requires 'equal_to';

sub not_equal_to {
    my ($self, $other) = @_;
    not $self->equial_to($other);
}

package Comparable;

use Moose::Role;

with 'Equivalent';
requires 'compare';

sub equal_to {
    my ($self, $other) = @_;
    $self->compare($other) == 0;
}

sub greater_than {
    my ($self, $other) = @_;
    $self->compare($other) == 1;
}

sub less_than {
    my ($self, $other) = @_;
    $self->compare($other) == -1;
}

package Printable;

use Moose::Role;

requires 'to_string';

package JP::Currency;

use Moose;

with 'Comparable', 'Printable';

has 'amount' => ( is => 'rw', isa => 'Num', default => 0 );

sub compare {
    my ($self, $other) = @_;
    $self->amount <=> $other->amount;
}

sub to_string {
    my $self = shift;
    sprintf('\%0.2f YEN', $self->amount);
}

package main;

use Data::Dump qw(dump);
use Perl6::Say;
use Test::More qw(no_plan);

eval {
    package InvalidEquivalentImpl;

    use Moose;

    with 'Equivalent';
};
if (my $err = $@) {
    ok($err, 'Not implements');
    undef $@;
}

my @currencies = map { JP::Currency->new( amount => int(rand(10000)) + 1 ); } (0 .. 10);

say dump (map { $_->amount } @currencies);

my @sorted = sort { $a->compare($b) } @currencies;

say dump (map { $_->amount } @sorted);

for (my $i = 0; $i < @sorted; $i++) {
    if ($i > 0) {
        ok($sorted[$i]->greater_than($sorted[$i - 1]), 'greater than');
    }

    ok($sorted[$i]->equal_to($sorted[$i]), 'equal_to');
    say $sorted[$i]->to_string;

    if ($i < @sorted - 1) {
        ok($sorted[$i]->less_than($sorted[$i + 1]), 'less than');
    }
}

解説

use Moose::Role した package と requires

これは interface ないしは abstract class (実装も書ける点で) な役割を持ちます。

package Equivalent;

### この package が role であると言う宣言
use Moose::Role;

### equil_to メソッドを実装する事を期待する
requires 'equal_to';

### 実装されるであろう equal_to に依存するコードを Role に直接 impl 
sub not_equal_to {
    my ($self, $other) = @_;
    not $self->equial_to($other);
}

はい、適宜コメントふりました。

public abstract class Equivalent {
  public abstract Boolean equal_to(Equivalent other) {}
  public Boolean not_equal_to(Equivalent other) {
    return this.equal_to(other);
  }
}

ちと java のソースは動作するか知らないけどw*1 ニュアンスはこういう感じ。

もう説明する必要は無いと思います。

with
package Comparable;

use Moose::Role;

with 'Equivalent';
requires 'compare';

sub equal_to {
    my ($self, $other) = @_;
    $self->compare($other) == 0;
}

再び Comparable role を作るんですが、その際に Equivalent を実装する事も可能です。role を実装するぜって宣言が with になると。

ちなみに不正な実装した場合
eval {
    package InvalidEquivalentImpl;

    use Moose;

    with 'Equivalent';
};
if (my $err = $@) {
    ok($err, 'Not implements');
    undef $@;
}

Equivalent は requires 'equal_to' を実装する事を期待してるので、これはダメです。

こういうコードを書いた場合は実行時に即座にエラーとなります。

これが例えばインスタンス化した時にエラーになるんではやりづらいので、こうした定義時にエラー検出してくれるのは非常に嬉しいですね。

まとめ

  • use Moose::Role すると interface 的な物を作れる
    • role 中でも具体的な(concreteな)メソッドを定義出来る
    • requires で abstract method を宣言出来る (その role を実装するクラスに、requires で指定したメソッドの実装を強制出来る)
  • with で特定の role を実装すると言う宣言を行う事が出来る
    • role の要求に沿ってない場合は即座にエラーとなる

role かわゆす。

Moose::Cookbook::Recipe9 - builder -

拡張可能な default と同等の機能である builder です。

ソースコード

package BinaryTree;

use Moose;

has 'node' => ( is => 'rw', isa => 'Any' );

has 'parent' => (
    is        => 'rw',
    isa       => 'BinaryTree',
    predicate => 'has_parent',
    weak_ref  => 1,
);

has 'left' => (
    is        => 'rw',
    isa       => 'BinaryTree',
    predicate => 'has_left',
    lazy      => 1,
    builder   => '_build_child_tree',
);

has 'right' => (
    is        => 'rw',
    isa       => 'BinaryTree',
    predicate => 'has_right',
    lazy      => 1,
    builder   => '_build_child_tree',
);

before 'right', 'left' => sub {
    my ( $self, $tree ) = @_;
    $tree->parent($self) if defined $tree;
};

sub _build_child_tree {
    my $self = shift;

    return BinaryTree->new( parent => $self );
}

package main;

use Perl6::Say;
use Data::Dump qw(dump);

my $tree = BinaryTree->new;

say dump $tree;

my $left = $tree->left;

say dump $tree;

解説

default を sub {} にしておき、lazy 付けたりって話は Moose::Cookbook::Recipe3 - predicate, weak_ref, lazy - - Yet Another Hackadelic で既にやりました。ソースもほとんど似たような構成です。

先にソースの実行結果を貼っておきます。

bless({}, "BinaryTree")
do {
  my $a = bless({ left => bless({ parent => 'fix' }, "BinaryTree") }, "BinaryTree");
  $a->{left}{parent} = $a;
  $a;
}

まず単純に new した段階では left, right, parent などには何も入ってません。しかし left を getter として利用した後に見てみると left に新しく BinaryTree オブジェクトが生成されているのが分かります。

default + lazy と同じ効果ですね。

default + lazy vs builder

builder は

has 'left' => (
    is        => 'rw',
    isa       => 'BinaryTree',
    predicate => 'has_left',
    lazy      => 1,
    builder   => '_build_child_tree',
);

とあるように、メソッド名を指定するだけです。で実際にメソッドが存在しますね。

sub _build_child_tree {
    my $self = shift;

    return BinaryTree->new( parent => $self );
}

実際に存在するメソッドなんだから、このメソッド上書きするなり、before, after, augment など Moose の機能をふんだんに使った拡張するなり自由に出来ますが、default の場合は直接 CODEREF を指定するので拡張性がありません。

この点が違いですね。

Moose::Cookbook::Recipe7 - make_immutable -

今度は make_immutable について。

ソース

package PointImmutable;

use Moose;

has 'x' => (isa => 'Int', is => 'ro');
has 'y' => (isa => 'Int', is => 'rw');

__PACKAGE__->meta->make_immutable;

package PointNoImmutable;

use Moose;

has 'x' => (isa => 'Int', is => 'ro');
has 'y' => (isa => 'Int', is => 'rw');

package PointCAF;

use base qw(Class::Accessor::Fast);

__PACKAGE__->mk_accessors(qw/x/);
__PACKAGE__->mk_ro_accessors(qw/y/);

package main;

use Benchmark qw(cmpthese);

my $count = shift @ARGV || 200000;

cmpthese($count, {
    immutable => sub { PointImmutable->new(x => 10, y => 20) },
    no_immutable => sub { PointNoImmutable->new(x => 10, y => 20) },
    class_accessor_fast => sub { PointCAF->new({ x => 10, y => 20 }) }
});

解説

今度はベンチマークです。手元でコマンド引数なし、つまり200000回のイテレーションでベンチマークしてみました。

                        Rate    no_immutable       immutable class_accessor_fast
no_immutable          4131/s              --            -96%                -99%
immutable           116279/s           2715%              --                -65%
class_accessor_fast 327869/s           7838%            182%                  --

と言う訳で make_immutable した方が、しない方よりも27倍ほど早い。(今はMacOSXでのベンチマークです、ちなみに)

また Class::Accessor::Fast とも比較しましたが、こちらは make_immutable しても及ばす 1.8倍ほど Class::Accessor::Fast 版のが早い。

この事から分かる通り、Moose ベースで何か作る際には make_immutable しないと全然実用的なスピードが出ないって事ですね。

SEE ALSO

Moose::Cookbook::Recipe6 - augment, inner -

次はネストする呼び出しである augment, inner についてです。

ソースコード

package Document::Page;

use Moose;
use Perl6::Say;

has 'body' => ( is => 'rw', isa => 'Str', default => sub { '' } );

sub create {
    my $self = shift;
    $self->open_page;
    inner();
    $self->close_page;
}

sub append_body {
    my ($self, $appendage) = @_;
    $self->body($self->body . $appendage);
}

sub open_page { 
    my $self = shift;
    say 'open_page';
    $self->append_body('<page>');
}
sub close_page { 
    my $self = shift;
    say 'close_page';
    $self->append_body('</page>');
}

package Document::PageWithHeadersAndFooters;

use Moose;
use Perl6::Say;

extends 'Document::Page';

augment 'create' => sub {
    my $self = shift;
    $self->create_header;
    inner();
    $self->create_footer;
};

sub create_header { 
    my $self = shift;
    say 'create_header';
    $self->append_body('<header />') 
}

sub create_footer {
    my $self = shift;
    say 'create_footer';
    $self->append_body('<footer />');
}

package TPSReport;

use Moose;
use Perl6::Say;

extends 'Document::PageWithHeadersAndFooters';

augment 'create' => sub {
    say 'begin inner()';
    my $self = shift;
    $self->create_tps_report;
    say 'end inner()';
    return $self->body;
};

sub create_tps_report {
    (shift)->append_body('<report type="tps" />');
}

package main;

use Perl6::Say;
use Test::More qw(no_plan);

is(Document::Page->new->create, '<page></page>', 'Document::Page::create');
is(Document::PageWithHeadersAndFooters->new->create, '<page><header /><footer /></page>', 'Document::PageWithHeadersAndFooters::create');
is(TPSReport->new->create, '<page><header /><report type="tps" /><footer /></page>', 'TPSReport::create');

解説

Document::Page の create
sub create {
    my $self = shift;
    $self->open_page;
    inner();
    $self->close_page;
}

とありますが、inner()なんてどこにも定義していません。実はこれ Moose 側で提供しています。

is(Document::Page->new->create, '<page></page>', 'Document::Page::create');

の expect 部を見れば分かりますが、単独で呼び出した際には inner() は何もしません。

Document::PageWithHeadersAndFooters の augment => 'create'

だいぶ直感的ですね。見ればすぐ分かる。

augment 'create' => sub {
    my $self = shift;
    $self->create_header;
    inner();
    $self->create_footer;
};

Template-Toolkit で使える WRAPPER と content の関係を思い出して下さい。augment はまさに wrapper で inner() は content に当たります。(See Template::Manual::Directives # WRAPPER)

実行結果を見るとさらに明らかになりますね。

is(Document::PageWithHeadersAndFooters->new->create, '<page><header /><footer /></page>', 'Document::PageWithHeadersAndFooters::create');

つまり、

  • begin Document::PageWithHeadersAndFooters->create
    • Document::PageWithHeadersAndFooters->create_header
    • begin inner() = Document::Page->create
      • Document::Page->open_page;
      • Document::Page->close_page;
    • end inner()
    • Document::PageWithHeadersAndFooters->create_footer
  • end

みたいな呼び出しになる。

この手の奴って、今までだと明示的に hook ポイントを用意するとか、グロブ操作して無理矢理前後に処理を挟むとかってやってた訳だけど、そうした事が奇麗に書けます。むろん親クラスがinner()を用意してくれている場合に限りますがw

で、とどのつまり augment は 親が用意してくれた inner() に収まる処理を記述する 属性って言えます。

後は自明ですな。

*1:と言うか構文的に誤りありそうだおw

2008-06-10

Moose::Cookbook::Recipe5 - coerce -

次は Recipe5 也。

ソース

package HTML::Location;

use URI;

sub __as_URI {
    my $self = shift;
    return URI->new( $self->uri );
}

package Request;

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

use HTTP::Headers ();
use Params::Coerce ();
use URI ();

subtype 'Header' => as 'Object' => where { $_->isa('HTTP::Headers') };
coerce 'Header'
    => from 'ArrayRef'
    => via { HTTP::Headers->new( @{$_} ) }
    => from 'HashRef'
    => via { HTTP::Headers->new( %{$_} ) };

subtype 'Uri' => as 'Object' => where { $_->isa('URI') };
coerce 'Uri'
    => from 'Object'
    => via { $_->isa('URI') ? $_ : Params::Coerce::coerce('URI', $_) }
    => from 'Str'
    => via { URI->new($_, 'http') };

subtype 'Protocol' => as 'Str' => where { m|^HTTP/[0-9]\.[0-9]$| };

has 'base' => ( is => 'rw', isa => 'Uri', coerce => 1 );
has 'uri' => ( is => 'rw', isa => 'Uri', coerce => 1 );
has 'method' => ( is => 'rw', isa => 'Uri' );
has 'protocol' => ( is => 'rw', isa => 'Protocol' );
has 'headers' => ( is => 'rw', isa => 'Header', coerce => 1, default => sub { HTTP::Headers->new } );

package main;

use HTML::Location;
use HTTP::Headers;
use Test::More qw(no_plan);

my $request = Request->new;

ok($request, 'Create instance');

$request->headers(['Content-Type', 'text/plain']);

ok($request->headers->isa('HTTP::Headers'), 'HTTP::Headers object');
is($request->headers->header('Content-Type'), 'text/plain', 'property check');

$request->headers({ 'Accept' => 'application/xrds+xml' });

is($request->headers->isa('HTTP::Headers'), 1, 'HTTP::Headers object');
is($request->headers->header('Content-Type'), undef, 'property check');
is($request->headers->header('Accept'), 'application/xrds+xml', 'property check');

my $location = HTML::Location->new('/var/www/htdocs', 'http://d.hatena.ne.jp');

$request->uri($location);

ok($request->uri->isa('URI'), 'URI object');
is($request->uri->as_string, 'http://d.hatena.ne.jp/', 'String compare');

解説

coerce

Params::Coerce のメモ - Yet Another Hackadelic で Params::Coerce を紹介しましたが、まさにその機能を変換ルールとして適用出来るのが coerce です。

coerce 'Header'
    => from 'ArrayRef'
    => via { HTTP::Headers->new( @{$_} ) }
    => from 'HashRef'
    => via { HTTP::Headers->new( %{$_} ) };

ArrayRef なら配列にデリファレンス、HashRef ならハッシュにデリファレンスしてインスタンス化って強制ですね。

coerce 'Uri'
    => from 'Object'
    => via { $_->isa('URI') ? $_ : Params::Coerce::coerce('URI', $_) }
    => from 'Str'
    => via { URI->new($_, 'http') };

こっちはプリミティブじゃないオブジェクトの場合の coerce もある。ここは Params::Coerce の機能を使って URI オブジェクトじゃなく、何かのオブジェクトで、coerce する為のルールがあれば変換って事にしてる。

従って冒頭の方に、

package HTML::Location;

use URI;

sub __as_URI {
    my $self = shift;
    return URI->new( $self->uri );
}

としておくことによって Params::Coerce の機能で URI に変換出来る。

これは非常に素敵な機能ですね。特にリクエストデータは Apache 系とか HTTP::Request, CGI とか色々考えられるけど、その辺りを一つのオブジェクトに集約出来る、しかもかなりクールに書けるのがいい。

2008-06-09 associate が失敗しました

Moose::Cookbook::Recipe4 - subtype -

ソースコード

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

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 オブジェクト配列リファレンスじゃないとダメって事ですな。

2008-06-06 悩むより前進あるのみ

Moose::Cookbook::Recipe3 - predicate, weak_ref, lazy -

さらに Recipe3 です。

ソース

package BinaryTree;

use Moose;

has 'node' => (is => 'rw', isa => 'Any');

has 'parent' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_parent',
    weak_ref => 1,
);

has 'left' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_left',
    lazy => 1,
    default => sub { BinaryTree->new(parent => $_[0]) },
);

has 'right' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_right',
    lazy => 1,
    default => sub { BinaryTree->new(parent => $_[0]) },
);

before 'right', 'left' => sub {
    my ($self, $tree) = @_;
    $tree->parent($self) if defined $tree;
};

package main;

use Data::Dump qw(dump);
use Perl6::Say;

sub tree {
    my ($node) = @_;
    BinaryTree->new(node => $node);
}

sub slot {
    my ($tree, $node) = @_;

    unless (defined $tree->node) {
        $tree->node($node);
        return 1;
    }

    if ($tree->node > $node) {
        unless ($tree->has_right) {
            $tree->right(tree($node));
            return 1;
        }
        else {
            return slot($tree->right, $node);
        }
    }
    else {
        unless ($tree->has_left) {
            $tree->left(tree($node));
            return 1;
        }
        else {
            return slot($tree->left, $node);
        }
    }
}

my @nodes = 
    map { $_->[0] }
    sort { $a->[1] <=> $b->[1] }
    map { [ $_, rand ] }
    (1 .. 10);

say dump \@nodes;

my $tree = BinaryTree->new;
slot($tree, $_) for (@nodes);

sub bsort {
    my ($tree, $order, $result) = @_;

    if ($order) {
        bsort($tree->right, $order, $result) if ($tree->has_right);
        push(@$result, $tree->node);
        bsort($tree->left, $order, $result) if ($tree->has_left);
    }
    else {
        bsort($tree->left, $order, $result) if ($tree->has_left);
        push(@$result, $tree->node);
        bsort($tree->right, $order, $result) if ($tree->has_right);
    }
}

my $result = [];
bsort($tree, 1, $result);

say dump $result;

解説

二分探索木と二分木ソート

これは 2分木ソート でいいのかな、多分。二分木 - Wikipedia # 二分探索木 を詳しくは参照して下さい。

特定のノードから見て、親と二つの部分木を持つ構造をクラス表現した物。

ノード毎に値が割り振られているとする。あるノードの左の子およびその全ての子孫ノードの持つ値はそのノードの値より小さく、右の子及びその全ての子孫ノードの持つ値はそのノードの値より大きくなるように構成した二分木を二分探索木 (binary search tree) という。 二分木 - Wikipedia # 二分探索木

とあるので、slot 関数ではそのように二分探索木を再帰的に作るような関数になってます。

このようにして出来た二分探索木を、

二分探索木を通りがけ順に探索すると、各ノードの値を大きさ順(あるいは逆順)に得ることができる。 二分木 - Wikipedia # 二分探索木

との事なので bsort 関数では昇順、降順を選んでソート出来るようになってます。

まぁアルゴリズムの解説がメインじゃないのでこんな感じで。

predicate 属性オプション、weak_ref 属性オプション

これはいわゆる初期化済みか否かを指定したメソッド名で取れるようになるってオプションです。

has 'parent' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_parent',
    weak_ref => 1,
);

has_parent メソッドが生えるって事ですね。weak_ref 属性オプションは名前のまま、weak reference を使うって事です。循環参照オブジェクトを作る際は必須ですね。

default 属性オプション、lazy 属性オプション

default 属性オプションは d:id:ZIGOROu:20080606:1212753180 でも出てきましたが、今回は CODEREF になってます。

has 'left' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_left',
    lazy => 1,
    default => sub { BinaryTree->new(parent => $_[0]) },
);

これは逆に言えばそのように書かないと、リファレンスオブジェクトの場合は同じ値が default 値として参照されてしまうので問題になっちゃうので、毎回新たに生成する事を保障する為にそうしているみたいです。

さらに lazy オプションは、

you cannot use the lazy option unless you have set the default option. Moose::Cookbook::Recipe3

との事なので、default 属性オプションが無い場合には lazy 属性オプションは使えません。lazy って言うとタイムキーパーが出来ない id:tomyhero さんを思い出しますね><

で lazy って何かって言えば、実際に値が突っ込まれるまでは初期化を遅らせるって事です。なので再帰的に呼び出す際にも省エネなんだぜって事ですな。

その他

before 'left', 'right' の使い方が素敵ですね。left, right を初期化する際に、さらりと parent を設定してくれる所が小憎らしいですw

SEE ALSO

Moose::Cookbook::Recipe2 - class based constraint, modifier with arguments -

続いて Recipe2 をやっちゃうぞー。

ソース

預貯金に関する英単語が良く分からなかったので調べてコメント振った。

package BankAccount;

use Moose;

# 預金残高
has 'balance' => (isa => 'Int', is => 'rw', default => 0);

# 預金する
sub deposit {
    my ($self, $amount) = @_;
    $self->balance($self->balance + $amount);
}

# 引き落とし
sub withdraw {
    my ($self, $amount) = @_;
    my $current_balance = $self->balance();
    ($current_balance >= $amount) 
        || confess "Account overdrawn"; ### 預金残高より多い額の支払い
    $self->balance($current_balance - $amount);
}

package CheckingAccount;

use Moose;
extends 'BankAccount';

## 借り入れ口座
has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );

## 借り入れ口座があって、支払い前にお金が足りない場合は借金して預金残高を必要な分増やす
before 'withdraw' => sub {
    my ($self, $amount) = @_;
    my $overdraft_amount = $amount - $self->balance(); ### 超過した支払い額
    if ($self->overdraft_account && $overdraft_amount > 0) { ### 借り入れ口座があって、借り過ぎの場合
        $self->overdraft_account->withdraw($overdraft_amount); ### 借り入れ口座から支払い
        $self->deposit($overdraft_amount); ### 預金口座に入金
    }
};

package main;

use Data::Dump qw(dump);
use Perl6::Say;
use Test::More qw(no_plan);

my $bank_account = BankAccount->new;

is($bank_account->balance, 0, 'default value');
is($bank_account->deposit(100), 100, 'deposit');
is($bank_account->withdraw(50), 50, 'withdraw');

{
    eval {
        my $check_account = CheckingAccount->new( balance => 1000 );
        $check_account->overdraft_account(2);
    };
    if (my $err = $@) {
        ok($err, 'constraint');
        diag($err);
    }
}

{
    my $check_account = CheckingAccount->new( balance => 1000 );
    ok(!defined $check_account->overdraft_account, 'not set');
    is($check_account->withdraw(250), 750, 'withdraw not exists overdraft_account');
}

{
    my $check_account = CheckingAccount->new( balance => 1000, overdraft_account => BankAccount->new( balance => 2000 ) );
    ok(defined $check_account->overdraft_account, 'set');
    is($check_account->withdraw(1250), 0, 'withdraw exists overdraft_account');
    is($check_account->overdraft_account->balance, 1750, 'overdraft_account balance');
}

解説

制約にはクラス名がそのまま使える

実は d:id:ZIGOROu:20080606:1212748447 に比べて対して真新しい事は無い。

制約にクラスをそのまま使えるよって所くらいか。

## 借り入れ口座
has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );

こんな感じ。

後は advice の実践的な使い方とか言いたかった感じかな。

引数ありの modifier

これは大事な点ですね。通常の Perl5 OO で override する場合は、

sub withdraw {
  my ($self, $amount) = @_;
  $self->SUPER::withdraw($amount);
}

のようにしなければなりませんが、before modifier で定義した部分にはそのような箇所はありません、が期待通りに渡されます。

一方で before から元のメソッドに対して新しく引数を増やすと言った事は出来ないようです。

Moose::Cookbook::Recipe1 - has, before, after, extends -

もの凄い乗り遅れた感ですが僕も Moooooooooooooooooose してみる。

とりあえず Cookbook をやってみる事にしてみました。

ソース

まぁ適当にテストとか追加してある。

package Point;

use Moose;

has 'x' => ( isa => 'Int', is => 'ro' );
has 'y' => ( isa => 'Int', is => 'rw' );

sub clear {
    my $self = shift;
    $self->{x} = 0;
    $self->y(0);
}

package Point3D;

use Moose;
extends 'Point';

has 'z' => ( isa => 'Int' );

after 'clear' => sub {
    my $self = shift;
    $self->{z} = 0;
};

package main;

use Data::Dump qw(dump);
use Perl6::Say;
use Test::More qw(no_plan);

my $point = Point->new( x => 10, y => 12 );

ok($point->can('x'), 'has x getter');
ok($point->can('y'), 'has y getter');
is($point->x, 10, 'getter x');
is($point->y, 12, 'getter y');

eval {
    $point->x(1);
};
if (my $err = $@) {
    ok($err);
    diag($err);
}

eval {
    $point->y('foo');
};
if (my $err = $@) {
    ok($err);
    diag($err);
}

$point->clear;

is($point->x, 0, 'after called clear method');
is($point->y, 0, 'after called clear method');

my $point3d = Point3D->new(x => 3, y => 4, z => 5);

ok(!$point3d->can('z'), 'has not z getter');
ok(defined $point3d->{z}, 'has z property');
is($point3d->{z}, 5, 'z property');

$point3d->clear;

is($point3d->x, 0, 'after called clear method');
is($point3d->y, 0, 'after called clear method');
is($point3d->{z}, 0, 'after called clear method');

解説

前提はこんな感じ。

  • use Moose すると strict, warnings が有効になる
  • use Moose した packageMoose::Object がスーパークラスになる
  • has はインスタンス属性を定義する
アクセサの定義
has 'x' => ( isa => 'Int', is => 'ro' );
has 'y' => ( isa => 'Int', is => 'rw' );

は概ね想像の通り、値として 'Int' と言う制約で、ro, rw は想像どおり read only, read write です。

has 'z' => ( isa => 'Int' );

Point3d では is を省略してるんだけど、省略するとアクセサメソッドは生成されない。

メソッドの定義

これは普通の Perl5 OO と同じ形式。

sub clear {
    my $self = shift;
    $self->{x} = 0;
    $self->y(0);
}

但し x は ro で定義してるから値を設定する時はアクセサ経由は出来ないので直で代入してる。

継承

use base じゃなくて、extendsを使う。

extends 'Point';

複数の親を持ちたい場合はリストで指定する。

xtends 'Foo', 'Bar', 'Baz';
modifier

AOP で言う所の advice に当たる物。

after 'clear' => sub {
    my $self = shift;
    $self->{z} = 0;
};

これは clear の実行の後に行う処理って言う意味。

package Person;

use Moose;
use Perl6::Say;

sub hello {
    say 'Hello';
}

package ZIGOROu;

use Moose;
use Perl6::Say;

extends 'Person';

before 'hello' => sub {
    say 'before';
};

after 'hello' => sub {
    say 'after';
};

package main;

ZIGOROu->hello;

まぁこんなんで挙動は分かります。

before
Hello
after

って感じですね。

override したい場合は、override modifier を使う。

コンストラクタ
my $point = Point->new(x => 1, y => 2);   
my $point3d = Point3D->new(x => 1, y => 2, z => 3);

まぁそのままですね。

SEE ALSO