[ID 20000724.004] Perl interpreter segfault when using built-in flock

Message-Id: <200007242247.PAA52177@monkeys.com>

p4raw-id: //depot/perl@6527

6 files changed, 68 insertions, 48 deletions

diff --git a/embed.pl b/embed.pl
index e851a7aaf0..3e4c7d5b4f 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2077,7 +2077,7 @@ Ap	|U8*	|uv_to_utf8	|U8 *d|UV uv
 p	|void	|vivify_defelem	|SV* sv
 p	|void	|vivify_ref	|SV* sv|U32 to_what
 p	|I32	|wait4pid	|Pid_t pid|int* statusp|int flags
-p	|void	|report_closed_fh|GV *gv|IO *io|const char *func|const char *obj
+p	|void	|report_evil_fh	|GV *gv|IO *io|I32 op
 p	|void	|report_uninit
 Afpd	|void	|warn		|const char* pat|...
 Ap	|void	|vwarn		|const char* pat|va_list* args
diff --git a/pp_hot.c b/pp_hot.c
index fde52c5714..9bfe44ad8a 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -417,7 +417,7 @@ PP(pp_print)
 			    SvPV(sv,n_a));
 	    }
 	    else if (ckWARN(WARN_CLOSED))
-		report_closed_fh(gv, io, "print", "filehandle");
+		report_evil_fh(gv, io, PL_op->op_type);
 	}
 	SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
 	goto just_say_no;
@@ -1394,7 +1394,7 @@ Perl_do_readline(pTHX)
 			    "glob failed (can't start child: %s)",
 			    Strerror(errno));
 	    else
-		report_closed_fh(PL_last_in_gv, io, "readline", "filehandle");
+		report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
 	}
 	if (gimme == G_SCALAR) {
 	    (void)SvOK_off(TARG);
diff --git a/pp_sys.c b/pp_sys.c
index b4cbb55254..e3c0784d4c 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1281,7 +1281,7 @@ PP(pp_leavewrite)
 			    SvPV_nolen(sv));
 	    }
 	    else if (ckWARN(WARN_CLOSED))
-		report_closed_fh(gv, io, "write", "filehandle");
+		report_evil_fh(gv, io, PL_op->op_type);
 	}
 	PUSHs(&PL_sv_no);
     }
@@ -1361,7 +1361,7 @@ PP(pp_prtf)
 			    SvPV(sv,n_a));
 	    }
 	    else if (ckWARN(WARN_CLOSED))
-		report_closed_fh(gv, io, "printf", "filehandle");
+		report_evil_fh(gv, io, PL_op->op_type);
 	}
 	SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
 	goto just_say_no;
@@ -1630,12 +1630,8 @@ PP(pp_send)
     io = GvIO(gv);
     if (!io || !IoIFP(io)) {
 	retval = -1;
-	if (ckWARN(WARN_CLOSED)) {
-	    if (PL_op->op_type == OP_SYSWRITE)
-		report_closed_fh(gv, io, "syswrite", "filehandle");
-	    else
-		report_closed_fh(gv, io, "send", "socket");
-	}
+	if (ckWARN(WARN_CLOSED))
+	    report_evil_fh(gv, io, PL_op->op_type);
     }
     else if (PL_op->op_type == OP_SYSWRITE) {
 	if (MARK < SP) {
@@ -1992,6 +1988,7 @@ PP(pp_flock)
     I32 value;
     int argtype;
     GV *gv;
+    IO *io = NULL;
     PerlIO *fp;
 
 #ifdef FLOCK
@@ -2000,19 +1997,21 @@ PP(pp_flock)
 	gv = PL_last_in_gv;
     else
 	gv = (GV*)POPs;
-    if (gv && GvIO(gv))
-	fp = IoIFP(GvIOp(gv));
-    else
+    if (gv && (io = GvIO(gv)))
+	fp = IoIFP(io);
+    else {
 	fp = Nullfp;
+	io = NULL;
+    }
     if (fp) {
 	(void)PerlIO_flush(fp);
 	value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
     }
     else {
+	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+	    report_evil_fh(gv, io, PL_op->op_type);
 	value = 0;
 	SETERRNO(EBADF,RMS$_IFI);
-	if (ckWARN(WARN_CLOSED))
-	    report_closed_fh(gv, GvIO(gv), "flock", "filehandle");
     }
     PUSHi(value);
     RETURN;
@@ -2173,7 +2172,7 @@ PP(pp_bind)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-	report_closed_fh(gv, io, "bind", "socket");
+	report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
     RETPUSHUNDEF;
 #else
@@ -2203,7 +2202,7 @@ PP(pp_connect)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-	report_closed_fh(gv, io, "connect", "socket");
+	report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
     RETPUSHUNDEF;
 #else
@@ -2229,7 +2228,7 @@ PP(pp_listen)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-	report_closed_fh(gv, io, "listen", "socket");
+	report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
     RETPUSHUNDEF;
 #else
@@ -2286,7 +2285,7 @@ PP(pp_accept)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-	report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket");
+	report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
 
 badexit:
@@ -2313,7 +2312,7 @@ PP(pp_shutdown)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-	report_closed_fh(gv, io, "shutdown", "socket");
+	report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,SS$_IVCHAN);
     RETPUSHUNDEF;
 #else
@@ -2392,9 +2391,7 @@ PP(pp_ssockopt)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-	report_closed_fh(gv, io,
-			 optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt",
-			 "socket");
+	report_evil_fh(gv, io, optype);
     SETERRNO(EBADF,SS$_IVCHAN);
 nuts2:
     RETPUSHUNDEF;
@@ -2467,10 +2464,7 @@ PP(pp_getpeername)
 
 nuts:
     if (ckWARN(WARN_CLOSED))
-	report_closed_fh(gv, io,
-			 optype == OP_GETSOCKNAME ? "getsockname"
-						  : "getpeername",
-			 "socket");
+	report_evil_fh(gv, io, optype);
     SETERRNO(EBADF,SS$_IVCHAN);
 nuts2:
     RETPUSHUNDEF;
diff --git a/proto.h b/proto.h
index 28597eaf07..b3e5f994fc 100644
--- a/proto.h
+++ b/proto.h
@@ -820,7 +820,7 @@ PERL_CALLCONV U8*	Perl_uv_to_utf8(pTHX_ U8 *d, UV uv);
 PERL_CALLCONV void	Perl_vivify_defelem(pTHX_ SV* sv);
 PERL_CALLCONV void	Perl_vivify_ref(pTHX_ SV* sv, U32 to_what);
 PERL_CALLCONV I32	Perl_wait4pid(pTHX_ Pid_t pid, int* statusp, int flags);
-PERL_CALLCONV void	Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj);
+PERL_CALLCONV void	Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op);
 PERL_CALLCONV void	Perl_report_uninit(pTHX);
 PERL_CALLCONV void	Perl_warn(pTHX_ const char* pat, ...)
 #ifdef CHECK_FORMAT
diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys
index eb17d68df9..feef456c7a 100644
--- a/t/pragma/warn/pp_sys
+++ b/t/pragma/warn/pp_sys
@@ -69,8 +69,10 @@
     getpeername STDIN;
 
   flock() on closed socket %s			[pp_flock]
+  flock() on closed socket			[pp_flock]
     close STDIN;
     flock STDIN, 8;
+    flock $a, 8;
 
   lstat() on filehandle %s			[pp_stat]
     lstat(STDIN);
@@ -209,19 +211,25 @@ EOM
     exit ;
   } 
 }
-use warnings 'closed' ;
+use warnings qw(unopened closed);
 close STDIN;
 flock STDIN, 8;
 opendir STDIN, ".";
 flock STDIN, 8;
-no warnings 'closed' ;
+flock FOO, 8;
+flock $a, 8;
+no warnings qw(unopened closed);
 flock STDIN, 8;
 opendir STDIN, ".";
 flock STDIN, 8;
+flock FOO, 8;
+flock $a, 8;
 EXPECT
 flock() on closed filehandle STDIN at - line 14.
 flock() on closed filehandle STDIN at - line 16.
 	(Are you trying to call flock() on dirhandle STDIN?)
+flock() on unopened filehandle FOO at - line 17.
+flock() on unopened filehandle at - line 18.
 ########
 # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername]
 use warnings 'io' ;
diff --git a/util.c b/util.c
index 897360cd66..69dea5c32b 100644
--- a/util.c
+++ b/util.c
@@ -3888,21 +3888,39 @@ Perl_my_atof(pTHX_ const char* s)
 }
 
 void
-Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj)
-{
-    SV *sv;
-    char *name;
-
-    assert(gv);
-
-    sv = sv_newmortal();
-    gv_efullname4(sv, gv, Nullch, FALSE);
-    name = SvPVX(sv);
-
-    Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name);
-
-    if (io && IoDIRP(io))
-	Perl_warner(aTHX_ WARN_CLOSED,
-		    "\t(Are you trying to call %s() on dirhandle %s?)\n",
-		    func, name);
+Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
+{
+    bool  closed = io && IoTYPE(io) == ' ';
+    char *vile = closed ? "closed"    : "unopened";
+    I32   warn = closed ? WARN_CLOSED : WARN_UNOPENED;
+    char *func =
+	op == OP_READLINE   ? "readline"  :
+	op == OP_LEAVEWRITE ? "write" :
+	PL_op_desc[op];
+    char *pars = OP_IS_FILETEST(op) ? "" : "()";
+    char *type = OP_IS_SOCKET(op)   ? "socket" : "filehandle";
+
+    if (isGV(gv)) {
+	SV *sv = sv_newmortal();
+	char *name;
+
+	gv_efullname4(sv, gv, Nullch, FALSE);
+	name = SvPVX(sv);
+
+	Perl_warner(aTHX_ warn, "%s%s on %s %s %s",
+		    func, pars, vile, type, name);
+
+	if (io && IoDIRP(io))
+	    Perl_warner(aTHX_ warn,
+			"\t(Are you trying to call %s%s on dirhandle %s?)\n",
+			func, pars, name);
+    } else {
+	Perl_warner(aTHX_ warn, "%s%s on %s %s",
+		    func, pars, vile, type);
+
+	if (io && IoDIRP(io))
+	    Perl_warner(aTHX_ warn,
+			"\t(Are you trying to call %s%s on dirhandle?)\n",
+			func, pars);
+    }
 }