This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!./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; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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; | |
} | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment