develooper Front page | perl.perl5.changes | Postings from June 2008

Change 34092: Some more missing isGV_with_GP()s

From:
Rafael Garcia-Suarez
Date:
June 28, 2008 14:15
Subject:
Change 34092: Some more missing isGV_with_GP()s
Message ID:
20080628211508.579AE50008@mx.activestate.com
Change 34092 by rgs@stcosmo on 2008/06/28 21:06:57

	Subject: Some more missing isGV_with_GP()s
	From: Ben Morrow <ben@morrow.me.uk>
	Date: Sat, 28 Jun 2008 17:00:17 +0100
	Message-ID: <20080628160017.GA81579@osiris.mauzo.dyndns.org>

Affected files ...

... //depot/perl/MANIFEST#1709 edit
... //depot/perl/doio.c#370 edit
... //depot/perl/ext/IO/t/io_taint.t#3 edit
... //depot/perl/mg.c#530 edit
... //depot/perl/pp.c#630 edit
... //depot/perl/pp_ctl.c#694 edit
... //depot/perl/pp_hot.c#577 edit
... //depot/perl/pp_sys.c#561 edit
... //depot/perl/sv.c#1544 edit
... //depot/perl/t/io/pvbm.t#1 add
... //depot/perl/t/op/attrs.t#19 edit
... //depot/perl/t/op/inc.t#15 edit
... //depot/perl/t/op/inccode.t#16 edit
... //depot/perl/t/op/magic.t#84 edit
... //depot/perl/t/op/ref.t#36 edit
... //depot/perl/t/op/undef.t#12 edit
... //depot/perl/xsutils.c#56 edit

Differences ...

==== //depot/perl/MANIFEST#1709 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#1708~34001~	2008-06-05 06:04:00.000000000 -0700
+++ perl/MANIFEST	2008-06-28 14:06:57.000000000 -0700
@@ -3556,6 +3556,7 @@
 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

==== //depot/perl/doio.c#370 (text) ====
Index: perl/doio.c
--- perl/doio.c#369~33766~	2008-04-30 01:17:51.000000000 -0700
+++ perl/doio.c	2008-06-28 14:06:57.000000000 -0700
@@ -926,7 +926,7 @@
 
     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 @@
 	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 @@
     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 @@
 	    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 @@
 			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 @@
 	    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 @@
 			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 @@
 	    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 @@
 			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;
 		}

==== //depot/perl/ext/IO/t/io_taint.t#3 (xtext) ====
Index: perl/ext/IO/t/io_taint.t
--- perl/ext/IO/t/io_taint.t#2~27609~	2006-03-25 18:49:11.000000000 -0800
+++ perl/ext/IO/t/io_taint.t	2008-06-28 14:06:57.000000000 -0700
@@ -18,7 +18,7 @@
 
 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 "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;

==== //depot/perl/mg.c#530 (text) ====
Index: perl/mg.c
--- perl/mg.c#529~33898~	2008-05-21 06:00:13.000000000 -0700
+++ perl/mg.c	2008-06-28 14:06:57.000000000 -0700
@@ -1497,7 +1497,7 @@
 	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

==== //depot/perl/pp.c#630 (text) ====
Index: perl/pp.c
--- perl/pp.c#629~33981~	2008-06-01 12:32:34.000000000 -0700
+++ perl/pp.c	2008-06-28 14:06:57.000000000 -0700
@@ -143,11 +143,11 @@
 	    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 @@
     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 @@
 	}
 	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 @@
 	    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_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_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_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)

==== //depot/perl/pp_ctl.c#694 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#693~34069~	2008-06-17 04:16:38.000000000 -0700
+++ perl/pp_ctl.c	2008-06-28 14:06:57.000000000 -0700
@@ -3353,11 +3353,11 @@
 			    }
 			}
 
-			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;

==== //depot/perl/pp_hot.c#577 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c#576~33778~	2008-05-02 04:44:25.000000000 -0700
+++ perl/pp_hot.c	2008-06-28 14:06:57.000000000 -0700
@@ -307,8 +307,8 @@
     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_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 @@
 	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 @@
     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 @@
 
     /* 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",

==== //depot/perl/pp_sys.c#561 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c#560~33770~	2008-04-30 04:51:12.000000000 -0700
+++ perl/pp_sys.c	2008-06-28 14:06:57.000000000 -0700
@@ -607,7 +607,7 @@
     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 @@
 	    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 @@
     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 @@
     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 @@
 	    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 @@
     }
     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 @@
 	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 {

==== //depot/perl/sv.c#1544 (text) ====
Index: perl/sv.c
--- perl/sv.c#1543~34084~	2008-06-24 06:30:23.000000000 -0700
+++ perl/sv.c	2008-06-28 14:06:57.000000000 -0700
@@ -1543,6 +1543,8 @@
 	break;
 
     case SVt_PVGV:
+	if (!isGV_with_GP(sv))
+	    break;
     case SVt_PVAV:
     case SVt_PVHV:
     case SVt_PVCV:
@@ -1650,6 +1652,8 @@
 	break;
 
     case SVt_PVGV:
+	if (!isGV_with_GP(sv))
+	    break;
     case SVt_PVAV:
     case SVt_PVHV:
     case SVt_PVCV:
@@ -7818,11 +7822,14 @@
 	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 @@
 	*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 @@
 		*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 @@
 	    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 @@
 	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";

==== //depot/perl/t/io/pvbm.t#1 (text) ====
Index: perl/t/io/pvbm.t
--- /dev/null	2008-05-07 15:08:24.549929899 -0700
+++ perl/t/io/pvbm.t	2008-06-28 14:06:57.000000000 -0700
@@ -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');
+}

==== //depot/perl/t/op/attrs.t#19 (text) ====
Index: perl/t/op/attrs.t
--- perl/t/op/attrs.t#18~31333~	2007-06-05 03:10:33.000000000 -0700
+++ perl/t/op/attrs.t	2008-06-28 14:06:57.000000000 -0700
@@ -10,7 +10,7 @@
     require './test.pl';
 }
 
-plan 'no_plan';
+plan 90;
 
 $SIG{__WARN__} = sub { die @_ };
 
@@ -185,3 +185,10 @@
 	}
     }
 }
+
+# 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';

==== //depot/perl/t/op/inc.t#15 (xtext) ====
Index: perl/t/op/inc.t
--- perl/t/op/inc.t#14~33049~	2008-01-23 01:18:41.000000000 -0800
+++ perl/t/op/inc.t	2008-06-28 14:06:57.000000000 -0700
@@ -2,7 +2,7 @@
 
 # use strict;
 
-print "1..50\n";
+print "1..54\n";
 
 my $test = 1;
 
@@ -270,3 +270,14 @@
     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 });
+

==== //depot/perl/t/op/inccode.t#16 (text) ====
Index: perl/t/op/inccode.t
--- perl/t/op/inccode.t#15~30600~	2007-03-15 10:18:18.000000000 -0700
+++ perl/t/op/inccode.t	2008-06-28 14:06:57.000000000 -0700
@@ -23,7 +23,7 @@
 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 @@
     @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: {

==== //depot/perl/t/op/magic.t#84 (xtext) ====
Index: perl/t/op/magic.t
--- perl/t/op/magic.t#83~31809~	2007-09-07 01:38:54.000000000 -0700
+++ perl/t/op/magic.t	2008-06-28 14:06:57.000000000 -0700
@@ -36,7 +36,7 @@
     return 1;
 }
 
-print "1..58\n";
+print "1..59\n";
 
 $Is_MSWin32  = $^O eq 'MSWin32';
 $Is_NetWare  = $^O eq 'NetWare';
@@ -131,7 +131,23 @@
     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?

==== //depot/perl/t/op/ref.t#36 (xtext) ====
Index: perl/t/op/ref.t
--- perl/t/op/ref.t#35~30915~	2007-04-11 12:48:36.000000000 -0700
+++ perl/t/op/ref.t	2008-06-28 14:06:57.000000000 -0700
@@ -8,7 +8,7 @@
 require 'test.pl';
 use strict qw(refs subs);
 
-plan(138);
+plan(182);
 
 # Test glob operations.
 
@@ -54,11 +54,6 @@
 $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 @@
 
 # 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($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);

==== //depot/perl/t/op/undef.t#12 (xtext) ====
Index: perl/t/op/undef.t
--- perl/t/op/undef.t#11~19424~	2003-05-05 08:44:39.000000000 -0700
+++ perl/t/op/undef.t	2008-06-28 14:06:57.000000000 -0700
@@ -5,7 +5,7 @@
     @INC = '../lib';
 }
 
-print "1..36\n";
+print "1..37\n";
 
 print defined($a) ? "not ok 1\n" : "ok 1\n";
 
@@ -102,3 +102,13 @@
     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++;

==== //depot/perl/xsutils.c#56 (text) ====
Index: perl/xsutils.c
--- perl/xsutils.c#55~33901~	2008-05-21 06:35:43.000000000 -0700
+++ perl/xsutils.c	2008-06-28 14:06:57.000000000 -0700
@@ -120,7 +120,7 @@
 		    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 @@
 	    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 @@
 		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:
End of Patch.



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About