On Tuesday 30 March 2010 19:10:36 Torsten Förtsch wrote:
> 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 one is much simpler. It swaps the SvANY pointer of the handle to
be saved with the SvANY pointer of a newly allocated GvIO.
I believe the IoFLUSH_off in the override function can be omitted since
this is standard for a new handle.
Since the whole XPVIO structure is saved this way all information about
the original handle is preserved including IFP, OFP, TYPE and even a
possible format or $., $%, $= etc.
Now, the 2 functions look this way:
static GV *modperl_io_perlio_override_stdhandle(pTHX_ request_rec *r, int mode)
{
dHANDLE(mode == O_RDONLY ? "STDIN" : "STDOUT");
int status;
GV *handle_save = (GV*)Nullsv;
SV *sv = sv_newmortal();
IO *srcio, *destio;
void *tmp;
MP_TRACE_o(MP_FUNC, "start STD%s", mode == O_RDONLY ? "IN" : "OUT");
if (handle && SvTYPE(handle) == SVt_PVGV &&
IoTYPE(srcio=GvIO(handle)) != IoTYPE_CLOSED) {
handle_save = gv_fetchpv(Perl_form(aTHX_
"Apache2::RequestIO::_GEN_%ld",
(long)PL_gensym++),
GV_ADD, SVt_PVIO);
destio=GvIO(handle_save);
tmp=SvANY(destio);
SvANY(destio)=SvANY(srcio);
SvANY(srcio)=tmp;
}
sv_setref_pv(sv, "Apache2::RequestRec", (void*)r);
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 STD%s: %" SVf,
mode == O_RDONLY ? "IN" : "OUT", get_sv("!", TRUE));
}
if (mode != O_RDONLY) {
IoFLUSH_off(handle); /* STDOUT's $|=0 */
}
MP_TRACE_o(MP_FUNC, "end STD%s", mode==O_RDONLY ? "IN" : "OUT");
return handle_save;
}
static void modperl_io_perlio_restore_stdhandle(pTHX_ GV *handle, int mode)
{
GV *handle_orig = gv_fetchpv(mode == O_RDONLY ? "STDIN" : "STDOUT",
FALSE, SVt_PVIO);
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
* handler call, which may try to close STDOUT too. We will
* segfault, if that subrequest doesn't return before the the top
* level STDOUT is attempted to be closed. To prevent this
* situation always explicitly flush STDOUT, before reopening it.
*/
if (mode != O_RDONLY &&
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));
}
/* close the overriding filehandle */
do_close(handle_orig, FALSE);
if (handle != (GV*)Nullsv) {
IO *srcio, *destio;
void *tmp;
MP_TRACE_o(MP_FUNC, "restoring STD%s", mode == O_RDONLY ? "IN" : "OUT");
srcio=GvIO(handle);
destio=GvIO(handle_orig);
tmp=SvANY(destio);
SvANY(destio)=SvANY(srcio);
SvANY(srcio)=tmp;
(void)hv_delete(gv_stashpv("Apache2::RequestIO", TRUE),
GvNAME(handle), GvNAMELEN(handle), G_DISCARD);
}
MP_TRACE_o(MP_FUNC, "end STD%s", mode == O_RDONLY ? "IN" : "OUT");
}
Torsten Förtsch
--
Need professional modperl support? Hire me! (http://foertsch.name)
Like fantasy? http://kabatinte.net
Index: src/modules/perl/modperl_io.c
===================================================================
--- src/modules/perl/modperl_io.c (revision 929182)
+++ src/modules/perl/modperl_io.c (working copy)
@@ -104,137 +104,55 @@
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");
+ dHANDLE(mode == O_RDONLY ? "STDIN" : "STDOUT");
int status;
GV *handle_save = (GV*)Nullsv;
SV *sv = sv_newmortal();
+ IO *srcio, *destio;
+ void *tmp;
- 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(srcio=GvIO(handle)) != IoTYPE_CLOSED) {
handle_save = gv_fetchpv(Perl_form(aTHX_
"Apache2::RequestIO::_GEN_%ld",
(long)PL_gensym++),
- TRUE, SVt_PVIO);
+ GV_ADD, SVt_PVIO);
- /* open my $oldout, "<&STDIN" or die "Can't dup STDIN: $!"; */
- status = do_open(handle_save, "<&STDIN", 7, FALSE,
- O_RDONLY, 0, Nullfp);
- if (status == 0) {
- Perl_croak(aTHX_ "Failed to dup STDIN: %" SVf, get_sv("!", TRUE));
- }
+ destio=GvIO(handle_save);
- /* similar to PerlIO::scalar, the PerlIO::Apache layer doesn't
- * have file descriptors, so STDIN must be closed before it can
- * be reopened */
- do_close(handle, TRUE);
+ tmp=SvANY(destio);
+ SvANY(destio)=SvANY(srcio);
+ SvANY(srcio)=tmp;
}
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_RDONLY) {
+ 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)
+static void modperl_io_perlio_restore_stdhandle(pTHX_ GV *handle, int mode)
{
- GV *handle_orig = gv_fetchpv("STDIN", 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");
- /* 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");
-}
-
-MP_INLINE void modperl_io_perlio_restore_stdout(pTHX_ GV *handle)
-{
- GV *handle_orig = gv_fetchpv("STDOUT", FALSE, SVt_PVIO);
-
- MP_TRACE_o(MP_FUNC, "start");
-
/* since closing unflushed STDOUT may trigger a subrequest
* (e.g. via mod_include), resulting in potential another response
* handler call, which may try to close STDOUT too. We will
@@ -242,7 +160,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_RDONLY &&
+ 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));
}
@@ -250,28 +169,43 @@
/* close the overriding filehandle */
do_close(handle_orig, FALSE);
- /*
- * open STDOUT, ">&STDOUT_SAVED" or die "Can't dup STDOUT_SAVED: $!";
- * close STDOUT_SAVED;
- */
if (handle != (GV*)Nullsv) {
- SV *err = Nullsv;
+ IO *srcio, *destio;
+ void *tmp;
- 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) {
- err = get_sv("!", TRUE);
- }
+ srcio=GvIO(handle);
+ destio=GvIO(handle_orig);
- do_close(handle, FALSE);
+ tmp=SvANY(destio);
+ SvANY(destio)=SvANY(srcio);
+ SvANY(srcio)=tmp;
+
(void)hv_delete(gv_stashpv("Apache2::RequestIO", TRUE),
GvNAME(handle), GvNAMELEN(handle), G_DISCARD);
-
- if (err != Nullsv) {
- Perl_croak(aTHX_ "Failed to restore STDOUT: %" SVf, err);
- }
}
- MP_TRACE_o(MP_FUNC, "end");
+ MP_TRACE_o(MP_FUNC, "end STD%s", mode == O_RDONLY ? "IN" : "OUT");
}
+
+MP_INLINE GV *modperl_io_perlio_override_stdin(pTHX_ request_rec *r)
+{
+ return modperl_io_perlio_override_stdhandle(aTHX_ r, O_RDONLY);
+}
+
+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_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);
+}
+
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscr...@perl.apache.org
For additional commands, e-mail: dev-h...@perl.apache.org
