2005年11月30日

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

今更ですが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
Comments

ugg, cheap ugg boot for sell.wow gold, wow gold on line store.压力表, Pressure Gauge cheap ugg boot, ugg cardy, ugg cardy for uk, cheap ugg cardy boots are popular,we sell real ugg boots, cheap ugg boots, ugg cardy, cheap ugg cardy boots,ugg boots uk at great prices to people, we are proud to offer you the high quality and low price ugg classic cardy,ugg classic cardy shop, cardy ugg boots, cheap cardy ugg boots, ugg classic cardy boots, ugg classic cardy boots online, and ugg classic tall, ugg classic tall boot, ugg boots uk, cardy ugg boots are using 100% natural sheepskinugg boots, good ugg boots cheap ugg boots, that means yucan buy ugg boot, プライバシーマーク


Posted by: replica bags at 2009年06月17日 02:04

As the Leader in china wholesale, Tradetang offer the best wholesale products , New products and Cheap Products. You can find Input Devices ,Laptop Parts Accessories ,Laptops, Notebooks ,Monitors Projectors and Networking. Well begun is the half done. Please choose our platform as you search the products to shorten your way to the success and we believe tradetang is your one-stop solution to purchasing China wholesale products online.

Posted by: fdsf at 2009年06月17日 02:05
Post a comment









Remember personal info?






コメントを投稿する前に↓の場所にnospamと入力してください。