YappoLogs

PerlのAttributeについてのお勉強

このエントリの内容は結構適当です。

今更ですがCatalystなどで使われているattributeに興味を持ったので調べてみた。
やや日本人向けははてな勉強会の資料などにもあります。

今回は、関数のattributeについて。SCALARとかARRAYとかHASHはスルーです。
あと、モジュールなperlではやってません。超シンプルです。

今のPerlでは

sub foo : baz {}

のように記述出来ますが、通常ではエラーになってしまうのです。
デフォルトで対応しているattributesは(lvalue|method|locked|unique|shared)のみらしいので、bazは対応してないのでエラーが出ます。

perldocを見るとMODIFY_CODE_ATTRIBUTESって関数でattributesの処理をしているそうなので、これを用いてattribute遊びをすることにします。
(ほかにもMODIFY_SCALAR_ATTRIBUTESとか色々ある)
で、必ずattributeな関数よりも前にMODIFY_CODE_ATTRIBUTESを記述しておかないとエラーになりました。

って事で、早速簡易なコードを用意

use strict;

test();

sub MODIFY_CODE_ATTRIBUTES {

    my ($pkg, $ref, @attrs) = @_;

    print "MODIFY_CODE_ATTRIBUTES: set up\n";

    return;

}

sub test : attribute {

    print "test: start\n";

}

実行すると…

$ perl ./sample1.pl

MODIFY_CODE_ATTRIBUTES: set up

test: start

うごいたー！

MODIFY_CODE_ATTRIBUTESの引数ですが
$pkgがattributeされた関数のカレントなパッケージ名
$refがattributeされた関数のリファレンス
@attrsがattribute名の配列
です。

sub test : foo bar baz {

のように指定すると、@attrsには(foo, bar, baz)が入ります。

こんな感じ

use strict;

test();

sub MODIFY_CODE_ATTRIBUTES {

    my ($pkg, $ref, @attrs) = @_;

    print "MODIFY_CODE_ATTRIBUTES: set up\n";

    print "MODIFY_CODE_ATTRIBUTES: attrs: $_\n" foreach @attrs;

    return;

}

sub test : attribute yappo gekko(hoge) {

    print "test: start\n";

}

実行結果は

$ perl ./sample2.pl

MODIFY_CODE_ATTRIBUTES: set up

MODIFY_CODE_ATTRIBUTES: attrs: attribute

MODIFY_CODE_ATTRIBUTES: attrs: yappo

MODIFY_CODE_ATTRIBUTES: attrs: gekko(hoge)

test: start

これはドキュメント真面目に読んでないので自信がないですが、MODIFY_CODE_ATTRIBUTESに戻り値を入れてしまうとエラーが出るようになってるようです。
多分、非対応のattributesが設定されたときの為にあるのかなぁと

use strict;

test();

sub MODIFY_CODE_ATTRIBUTES {

    my ($pkg, $ref, @attrs) = @_;

    print "MODIFY_CODE_ATTRIBUTES: set up\n";

    return grep {defined && !/(yappo|osawa|blogdb)/} @attrs;

}

sub test : foo yappo bar osawa baz  {

    print "test: start\n";

}

こんな感じで、非対応のattributeのみを配列で戻すようにします。
これを実行すると…

$ perl ./sample3.pl

MODIFY_CODE_ATTRIBUTES: set up

Invalid CODE attributes: foo : bar : baz at ./sample3.pl line 10

BEGIN failed--compilation aborted at ./sample3.pl line 12.

と、エラーになりました。

MODIFY_CODE_ATTRIBUTESに渡されるリファレンスを活用して変なことも出来ます。

use strict;

my $lastref;

&$lastref;

sub MODIFY_CODE_ATTRIBUTES {

    my ($pkg, $ref, @attrs) = @_;

    $lastref = $ref;

    #&$lastref; # ← 呼出しに失敗する

    return;

}

sub test : attribute {

    print "test: start\n";

}

というコードは

$ perl ./sample4.pl

test: start

と期待通り実行されます。

    #&$lastref; # ← 呼出しに失敗する

の位置で関数を呼び出すと、Perl内部にて関数が準備されていないためかエラーになります。
コメントアウトしたソースの結果

$ perl ./sample4.pl

Undefined subroutine called at ./sample4.pl line 10.

BEGIN failed--compilation aborted at ./sample4.pl line 15.

それを応用すると、関数へ対して様々な挙動を付加することが可能です。
基本的には、スクリプトのコンパイル時に一度だけ呼び出されるのに、実行時の関数呼び出し毎に好きな挙動を割り振ることが出来るようになるのです。

use strict;

test();

test2('value');

test3('value');

my @cache;

CHECK {

    no strict 'refs';

    my %code_cache;

    foreach (@cache) {

        my ($pkg, $ref, @attrs) = @$_;

        unless ($code_cache{$pkg}) {

            $code_cache{$pkg} = {};

            foreach my $sym ( values %{'main::'} ) {

                next unless ref(*{$sym}{CODE}) eq 'CODE';

                $code_cache{$pkg}->{*{$sym}{CODE}} = *{$sym}{NAME};

            }

        }

        my $sym = $pkg . '::' . $code_cache{$pkg}->{$ref};

        *{$sym} = sub {

            no strict 'subs';

            my ($cpkg, $cfile, $cline) = caller;

            print "\n";

            print "before: $cpkg, $cfile, $cline\n";

            print 'before: input : ' . join(',', @_) . "\n";

            my @ret = &$ref(@_);

            print 'affter: return : ' . join(',', @ret) . "\n";

            print "affter: $cpkg, $cfile, $cline\n";

            print "\n";

        };

    }

}

sub MODIFY_CODE_ATTRIBUTES {

    my ($pkg, $ref, @attrs) = @_;

    push(@cache, [$pkg, $ref, @attrs]);

    return;

}

sub test : attribute {

    print "test: start\n";

    print "test: end\n";

    return 'test1 return';

}

sub test2 : attribute {

    print "test2: start\n";

    print "test2: $_[0]\n";

    print "test2: end\n";

    return 'test2 return';

}

sub test3 {

    print "test3: start\n";

    print "test3: $_[0]\n";

    print "test3: end\n";

    return 'test3 return';

}

やってる事は、attributeがついている関数のシンボルテーブルを書き換えまくって、別のロジックを付与しています。
MODIFY_CODE_ATTRIBUTES内でシンボルいじるのに失敗するのでCHECKの中でいじってます。

この結果は下記の通り

$ perl ./sample5.pl


before: main, ./sample5.pl, 3

before: input :

test: start

test: end

affter: return : test1 return

affter: main, ./sample5.pl, 3



before: main, ./sample5.pl, 4

before: input : value

test2: start

test2: value

test2: end

affter: return : test2 return

affter: main, ./sample5.pl, 4

test3: start

test3: value

今回のは適当なサンプルを作っただけですが、応用しだいでは便利に使えそうな気がします。
ただ、今回のサンプルは随分と面倒な実装でやる気が失せます。

そこでAttribute::Handlersの登場です。

もづく

突っ込みどころ多いと思いますので、突込みなどあればビシバシと・・・

Posted by Yappo at 2005年11月30日 22:24 | TrackBack | Perl