From 345599ca7248bba771c8a9cadc2422a744a61ff2 Mon Sep 17 00:00:00 2001
From: Gurusamy Sarathy <gsar@cpan.org>
Date: Tue, 15 Feb 2000 17:42:06 +0000
Subject: [PATCH] optimize pseudohash slice in array slice at compile time
 (from John Tobey <jtobey@john-edwin-tobey.org>)

p4raw-id: //depot/perl@5104
---
 op.c           | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 t/lib/fields.t | 10 +++++++++-
 2 files changed, 65 insertions(+), 1 deletion(-)

diff --git a/op.c b/op.c
index bc30f01..ea58e6f 100644
--- a/op.c
+++ b/op.c
@@ -6493,6 +6493,62 @@ Perl_peep(pTHX_ register OP *o)
 	    *svp = newSViv(ind);
 	    break;
 	}
+	
+	case OP_HSLICE: {
+	    UNOP *rop;
+	    SV *lexname;
+	    GV **fields;
+	    SV **svp, **indsvp;
+	    I32 ind;
+	    char *key;
+	    STRLEN keylen;
+	    SVOP *first_key_op, *key_op;
+	
+	    if ((o->op_private & (OPpLVAL_INTRO))
+		/* I bet there's always a pushmark... */
+		|| ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
+		/* hmmm, no optimization if list contains only one key. */
+		break;
+	    rop = (UNOP*)((LISTOP*)o)->op_last;
+	    if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+		break;
+	    lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
+	    if (!SvOBJECT(lexname))
+		break;
+	    fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+	    if (!fields || !GvHV(*fields))
+		break;
+	    /* Again guessing that the pushmark can be jumped over.... */
+	    first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
+		->op_first->op_sibling;
+	    /* Check that the key list contains only constants. */
+	    for (key_op = first_key_op; key_op;
+		 key_op = (SVOP*)key_op->op_sibling)
+		if (key_op->op_type != OP_CONST)
+		    break;
+	    if (key_op)
+		break;
+	    rop->op_type = OP_RV2AV;
+	    rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
+	    o->op_type = OP_ASLICE;
+	    o->op_ppaddr = PL_ppaddr[OP_ASLICE];
+	    for (key_op = first_key_op; key_op;
+		 key_op = (SVOP*)key_op->op_sibling) {
+		svp = cSVOPx_svp(key_op);
+		key = SvPV(*svp, keylen);
+		indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
+		if (!indsvp) {
+		    Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
+			  key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
+		}
+		ind = SvIV(*indsvp);
+		if (ind < 1)
+		    Perl_croak(aTHX_ "Bad index while coercing array into hash");
+		SvREFCNT_dec(*svp);
+		*svp = newSViv(ind);
+	    }
+	    break;
+	}
 
 	case OP_RV2AV:
 	case OP_RV2HV:
diff --git a/t/lib/fields.t b/t/lib/fields.t
index 74be2c2..01f9389 100755
--- a/t/lib/fields.t
+++ b/t/lib/fields.t
@@ -90,7 +90,7 @@ my %expect = (
     'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
 );
 
-print "1..", int(keys %expect)+5, "\n";
+print "1..", int(keys %expect)+7, "\n";
 my $testno = 0;
 while (my($class, $exp) = each %expect) {
    no strict 'refs';
@@ -117,6 +117,14 @@ eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
 print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/;
 print "ok ", ++$testno, "\n";
 
+# Slices
+@$obj1{"_b1", "b1"} = (17, 29);
+print "not " unless "@$obj1[1,2]" eq "17 29";
+print "ok ", ++$testno, "\n";
+@$obj1[1,2] = (44,28);
+print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28";
+print "ok ", ++$testno, "\n";
+
 #fields::_dump();
 
 # check if 
-- 
2.7.4