Some more missing isGV_with_GP()s

Message-ID: <20080628160017.GA81579@osiris.mauzo.dyndns.org>

p4raw-id: //depot/perl@34092

7 files changed, 211 insertions, 15 deletions

diff --git a/t/io/pvbm.t b/t/io/pvbm.t
new file mode 100644
index 0000000000..6c97edf4e3
--- /dev/null
+++ b/t/io/pvbm.t
@@ -0,0 +1,81 @@
+#!./perl
+
+# Test that various IO functions don't try to treat PVBMs as
+# filehandles. Most of these will segfault perl if they fail.
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(. ../lib);
+    require "./test.pl";
+}
+
+BEGIN { $| = 1 }
+
+plan(28);
+
+sub PVBM () { 'foo' }
+{ my $dummy = index 'foo', PVBM }
+
+{
+    my $which;
+    {
+        package Tie;
+
+        sub TIEHANDLE { $which = 'TIEHANDLE' }
+        sub TIESCALAR { $which = 'TIESCALAR' }
+    }
+    my $pvbm = PVBM;
+    
+    tie $pvbm, 'Tie';
+    is ($which, 'TIESCALAR', 'PVBM gets TIESCALAR');
+}
+
+{
+    my $pvbm = PVBM;
+    ok (scalar eval { untie $pvbm; 1 }, 'untie(PVBM) doesn\'t segfault');
+    ok (scalar eval { tied $pvbm; 1  }, 'tied(PVBM) doesn\'t segfault');
+}
+
+{
+    my $pvbm = PVBM;
+
+    ok (scalar eval { pipe $pvbm, PIPE; }, 'pipe(PVBM, ) succeeds');
+    close foo;
+    close PIPE;
+    ok (scalar eval { pipe PIPE, $pvbm;  }, 'pipe(, PVBM) succeeds');
+    close foo;
+    close PIPE;
+    ok (!eval { pipe \$pvbm, PIPE;  }, 'pipe(PVBM ref, ) fails');
+    ok (!eval { pipe PIPE, \$pvbm;  }, 'pipe(, PVBM ref) fails');
+
+    ok (!eval { truncate $pvbm, 0 }, 'truncate(PVBM) fails');
+    ok (!eval { truncate \$pvbm, 0}, 'truncate(PVBM ref) fails');
+
+    ok (!eval { stat $pvbm }, 'stat(PVBM) fails');
+    ok (!eval { stat \$pvbm }, 'stat(PVBM ref) fails');
+
+    ok (!eval { lstat $pvbm }, 'lstat(PVBM) fails');
+    ok (!eval { lstat \$pvbm }, 'lstat(PVBM ref) fails');
+
+    ok (!eval { chdir $pvbm }, 'chdir(PVBM) fails');
+    ok (!eval { chdir \$pvbm }, 'chdir(pvbm ref) fails');
+
+    ok (!eval { close $pvbm }, 'close(PVBM) fails');
+    ok (!eval { close $pvbm }, 'close(PVBM ref) fails');
+
+    ok (!eval { chmod 0600, $pvbm }, 'chmod(PVBM) fails');
+    ok (!eval { chmod 0600, \$pvbm }, 'chmod(PVBM ref) fails');
+
+    ok (!eval { chown 0, 0, $pvbm }, 'chown(PVBM) fails');
+    ok (!eval { chown 0, 0, \$pvbm }, 'chown(PVBM ref) fails');
+
+    ok (!eval { utime 0, 0, $pvbm }, 'utime(PVBM) fails');
+    ok (!eval { utime 0, 0, \$pvbm }, 'utime(PVBM ref) fails');
+
+    ok (!eval { <$pvbm> }, '<PVBM> fails');
+    ok (!eval { readline $pvbm }, 'readline(PVBM) fails');
+    ok (!eval { readline \$pvbm }, 'readline(PVBM ref) fails');
+
+    ok (!eval { open $pvbm, '<', 'none.such' }, 'open(PVBM) fails');
+    ok (!eval { open \$pvbm, '<', 'none.such', }, 'open(PVBM ref) fails');
+}
diff --git a/t/op/attrs.t b/t/op/attrs.t
index 04e4517520..a27b61e580 100644
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -10,7 +10,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan 'no_plan';
+plan 90;
 
 $SIG{__WARN__} = sub { die @_ };
 
@@ -185,3 +185,10 @@ foreach my $value (\&foo, \$scalar, \@array, \%hash) {
 	}
     }
 }
+
+# this will segfault if it fails
+sub PVBM () { 'foo' }
+{ my $dummy = index 'foo', PVBM }
+
+ok !defined(attributes::get(\PVBM)), 
+    'PVBMs don\'t segfault attributes::get';
diff --git a/t/op/inc.t b/t/op/inc.t
index f722336d5b..99123c79d6 100755
--- a/t/op/inc.t
+++ b/t/op/inc.t
@@ -2,7 +2,7 @@
 
 # use strict;
 
-print "1..50\n";
+print "1..54\n";
 
 my $test = 1;
 
@@ -270,3 +270,14 @@ for my $n (47..113) {
     last;
 }
 die "Could not find a value which overflows the mantissa" unless $found;
+
+# these will segfault if they fail
+
+sub PVBM () { 'foo' }
+{ my $dummy = index 'foo', PVBM }
+
+ok (scalar eval { my $pvbm = PVBM; $pvbm++ });
+ok (scalar eval { my $pvbm = PVBM; $pvbm-- });
+ok (scalar eval { my $pvbm = PVBM; ++$pvbm });
+ok (scalar eval { my $pvbm = PVBM; --$pvbm });
+
diff --git a/t/op/inccode.t b/t/op/inccode.t
index 9457226b59..45022fff6d 100644
--- a/t/op/inccode.t
+++ b/t/op/inccode.t
@@ -23,7 +23,7 @@ use strict;
 use File::Spec;
 
 require "test.pl";
-plan(tests => 45 + !$minitest * (3 + 14 * $can_fork));
+plan(tests => 49 + !$minitest * (3 + 14 * $can_fork));
 
 my @tempfiles = ();
 
@@ -211,6 +211,29 @@ is( $ret, 'abc', 'do "abc.pl" sees return value' );
     @INC = @old_INC;
 }
 
+# this will segfault if it fails
+
+sub PVBM () { 'foo' }
+{ my $dummy = index 'foo', PVBM }
+
+# I don't know whether these requires should succeed or fail. 5.8 failed
+# all of them; 5.10 with an ordinary constant in place of PVBM lets the
+# latter two succeed. For now I don't care, as long as they don't
+# segfault :).
+
+unshift @INC, sub { PVBM };
+eval 'require foo';
+ok( 1, 'returning PVBM doesn\'t segfault require' );
+eval 'use foo';
+ok( 1, 'returning PVBM doesn\'t segfault use' );
+shift @INC;
+unshift @INC, sub { \PVBM };
+eval 'require foo';
+ok( 1, 'returning PVBM ref doesn\'t segfault require' );
+eval 'use foo';
+ok( 1, 'returning PVBM ref doesn\'t segfault use' );
+shift @INC;
+
 exit if $minitest;
 
 SKIP: {
diff --git a/t/op/magic.t b/t/op/magic.t
index 799c7178ac..d852e834f0 100755
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -36,7 +36,7 @@ sub skip {
     return 1;
 }
 
-print "1..58\n";
+print "1..59\n";
 
 $Is_MSWin32  = $^O eq 'MSWin32';
 $Is_NetWare  = $^O eq 'NetWare';
@@ -131,7 +131,23 @@ END
     my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : '');
     print $? & 0xFF ? "ok 6$todo\n" : "not ok 6$todo\n";
 
-    $test += 4;
+    open(CMDPIPE, "| $PERL");
+    print CMDPIPE <<'END';
+
+    sub PVBM () { 'foo' }
+    index 'foo', PVBM;
+    my $pvbm = PVBM;
+
+    sub foo { exit 0 }
+
+    $SIG{"INT"} = $pvbm;
+    kill "INT", $$; sleep 1;
+END
+    close CMDPIPE;
+    $? >>= 8 if $^O eq 'VMS';
+    print $? ? "not ok 7\n" : "ok 7\n";
+
+    $test += 5;
 }
 
 # can we slice ENV?
diff --git a/t/op/ref.t b/t/op/ref.t
index 3fdc833388..e3d66dc1c2 100755
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -8,7 +8,7 @@ BEGIN {
 require 'test.pl';
 use strict qw(refs subs);
 
-plan(138);
+plan(182);
 
 # Test glob operations.
 
@@ -54,11 +54,6 @@ $BAR = \$BAZ;
 $BAZ = "hit";
 is ($$$FOO, 'hit');
 
-# test that ref(vstring) makes sense
-my $vstref = \v1;
-is (ref($vstref), "VSTRING", "ref(vstr) eq VSTRING");
-like ( $vstref, qr/VSTRING\(0x[0-9a-f]+\)/, '\vstr is also VSTRING');
-
 # Test references to real arrays.
 
 my $test = curr_test();
@@ -131,9 +126,49 @@ sub mysub2 { lc shift }
 
 # Test the ref operator.
 
-is (ref $subref, 'CODE');
-is (ref $ref, 'ARRAY');
-is (ref $refref, 'HASH');
+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.
 
@@ -536,6 +571,19 @@ is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' );
     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');
+
 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
 $test = curr_test();
 curr_test($test + 3);
diff --git a/t/op/undef.t b/t/op/undef.t
index 04cac52fd6..2262e755ce 100755
--- a/t/op/undef.t
+++ b/t/op/undef.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..36\n";
+print "1..37\n";
 
 print defined($a) ? "not ok 1\n" : "ok 1\n";
 
@@ -102,3 +102,13 @@ sub X::DESTROY {
     print "not " if each   %hash; print "ok $test\n"; $test++;
     print "not " if defined delete $hash{'key2'}; print "ok $test\n"; $test++;
 }
+
+# this will segfault if it fails
+
+sub PVBM () { 'foo' }
+{ my $dummy = index 'foo', PVBM }
+
+my $pvbm = PVBM;
+undef $pvbm;
+print 'not ' if defined $pvbm;
+print "ok $test\n"; $test++;