Ermitejo - エスペラント語日本語翻訳

#BLOGO
2009/5/13

Singletonを(MouseX::Singletonの代わりに)手動で実装する方法

分類: 開発記 / タグ: ,

まず最初に、MouseX::ClassAttributeMouseX::Singletonで検索してこの記事に辿り着いた方にはお詫びを申し上げます。残念ながら、2009年5月13日現在では、それらのモジュールはCPANにはまだ存在していません。それではSingletonパターンをどう実装するか、というのが以下の話です。

Singletonを楽に書きたい

Moose/Mouseの流行を周回遅れでフォローする情けない技術者の肖像

私がMoose/Mouseを使いだして2ヶ月目になります。本当にこれは便利ですね。今まで食わず嫌いをしていたのは、技術者としても恥ずかしいことですし、それによって失った時間を思うと、いてもたってもいられません。某金融ユーザ系システム子会社のように、金にあかせて兵隊を揃えて効率の悪い高コスト体質な開発をしているような気分になりました。

白鳥はバタ足しなくても油分で浮くとか浮かないとか

さて、Moose/Mouseはそれだけでも恐ろしい切れ味を誇るプログラミングツールですが、あまりに便利すぎると、あばたでないえくぼもパテで埋めたくなるのが人情というものです。使い勝手の悪いツールであれば、そのツールの必須度が高ければ「やむを得ず」という形でパッチを当てたりすることもありますが、ツールへの愛があれば、進んでそれらをやってみようという気にもなるものです。

しかし、白鳥たちが見えないところでバタ足しているのと同様、使い易いツールがその裏でそれなりのコードが投入されていることも無視出来ません。最近ですと、MooseX::ClassAttributeが変態過ぎてMouseX化出来なかったので、次善策としてMooseX::Singletonをいじろうとしたら、やっぱり出来なかった……というスキルのない私です。Class::MOPを触らない範囲でMoose互換機能を使わせていただく、というように、何事も適材適所なのかも知れません。

ただ、Singleton程度であればまだしも、ちょっと込み入った拡張をしようとすると、CPANモジュールを落としてきたり参考にしたりといったことが通用することがまだ少ないので、隣のMooseの芝が青く見えて来ようものです。じっくりと腰を据えて見る必要があるのはともかく、その気力が続かないのはどうにかしたいところです。

さて、前置きが長いのはもはや様式美ですが、Mouseを使うけれどもSingletonにもしたい、というわがままを書いてみました。

ともあれ、バタ足

{
    package Foo;

    use Carp;

    my $Singleton;  # class variable

    use Any::Moose;

    has 'foo' => (
        is  => 'rw',
        isa => 'Str',
    );

    no Any::Moose;
    __PACKAGE__->meta->make_immutable;

    sub BUILDARGS {
        my ($class, %option) = @_;

        # (caller(0))[0] is
        # 'Mouse::Meta::Method::Constructor' or 'Class::MOP::Method::Generated'
        croak   "Cannot create instance: ",
                "invalid usage. ",
                "Use $class->instance() ",
                "instead of $class->new()"
                    if $class ne (caller(1))[0];

        return { %option };
    }

    sub instance {
        my ($class, %option) = @_;

        if (defined $Singleton) {
            while (my ($attribute, $value) = each %option) {
                $Singleton->$attribute($value);
            }
        }
        else {
            $Singleton = $class->new(%option);
        }

        return $Singleton;
    }

    1;
}

{
    package Foo::Bar;

    use Any::Moose;

    my $Singleton;  # don't forget it!

    extends qw(
        Foo
    );

    no Any::Moose;
    __PACKAGE__->meta->make_immutable;

    1;
}

{
    package main;

    use 5.010_000;
    use strict;
    use warnings;

    use English;
    use Scalar::Util qw(refaddr);

    foreach my $class (qw(Foo Foo::Bar)) {
        my $instance0 = $class->instance(foo => 'bar');
        my $instance1 = $class->instance(foo => 'baz');

        if (refaddr($instance0) == refaddr($instance1)) {
            say "Singleton mechanism is active!";
            say $instance0;
            say $instance1;
            say join ' eq ', $instance0->foo, $instance1->foo;
        };

        {
            local $EVAL_ERROR;
            eval {
                my $instance2 = $class->new;
            };
            if ($EVAL_ERROR) {
                say "Constraint mechanism for constructor-method is active!";
            }
        }
        say '-' x 8;
    }
}

__END__

うっかりぽん

……と、深く考えずに書いていたら、して得たインスタンスがFoo::BarではなくFooのクラス変数そのものだということ(全然継承出来ていないYO!)に気が付いて戦々恐々です。

Singleton mechanism is active!
baz eq baz
Foo=HASH(0xbaf26c)
Foo=HASH(0xbaf26c)
Constraint mechanism for constructor-method is active!
--------
Singleton mechanism is active!
baz eq baz
Foo=HASH(0xbaf26c)
Foo=HASH(0xbaf26c)
Constraint mechanism for constructor-method is active!
--------

うーん、出直しですね。

少々強引にシンボリックリファレンスを使う血路

ということで、もう少しだけ考えたところ、単純にやりたいことを書けばいいじゃん、という結論に至りました。

{
    package MySingletonRole;

    use Carp;

    use Any::Moose '::Role';

    no Any::Moose '::Role';

    sub BUILDARGS {
        my ($class, %option) = @_;

        # (caller(0))[0] is
        # 'Mouse::Meta::Method::Constructor' or 'Class::MOP::Method::Generated'
        croak   "Cannot create instance: ",
                "invalid usage. ",
                "Use $class->instance() ",
                "instead of $class->new()"
                    if __PACKAGE__ ne (caller(1))[0];

        return { %option };
    }

    sub instance {
        my ($class, %option) = @_;

        my $singleton;
        {
            no strict 'refs';
            $singleton = \do{ ${$class . '::Singleton'} };
        }

        if (defined $$singleton) {
            while (my ($attribute, $value) = each %option) {
                $$singleton->$attribute($value);
            }
        }
        else {
            $$singleton = $class->new(%option);
        }

        return $$singleton;
    }

    1;
}

{
    package Foo;

    use Any::Moose;

    has 'foo' => (
        is  => 'rw',
        isa => 'Str',
    );

    with qw(
        MySingletonRole
    );

    no Any::Moose;
    __PACKAGE__->meta->make_immutable;

    sub foobar {
        return 'Foo, Bar';
    }

    1;
}

{
    package Foo::Bar;

    use Any::Moose;

    extends qw(
        Foo
    );

    no Any::Moose;
    __PACKAGE__->meta->make_immutable;

    sub foobar {
        return 'Foo, Bar (override)';
    }
    sub bazqux {
        return 'Baz, Qux';
    }

    1;
}

{
    package main;

    use 5.010_000;
    use strict;
    use warnings;

    use English;
    use Scalar::Util qw(refaddr);

    foreach my $class (qw(Foo Foo::Bar)) {
        my $instance0 = $class->instance(foo => 'bar');
        my $instance1 = $class->instance(foo => 'baz');

        say $instance0->foobar;
        say $instance0->can('bazqux') ? $instance0->bazqux : q{};

        if (refaddr($instance0) == refaddr($instance1)) {
            say "Singleton mechanism is active!";
            say $instance0;
            say $instance1;
            say join ' eq ', $instance0->foo, $instance1->foo;
        };

        {
            local $EVAL_ERROR;
            eval {
                my $instance2 = $class->new;
            };
            if ($EVAL_ERROR) {
                say "Constraint mechanism for constructor-method is active!";
            }
        }
        say '-' x 8;
    }
}

__END__

これで何とか出来ました。実行結果も問題ありません。

Foo, Bar

Singleton mechanism is active!
Foo=HASH(0xbfd2b4)
Foo=HASH(0xbfd2b4)
baz eq baz
Constraint mechanism for constructor-method is active!
--------
Foo, Bar (override)
Baz, Qux
Singleton mechanism is active!
Foo::Bar=HASH(0xbfd244)
Foo::Bar=HASH(0xbfd244)
baz eq baz
Constraint mechanism for constructor-method is active!
--------

当たり前といえば当たり前ですが、継承先の$Singletonクラス変数を触れなければ行けないので、少々アクロバティックな書き方になってしまいました。Singletonでなければ(毎回別のインスタンスなら)作ったインスタンスを再度blessしてしまうという荒技(別名:手抜き)も使えますが、本稿の趣旨とは180度というか540度ほど違うので、ネタに走るのは大概にしておきます。

留意点としては、$singletonは(というより、オブジェクトは)リファレンスでなくてはならないので、$singleton = ${$class . '::Singleton'};と書かないことが挙げられようかと思います。あと、ついでにSingletonな動きをロールに括り出しておきました。

これで、非Moose/Mouseクラスで使っていたClass::Singletonのように、単にMySingletonRoleを使うだけで、お手軽にSingletonパターンを楽しめるようになりました。……恐らく。流石にMouseX::Singletonだなんて名前は畏れ多くて付けていません。

などと書いていて気が付いてClass::Singletonの実装を慌てて見てみたのですが、やはりシンボリックリファレンスを使っていました。先にこっちを見ておけば良かったです。Class::Singletonの実装で他に気付かされた点としては、ロール使用先で$Singletonクラス変数を予め宣言しておく必要性がないということです。名前空間を汚すことの是非はありますが、私の場合5回に4回くらいの割合で宣言を忘れていそうなので、自堕落で済むのは好きなところです。なお、本当にプロダクションコードの中で使う場合には、Class::Singletonと同様、頭に_を付けるなどして、慎ましやかな名前を使っておきたいところです。慣習的にはClass::Singletonと同じ_instanceとかでしょうか。

他に気になったのは、newメソッドを直接呼ばれたら死ぬ(instanceメソッドを使うよう、APIを強制する)ように、BUILDARGSメソッドに検証ロジックを仕込んだ箇所くらいです。caller(1)で本当にいいのかが、まだちょっと不安なところです。一応、継承しても動いてはいます。もうちょっと洗練された方法がいくらでもありそうですが(override new => sub { ... }かな?)、現状はこれで行ってみようと思います。

そのほか、read-only attributeにしたいなら上記じゃだめだろ、とか、入ってくるのがハッシュとは限らんだろ、とか、そのテストはないわ(苦笑)だとか、短い検証コードもTest::Classか、せめてTest::Moreに食わせられるテストにしろだとか、色々突っ込みどころがありそうな感触です。

最低限の動きとしては回っているように見えるので、もうちょっと洗練された書き方がないものか、勉強を続けていきたいところです。

#516 (2009/05/13 02:17:56), Gardejo

コメントはまだありません »

コメントはまだありません。

このコメント欄の RSS フィード トラックバック URL

ご意見・ご感想をお寄せください

< 脇書非表示 > 脇書表示