[tech] perl 5.19.9 の signatures 構文 (普通に引数を書ける構文) を試す | Mon, Feb 24. 2014 - 氾濫原 で「ただ引数の名前とかは外からとることができない。せっかく構文に組込まれたのなら、とれてもよさそうだなと思った」と書いたので、すこしだけ実装を書いてみた。
blead perl ecb4de39577c95734821743685366f6fe7f59a2d へのパッチです。
| #!./perl -Ilib | |
| use v5.19; | |
| use strict; | |
| use warnings; | |
| use feature 'signatures'; | |
| no warnings "experimental::signatures"; | |
| use Test::More; | |
| package signatures { | |
| sub args ($sub) { | |
| $signatures::subs{$sub+0}; | |
| } | |
| sub arity ($sub) { | |
| $signatures::arities{$sub+0}; | |
| } | |
| } | |
| subtest "signatures" => sub { | |
| package _test1 { | |
| sub foo ($xxx, $yyy) { | |
| } | |
| sub bar ($zzz, $aaa=1) { | |
| } | |
| sub baz ($zzz, @rest) { | |
| } | |
| } | |
| is_deeply signatures::args(_test1->can('foo')), [qw( | |
| $xxx | |
| $yyy | |
| )]; | |
| is signatures::arity(_test1->can('foo')), 2; | |
| is_deeply signatures::args(_test1->can('bar')), [qw( | |
| $zzz | |
| $aaa | |
| )]; | |
| is signatures::arity(_test1->can('bar')), 1; | |
| is_deeply signatures::args(_test1->can('baz')), [qw( | |
| $zzz | |
| @rest | |
| )]; | |
| is signatures::arity(_test1->can('baz')), -2; | |
| }; | |
| subtest "no signature subs" => sub { | |
| package _test2 { | |
| sub foo { | |
| } | |
| } | |
| is signatures::args(_test2->can('foo')), undef; | |
| is signatures::arity(_test2->can('foo')), undef; | |
| }; | |
| TODO: subtest 'lexical_subs' => sub { | |
| local $TODO = "FAIL"; | |
| use feature 'lexical_subs'; | |
| no warnings "experimental::lexical_subs"; | |
| state sub foo ($foo) { | |
| } | |
| is_deeply signatures::args(\&foo), [qw( | |
| $foo | |
| )]; | |
| is signatures::arity(\&foo), 1; | |
| }; | |
| done_testing; |
| diff --git a/toke.c b/toke.c | |
| index 88524b4..b517e37 100644 | |
| --- a/toke.c | |
| +++ b/toke.c | |
| @@ -12432,6 +12432,48 @@ S_parse_opt_lexvar(pTHX) | |
| return var; | |
| } | |
| +void | |
| +Perl_parse_subsignature_remember_sub_arg(pTHX_ OP* var) | |
| +{ | |
| + HV* signaturesubmap; | |
| + SV* subid; | |
| + SV* name; | |
| + HE* signatures; | |
| + AV* list; | |
| + | |
| + signaturesubmap = get_hv("signatures::subs", 0); | |
| + if (!signaturesubmap) signaturesubmap = get_hv("signatures::subs", GV_ADD); | |
| + | |
| + subid = newSViv((IV)(PL_compcv)); | |
| + name = newSVsv(PAD_COMPNAME_SV(var->op_targ)); | |
| + signatures = hv_fetch_ent(signaturesubmap, subid, 0, 0); | |
| + if (signatures) { | |
| + list = (AV*)SvRV(HeVAL(signatures)); | |
| + } else { | |
| + list = newAV(); | |
| + } | |
| + av_push(list, name); | |
| + hv_store_ent(signaturesubmap, subid, newRV_inc((SV*)list), 0); | |
| +} | |
| + | |
| +void | |
| +Perl_parse_subsignature_remember_sub_arity(pTHX_ int min_arity, int max_arity) { | |
| + HV* signaturearitymap; | |
| + SV* subid; | |
| + int arity; | |
| + | |
| + signaturearitymap = get_hv("signatures::arities", 0); | |
| + if (!signaturearitymap) signaturearitymap = get_hv("signatures::arities", GV_ADD); | |
| + | |
| + subid = newSViv((IV)(PL_compcv)); | |
| + if (max_arity == -1) { | |
| + arity = -(min_arity + 1); | |
| + } else { | |
| + arity = min_arity; | |
| + } | |
| + hv_store_ent(signaturearitymap, subid, newSViv(arity), 0); | |
| +} | |
| + | |
| OP * | |
| Perl_parse_subsignature(pTHX) | |
| { | |
| @@ -12488,7 +12530,10 @@ Perl_parse_subsignature(pTHX) | |
| prev_type = 0; | |
| min_arity = pos + 1; | |
| } | |
| - if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr); | |
| + if (var) { | |
| + expr = newASSIGNOP(OPf_STACKED, var, 0, expr); | |
| + Perl_parse_subsignature_remember_sub_arg(var); | |
| + } | |
| if (expr) | |
| initops = op_append_list(OP_LINESEQ, initops, | |
| newSTATEOP(0, NULL, expr)); | |
| @@ -12539,6 +12584,7 @@ Perl_parse_subsignature(pTHX) | |
| initops = op_append_list(OP_LINESEQ, initops, | |
| newSTATEOP(0, NULL, | |
| newASSIGNOP(OPf_STACKED, var, 0, slice))); | |
| + Perl_parse_subsignature_remember_sub_arg(var); | |
| } | |
| prev_type = 2; | |
| max_arity = -1; | |
| @@ -12590,6 +12636,7 @@ Perl_parse_subsignature(pTHX) | |
| newSVpvs("Too many arguments for subroutine"))))), | |
| initops); | |
| } | |
| + Perl_parse_subsignature_remember_sub_arity(min_arity, max_arity); | |
| return initops; | |
| } | |
やってることは signatures::subs みたいな名前でハッシュをつくって放りこんでるだけです。perl のコード難しくてあってるかわからないのと、たぶん参照カウントがおかしかったりしてそうですが、とりあえず簡単には動く。
ただ、lexical_subs に対してはうまくとれない (とってるサブルーチンのアドレスがちがう) ので、そこが TODO かな、というのと、サブルーチンとか大量に定義されるので、結構メモリ食ったりしそうだな、ってのが怪しい感じです。
