Made bad slurpy args fatal (fixed TODO test)
authorPeter Martini <PeterCMartini@GMail.com>
Thu, 18 Oct 2012 03:05:17 +0000 (23:05 -0400)
committerPeter Martini <PeterCMartini@GMail.com>
Thu, 18 Oct 2012 03:05:17 +0000 (23:05 -0400)
Added the error to perldiag.pod
Note that the check happens very late, so a malformed
signature isn't even checked - it gets stored in CvPROTO,
is warned on if the warning for illegal proto are set,
and will die only when the sub is called (traditional proto
behavior).

pod/perldiag.pod
t/comp/namedproto.t
toke.c

index c2a1518..a6c32aa 100644 (file)
@@ -2223,6 +2223,12 @@ two from 1 to 32 (or 64, if your platform supports that).
 (W digit) You may have tried to use an 8 or 9 in an octal number.
 Interpretation of the octal number stopped before the 8 or 9.
 
+=item Illegal signature for %s (%s): only the last arg can be an array or hash
+
+(F) An array or a hash in a signature will be constructed from 0 or more
+values in the calling function, so having one of those types anywhere but
+the last parameter is ambiguous and thus illegal.
+
 =item Illegal switch in PERL5OPT: -%c
 
 (X) The PERL5OPT environment variable may only be used to set the
index 5b11452..331a5f2 100644 (file)
@@ -254,22 +254,27 @@ BEGIN {
     is(shadowing2(3), 15, "variable shadowing works");
 }
 
-{ local $TODO = "slurpy parameters not supported yet";
 {
     my $failed = !eval 'sub bad_slurpy_array (@foo, $bar) { }; 1';
     my $err = $@;
     ok($failed, "slurpies must come last");
-    like($err, qr/slurpy/, "slurpies must come last"); # XXX better regex
+    like($err, qr/^Illegal signature/, "slurpies must come last");
 }
 
 {
     my $failed = !eval 'sub bad_slurpy_hash (%foo, $bar) { }; 1';
     my $err = $@;
     ok($failed, "slurpies must come last");
-    like($err, qr/slurpy/, "slurpies must come last"); # XXX better regex
+    like($err, qr/^Illegal signature/, "slurpies must come last");
 }
-no_warnings("invalid slurpy parameters");
+
+{
+    my $failed = !eval 'sub bad_slurpy_dup (%foo, %bar) { }; 1';
+    my $err = $@;
+    ok($failed, "Can't use two slurpy args");
+    like($err, qr/^Illegal signature/, "Can't use two slurpy args");
 }
+no_warnings("invalid slurpy parameters");
 
 # Ban @_ inside the sub if it has a named proto
 {
diff --git a/toke.c b/toke.c
index db89183..f0a6adc 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -8943,6 +8943,7 @@ S_scan_named_proto (pTHX_ SV *sv)
     AV *protolist;
     int argcount, index;
     bool bad = FALSE;
+    bool has_greedy = FALSE;
 
     PERL_ARGS_ASSERT_SCAN_NAMED_PROTO;
 
@@ -8990,6 +8991,14 @@ S_scan_named_proto (pTHX_ SV *sv)
        const int pad_ix = pad_add_name_pv(SvPV_nolen(proto_name), 0, NULL, NULL);
        /* The named parameters must be the first entries in the pad */
        assert(pad_ix == index + 1);
+       if (has_greedy) {
+           sv_free(MUTABLE_SV(protolist));
+           Perl_croak(aTHX_
+                      "Illegal signature for %"SVf" (%s): "
+                      "only the last arg can be an array or hash",
+                      SVfARG(PL_subname),
+                      SvPVX(sv));
+       }
        pad_name = AvARRAY(PL_comppad_name)[pad_ix];
        /* Mark the entries as in scope */
        ((XPVNV*)SvANY(pad_name))->xnv_u.xpad_cop_seq.xlow = PL_cop_seqmax;
@@ -8997,9 +9006,11 @@ S_scan_named_proto (pTHX_ SV *sv)
        /* Upgrade to an array / hash if needed */
        if (proto_type == '@') {
            sv_upgrade(PAD_SVl(pad_ix), SVt_PVAV);
+           has_greedy = TRUE;
        }
        else if (proto_type == '%') {
            sv_upgrade(PAD_SVl(pad_ix), SVt_PVHV);
+           has_greedy = TRUE;
        }
     }
     sv_free(MUTABLE_SV(protolist));