X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fref.t;h=aca94a35678aa5385edede542641bb02372c0319;hb=e66590ee0c794dd404055173204d6a0057f5d90d;hp=ae3eef7dbf59957d1eddeada31f2f7b7a6bb2e53;hpb=39cff0d9bacec3b7c45b12560665095ba3be16b2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/ref.t b/t/op/ref.t old mode 100755 new mode 100644 index ae3eef7..aca94a3 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -5,54 +5,60 @@ BEGIN { @INC = qw(. ../lib); } -print "1..66\n"; - require 'test.pl'; +use strict qw(refs subs); +use re (); + +plan(196); # Test glob operations. -$bar = "ok 1\n"; -$foo = "ok 2\n"; +$bar = "one"; +$foo = "two"; { local(*foo) = *bar; - print $foo; + is($foo, 'one'); } -print $foo; +is ($foo, 'two'); -$baz = "ok 3\n"; -$foo = "ok 4\n"; +$baz = "three"; +$foo = "four"; { local(*foo) = 'baz'; - print $foo; + is ($foo, 'three'); } -print $foo; +is ($foo, 'four'); -$foo = "ok 6\n"; +$foo = "global"; { local(*foo); - print $foo; - $foo = "ok 5\n"; - print $foo; + is ($foo, undef); + $foo = "local"; + is ($foo, 'local'); } -print $foo; +is ($foo, 'global'); +{ + no strict 'refs'; # Test fake references. -$baz = "ok 7\n"; -$bar = 'baz'; -$foo = 'bar'; -print $$$foo; + $baz = "valid"; + $bar = 'baz'; + $foo = 'bar'; + is ($$$foo, 'valid'); +} # Test real references. $FOO = \$BAR; $BAR = \$BAZ; -$BAZ = "ok 8\n"; -print $$$FOO; +$BAZ = "hit"; +is ($$$FOO, 'hit'); # Test references to real arrays. -@ary = (9,10,11,12); +my $test = curr_test(); +@ary = ($test,$test+1,$test+2,$test+3); $ref[0] = \@a; $ref[1] = \@b; $ref[2] = \@c; @@ -63,127 +69,202 @@ for $i (3,1,2,0) { print @a; print ${$ref[1]}[0]; print @{$ref[2]}[0]; -print @{'d'}; +{ + no strict 'refs'; + print @{'d'}; +} +curr_test($test+4); # Test references to references. $refref = \\$x; -$x = "ok 13\n"; -print $$$refref; +$x = "Good"; +is ($$$refref, 'Good'); # Test nested anonymous lists. $ref = [[],2,[3,4,5,]]; -print scalar @$ref == 3 ? "ok 14\n" : "not ok 14\n"; -print $$ref[1] == 2 ? "ok 15\n" : "not ok 15\n"; -print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n"; -print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n"; +is (scalar @$ref, 3); +is ($$ref[1], 2); +is (${$$ref[2]}[2], 5); +is (scalar @{$$ref[0]}, 0); -print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n"; -print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n"; +is ($ref->[1], 2); +is ($ref->[2]->[0], 3); # Test references to hashes of references. $refref = \%whatever; $refref->{"key"} = $ref; -print $refref->{"key"}->[2]->[0] == 3 ? "ok 20\n" : "not ok 20\n"; +is ($refref->{"key"}->[2]->[0], 3); # Test to see if anonymous subarrays spring into existence. $spring[5]->[0] = 123; $spring[5]->[1] = 456; push(@{$spring[5]}, 789); -print join(':',@{$spring[5]}) eq "123:456:789" ? "ok 21\n" : "not ok 21\n"; +is (join(':',@{$spring[5]}), "123:456:789"); # Test to see if anonymous subhashes spring into existence. @{$spring2{"foo"}} = (1,2,3); $spring2{"foo"}->[3] = 4; -print join(':',@{$spring2{"foo"}}) eq "1:2:3:4" ? "ok 22\n" : "not ok 22\n"; +is (join(':',@{$spring2{"foo"}}), "1:2:3:4"); # Test references to subroutines. -sub mysub { print "ok 23\n" } -$subref = \&mysub; -&$subref; +{ + my $called; + sub mysub { $called++; } + $subref = \&mysub; + &$subref; + is ($called, 1); +} $subrefref = \\&mysub2; -$$subrefref->("ok 24\n"); -sub mysub2 { print shift } +is ($$subrefref->("GOOD"), "good"); +sub mysub2 { lc shift } + +# Test REGEXP assignment + +{ + my $x = qr/x/; + my $str = "$x"; # regex stringification may change + + my $y = $$x; + is ($y, $str, "bare REGEXP stringifies correctly"); + ok (eval { "x" =~ $y }, "bare REGEXP matches correctly"); + + my $z = \$y; + ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp"); + is ($z, $str, "new ref to REGEXP stringifies correctly"); + ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly"); +} +{ + my ($x, $str); + { + my $y = qr/x/; + $str = "$y"; + $x = $$y; + } + is ($x, $str, "REGEXP keeps a ref to its mother_re"); + ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches"); +} # Test the ref operator. -print ref $subref eq CODE ? "ok 25\n" : "not ok 25\n"; -print ref $ref eq ARRAY ? "ok 26\n" : "not ok 26\n"; -print ref $refref eq HASH ? "ok 27\n" : "not ok 27\n"; +sub PVBM () { 'foo' } +{ my $dummy = index 'foo', PVBM } + +my $pviv = 1; "$pviv"; +my $pvnv = 1.0; "$pvnv"; +my $x; + +# we don't test +# tied lvalue => SCALAR, as we haven't tested tie yet +# BIND, 'cos we can't create them yet +# REGEXP, 'cos that requires overload or Scalar::Util +# LVALUE ref, 'cos I can't work out how to create one :) + +for ( + [ 'undef', SCALAR => \undef ], + [ 'constant IV', SCALAR => \1 ], + [ 'constant NV', SCALAR => \1.0 ], + [ 'constant PV', SCALAR => \'f' ], + [ 'scalar', SCALAR => \$x ], + [ 'PVIV', SCALAR => \$pviv ], + [ 'PVNV', SCALAR => \$pvnv ], + [ 'PVMG', SCALAR => \$0 ], + [ 'PVBM', SCALAR => \PVBM ], + [ 'vstring', VSTRING => \v1 ], + [ 'ref', REF => \\1 ], + [ 'lvalue', LVALUE => \substr($x, 0, 0) ], + [ 'named array', ARRAY => \@ary ], + [ 'anon array', ARRAY => [ 1 ] ], + [ 'named hash', HASH => \%whatever ], + [ 'anon hash', HASH => { a => 1 } ], + [ 'named sub', CODE => \&mysub, ], + [ 'anon sub', CODE => sub { 1; } ], + [ 'glob', GLOB => \*foo ], + [ 'format', FORMAT => *STDERR{FORMAT} ], +) { + my ($desc, $type, $ref) = @$_; + is (ref $ref, $type, "ref() for ref to $desc"); + like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc"); +} + +is (ref *STDOUT{IO}, 'IO::Handle', 'IO refs are blessed into IO::Handle'); +like (*STDOUT{IO}, qr/^IO::Handle=IO\(0x[0-9a-f]+\)$/, + 'stringify for IO refs'); # Test anonymous hash syntax. $anonhash = {}; -print ref $anonhash eq HASH ? "ok 28\n" : "not ok 28\n"; -$anonhash2 = {FOO => BAR, ABC => XYZ,}; -print join('', sort values %$anonhash2) eq BARXYZ ? "ok 29\n" : "not ok 29\n"; +is (ref $anonhash, 'HASH'); +$anonhash2 = {FOO => 'BAR', ABC => 'XYZ',}; +is (join('', sort values %$anonhash2), 'BARXYZ'); # Test bless operator. package MYHASH; $object = bless $main'anonhash2; -print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n"; -print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n"; +main::is (ref $object, 'MYHASH'); +main::is ($object->{ABC}, 'XYZ'); $object2 = bless {}; -print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n"; +main::is (ref $object2, 'MYHASH'); # Test ordinary call on object method. -&mymethod($object,33); +&mymethod($object,"argument"); sub mymethod { local($THIS, @ARGS) = @_; die 'Got a "' . ref($THIS). '" instead of a MYHASH' - unless ref $THIS eq MYHASH; - print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n"; + unless ref $THIS eq 'MYHASH'; + main::is ($ARGS[0], "argument"); + main::is ($THIS->{FOO}, 'BAR'); } # Test automatic destructor call. -$string = "not ok 34\n"; +$string = "bad"; $object = "foo"; -$string = "ok 34\n"; +$string = "good"; $main'anonhash2 = "foo"; $string = ""; DESTROY { return unless $string; - print $string; + main::is ($string, 'good'); # Test that the object has not already been "cursed". - print ref shift ne HASH ? "ok 35\n" : "not ok 35\n"; + main::isnt (ref shift, 'HASH'); } # Now test inheritance of methods. package OBJ; -@ISA = (BASEOBJ); +@ISA = ('BASEOBJ'); -$main'object = bless {FOO => foo, BAR => bar}; +$main'object = bless {FOO => 'foo', BAR => 'bar'}; package main; # Test arrow-style method invocation. -print $object->doit("BAR") eq bar ? "ok 36\n" : "not ok 36\n"; +is ($object->doit("BAR"), 'bar'); # Test indirect-object-style method invocation. $foo = doit $object "FOO"; -print $foo eq foo ? "ok 37\n" : "not ok 37\n"; +main::is ($foo, 'foo'); sub BASEOBJ'doit { local $ref = shift; - die "Not an OBJ" unless ref $ref eq OBJ; + die "Not an OBJ" unless ref $ref eq 'OBJ'; $ref->{shift()}; } @@ -191,38 +272,38 @@ package UNIVERSAL; @ISA = 'LASTCHANCE'; package LASTCHANCE; -sub foo { print $_[1] } +sub foo { main::is ($_[1], 'works') } package WHATEVER; -foo WHATEVER "ok 38\n"; +foo WHATEVER "works"; # # test the \(@foo) construct # package main; -@foo = (1,2,3); +@foo = \(1..3); @bar = \(@foo); @baz = \(1,@foo,@bar); -print @bar == 3 ? "ok 39\n" : "not ok 39\n"; -print grep(ref($_), @bar) == 3 ? "ok 40\n" : "not ok 40\n"; -print @baz == 3 ? "ok 41\n" : "not ok 41\n"; +is (scalar (@bar), 3); +is (scalar grep(ref($_), @bar), 3); +is (scalar (@baz), 3); -my(@fuu) = (1,2,3); +my(@fuu) = \(1..2,3); my(@baa) = \(@fuu); my(@bzz) = \(1,@fuu,@baa); -print @baa == 3 ? "ok 42\n" : "not ok 42\n"; -print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n"; -print @bzz == 3 ? "ok 44\n" : "not ok 44\n"; +is (scalar (@baa), 3); +is (scalar grep(ref($_), @baa), 3); +is (scalar (@bzz), 3); # also, it can't be an lvalue eval '\\($x, $y) = (1, 2);'; -print $@ =~ /Can\'t modify.*ref.*in.*assignment/ ? "ok 45\n" : "not ok 45\n"; +like ($@, qr/Can\'t modify.*ref.*in.*assignment/); # test for proper destruction of lexical objects - -sub larry::DESTROY { print "# larry\nok 46\n"; } -sub curly::DESTROY { print "# curly\nok 47\n"; } -sub moe::DESTROY { print "# moe\nok 48\n"; } +$test = curr_test(); +sub larry::DESTROY { print "# larry\nok $test\n"; } +sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; } +sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; } { my ($joe, @curly, %larry); @@ -233,44 +314,48 @@ sub moe::DESTROY { print "# moe\nok 48\n"; } } print "# left block\n"; +curr_test($test + 3); # another glob test -$foo = "not ok 49"; + +$foo = "garbage"; { local(*bar) = "foo" } -$bar = "ok 49"; +$bar = "glob 3"; local(*bar) = *bar; -print "$bar\n"; +is ($bar, "glob 3"); -$var = "ok 50"; +$var = "glob 4"; $_ = \$var; -print $$_,"\n"; +is ($$_, 'glob 4'); -# test if reblessing during destruction results in more destruction +# test if reblessing during destruction results in more destruction +$test = curr_test(); { package A; sub new { bless {}, shift } - DESTROY { print "# destroying 'A'\nok 52\n" } + DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" } package _B; sub new { bless {}, shift } - DESTROY { print "# destroying '_B'\nok 51\n"; bless shift, 'A' } + DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' } package main; my $b = _B->new; } +curr_test($test + 2); # test if $_[0] is properly protected in DESTROY() { + my $test = curr_test(); my $i = 0; local $SIG{'__DIE__'} = sub { my $m = shift; if ($i++ > 4) { - print "# infinite recursion, bailing\nnot ok 53\n"; + print "# infinite recursion, bailing\nnot ok $test\n"; exit 1; } - print "# $m"; - if ($m =~ /^Modification of a read-only/) { print "ok 53\n" } + like ($m, qr/^Modification of a read-only/); }; package C; sub new { bless {}, shift } @@ -283,40 +368,38 @@ print $$_,"\n"; } # test if refgen behaves with autoviv magic - { my @a; - $a[1] = "ok 54\n"; - print ${\$_} for @a; + $a[1] = "good"; + my $got; + for (@a) { + $got .= ${\$_}; + $got .= ';'; + } + is ($got, ";good;"); } # This test is the reason for postponed destruction in sv_unref $a = [1,2,3]; $a = $a->[1]; -print "not " unless $a == 2; -print "ok 55\n"; +is ($a, 2); # This test used to coredump. The BEGIN block is important as it causes the # op that created the constant reference to be freed. Hence the only # reference to the constant string "pass" is in $a. The hack that made # sure $a = $a->[1] would work didn't work with references to constants. -my $test = 56; foreach my $lexical ('', 'my $a; ') { my $expect = "pass\n"; my $result = runperl (switches => ['-wl'], stderr => 1, prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a'); - if ($? == 0 and $result eq $expect) { - print "ok $test\n"; - } else { - print "not ok $test # \$? = $?\n"; - print "# expected ", _qq ($expect), ", got ", _qq ($result), "\n"; - } - $test++; + is ($?, 0); + is ($result, $expect); } +$test = curr_test(); sub x::DESTROY {print "ok ", $test + shift->[0], "\n"} { my $a1 = bless [3],"x"; my $a2 = bless [2],"x"; @@ -325,30 +408,227 @@ sub x::DESTROY {print "ok ", $test + shift->[0], "\n"} 567; } } -$test+=4; - -my $result = runperl (switches=>['-l'], - prog=> 'print 1; print qq-*$\*-;print 1;'); -my $expect = "1\n*\n*\n1\n"; -if ($result eq $expect) { - print "ok $test\n"; -} else { - print "not ok $test\n"; - foreach ($expect, $result) { - s/\n/\\n/gs; - } - print "# expected \"$expect\", got \"$result\"\n"; -} +curr_test($test+4); + +is (runperl (switches=>['-l'], + prog=> 'print 1; print qq-*$\*-;print 1;'), + "1\n*\n*\n1\n"); # bug #21347 runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' ); -if ($? != 0) { print "not " }; -print "ok ",++$test," - UNIVERSAL::AUTOLOAD called when freeing qr//\n"; +is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//'); + +runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1); +is ($?, 0, 'warn called inside UNIVERSAL::DESTROY'); + + +# bug #22719 + +runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();'); +is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)'); +# bug #27268: freeing self-referential typeglobs could trigger +# "Attempt to free unreferenced scalar" warnings + +is (runperl( + prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x', + stderr => 1 +), '', 'freeing self-referential typeglob'); + +# using a regex in the destructor for STDOUT segfaulted because the +# REGEX pad had already been freed (ithreads build only). The +# object is required to trigger the early freeing of GV refs to to STDOUT + +like (runperl( + prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}', + stderr => 1 + ), qr/^(ok)+$/, 'STDOUT destructor'); + +TODO: { + no strict 'refs'; + $name8 = chr 163; + $name_utf8 = $name8 . chr 256; + chop $name_utf8; + + is ($$name8, undef, 'Nothing before we start'); + is ($$name_utf8, undef, 'Nothing before we start'); + $$name8 = "Pound"; + is ($$name8, "Pound", 'Accessing via 8 bit symref works'); + local $TODO = "UTF8 mangled in symrefs"; + is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works'); +} + +TODO: { + no strict 'refs'; + $name_utf8 = $name = chr 9787; + utf8::encode $name_utf8; + + is (length $name, 1, "Name is 1 char"); + is (length $name_utf8, 3, "UTF8 representation is 3 chars"); + + is ($$name, undef, 'Nothing before we start'); + is ($$name_utf8, undef, 'Nothing before we start'); + $$name = "Face"; + is ($$name, "Face", 'Accessing via Unicode symref works'); + local $TODO = "UTF8 mangled in symrefs"; + is ($$name_utf8, undef, + 'Accessing via the UTF8 byte sequence gives nothing'); +} + +{ + no strict 'refs'; + $name1 = "\0Chalk"; + $name2 = "\0Cheese"; + + isnt ($name1, $name2, "They differ"); + + is ($$name1, undef, 'Nothing before we start (scalars)'); + is ($$name2, undef, 'Nothing before we start'); + $$name1 = "Yummy"; + is ($$name1, "Yummy", 'Accessing via the correct name works'); + is ($$name2, undef, + 'Accessing via a different NUL-containing name gives nothing'); + # defined uses a different code path + ok (defined $$name1, 'defined via the correct name works'); + ok (!defined $$name2, + 'defined via a different NUL-containing name gives nothing'); + + is ($name1->[0], undef, 'Nothing before we start (arrays)'); + is ($name2->[0], undef, 'Nothing before we start'); + $name1->[0] = "Yummy"; + is ($name1->[0], "Yummy", 'Accessing via the correct name works'); + is ($name2->[0], undef, + 'Accessing via a different NUL-containing name gives nothing'); + ok (defined $name1->[0], 'defined via the correct name works'); + ok (!defined$name2->[0], + 'defined via a different NUL-containing name gives nothing'); + + my (undef, $one) = @{$name1}[2,3]; + my (undef, $two) = @{$name2}[2,3]; + is ($one, undef, 'Nothing before we start (array slices)'); + is ($two, undef, 'Nothing before we start'); + @{$name1}[2,3] = ("Very", "Yummy"); + (undef, $one) = @{$name1}[2,3]; + (undef, $two) = @{$name2}[2,3]; + is ($one, "Yummy", 'Accessing via the correct name works'); + is ($two, undef, + 'Accessing via a different NUL-containing name gives nothing'); + ok (defined $one, 'defined via the correct name works'); + ok (!defined $two, + 'defined via a different NUL-containing name gives nothing'); + + is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)'); + is ($name2->{PWOF}, undef, 'Nothing before we start'); + $name1->{PWOF} = "Yummy"; + is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works'); + is ($name2->{PWOF}, undef, + 'Accessing via a different NUL-containing name gives nothing'); + ok (defined $name1->{PWOF}, 'defined via the correct name works'); + ok (!defined $name2->{PWOF}, + 'defined via a different NUL-containing name gives nothing'); + + my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; + my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; + is ($one, undef, 'Nothing before we start (hash slices)'); + is ($two, undef, 'Nothing before we start'); + @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy"); + (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; + (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; + is ($one, "Yummy", 'Accessing via the correct name works'); + is ($two, undef, + 'Accessing via a different NUL-containing name gives nothing'); + ok (defined $one, 'defined via the correct name works'); + ok (!defined $two, + 'defined via a different NUL-containing name gives nothing'); + + $name1 = "Left"; $name2 = "Left\0Right"; + my $glob2 = *{$name2}; + + is ($glob1, undef, "We get different typeglobs. In fact, undef"); + + *{$name1} = sub {"One"}; + *{$name2} = sub {"Two"}; + + is (&{$name1}, "One"); + is (&{$name2}, "Two"); +} + +# test derefs after list slice + +is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' ); +is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' ); +is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' ); +is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' ); +is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' ); +is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' ); + +# deref on empty list shouldn't autovivify +{ + local $@; + eval { ()[0]{foo} }; + like ( "$@", "Can't use an undefined value as a HASH reference", + "deref of undef from list slice fails" ); +} + +# test dereferencing errors +{ + format STDERR = +. + my $ref; + foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) { + eval q/ $$ref /; + like($@, qr/Not a SCALAR reference/, "Scalar dereference"); + eval q/ @$ref /; + like($@, qr/Not an ARRAY reference/, "Array dereference"); + eval q/ %$ref /; + like($@, qr/Not a HASH reference/, "Hash dereference"); + eval q/ &$ref /; + like($@, qr/Not a CODE reference/, "Code dereference"); + } + + $ref = *STDERR{FORMAT}; + eval q/ *$ref /; + like($@, qr/Not a GLOB reference/, "Glob dereference"); + + $ref = *STDOUT{IO}; + eval q/ *$ref /; + is($@, '', "Glob dereference of PVIO is acceptable"); + + is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly"); +} + +# these will segfault if they fail + +my $pvbm = PVBM; +my $rpvbm = \$pvbm; + +ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref'); +ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref'); +ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref'); +ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref'); +ok (!eval { %$pvbm }, 'PVBM is not a HASH ref'); +ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref'); +ok (!eval { $rpvbm->foo }, 'PVBM is not an object'); + +# bug 24254 +is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), ""); +is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), ""); +is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), ""); +my $hushed = $^O eq 'VMS' ? 'use vmsish qw(hushed);' : ''; +is( runperl(stderr => 1, prog => $hushed . 'map die,4 for 3'), "Died at -e line 1.\n"); +is( runperl(stderr => 1, prog => $hushed . 'grep die,4 for 3'), "Died at -e line 1.\n"); +is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n"); + +# bug 57564 +is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), ""); + + +# Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. +$test = curr_test(); +curr_test($test + 3); # test global destruction -++$test; my $test1 = $test + 1; my $test2 = $test + 2; @@ -364,3 +644,4 @@ package FINALE; DESTROY { print $_[0][0]; } +