From: Ronald F. Guilmette Date: Mon, 24 Jul 2000 15:47:00 +0000 (-0700) Subject: [ID 20000724.004] Perl interpreter segfault when using built-in flock X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bc37a18f04c6e2feea5bb9e2e546e59c37c7c04a;p=p5sagit%2Fp5-mst-13.2.git [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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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); + } }