From: Rick Delaney Date: Fri, 13 Aug 2004 19:54:12 +0000 (-0400) Subject: fields.pm lost compile-time benefit X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e75d1f1083177907de70add76a22bf9ee81d8f6c;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 pragma. + =item No such class %s (F) You provided a class qualifier in a "my" or "our" declaration, but