01-signatures-args.t

#!./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;

signatures-args.patch

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;
 }