Some more missing isGV_with_GP()s

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

p4raw-id: //depot/perl@34092

diff --git a/MANIFEST b/MANIFEST
index 7889c28..dd8bd12 100644 (file)
--- 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 (file)
--- 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 4a9b76e..1cec9d7 100755 (executable)
--- 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 6012d32..30ac035 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 6431cba..0f6903c 100644 (file)
--- 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 (file)
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 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (executable)
--- 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 (executable)
--- 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 (executable)
--- 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 dcc8d09..1864050 100644 (file)
--- 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: