fields.pm lost compile-time benefit

Message-Id:  <20040813235412.GB12980@biff.bort.ca>

restore the compile-time field checking for
    my Dog $spot; $spot->{'walkies'};
that was lost when pseudo-hashes were removed

p4raw-id: //depot/perl@23256

1 files changed, 81 insertions, 0 deletions

diff --git a/op.c b/op.c
index 1d9a7350d2..d99045b0d9 100644
--- a/op.c
+++ b/op.c
@@ -6600,7 +6600,9 @@ Perl_peep(pTHX_ register OP *o)
 	    break;
 
 	case OP_HELEM: {
+	    UNOP *rop;
             SV *lexname;
+	    GV **fields;
 	    SV **svp, *sv;
 	    char *key = NULL;
 	    STRLEN keylen;
@@ -6620,9 +6622,88 @@ Perl_peep(pTHX_ register OP *o)
 		SvREFCNT_dec(sv);
 		*svp = lexname;
 	    }
+
+	    if ((o->op_private & (OPpLVAL_INTRO)))
+		break;
+
+	    rop = (UNOP*)((BINOP*)o)->op_first;
+	    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 (!(SvFLAGS(lexname) & SVpad_TYPED))
+		break;
+	    fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+	    if (!fields || !GvHV(*fields))
+		break;
+	    key = SvPV(*svp, keylen);
+	    if (!hv_fetch(GvHV(*fields), key,
+			SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+	    {
+		Perl_croak(aTHX_ "No such class field \"%s\" " 
+			   "in variable %s of type %s", 
+		      key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+	    }
+
             break;
         }
 
+	case OP_HSLICE: {
+	    UNOP *rop;
+	    SV *lexname;
+	    GV **fields;
+	    SV **svp;
+	    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)
+		break;
+	    if (rop->op_first->op_type == OP_PADSV)
+		/* @$hash{qw(keys here)} */
+		rop = (UNOP*)rop->op_first;
+	    else {
+		/* @{$hash}{qw(keys here)} */
+		if (rop->op_first->op_type == OP_SCOPE 
+		    && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
+		{
+		    rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
+		}
+		else
+		    break;
+	    }
+		    
+	    lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
+	    if (!(SvFLAGS(lexname) & SVpad_TYPED))
+		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;
+	    for (key_op = first_key_op; key_op;
+		 key_op = (SVOP*)key_op->op_sibling) {
+		if (key_op->op_type != OP_CONST)
+		    continue;
+		svp = cSVOPx_svp(key_op);
+		key = SvPV(*svp, keylen);
+		if (!hv_fetch(GvHV(*fields), key, 
+			    SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+		{
+		    Perl_croak(aTHX_ "No such class field \"%s\" "
+			       "in variable %s of type %s",
+			  key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+		}
+	    }
+	    break;
+	}
+
 	case OP_SORT: {
 	    /* will point to RV2AV or PADAV op on LHS/RHS of assign */
 	    OP *oleft, *oright;