Enabled named parameters in entersub Updated t/comp/proto.t to cover the now legal...

diff --git a/pp_hot.c b/pp_hot.c
index 0d70dfc..06bfeb8 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2675,6 +2675,7 @@ try_autoload:
        dMARK;
        I32 items = SP - MARK;
        PADLIST * const padlist = CvPADLIST(cv);
+       AV * namedargs = PadlistNAMEDPARAMS(padlist);
        PUSHBLOCK(cx, CXt_SUB, MARK);
        PUSHSUB(cx);
        cx->blk_sub.retop = PL_op->op_next;
@@ -2685,7 +2686,7 @@ try_autoload:
        }
        SAVECOMPPAD();
        PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
-       if (hasargs) {
+       if (hasargs || namedargs) {
            AV *const av = MUTABLE_AV(PAD_SVl(0));
            if (AvREAL(av)) {
                /* @_ is normally not REAL--this should only ever
@@ -2715,6 +2716,20 @@ try_autoload:
            }
            Copy(MARK,AvARRAY(av),items,SV*);
            AvFILLp(av) = items - 1;
+
+           if (namedargs) {
+/* XXX TODO: Handle mismatched parameters */
+               int i;
+               int named_count = AvFILLp(namedargs) + 1;
+               int max = items < named_count ? items : named_count;
+               for (i = 0; i < max; i++) {
+                   SV * name = AvARRAY(namedargs)[i];
+                   SV * value = newSVsv(AvARRAY(av)[i]);
+                   PAD_SETSV(SvIV(name), value);
+                   SvPADTMP_on(value);
+                   SvREADONLY_on(value);
+               }
+           }
        
            while (items--) {
                if (*MARK)

diff --git a/t/comp/namedproto.t b/t/comp/namedproto.t
new file mode 100644 (file)
index 0000000..83c3611
--- /dev/null
+++ b/t/comp/namedproto.t
@@ -0,0 +1,105 @@
+#!./perl
+#
+# Tests for named prototypes
+# 
+
+my @warnings;
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = ('../lib','.');
+    require './test.pl';
+    $SIG{'__WARN__'} = sub { push @warnings, @_ };
+    $| = 1;
+}
+
+use warnings;
+use Scalar::Util qw(set_prototype);
+
+BEGIN {
+    plan tests => 18;  # Update this when adding/deleting tests.
+}
+
+# Not yet implemented: Greedy
+# Arrays (@array = ()) silences the used only once warning)
+sub greedyarray(@array){return $#array; @array = ();}
+BEGIN {
+    local $TODO = "Named arrays not yet implemented";
+    is($#warnings,-1);
+    print "# $warnings[0]" if $#warnings >= 0;
+    my @array = qw(1 2 3);
+    is(greedyarray(@array),2);
+    is(greedyarray(1,2,3),2);
+    @warnings = ();
+}
+
+# Hashes (%hash = ()) silences the used only once warning)
+sub greedyhash(%hash){my @keys = sort keys %hash; return "@keys"; %hash = ();}
+BEGIN {
+    local $TODO = "Named hashes not yet implemented";
+    is($#warnings,-1);
+    print "# $warnings[0]" if $#warnings >= 0;
+    my %hash = (c => 1, d => 2);
+    is(greedyhash(%hash),"c d");
+    is(greedyhash("c",1,"d",2),"c d");
+    @warnings = ();
+}
+
+# Checking params
+sub onep($one){ return "$one"; }
+is(onep("A"), "A", "Checking one param");
+
+sub twop($one,$two){ return "$one $two"; }
+is(twop("A","B"), "A B", "Checking two param");
+
+sub recc($a,$c){ return recc("$a $a",$c-1) if $c; return $a; }
+is(recc("A", 2), "A A A A", "Checking recursive");
+is($#warnings,-1,"No warnings checking params");
+print "@warnings" if $#warnings != -1;
+
+# Make sure whitespace doesn't matter
+sub whitespace (  $a  ,  $b   ) { return $b; }
+BEGIN {
+    is($#warnings,-1,"No warnings with extra whitespace in the definition");
+    print "# $warnings[0]" if $#warnings >= 0;
+    @warnings = ();
+}
+is(whitespace(4,5),5,"Prototype ignores whitespace");
+
+
+# Testing readonly
+my $a = 5;
+sub testro($a){ $a = 5; }
+eval { testro($a); };
+like($@,"read-only","Args should be passed read-only");
+
+# Checking old prototype behavior
+sub oldproto(*){ my $name = shift; return $name;}
+is(oldproto STDOUT,"STDOUT", "Traditional prototype behavior still works");
+
+sub manualproto($name){ return $name; }
+BEGIN { set_prototype(\&manualproto,"*");}
+is(manualproto STDOUT, "STDOUT", "Forcing it with set_prototype works");
+
+sub manualrecproto($name){
+    BEGIN { set_prototype(\&manualrecproto,"*");}
+    return $name;
+}
+BEGIN {
+    local $TODO = "Not sure how to use set_prototype for a recursive";
+    is($#warnings,-1);
+    print "# $warnings[0]" if $#warnings >= 0;
+    @warnings = ();
+}
+
+sub ignoredproto(*);
+sub ignoredproto($name){ return $name;}
+BEGIN {
+    is($#warnings,0,"Should have exactly one error");
+    like($warnings[0],"vs none","ignoredproto should complain of a mismatch");
+    @warnings = ();
+}
+
+# Test UTF-8
+
+1;

diff --git a/t/comp/proto.t b/t/comp/proto.t
index d5e4d5b..62cd09a 100644 (file)
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -18,7 +18,7 @@ BEGIN {
 # strict
 use strict;
 
-print "1..180\n";
+print "1..179\n";
 
 my $i = 1;
 
@@ -658,10 +658,6 @@ for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
   my $warn = "";
   local $SIG{__WARN__} = sub { $warn .= join("",@_) };
   
-  eval 'sub badproto (@bar) { 1; }';
-  print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/;
-  print "ok ", $i++, "\n";
-
   eval 'sub badproto2 (bar) { 1; }';
   print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/;
   print "ok ", $i++, "\n";
@@ -671,7 +667,7 @@ for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
   print "ok ", $i++, "\n";
   
   eval 'sub badproto4 (@ $b ar) { 1; }';
-  print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/;
+  print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$b ar/;
   print "ok ", $i++, "\n";
 }