2010/3/30 Torsten Förtsch <[email protected]>:
> Hi,
>
> the patch below is a raw fix for the "mod_perl closes apache's stdin and/or
> stdout"-bug, see also
>
> http://www.gossamer-threads.com/lists/modperl/modperl/94921
Posting a copy of the patch inline for the archives. Thanks for
putting this together Torsten.
Index: src/modules/perl/modperl_io.c
===================================================================
--- src/modules/perl/modperl_io.c (revision 929182)
+++ src/modules/perl/modperl_io.c (working copy)
@@ -104,28 +104,39 @@
sv_unmagic(TIEHANDLE_SV(handle), PERL_MAGIC_tiedscalar);
}
-MP_INLINE GV *modperl_io_perlio_override_stdin(pTHX_ request_rec *r)
+static GV *modperl_io_perlio_override_stdhandle(pTHX_ request_rec *r, int mode)
{
- dHANDLE("STDIN");
- int status;
+ dHANDLE(mode == O_RDONLY ? "STDIN" : "STDOUT");
+ int status, fileno;
GV *handle_save = (GV*)Nullsv;
SV *sv = sv_newmortal();
+ SV *gsv;
+ IO *io;
- MP_TRACE_o(MP_FUNC, "start");
+ MP_TRACE_o(MP_FUNC, "start STD%s", mode == O_RDONLY ? "IN" : "OUT");
/* if STDIN is open, dup it, to be restored at the end of response */
if (handle && SvTYPE(handle) == SVt_PVGV &&
- IoTYPE(GvIO(handle)) != IoTYPE_CLOSED) {
+ IoTYPE(io=GvIO(handle)) != IoTYPE_CLOSED &&
+ (fileno=PerlIO_fileno(IoIFP(io))) >= 0) {
handle_save = gv_fetchpv(Perl_form(aTHX_
"Apache2::RequestIO::_GEN_%ld",
(long)PL_gensym++),
- TRUE, SVt_PVIO);
+ GV_ADD, SVt_PVIO);
+ if (!GvSV(handle_save)) GvSV(handle_save) = newSV(0);
+ gsv=GvSV(handle_save);
- /* open my $oldout, "<&STDIN" or die "Can't dup STDIN: $!"; */
- status = do_open(handle_save, "<&STDIN", 7, FALSE,
- O_RDONLY, 0, Nullfp);
+ /* open my $oldout, "<&=".fileno(STDIN) or die "Can't dup
STDIN: $!"; */
+ SvUPGRADE(gsv, SVt_PV);
+ SvGROW(gsv, 20);
+ sv_setpvf(gsv, mode == O_RDONLY ? "<&=%d" : ">&=%d", fileno);
+
+ status = do_open(handle_save, SvPVX(GvSV(handle_save)),
+ SvCUR(GvSV(handle_save)), FALSE, mode, 0, Nullfp);
+
if (status == 0) {
- Perl_croak(aTHX_ "Failed to dup STDIN: %" SVf, get_sv("!", TRUE));
+ Perl_croak(aTHX_ "Failed to dup STD%s: %" SVf,
+ mode == O_RDONLY ? "IN" : "OUT", get_sv("!", TRUE));
}
/* similar to PerlIO::scalar, the PerlIO::Apache layer doesn't
@@ -135,105 +146,41 @@
}
sv_setref_pv(sv, "Apache2::RequestRec", (void*)r);
- status = do_open9(handle, "<:Apache2", 9, FALSE, O_RDONLY,
- 0, Nullfp, sv, 1);
+ status = do_open9(handle, mode == O_RDONLY ? "<:Apache2" : ">:Apache2",
+ 9, FALSE, mode, 0, Nullfp, sv, 1);
if (status == 0) {
- Perl_croak(aTHX_ "Failed to open STDIN: %" SVf, get_sv("!", TRUE));
+ Perl_croak(aTHX_ "Failed to open STD%s: %" SVf,
+ mode == O_RDONLY ? "IN" : "OUT", get_sv("!", TRUE));
}
- MP_TRACE_o(MP_FUNC, "end");
-
- return handle_save;
-}
-
-/* XXX: refactor to merge with the previous function */
-MP_INLINE GV *modperl_io_perlio_override_stdout(pTHX_ request_rec *r)
-{
- dHANDLE("STDOUT");
- int status;
- GV *handle_save = (GV*)Nullsv;
- SV *sv = sv_newmortal();
-
- MP_TRACE_o(MP_FUNC, "start");
-
- /* if STDOUT is open, dup it, to be restored at the end of response */
- if (handle && SvTYPE(handle) == SVt_PVGV &&
- IoTYPE(GvIO(handle)) != IoTYPE_CLOSED) {
- handle_save = gv_fetchpv(Perl_form(aTHX_
- "Apache2::RequestIO::_GEN_%ld",
- (long)PL_gensym++),
- TRUE, SVt_PVIO);
-
- /* open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!"; */
- status = do_open(handle_save, ">&STDOUT", 8, FALSE,
- O_WRONLY, 0, Nullfp);
- if (status == 0) {
- Perl_croak(aTHX_ "Failed to dup STDOUT: %" SVf, get_sv("!", TRUE));
- }
-
- /* similar to PerlIO::scalar, the PerlIO::Apache layer doesn't
- * have file descriptors, so STDOUT must be closed before it can
- * be reopened */
- do_close(handle, TRUE);
+ if (mode == O_WRONLY) {
+ /* XXX: shouldn't we preserve the value STDOUT had before it was
+ * overridden? */
+ IoFLUSH_off(handle); /* STDOUT's $|=0 */
}
- sv_setref_pv(sv, "Apache2::RequestRec", (void*)r);
- status = do_open9(handle, ">:Apache2", 9, FALSE, O_WRONLY,
- 0, Nullfp, sv, 1);
- if (status == 0) {
- Perl_croak(aTHX_ "Failed to open STDOUT: %" SVf, get_sv("!", TRUE));
- }
+ MP_TRACE_o(MP_FUNC, "end STD%s", mode==O_RDONLY ? "IN" : "OUT");
- MP_TRACE_o(MP_FUNC, "end");
-
- /* XXX: shouldn't we preserve the value STDOUT had before it was
- * overridden? */
- IoFLUSH_off(handle); /* STDOUT's $|=0 */
-
return handle_save;
-
}
-MP_INLINE void modperl_io_perlio_restore_stdin(pTHX_ GV *handle)
+MP_INLINE GV *modperl_io_perlio_override_stdin(pTHX_ request_rec *r)
{
- GV *handle_orig = gv_fetchpv("STDIN", FALSE, SVt_PVIO);
+ return modperl_io_perlio_override_stdhandle(aTHX_ r, O_RDONLY);
+}
- MP_TRACE_o(MP_FUNC, "start");
-
- /* close the overriding filehandle */
- do_close(handle_orig, FALSE);
-
- /*
- * open STDIN, "<&STDIN_SAVED" or die "Can't dup STDIN_SAVED: $!";
- * close STDIN_SAVED;
- */
- if (handle != (GV*)Nullsv) {
- SV *err = Nullsv;
-
- MP_TRACE_o(MP_FUNC, "restoring STDIN");
-
- if (do_open9(handle_orig, "<&", 2, FALSE,
- O_RDONLY, 0, Nullfp, (SV*)handle, 1) == 0) {
- err = get_sv("!", TRUE);
- }
-
- do_close(handle, FALSE);
- (void)hv_delete(gv_stashpv("Apache2::RequestIO", TRUE),
- GvNAME(handle), GvNAMELEN(handle), G_DISCARD);
-
- if (err != Nullsv) {
- Perl_croak(aTHX_ "Failed to restore STDIN: %" SVf, err);
- }
- }
-
- MP_TRACE_o(MP_FUNC, "end");
+/* XXX: refactor to merge with the previous function */
+MP_INLINE GV *modperl_io_perlio_override_stdout(pTHX_ request_rec *r)
+{
+ return modperl_io_perlio_override_stdhandle(aTHX_ r, O_WRONLY);
}
-MP_INLINE void modperl_io_perlio_restore_stdout(pTHX_ GV *handle)
+static void modperl_io_perlio_restore_stdhandle(pTHX_ GV *handle, int mode)
{
- GV *handle_orig = gv_fetchpv("STDOUT", FALSE, SVt_PVIO);
+ GV *handle_orig = gv_fetchpv(mode == O_RDONLY ? "STDIN" : "STDOUT",
+ FALSE, SVt_PVIO);
- MP_TRACE_o(MP_FUNC, "start");
+ MP_TRACE_o(MP_FUNC, "start STD%s", mode == O_RDONLY ? "IN" : "OUT");
/* since closing unflushed STDOUT may trigger a subrequest
* (e.g. via mod_include), resulting in potential another response
@@ -242,7 +189,8 @@
* level STDOUT is attempted to be closed. To prevent this
* situation always explicitly flush STDOUT, before reopening it.
*/
- if (GvIOn(handle_orig) && IoOFP(GvIOn(handle_orig)) &&
+ if (mode == O_WRONLY &&
+ GvIOn(handle_orig) && IoOFP(GvIOn(handle_orig)) &&
(PerlIO_flush(IoOFP(GvIOn(handle_orig))) == -1)) {
Perl_croak(aTHX_ "Failed to flush STDOUT: %" SVf, get_sv("!", TRUE));
}
@@ -251,16 +199,15 @@
do_close(handle_orig, FALSE);
/*
- * open STDOUT, ">&STDOUT_SAVED" or die "Can't dup STDOUT_SAVED: $!";
- * close STDOUT_SAVED;
+ * open STDIN, "<&=$FD_SAVED" or die "Can't dup STDIN_SAVED: $!";
*/
if (handle != (GV*)Nullsv) {
SV *err = Nullsv;
- MP_TRACE_o(MP_FUNC, "restoring STDOUT");
+ MP_TRACE_o(MP_FUNC, "restoring STD%s", mode == O_RDONLY ?
"IN" : "OUT");
- if (do_open9(handle_orig, ">&", 2, FALSE,
- O_WRONLY, 0, Nullfp, (SV*)handle, 1) == 0) {
+ if (do_open(handle_orig, SvPVX(GvSV(handle)), SvCUR(GvSV(handle)),
+ FALSE, mode, 0, NULL) == 0) {
err = get_sv("!", TRUE);
}
@@ -269,9 +216,21 @@
GvNAME(handle), GvNAMELEN(handle), G_DISCARD);
if (err != Nullsv) {
- Perl_croak(aTHX_ "Failed to restore STDOUT: %" SVf, err);
+ Perl_croak(aTHX_ "Failed to restore STD: %" SVf,
+ mode == O_RDONLY ? "IN" : "OUT", err);
}
}
- MP_TRACE_o(MP_FUNC, "end");
+ MP_TRACE_o(MP_FUNC, "end STD%s", mode == O_RDONLY ? "IN" : "OUT");
}
+
+MP_INLINE void modperl_io_perlio_restore_stdin(pTHX_ GV *handle)
+{
+ modperl_io_perlio_restore_stdhandle(aTHX_ handle, O_RDONLY);
+}
+
+MP_INLINE void modperl_io_perlio_restore_stdout(pTHX_ GV *handle)
+{
+ modperl_io_perlio_restore_stdhandle(aTHX_ handle, O_WRONLY);
+}
+
>
> Previously the code did something similar to
>
> open SAVEFH, '<&STDIN';
> close STDIN;
> ...
> open STDIN, '<&SAVEFH';
>
> The idea is to change that into
>
> open SAVEFH, '<&='.fileno(STDIN);
> close STDIN;
> ...
> open STDIN, '<&='.fileno(SAVEFH);
>
> This avoids calling dup().
>
> This is the first time I do something Perl-IO-related in C. So, please review!
> One thing that I don't understand is the difference between IoIFP and IoOFP.
> Why does perl need 2 such structures to hold 1 file handle?
>
> Torsten Förtsch
>
> --
> Need professional modperl support? Hire me! (http://foertsch.name)
>
> Like fantasy? http://kabatinte.net
>
>
> ---------------------------------------------------------------------
> To unsubscribe, e-mail: [email protected]
> For additional commands, e-mail: [email protected]
>
---------------------------------------------------------------------
To unsubscribe, e-mail: [email protected]
For additional commands, e-mail: [email protected]
