On Wednesday 31 March 2010 17:55:47 Fred Moyer wrote: > Can you repost the latest patch inline so that interested parties can > add comments and understand what is going on in there? I know that > only a few people understand the innards of mod_perl with XS magic, > but just getting it out there will help with that and the more eyes on > the code the better. > Let me explain what the patch does. As mentioned before the previous code did something like this:
open SAVEFH, '<&STDIN'; close STDIN; ... open STDIN, '<&SAVEFH'; This code opens SAVEFH on a different file descriptor. Before STDIN is closed fileno(SAVEFH)!=fileno(STDIN). Later, when STDIN is restored from STDIN it is still the same file but it is not necessarily bound to file descriptor 0. This is the heart of the problem. My first solution replaced the dup() by an fdopen(). Thus, the file descriptor remains the same. open SAVEFH, '<&='.fileno(STDIN); close STDIN; ... open STDIN, '<&='.fileno(SAVEFH); But in Perl there is more data related to a file handle save for the file descriptor. There are flags like $|, integer values like $. or $=, even GVs. Both of the approaches above destroy that information. After studying Reini Urban's and Gisle Aas' illguts document: http://rurban.xarch.at/software/perl/illguts/ http://cpansearch.perl.org/src/GAAS/illguts-0.09/index.html it occurred to me that just exchanging one pointer would be enough to solve all the problems. GvIO(handle) returns an IO* pointer. The first element of this structure, the SvANY-element, points to a struct xpvio. This structure contains all of the data related to a file handle except for the reference count. So, to save a standard handle the code now creates a new GV. Then swaps its SvANY(GvIO(newhandle)) for SvANY(GvIO(STDIN)). Now STDIN looks like a fresh, still closed file handle. So it can be opened with the Apache2 perlio layer as before. The restoring code then flushes and closes the STD{IN,OUT} handle. After that any resources bound to an open file handle are destroyed. So, it's safe to undo the swap-operation. Then the temporary handle is destroyed and the standard handle looks exactly the same as it has before the whole operation. I think, this is the safest (and fastest) way to do preserve a file handle. Now, one could do such stuff: <Perl> open STDIN, '<', '/dev/urandom'; { package My::XXX; use Apache2::RequestRec (); use Apache2::Const -compile=>'OK'; sub handler { my ($r)=...@_; local $/=\10; my $str=readline STDIN; $r->print("$.: ".unpack('H*',$str)."\n"); return Apache2::Const::OK; } } </Perl> <Location /My__XXX/mp> SetHandler modperl PerlResponseHandler My::XXX </Location> <Location /My__XXX/ps> SetHandler perl-script PerlResponseHandler My::XXX </Location> and intermix calls to /My__XXX/mp with calls to /My__XXX/ps on the same apache instance. And $. will still count upwards. $ curl http://localhost:8529/My__XXX/mp 1: 645d1c3a880c15a4f889 $ curl http://localhost:8529/My__XXX/ps 0: $ curl http://localhost:8529/My__XXX/mp 2: 86b0ebdc88936475ef21 $ curl http://localhost:8529/My__XXX/ps 0: $ curl http://localhost:8529/My__XXX/mp 3: 91de660a45e64a2a6dfb $ curl http://localhost:8529/My__XXX/ps 0: $ curl http://localhost:8529/My__XXX/mp 4: f4184c04e20422a67bd9 httpd was started with -D ONE_PROCESS. $. is preserved. 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,51 @@ 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"); + MP_TRACE_o(MP_FUNC, "end STD%s", mode==O_RDONLY ? "IN" : "OUT"); return handle_save; } -/* XXX: refactor to merge with the previous function */ -MP_INLINE GV *modperl_io_perlio_override_stdout(pTHX_ request_rec *r) +static void modperl_io_perlio_restore_stdhandle(pTHX_ GV *handle, int mode) { - dHANDLE("STDOUT"); - int status; - GV *handle_save = (GV*)Nullsv; - SV *sv = sv_newmortal(); + 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"); - /* 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); - } - - 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"); - - /* 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) -{ - GV *handle_orig = gv_fetchpv("STDIN", FALSE, SVt_PVIO); - - 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"); -} - -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 +156,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 +165,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); +} + Torsten Förtsch -- Need professional modperl support? Hire me! (http://foertsch.name) Like fantasy? http://kabatinte.net --------------------------------------------------------------------- To unsubscribe, e-mail: dev-unsubscr...@perl.apache.org For additional commands, e-mail: dev-h...@perl.apache.org
