[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]
Some more missing isGV_with_GP()s
This patch fixes some more places where SvTYPE==SVt_PVGV should have
been isGV_with_GP. The patch is against blead, but I would have thought
it ought to go into maint-5.10 at some point as well.
If there is an equivalent level of breakage in CPAN code, this could
turn into something of a problem; especially as PVBMs are so rare in
practice, so the bugs won't get found. Is there some reason I'm missing
why PVBMs weren't made into ordinary PVMGs, rather than PVGVs?
Ben
--
"If a book is worth reading when you are six, * ben@morrow.me.uk
it is worth reading when you are sixty." [C.S.Lewis]
diff --git a/t/io/pvbm.t b/t/io/pvbm.t
new file mode 100644
index 0000000..6c97edf
--- /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 04e4517..a27b61e 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 f722336..99123c7 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 9457226..45022ff 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 799c717..d852e83 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 3fdc833..e3d66dc 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 04cac52..2262e75 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++;
diff --git a/ext/IO/t/io_taint.t b/ext/IO/t/io_taint.t
index 4a9b76e..1cec9d7 100755
--- a/ext/IO/t/io_taint.t
+++ b/ext/IO/t/io_taint.t
@@ -18,7 +18,7 @@ BEGIN {
END { unlink "./__taint__$$" }
-print "1..3\n";
+print "1..5\n";
use IO::File;
$x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n");
print $x "$$\n";
@@ -43,4 +43,15 @@ print "not " if ($@ =~ /^Insecure/o);
print "ok 3\n"; # No Insecure message from using the data
$x->close;
+# this will segfault if it fails
+
+sub PVBM () { 'foo' }
+{ my $dummy = index 'foo', PVBM }
+
+eval { IO::Handle::untaint(PVBM) };
+print "ok 4\n";
+
+eval { IO::Handle::untaint(\PVBM) };
+print "ok 5\n";
+
exit 0;
diff --git a/MANIFEST b/MANIFEST
index 7889c28..dd8bd12 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3556,6 +3556,7 @@ t/io/openpid.t See if open works for subprocesses
t/io/open.t See if open works
t/io/pipe.t See if secure pipes work
t/io/print.t See if print commands work
+t/io/pvbm.t See if PVBMs break IO commands
t/io/read.t See if read works
t/io/say.t See if say works
t/io/tell.t See if file seeking works
diff --git a/doio.c b/doio.c
index b73f127..c37f2dc 100644
--- a/doio.c
+++ b/doio.c
@@ -926,7 +926,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
if (!gv)
gv = PL_argvgv;
- if (!gv || SvTYPE(gv) != SVt_PVGV) {
+ if (!gv || !isGV_with_GP(gv)) {
if (not_implicit)
SETERRNO(EBADF,SS_IVCHAN);
return FALSE;
@@ -1307,11 +1307,11 @@ Perl_my_stat(pTHX)
const char *s;
STRLEN len;
PUTBACK;
- if (SvTYPE(sv) == SVt_PVGV) {
+ if (isGV_with_GP(sv)) {
gv = (GV*)sv;
goto do_fstat;
}
- else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
gv = (GV*)SvRV(sv);
goto do_fstat;
}
@@ -1363,7 +1363,7 @@ Perl_my_lstat(pTHX)
PL_statgv = NULL;
sv = POPs;
PUTBACK;
- if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV && ckWARN(WARN_IO)) {
+ if (SvROK(sv) && isGV_with_GP(SvRV(sv)) && ckWARN(WARN_IO)) {
Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
GvENAME((GV*) SvRV(sv)));
return (PL_laststatval = -1);
@@ -1624,7 +1624,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
tot = sp - mark;
while (++mark <= sp) {
GV* gv;
- if (SvTYPE(*mark) == SVt_PVGV) {
+ if (isGV_with_GP(*mark)) {
gv = (GV*)*mark;
do_fchmod:
if (GvIO(gv) && IoIFP(GvIOp(gv))) {
@@ -1640,7 +1640,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
tot--;
}
}
- else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) {
+ else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
gv = (GV*)SvRV(*mark);
goto do_fchmod;
}
@@ -1664,7 +1664,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
tot = sp - mark;
while (++mark <= sp) {
GV* gv;
- if (SvTYPE(*mark) == SVt_PVGV) {
+ if (isGV_with_GP(*mark)) {
gv = (GV*)*mark;
do_fchown:
if (GvIO(gv) && IoIFP(GvIOp(gv))) {
@@ -1680,7 +1680,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
tot--;
}
}
- else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) {
+ else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
gv = (GV*)SvRV(*mark);
goto do_fchown;
}
@@ -1836,7 +1836,7 @@ nothing in the core.
tot = sp - mark;
while (++mark <= sp) {
GV* gv;
- if (SvTYPE(*mark) == SVt_PVGV) {
+ if (isGV_with_GP(*mark)) {
gv = (GV*)*mark;
do_futimes:
if (GvIO(gv) && IoIFP(GvIOp(gv))) {
@@ -1853,7 +1853,7 @@ nothing in the core.
tot--;
}
}
- else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) {
+ else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
gv = (GV*)SvRV(*mark);
goto do_futimes;
}
diff --git a/mg.c b/mg.c
index 6012d32..30ac035 100644
--- a/mg.c
+++ b/mg.c
@@ -1497,7 +1497,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
PL_psig_name[i] = newSVpvn(s, len);
SvREADONLY_on(PL_psig_name[i]);
}
- if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
+ if (isGV_with_GP(sv) || SvROK(sv)) {
if (i) {
(void)rsignal(i, PL_csighandlerp);
#ifdef HAS_SIGPROCMASK
diff --git a/pp.c b/pp.c
index 10dbb06..ca9b3d9 100644
--- a/pp.c
+++ b/pp.c
@@ -143,11 +143,11 @@ PP(pp_rv2gv)
SvREFCNT_inc_void_NN(sv);
sv = (SV*) gv;
}
- else if (SvTYPE(sv) != SVt_PVGV)
+ else if (!isGV_with_GP(sv))
DIE(aTHX_ "Not a GLOB reference");
}
else {
- if (SvTYPE(sv) != SVt_PVGV) {
+ if (!isGV_with_GP(sv)) {
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
@@ -285,7 +285,7 @@ PP(pp_rv2sv)
else {
gv = (GV*)sv;
- if (SvTYPE(gv) != SVt_PVGV) {
+ if (!isGV_with_GP(gv)) {
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
@@ -822,9 +822,11 @@ PP(pp_undef)
}
break;
case SVt_PVGV:
- if (SvFAKE(sv))
+ if (SvFAKE(sv)) {
SvSetMagicSV(sv, &PL_sv_undef);
- else {
+ break;
+ }
+ else if (isGV_with_GP(sv)) {
GP *gp;
HV *stash;
@@ -842,8 +844,9 @@ PP(pp_undef)
GvLINE(sv) = CopLINE(PL_curcop);
GvEGV(sv) = (GV*)sv;
GvMULTI_on(sv);
+ break;
}
- break;
+ /* FALL THROUGH */
default:
if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
SvPV_free(sv);
@@ -860,7 +863,7 @@ PP(pp_undef)
PP(pp_predec)
{
dVAR; dSP;
- if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MIN)
@@ -877,7 +880,7 @@ PP(pp_predec)
PP(pp_postinc)
{
dVAR; dSP; dTARGET;
- if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
@@ -899,7 +902,7 @@ PP(pp_postinc)
PP(pp_postdec)
{
dVAR; dSP; dTARGET;
- if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
diff --git a/pp_ctl.c b/pp_ctl.c
index fd8c87f..93bfbb4 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3353,11 +3353,11 @@ PP(pp_require)
}
}
- if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
+ if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
arg = SvRV(arg);
}
- if (SvTYPE(arg) == SVt_PVGV) {
+ if (isGV_with_GP(arg)) {
IO * const io = GvIO((GV *)arg);
++filter_has_file;
diff --git a/pp_hot.c b/pp_hot.c
index 64b5fc5..c3d1565 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -307,8 +307,8 @@ PP(pp_readline)
dVAR;
tryAMAGICunTARGET(iter, 0);
PL_last_in_gv = (GV*)(*PL_stack_sp--);
- if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
- if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
+ if (!isGV_with_GP(PL_last_in_gv)) {
+ if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
else {
dSP;
@@ -397,7 +397,7 @@ PP(pp_eq)
PP(pp_preinc)
{
dVAR; dSP;
- if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
@@ -843,7 +843,7 @@ PP(pp_rv2av)
else {
GV *gv;
- if (SvTYPE(sv) != SVt_PVGV) {
+ if (!isGV_with_GP(sv)) {
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
@@ -2665,6 +2665,8 @@ PP(pp_entersub)
switch (SvTYPE(sv)) {
/* This is overwhelming the most common case: */
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ DIE(aTHX_ "Not a CODE reference");
if (!(cv = GvCVu((GV*)sv))) {
HV *stash;
cv = sv_2cv(sv, &stash, &gv, 0);
@@ -3074,7 +3076,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
/* if we got here, ob should be a reference or a glob */
if (!ob || !(SvOBJECT(ob)
- || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
+ || (SvTYPE(ob) == SVt_PVGV
+ && isGV_with_GP(ob)
+ && (ob = (SV*)GvIO((GV*)ob))
&& SvOBJECT(ob))))
{
Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
diff --git a/pp_sys.c b/pp_sys.c
index 833e565..481864b 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -607,7 +607,7 @@ PP(pp_pipe_op)
if (!rgv || !wgv)
goto badexit;
- if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
+ if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
DIE(aTHX_ PL_no_usym, "filehandle");
rstio = GvIOn(rgv);
wstio = GvIOn(wgv);
@@ -806,19 +806,22 @@ PP(pp_tie)
methname = "TIEARRAY";
break;
case SVt_PVGV:
+ if (isGV_with_GP(varsv)) {
#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((GV*)varsv)) {
- Perl_croak(aTHX_ "Attempt to tie unique GV");
- }
+ if (GvUNIQUE((GV*)varsv)) {
+ Perl_croak(aTHX_ "Attempt to tie unique GV");
+ }
#endif
- methname = "TIEHANDLE";
- how = PERL_MAGIC_tiedscalar;
- /* For tied filehandles, we apply tiedscalar magic to the IO
- slot of the GP rather than the GV itself. AMS 20010812 */
- if (!GvIOp(varsv))
- GvIOp(varsv) = newIO();
- varsv = (SV *)GvIOp(varsv);
- break;
+ methname = "TIEHANDLE";
+ how = PERL_MAGIC_tiedscalar;
+ /* For tied filehandles, we apply tiedscalar magic to the IO
+ slot of the GP rather than the GV itself. AMS 20010812 */
+ if (!GvIOp(varsv))
+ GvIOp(varsv) = newIO();
+ varsv = (SV *)GvIOp(varsv);
+ break;
+ }
+ /* FALL THROUGH */
default:
methname = "TIESCALAR";
how = PERL_MAGIC_tiedscalar;
@@ -883,7 +886,7 @@ PP(pp_untie)
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
+ if (isGV_with_GP(sv) && !(sv = (SV *)GvIOp(sv)))
RETPUSHYES;
if ((mg = SvTIED_mg(sv, how))) {
@@ -921,7 +924,7 @@ PP(pp_tied)
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
+ if (isGV_with_GP(sv) && !(sv = (SV *)GvIOp(sv)))
RETPUSHUNDEF;
if ((mg = SvTIED_mg(sv, how))) {
@@ -2195,11 +2198,11 @@ PP(pp_truncate)
SV * const sv = POPs;
const char *name;
- if (SvTYPE(sv) == SVt_PVGV) {
+ if (isGV_with_GP(sv)) {
tmpgv = (GV*)sv; /* *main::FRED for example */
goto do_ftruncate_gv;
}
- else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
goto do_ftruncate_gv;
}
@@ -2842,10 +2845,10 @@ PP(pp_stat)
}
else {
SV* const sv = POPs;
- if (SvTYPE(sv) == SVt_PVGV) {
+ if (isGV_with_GP(sv)) {
gv = (GV*)sv;
goto do_fstat;
- } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
gv = (GV*)SvRV(sv);
if (PL_op->op_type == OP_LSTAT)
goto do_fstat_warning_check;
@@ -3401,10 +3404,10 @@ PP(pp_chdir)
if (PL_op->op_flags & OPf_SPECIAL) {
gv = gv_fetchsv(sv, 0, SVt_PVIO);
}
- else if (SvTYPE(sv) == SVt_PVGV) {
+ else if (isGV_with_GP(sv)) {
gv = (GV*)sv;
}
- else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
gv = (GV*)SvRV(sv);
}
else {
diff --git a/sv.c b/sv.c
index 37c60cf..982e2ed 100644
--- a/sv.c
+++ b/sv.c
@@ -1543,6 +1543,8 @@ Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
break;
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ break;
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
@@ -1650,6 +1652,8 @@ Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
break;
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ break;
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
@@ -7818,11 +7822,14 @@ Perl_sv_2io(pTHX_ SV *const sv)
io = (IO*)sv;
break;
case SVt_PVGV:
- gv = (GV*)sv;
- io = GvIO(gv);
- if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
- break;
+ if (isGV_with_GP(sv)) {
+ gv = (GV*)sv;
+ io = GvIO(gv);
+ if (!io)
+ Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
+ break;
+ }
+ /* FALL THROUGH */
default:
if (!SvOK(sv))
Perl_croak(aTHX_ PL_no_usym, "filehandle");
@@ -7875,10 +7882,13 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
*gvp = NULL;
return NULL;
case SVt_PVGV:
- gv = (GV*)sv;
- *gvp = gv;
- *st = GvESTASH(gv);
- goto fix_gv;
+ if (isGV_with_GP(sv)) {
+ gv = (GV*)sv;
+ *gvp = gv;
+ *st = GvESTASH(gv);
+ goto fix_gv;
+ }
+ /* FALL THROUGH */
default:
if (SvROK(sv)) {
@@ -7893,12 +7903,12 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
*st = CvSTASH(cv);
return cv;
}
- else if(isGV(sv))
+ else if(isGV_with_GP(sv))
gv = (GV*)sv;
else
Perl_croak(aTHX_ "Not a subroutine reference");
}
- else if (isGV(sv)) {
+ else if (isGV_with_GP(sv)) {
SvGETMAGIC(sv);
gv = (GV*)sv;
}
@@ -7910,7 +7920,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
return NULL;
}
/* Some flags to gv_fetchsv mean don't really create the GV */
- if (SvTYPE(gv) != SVt_PVGV) {
+ if (!isGV_with_GP(gv)) {
*st = NULL;
return NULL;
}
@@ -8125,7 +8135,8 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
case SVt_PVCV: return "CODE";
- case SVt_PVGV: return "GLOB";
+ case SVt_PVGV: return (char *) (isGV_with_GP(sv)
+ ? "GLOB" : "SCALAR");
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
case SVt_BIND: return "BIND";
diff --git a/xsutils.c b/xsutils.c
index dcc8d09..1864050 100644
--- a/xsutils.c
+++ b/xsutils.c
@@ -120,7 +120,7 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
break;
case 'e':
if (memEQ(name, "uniqu", 5)) {
- if (SvTYPE(sv) == SVt_PVGV) {
+ if (isGV_with_GP(sv)) {
if (negated) {
GvUNIQUE_off(sv);
} else {
@@ -216,7 +216,7 @@ usage:
XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
break;
case SVt_PVGV:
- if (GvUNIQUE(sv))
+ if (isGV_with_GP(sv) && GvUNIQUE(sv))
XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
break;
default:
@@ -260,7 +260,7 @@ usage:
stash = CvSTASH(sv);
break;
case SVt_PVGV:
- if (GvGP(sv) && GvESTASH((GV*)sv))
+ if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH((GV*)sv))
stash = GvESTASH((GV*)sv);
break;
default:
- Follow-Ups from:
-
"Rafael Garcia-Suarez" <rgarciasuarez@gmail.com>
Nicholas Clark <nick@ccl4.org>
[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]