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

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

p4raw-id: //depot/perl@6527

diff --git a/embed.pl b/embed.pl
index e851a7a..3e4c7d5 100755 (executable)
--- 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 fde52c5..9bfe44a 100644 (file)
--- 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 b4cbb55..e3c0784 100644 (file)
--- 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 28597ea..b3e5f99 100644 (file)
--- 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 eb17d68..feef456 100644 (file)
--- 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 897360c..69dea5c 100644 (file)
--- 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);
+    }
 }