CGI::Application インターナル(2) callback

BBS

CGI::Applicationの双璧をなす機能として

  • run modeに対応したサブルーチンのdispatcher
  • hookとそれに対応したcallbackの設定

があります。dispatcherに続いて、今回はcallbackについて。これも簡単なコードで面白い機能を付けてます。CGI::Applicationのコードはシンプルで分かりやすい上に短い*1ので、読んでみることをお勧めします。Perlのリハビリにはもってこい。

まず、callbackには2つの種類があります。

  1. Object-based callback (そのオブジェクト単体でのみ管理されるcallback)
  2. Class-based callback (全てのオブジェクトに適用されるcallback)
package SampleBase;
use base 'CGI::Application';
use strict;

sub setup{
    my $self = shift;
    $self->new_hook('hook_sample');
}
sub call{
    my $self = shift;
    $self->call_hook('hook_sample', @_);
}
sub callback001{
    print "  SampleBase::callback001\n";
}
sub callback002{
    print "  SampleBase::callback002\n";
}

package SampleA;
use base 'SampleBase';

sub callback001{
    print "  SampleA::callback001\n";
}

package SampleB;
use base 'SampleBase';

sub callback001{
    print "  SampleB::callback001\n";
}

package main;
use strict;

my $a = new SampleA();
my $b = new SampleB();

CGI::Application->add_callback('hook_sample', 'callback001');
$a->add_callback('hook_sample', 'callback002');
$b->add_callback('hook_sample', 'callback001');

print "callback SampleA\n";
$a->call();
print "callback SampleB\n";
$b->call();

実行結果

callback SampleA
  SampleBase::callback002
  SampleA::callback001
callback SampleB
  SampleB::callback001

object-basedとして設定したコールバック($a->add_callback)は$aのオブジェクトでしか適用されていませんが、class-basedとして設定したコールバック(CGI::Application->add_callback)は$aと$bの両方に適用されています。

実行順は、object-based→class-basedになります。

また、$b->add_callback()で再びcallback001を追加していますが、同名のcallbackを複数追加しても、実行されるのは一度だけです。

1.object-based callback

$self->{__INSTALLED_CALLBACKS}で管理されています。

# First, run callbacks installed in the object
foreach my $callback (@{ $self->{__INSTALLED_CALLBACKS}{$hook} }) {
        next if $executed_callback{$callback};
        eval { $self->$callback(@args); };
        $executed_callback{$callback} = 1;
        die "Error executing object callback in $hook stage: $@" if $@;
}

%executed_callbackというハッシュで、callbackが実行済みかどうかを判定します。同じ名前のcallbackは一度しか実行されないので、class-basedとobject-basedで同じ名前のcallbackが設定されていれば、object-basedとしてのみ実行されます。

2.class-based callback

%INSTALLED_CALLBACKSというハッシュで管理されています。

my %INSTALLED_CALLBACKS = (
#       hook name          package                 sub
        init      => { 'CGI::Application' => [ 'cgiapp_init'    ] },
        prerun    => { 'CGI::Application' => [ 'cgiapp_prerun'  ] },
        postrun   => { 'CGI::Application' => [ 'cgiapp_postrun' ] },
        teardown  => { 'CGI::Application' => [ 'teardown'       ] },
        load_tmpl => { },
        error     => { },
);

ここで登録したcallbackが全て実行されるわけではなく、packageが自分自身またはスーパークラスのものだけが実行されます。

# Cache this value as a performance boost
$self->{__CALLBACK_CLASSES} ||=  [ Class::ISA::self_and_super_path($app_class) ];

# Get list of classes that the current app inherits from
foreach my $class (@{ $self->{__CALLBACK_CLASSES} }) {

        # skip those classes that contain no callbacks
        next unless exists $INSTALLED_CALLBACKS{$hook}{$class};

        # call all of the callbacks in the class
        foreach my $callback (@{ $INSTALLED_CALLBACKS{$hook}{$class} }) {
                next if $executed_callback{$callback};
                eval { $self->$callback(@args); };
                $executed_callback{$callback} = 1;
                die "Error executing class callback in $hook stage: $@" if $@;
        }
}

*1:POD除いたら1000行ないんじゃないかな