-:    0:Source:modperl_io.c
        -:    0:Object:modperl_io.bb
        -:    1:/* Copyright 2001-2004 The Apache Software Foundation
        -:    2: *
        -:    3: * Licensed under the Apache License, Version 2.0 (the "License");
        -:    4: * you may not use this file except in compliance with the License.
        -:    5: * You may obtain a copy of the License at
        -:    6: *
        -:    7: *     http://www.apache.org/licenses/LICENSE-2.0
        -:    8: *
        -:    9: * Unless required by applicable law or agreed to in writing, software
        -:   10: * distributed under the License is distributed on an "AS IS" BASIS,
        -:   11: * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
        -:   12: * See the License for the specific language governing permissions and
        -:   13: * limitations under the License.
        -:   14: */
        -:   15:
        -:   16:#include "mod_perl.h"
        -:   17:
        -:   18:#define TIEHANDLE(handle,r) \
        -:   19:modperl_io_handle_tie(aTHX_ handle, "Apache::RequestRec", (void *)r)
        -:   20:
        -:   21:#define TIED(handle) \
        -:   22:modperl_io_handle_tied(aTHX_ handle, "Apache::RequestRec")
        -:   23:
        -:   24:MP_INLINE void modperl_io_handle_tie(pTHX_ GV *handle,
        -:   25:                                     char *classname, void *ptr)
    #####:   26:{
    #####:   27:    SV *obj = modperl_ptr2obj(aTHX_ classname, ptr);
        -:   28:
    #####:   29:    modperl_io_handle_untie(aTHX_ handle);
        -:   30:
    #####:   31:    sv_magic(TIEHANDLE_SV(handle), obj, 'q', Nullch, 0);
        -:   32:
    #####:   33:    SvREFCNT_dec(obj); /* since sv_magic did SvREFCNT_inc */
        -:   34:
    #####:   35:    MP_TRACE_g(MP_FUNC, "tie *%s(0x%lx) => %s, REFCNT=%d\n",
        -:   36:               GvNAME(handle), (unsigned long)handle, classname,
        -:   37:               SvREFCNT(TIEHANDLE_SV(handle)));
        -:   38:}
        -:   39:
        -:   40:MP_INLINE GV *modperl_io_tie_stdin(pTHX_ request_rec *r)
    #####:   41:{
        -:   42:#if defined(MP_IO_TIE_SFIO)
        -:   43:    /* XXX */
        -:   44:#else
    #####:   45:    dHANDLE("STDIN");
        -:   46:
    #####:   47:    if (TIED(handle)) {
    #####:   48:        return handle;
        -:   49:    }
        -:   50:
    #####:   51:    TIEHANDLE(handle, r);
        -:   52:
    #####:   53:    return handle;
        -:   54:#endif
        -:   55:}
        -:   56:
        -:   57:MP_INLINE GV *modperl_io_tie_stdout(pTHX_ request_rec *r)
    #####:   58:{
        -:   59:#if defined(MP_IO_TIE_SFIO)
        -:   60:    /* XXX */
        -:   61:#else
    #####:   62:    dHANDLE("STDOUT");
        -:   63:
    #####:   64:    if (TIED(handle)) {
    #####:   65:        return handle;
        -:   66:    }
        -:   67:
    #####:   68:    IoFLUSH_off(PL_defoutgv); /* $|=0 */
        -:   69:
    #####:   70:    TIEHANDLE(handle, r);
        -:   71:
    #####:   72:    return handle;
        -:   73:#endif
        -:   74:}
        -:   75:
        -:   76:MP_INLINE int modperl_io_handle_tied(pTHX_ GV *handle, char *classname)
    #####:   77:{
    #####:   78:    MAGIC *mg;
    #####:   79:    SV *sv = TIEHANDLE_SV(handle);
        -:   80:
    #####:   81:    if (SvMAGICAL(sv) && (mg = mg_find(sv, 'q'))) {
    #####:   82:	char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj)));
        -:   83:
    #####:   84:	if (!strEQ(package, classname)) {
    #####:   85:	    MP_TRACE_g(MP_FUNC, "%s tied to %s\n", GvNAME(handle), package);
    #####:   86:	    return TRUE;
        -:   87:	}
        -:   88:    }
        -:   89:
    #####:   90:    return FALSE;
        -:   91:}
        -:   92:
        -:   93:MP_INLINE void modperl_io_handle_untie(pTHX_ GV *handle)
    #####:   94:{
        -:   95:#ifdef MP_TRACE
    #####:   96:    if (mg_find(TIEHANDLE_SV(handle), 'q')) {
    #####:   97:        MP_TRACE_g(MP_FUNC, "untie *%s(0x%lx), REFCNT=%d\n",
        -:   98:                   GvNAME(handle), (unsigned long)handle,
        -:   99:                   SvREFCNT(TIEHANDLE_SV(handle)));
        -:  100:    }
        -:  101:#endif
        -:  102:
    #####:  103:    sv_unmagic(TIEHANDLE_SV(handle), 'q');
        -:  104:}
        -:  105:
        -:  106:MP_INLINE GV *modperl_io_perlio_override_stdin(pTHX_ request_rec *r)
      127:  107:{
      127:  108:    dHANDLE("STDIN");
      127:  109:    int status;
      127:  110:    GV *handle_save = (GV*)Nullsv;
      127:  111:    SV *sv = sv_newmortal();
        -:  112:
      127:  113:    MP_TRACE_o(MP_FUNC, "start");
        -:  114:
        -:  115:    /* if STDIN is open, dup it, to be restored at the end of response */
      127:  116:    if (handle && SvTYPE(handle) == SVt_PVGV &&
        -:  117:        IoTYPE(GvIO(handle)) != IoTYPE_CLOSED) {
      125:  118:        handle_save = gv_fetchpv(Perl_form(aTHX_
        -:  119:                                           "Apache::RequestIO::_GEN_%ld",
        -:  120:                                           (long)PL_gensym++),
        -:  121:                                 TRUE, SVt_PVIO);
        -:  122:
        -:  123:        /* open my $oldout, "<&STDIN" or die "Can't dup STDIN: $!"; */
      125:  124:        status = Perl_do_open(aTHX_ handle_save, "<&STDIN", 7, FALSE,
        -:  125:                              O_RDONLY, 0, Nullfp);
      125:  126:        if (status == 0) {
    #####:  127:            Perl_croak(aTHX_ "Failed to dup STDIN: %_", get_sv("!", TRUE));
        -:  128:        }
        -:  129:
        -:  130:        /* similar to PerlIO::scalar, the PerlIO::Apache layer doesn't
        -:  131:         * have file descriptors, so STDIN must be closed before it can
        -:  132:         * be reopened */
      125:  133:        Perl_do_close(aTHX_ handle, TRUE);
        -:  134:    }
        -:  135:
      127:  136:    sv_setref_pv(sv, "Apache::RequestRec", (void*)r);
      127:  137:    status = Perl_do_open9(aTHX_ handle, "<:Apache", 8, FALSE, O_RDONLY,
        -:  138:                           0, Nullfp, sv, 1);
      127:  139:    if (status == 0) {
    #####:  140:        Perl_croak(aTHX_ "Failed to open STDIN: %_", get_sv("!", TRUE));
        -:  141:    }
        -:  142:
      127:  143:    MP_TRACE_o(MP_FUNC, "end\n");
        -:  144:
      127:  145:    return handle_save;
        -:  146:}
        -:  147:
        -:  148:/* XXX: refactor to merge with the previous function */
        -:  149:MP_INLINE GV *modperl_io_perlio_override_stdout(pTHX_ request_rec *r)
      127:  150:{
      127:  151:    dHANDLE("STDOUT");
      127:  152:    int status;
      127:  153:    GV *handle_save = (GV*)Nullsv;
      127:  154:    SV *sv = sv_newmortal();
        -:  155:
      127:  156:    MP_TRACE_o(MP_FUNC, "start");
        -:  157:
        -:  158:    /* if STDOUT is open, dup it, to be restored at the end of response */
      127:  159:    if (handle && SvTYPE(handle) == SVt_PVGV &&
        -:  160:        IoTYPE(GvIO(handle)) != IoTYPE_CLOSED) {
      125:  161:        handle_save = gv_fetchpv(Perl_form(aTHX_
        -:  162:                                           "Apache::RequestIO::_GEN_%ld",
        -:  163:                                           (long)PL_gensym++),
        -:  164:                                 TRUE, SVt_PVIO);
        -:  165:        
        -:  166:        /* open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!"; */
      125:  167:        status = Perl_do_open(aTHX_ handle_save, ">&STDOUT", 8, FALSE,
        -:  168:                              O_WRONLY, 0, Nullfp);
      125:  169:        if (status == 0) {
    #####:  170:            Perl_croak(aTHX_ "Failed to dup STDOUT: %_", get_sv("!", TRUE));
        -:  171:        }
        -:  172:
        -:  173:        /* similar to PerlIO::scalar, the PerlIO::Apache layer doesn't
        -:  174:         * have file descriptors, so STDOUT must be closed before it can
        -:  175:         * be reopened */
      125:  176:        Perl_do_close(aTHX_ handle, TRUE);
        -:  177:    }
        -:  178:
      127:  179:    sv_setref_pv(sv, "Apache::RequestRec", (void*)r);
      127:  180:    status = Perl_do_open9(aTHX_ handle, ">:Apache", 8, FALSE, O_WRONLY,
        -:  181:                           0, Nullfp, sv, 1);
      127:  182:    if (status == 0) {
    #####:  183:        Perl_croak(aTHX_ "Failed to open STDOUT: %_", get_sv("!", TRUE));
        -:  184:    }
        -:  185:
      127:  186:    MP_TRACE_o(MP_FUNC, "end\n");
        -:  187:
        -:  188:    /* XXX: shouldn't we preserve the value STDOUT had before it was
        -:  189:     * overridden? */
      127:  190:    IoFLUSH_off(handle); /* STDOUT's $|=0 */
        -:  191:
      127:  192:    return handle_save;
        -:  193:    
        -:  194:}
        -:  195:
        -:  196:MP_INLINE void modperl_io_perlio_restore_stdin(pTHX_ GV *handle)
      127:  197:{
      127:  198:    GV *handle_orig = gv_fetchpv("STDIN", FALSE, SVt_PVIO);
        -:  199:
      127:  200:    MP_TRACE_o(MP_FUNC, "start");
        -:  201:
        -:  202:    /* close the overriding filehandle */
      127:  203:    Perl_do_close(aTHX_ handle_orig, FALSE);
        -:  204:
        -:  205:    /*
        -:  206:     * open STDIN, "<&STDIN_SAVED" or die "Can't dup STDIN_SAVED: $!";
        -:  207:     * close STDIN_SAVED;
        -:  208:     */
      127:  209:    if (handle != (GV*)Nullsv) {
      125:  210:        SV *err = Nullsv;
        -:  211:        
      125:  212:        MP_TRACE_o(MP_FUNC, "restoring STDIN");
        -:  213:
      125:  214:        if (Perl_do_open9(aTHX_ handle_orig, "<&", 2, FALSE,
        -:  215:                          O_RDONLY, 0, Nullfp, (SV*)handle, 1) == 0) {
    #####:  216:            err = get_sv("!", TRUE);
        -:  217:        }
        -:  218:        
      125:  219:        Perl_do_close(aTHX_ handle, FALSE);
      125:  220:        (void)hv_delete(gv_stashpv("Apache::RequestIO", TRUE), 
        -:  221:                        GvNAME(handle), GvNAMELEN(handle), G_DISCARD);
        -:  222:
      125:  223:        if (err != Nullsv) {
    #####:  224:            Perl_croak(aTHX_ "Failed to restore STDIN: %_", err);
        -:  225:        }
        -:  226:    }
        -:  227:
      127:  228:    MP_TRACE_o(MP_FUNC, "end\n");
        -:  229:}
        -:  230:
        -:  231:MP_INLINE void modperl_io_perlio_restore_stdout(pTHX_ GV *handle)
      127:  232:{ 
      127:  233:    GV *handle_orig = gv_fetchpv("STDOUT", FALSE, SVt_PVIO);
        -:  234:
      127:  235:    MP_TRACE_o(MP_FUNC, "start");
        -:  236:
        -:  237:    /* since closing unflushed STDOUT may trigger a subrequest
        -:  238:     * (e.g. via mod_include), resulting in potential another response
        -:  239:     * handler call, which may try to close STDOUT too. We will
        -:  240:     * segfault, if that subrequest doesn't return before the the top
        -:  241:     * level STDOUT is attempted to be closed. To prevent this
        -:  242:     * situation always explicitly flush STDOUT, before reopening it.
        -:  243:     */
      127:  244:    if (GvIOn(handle_orig) && IoOFP(GvIOn(handle_orig)) &&
        -:  245:        (PerlIO_flush(IoOFP(GvIOn(handle_orig))) == -1)) {
    #####:  246:        Perl_croak(aTHX_ "Failed to flush STDOUT: %_", get_sv("!", TRUE));
        -:  247:    }
        -:  248:
        -:  249:    /* close the overriding filehandle */
      127:  250:    Perl_do_close(aTHX_ handle_orig, FALSE);
        -:  251:    
        -:  252:    /*
        -:  253:     * open STDOUT, ">&STDOUT_SAVED" or die "Can't dup STDOUT_SAVED: $!";
        -:  254:     * close STDOUT_SAVED;
        -:  255:     */
      127:  256:    if (handle != (GV*)Nullsv) {
      125:  257:        SV *err = Nullsv;
        -:  258:        
      125:  259:        MP_TRACE_o(MP_FUNC, "restoring STDOUT");
        -:  260:
      125:  261:        if (Perl_do_open9(aTHX_ handle_orig, ">&", 2, FALSE,
        -:  262:                          O_WRONLY, 0, Nullfp, (SV*)handle, 1) == 0) {
    #####:  263:            err = get_sv("!", TRUE);
        -:  264:        }
        -:  265:        
      125:  266:        Perl_do_close(aTHX_ handle, FALSE);
      125:  267:        (void)hv_delete(gv_stashpv("Apache::RequestIO", TRUE), 
        -:  268:                        GvNAME(handle), GvNAMELEN(handle), G_DISCARD);
        -:  269:
      125:  270:        if (err != Nullsv) {
    #####:  271:            Perl_croak(aTHX_ "Failed to restore STDOUT: %_", err);
        -:  272:        }
        -:  273:    }
        -:  274:
      127:  275:    MP_TRACE_o(MP_FUNC, "end\n");
        -:  276:}