[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;
view raw 01-signatures-args.t hosted with ❤ by GitHub
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 かな、というのと、サブルーチンとか大量に定義されるので、結構メモリ食ったりしそうだな、ってのが怪しい感じです。

  1. トップ
  2. tech
  3. perl 5.19.9 の signatures 構文に引数リストをとれる機能を足す
▲ この日のエントリ