[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 かな、というのと、サブルーチンとか大量に定義されるので、結構メモリ食ったりしそうだな、ってのが怪しい感じです。