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

diff --git a/lib/base/t/fields-base.t b/lib/base/t/fields-base.t
index f4a17f5..491279f 100644 (file)
--- a/lib/base/t/fields-base.t
+++ b/lib/base/t/fields-base.t
@@ -1,8 +1,9 @@
 #!/usr/bin/perl -w
 
-my $Has_PH;
+my ($Has_PH, $Field);
 BEGIN { 
     $Has_PH = $] < 5.009;
+    $Field = $Has_PH ? "pseudo-hash field" : "class field";
 }
 
 my $W;
@@ -20,7 +21,7 @@ BEGIN {
 }
 
 use strict;
-use Test::More tests => 26;
+use Test::More tests => 28;
 
 BEGIN { use_ok('base'); }
 
@@ -156,17 +157,22 @@ my D3 $obj2 = $obj1;
 $obj2->{b1} = "D3";
 
 # We should get compile time failures field name typos
-eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
-if( $Has_PH ) {
-    like $@, 
-      qr/^No such pseudo-hash field "notthere" in variable \$obj3 of type D3/;
-}
-else {
-    like $@, 
-      qr/^Attempt to access disallowed key 'notthere' in a restricted hash/;
-}
+eval q(return; my D3 $obj3 = $obj2; $obj3->{notthere} = "");
+like $@, 
+    qr/^No such $Field "notthere" in variable \$obj3 of type D3/,
+    "Compile failure of undeclared fields (helem)";
 
 # Slices
+# We should get compile time failures field name typos
+eval q(return; my D3 $obj3 = $obj2; my $k; @$obj3{$k,'notthere'} = ());
+like $@, 
+    qr/^No such $Field "notthere" in variable \$obj3 of type D3/,
+    "Compile failure of undeclared fields (hslice)";
+eval q(return; my D3 $obj3 = $obj2; my $k; @{$obj3}{$k,'notthere'} = ());
+like 
+    $@, qr/^No such $Field "notthere" in variable \$obj3 of type D3/,
+    "Compile failure of undeclared fields (hslice (block form))";
+
 @$obj1{"_b1", "b1"} = (17, 29);
 is( $obj1->{_b1}, 17 );
 is( $obj1->{b1},  29 );

diff --git a/lib/base/t/fields.t b/lib/base/t/fields.t
index 9ddae34..f36fc82 100644 (file)
--- a/lib/base/t/fields.t
+++ b/lib/base/t/fields.t
@@ -39,12 +39,12 @@ is_deeply( [sort &show_fields('Foo', fields::PRIVATE)],
            [sort qw(_no _up_yours)]);
 
 # We should get compile time failures field name typos
-eval q(my Foo $obj = Foo->new; $obj->{notthere} = "");
+eval q(return; my Foo $obj = Foo->new; $obj->{notthere} = "");
 
 my $error = $Has_PH ? 'No such(?: [\w-]+)? field "notthere"'
-                    : q[Attempt to access disallowed key 'notthere' in a ].
-                      q[restricted hash at ];
-ok( $@ && $@ =~ /^$error/i );
+                    : q[No such class field "notthere" in variable $obj ].
+                      q[of type Foo];
+ok( $@ && $@ =~ /^\Q$error/i );
 
 
 foreach (Foo->new) {

diff --git a/op.c b/op.c
index 1d9a735..d99045b 100644 (file)
--- 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;

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 1b4ab09..c56f5dd 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2449,6 +2449,12 @@ immediately after the switch, without intervening spaces.
 (F) The indicated command line switch needs a mandatory argument, but
 you haven't specified one.
 
+=item No such class field "%s" in variable %s of type %s
+
+(F) You tried to access a key from a hash through the indicated typed variable
+but that key is not allowed by the package of the same type.  The indicated
+package has restricted the set of allowed keys using the L<fields> pragma.
+
 =item No such class %s
 
 (F) You provided a class qualifier in a "my" or "our" declaration, but