summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--MANIFEST1
-rw-r--r--doio.c20
-rwxr-xr-xext/IO/t/io_taint.t13
-rw-r--r--mg.c2
-rw-r--r--pp.c21
-rw-r--r--pp_ctl.c4
-rw-r--r--pp_hot.c14
-rw-r--r--pp_sys.c43
-rw-r--r--sv.c37
-rw-r--r--t/io/pvbm.t81
-rw-r--r--t/op/attrs.t9
-rwxr-xr-xt/op/inc.t13
-rw-r--r--t/op/inccode.t25
-rwxr-xr-xt/op/magic.t20
-rwxr-xr-xt/op/ref.t66
-rwxr-xr-xt/op/undef.t12
-rw-r--r--xsutils.c6
17 files changed, 308 insertions, 79 deletions
diff --git a/MANIFEST b/MANIFEST
index 7889c28fb1..dd8bd129b1 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 b73f127a1e..c37f2dccac 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/ext/IO/t/io_taint.t b/ext/IO/t/io_taint.t
index 4a9b76e84b..1cec9d7baf 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/mg.c b/mg.c
index 6012d32f9e..30ac03599f 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 10dbb06c8a..ca9b3d99ad 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 fd8c87f0a9..93bfbb4365 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 64b5fc59f9..c3d15653de 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 833e5656af..481864b2c2 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 6431cbad37..0f6903cdd7 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/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++;
diff --git a/xsutils.c b/xsutils.c
index dcc8d09d8d..186405092f 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: