From: Rafael Garcia-Suarez Date: Fri, 2 Aug 2002 23:44:21 +0000 (+0200) Subject: Re: [perl #15898] coredump with variable our X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1ce0b88cbbc3b4ceae3caf23aae18979e81daba4;p=p5sagit%2Fp5-mst-13.2.git Re: [perl #15898] coredump with variable our Message-id: <20020802234421.11c62fe6.rgarciasuarez@free.fr> p4raw-id: //depot/perl@17699 --- diff --git a/op.c b/op.c index c8dba1b..82fe5b9 100644 --- a/op.c +++ b/op.c @@ -2090,19 +2090,19 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ - if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ - yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o))); - } - if (attrs) { - GV *gv = cGVOPx_gv(cUNOPo->op_first); - PL_in_my = FALSE; - PL_in_my_stash = Nullhv; - apply_attrs(GvSTASH(gv), - (type == OP_RV2SV ? GvSV(gv) : - type == OP_RV2AV ? (SV*)GvAV(gv) : - type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), - attrs, FALSE); - } + if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ + yyerror(Perl_form(aTHX_ "Can't declare %s in %s", + OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); + } else if (attrs) { + GV *gv = cGVOPx_gv(cUNOPo->op_first); + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + apply_attrs(GvSTASH(gv), + (type == OP_RV2SV ? GvSV(gv) : + type == OP_RV2AV ? (SV*)GvAV(gv) : + type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), + attrs, FALSE); + } o->op_private |= OPpOUR_INTRO; return o; } diff --git a/t/op/attrs.t b/t/op/attrs.t index 1ed92a1..dc604f3 100644 --- a/t/op/attrs.t +++ b/t/op/attrs.t @@ -5,188 +5,93 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } -sub NTESTS () ; - -my ($test, $ntests); -BEGIN {$ntests=0} -$test=0; -my $failed = 0; - -print "1..".NTESTS."\n"; +plan tests => 37; $SIG{__WARN__} = sub { die @_ }; -sub mytest { - my $bad = ''; - if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) { - if ($@) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# Got: $x\n" - } - else { - print "# Got unexpected success\n"; - } - if ($_[0]) { - print "# Expected: $_[0]\n"; - } - else { - print "# Expected success\n"; - } - $failed = 1; - $bad = 'not '; - } - elsif (@_ == 3 && $_[1] ne $_[2]) { - print "# Got: $_[1]\n"; - print "# Expected: $_[2]\n"; - $failed = 1; - $bad = 'not '; - } - print $bad."ok ".++$test."\n"; +sub eval_ok ($) { + eval $_[0]; + is( $@, '' ); } -eval 'sub t1 ($) : locked { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -eval 'sub t2 : locked { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -eval 'sub t3 ($) : locked ;'; -mytest; -BEGIN {++$ntests} - -eval 'sub t4 : locked ;'; -mytest; -BEGIN {++$ntests} - -my $anon1; -eval '$anon1 = sub ($) : locked:method { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -my $anon2; -eval '$anon2 = sub : locked : method { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -my $anon3; -eval '$anon3 = sub : method { $_[0]->[1] }'; -mytest; -BEGIN {++$ntests} +eval_ok 'sub t1 ($) : locked { $_[0]++ }'; +eval_ok 'sub t2 : locked { $_[0]++ }'; +eval_ok 'sub t3 ($) : locked ;'; +eval_ok 'sub t4 : locked ;'; +our $anon1; eval_ok '$anon1 = sub ($) : locked:method { $_[0]++ }'; +our $anon2; eval_ok '$anon2 = sub : locked : method { $_[0]++ }'; +our $anon3; eval_ok '$anon3 = sub : method { $_[0]->[1] }'; eval 'sub e1 ($) : plugh ;'; -mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/; -BEGIN {++$ntests} +like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; -mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; -BEGIN {++$ntests} +like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; -mytest qr/Unterminated attribute parameter in attribute list at/; -BEGIN {++$ntests} +like $@, qr/Unterminated attribute parameter in attribute list at/; eval 'sub e4 ($) : plugh + xyzzy ;'; -mytest qr/Invalid separator character '[+]' in attribute list at/; -BEGIN {++$ntests} - -eval 'my main $x : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my $x : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my $x ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x) : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x) ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x) : ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) : ;'; -mytest; -BEGIN {++$ntests} +like $@, qr/Invalid separator character '[+]' in attribute list at/; + +eval_ok 'my main $x : = 0;'; +eval_ok 'my $x : = 0;'; +eval_ok 'my $x ;'; +eval_ok 'my ($x) : = 0;'; +eval_ok 'my ($x) ;'; +eval_ok 'my ($x) : ;'; +eval_ok 'my ($x,$y) : = 0;'; +eval_ok 'my ($x,$y) ;'; +eval_ok 'my ($x,$y) : ;'; eval 'my ($x,$y) : plugh;'; -mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; -BEGIN {++$ntests} +like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; sub A::MODIFY_SCALAR_ATTRIBUTES { return } eval 'my A $x : plugh;'; -mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; -BEGIN {++$ntests} +like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; eval 'my A $x : plugh plover;'; -mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; -BEGIN {++$ntests} +like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; eval 'package Cat; my Cat @socks;'; -mytest qr/^Can't declare class for non-scalar \@socks in "my"/; -BEGIN {++$ntests} +like $@, qr/^Can't declare class for non-scalar \@socks in "my"/; sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } sub X::foo { 1 } *Y::bar = \&X::foo; *Y::bar = \&X::foo; # second time for -w eval 'package Z; sub Y::bar : foo'; -mytest qr/^X at /; -BEGIN {++$ntests} +like $@, qr/^X at /; eval 'package Z; sub Y::baz : locked {}'; my @attrs = eval 'attributes::get \&Y::baz'; -mytest '', "@attrs", "locked"; -BEGIN {++$ntests} +is "@attrs", "locked"; @attrs = eval 'attributes::get $anon1'; -mytest '', "@attrs", "locked method"; -BEGIN {++$ntests} +is "@attrs", "locked method"; sub Z::DESTROY { } sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; -mytest '', ref($thunk), "Z"; -BEGIN {++$ntests} +is ref($thunk), "Z"; @attrs = eval 'attributes::get $thunk'; -mytest '', "@attrs", "locked method Z"; -BEGIN {++$ntests} +is "@attrs", "locked method Z"; # Test ability to modify existing sub's (or XSUB's) attributes. eval 'package A; sub X { $_[0] } sub X : lvalue'; @attrs = eval 'attributes::get \&A::X'; -mytest '', "@attrs", "lvalue"; -BEGIN {++$ntests} +is "@attrs", "lvalue"; # Above not with just 'pure' built-in attributes. sub Z::MODIFY_CODE_ATTRIBUTES { (); } eval 'package Z; sub L { $_[0] } sub L : Z lvalue'; @attrs = eval 'attributes::get \&Z::L'; -mytest '', "@attrs", "lvalue Z"; -BEGIN {++$ntests} - +is "@attrs", "lvalue Z"; # Begin testing attributes that tie @@ -196,26 +101,23 @@ BEGIN {++$ntests} sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } sub FETCH { ${$_[0]} } sub STORE { - #print "# In Ttie::STORE\n"; - ::mytest ''; + ::pass; ${$_[0]} = $_[1]*2; } package Tloop; sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } } -eval ' +eval_ok ' package Tloop; for my $i (0..2) { my $x : TieLoop = $i; - $x != $i*2 and ::mytest "", $x, $i*2; + $x != $i*2 and ::is $x, $i*2; } '; -mytest; -BEGIN {$ntests += 4} - -# Other tests should be added above this line - -sub NTESTS () { $ntests } -exit $failed; +# bug #15898 +eval 'our ${""} : foo = 1'; +like $@, qr/Can't declare scalar dereference in our/; +eval 'my $$foo : bar = 1'; +like $@, qr/Can't declare scalar dereference in my/;