Class::Component の run_hook にPlaggerライクな rule をかます

技術ブログのつもりではじめた日記だけど、自転車と日々のことをだらだらと綴ってばかりいるぞ！
久しぶりにperlのことを書くぞ！

さて、最近Class::Componentを使ったアプリを作ってるんですが、Plaggerみたいにrule使いたいなーと思って頑張ってみました。
ほぼPlaggerのコードをパクっただけだけど、実は一度もPlagger使ったことないので、コードを読み解くのが大変でした。けどすごく勉強になったよ。

作ったのは、naoyaが自転車のベルを鳴らすけど、ベルの音が単発だと鳴らなくなる。というもの。
テストアプリのディレクトリ構成はこんな感じ。ちなみにnaoyaさんとはなんの面識もないです。この辺をベースに作ったのでこうなっただけです。

.
|-- Naoya
|   |-- Plugin
|   |   `-- Jitensya.pm
|   |-- Plugin.pm
|   |-- Rule
|   |   |-- Always.pm
|   |   `-- Twice.pm
|   `-- Rule.pm
|-- Naoya.pm
`-- hatena.pl

コードをバリバリ貼り付けます。

package Naoya;
use strict;
use warnings;
use base qw/Class::Component/;

__PACKAGE__->load_components(
    qw/ Autocall::InjectMethod /
);
__PACKAGE__->load_plugins(qw/ Jitensya /);


sub run_hook {
    my($c, $hook, $args) = @_;
    return unless my $hooks = $c->class_component_hooks->{$hook};

    my @ret;
    for my $obj (@{ $hooks }) {
        my($plugin, $method) = ($obj->{plugin}, $obj->{method});
        next unless $plugin->rule->_dispatch($plugin, $hook, $args);
        my $ret = $plugin->$method($c, $args);
        push @ret, $ret;
    }
    \@ret;
}

1;

run_hookをオーバーライドして、rule->dispatchをはさみました。

package Naoya::Plugin;
use strict;
use warnings;
use base qw/ Class::Component::Plugin Class::Accessor::Lvalue::Fast /;
use Naoya::Rule;

__PACKAGE__->mk_accessors(qw/ rule /);

sub rule_hook { '' }

sub init {
    my($self, $context) = @_;

    if (my $rule = $self->config->{rule}) {
        $self->{rule} = Naoya::Rule->new($rule);
    } else {
        $self->{rule} = Naoya::Rule->new({ module => 'Always' });
    }
}

sub dispatch_rule_on {
    my($self, $hook) = @_;
    $self->rule_hook && $self->rule_hook eq $hook;
}


1;

Pluginのベースクラス。initでruleを登録。dispatch_rule_onでruleを適用するhookかどうか判定。

package Naoya::Plugin::Jitensya;
use strict;
use warnings;
use base 'Naoya::Plugin';

sub rule_hook { 'bell' }

sub ruled : Hook('bell') {
    my($self, $context, @args) = @_;
    print $self->config->{sound}, "\n";
}

sub normal : Hook('force_bell') {
    my($self, $context, @args) = @_;
    print $self->config->{sound}, "\n";
}

1;

rule_hookでruleを適用するhookを登録。bellはruleを通らないと鳴らない。force_bellはいつでも鳴るはず。

package Naoya::Rule;
use strict;
use warnings;
use UNIVERSAL::require;

sub new {
    my($class, $config) = @_;

    my $module = delete $config->{module};
    $module = "Naoya::Rule::$module";
    $module->require or die $@;

    my $self = bless {%$config}, $module;
    $self->init();
    $self;
}

sub _dispatch {
    my ( $self, $plugin, $hook, $args ) = @_;
    return 1 unless $plugin->dispatch_rule_on($hook);
    $self->dispatch($plugin, $args);
}

sub init { }

1;

ruleのベースクラス。

package Naoya::Rule::Always;
use strict;
use base qw( Naoya::Rule );

sub dispatch { 1 }

1;

デフォルトのrule。全部通す。

package Naoya::Rule::Twice;
use strict;
use base qw( Naoya::Rule );

sub dispatch {
    my ( $self, $plugin, $args ) = @_;
    $plugin->config->{sound} =~ /^(.+)\1$/;
}

1;

soundは同じ音2回繰り返しかい？

そしてテストスクリプト（hatena.pl）*1。

use strict;
use warnings;
use Naoya;
use Test::Base;

plan tests => 1 * blocks;

filters {
    input => [qw/yaml/],
};

run {
    my $block = shift;

    my $naoya = Naoya->new({ config => $block->input });

    my $out = '';
    tie_output(local *STDOUT, $out);

    $naoya->run_hook('bell');
    print "!\n";
    $naoya->run_hook('force_bell');

    is($out, $block->expected);
};

__END__
===
--- input
Jitensya:
  sound: rin
--- expected
rin
!
rin
===
--- input
Jitensya:
  sound: rin
  rule:
    module: Twice

--- expected
!
rin
===
--- input
Jitensya:
  sound: rinrin
  rule:
    module: Twice

--- expected
rinrin
!
rinrin

やったー無事テスト通った。
しかし、Attributeでなんとかなりそうな気がしないでもないので、もうちょと試してみよう。
ちなみにこのコードでは、Plaggerみたいに複数のruleをかますことはできません。でも、さらにコードをパクリまくればすぐに出来るようになります。

*1:tie_outputを使うとPerl6::Say#sayが死ぬのはなぜだろう。。