Add support for named hashes.
authorPeter Martini <PeterCMartini@GMail.com>
Mon, 8 Oct 2012 06:27:41 +0000 (02:27 -0400)
committerPeter Martini <PeterCMartini@GMail.com>
Wed, 17 Oct 2012 20:36:13 +0000 (16:36 -0400)
Removed TODO from hash related tests.
Still need to validate that slurpies come last.

pp_hot.c
t/comp/namedproto.t
toke.c

index d7aed31..0298453 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2746,6 +2746,27 @@ try_autoload:
                            MARK++;
                        }
                    }
+                   else if (SvTYPE(PAD_SVl(namecnt)) == SVt_PVHV) {
+                       HV * const hv = MUTABLE_HV(PAD_SVl(namecnt));
+                       SvPADSTALE_off(hv);
+                       HvSHAREKEYS_off(hv);
+                       if ((items - namecnt) % 2 == 0) {
+                           (void)hv_store_ent(hv, source[--items], newSV(0), 0);
+                           if (*MARK)
+                               SvTEMP_off(*MARK);
+                           MARK++;
+                       }
+                       while (items > namecnt) {
+                           SV * const val = newSVsv(source[--items]);
+                           if (*MARK)
+                               SvTEMP_off(*MARK);
+                           MARK++;
+                           (void)hv_store_ent(hv, source[--items], val, 0);
+                           if (*MARK)
+                               SvTEMP_off(*MARK);
+                           MARK++;
+                       }
+                   }
                    SSPUSHUV(saveclearval + (namecnt-- * (1 << SAVE_TIGHT_SHIFT)));
                    /* XXX TODO: Refactor, this is for the while(items) check */
                    if (items < 0)
index 524f409..007074f 100644 (file)
@@ -124,11 +124,10 @@ BEGIN {
 # 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";
     no_warnings("named hashes");
     my %hash = (c => 1, d => 2);
-    is(greedyhash(%hash),"c d");
-    is(greedyhash("c",1,"d",2),"c d");
+    is(greedyhash(%hash),"c d","Named hash using a literal hash");
+    is(greedyhash("c",1,"d",2),"c d","Named hash using a list of args");
 }
 
 # Checking params
diff --git a/toke.c b/toke.c
index 0a73a2c..0c84a7c 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -8952,7 +8952,7 @@ S_scan_named_proto (pTHX_ SV *sv, bool * bad)
     proto = SvPV(sv, protolen);
     while (*proto) {
        while (isSPACE(*proto)) proto++;
-       if (strchr("$@", *proto)) {
+       if (strchr("$@%", *proto)) {
            token[0] = *proto++;
            proto = scan_word(proto, token+1, sizeof(token) - 1, FALSE, &len);
            if (len) {
@@ -8996,10 +8996,13 @@ S_scan_named_proto (pTHX_ SV *sv, bool * bad)
        /* Mark the entries as in scope */
        ((XPVNV*)SvANY(pad_name))->xnv_u.xpad_cop_seq.xlow = PL_cop_seqmax;
        ((XPVNV*)SvANY(pad_name))->xnv_u.xpad_cop_seq.xhigh = PERL_PADSEQ_INTRO;
-       /* Upgrade to an array if needed */
+       /* Upgrade to an array / hash if needed */
        if (proto_type == '@') {
            sv_upgrade(PAD_SVl(pad_ix), SVt_PVAV);
        }
+       else if (proto_type == '%') {
+           sv_upgrade(PAD_SVl(pad_ix), SVt_PVHV);
+       }
     }
     sv_free(MUTABLE_SV(protolist));
     PL_cop_seqmax++;