-:    0:Source:modperl_io_apache.c
        -:    0:Object:modperl_io_apache.bb
        -:    1:/* Copyright 2003-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:/* not too long so it won't wrap when posted in email */
        -:   19:#define IO_DUMP_LENGTH 35
        -:   20:/* dumping hundreds of lines in the trace, makes it hard to read. Get
        -:   21: * a string chunk of IO_DUMP_LENGTH or less */
        -:   22:#define IO_DUMP_FIRST_CHUNK(p, str, count)       \
        -:   23:    count < IO_DUMP_LENGTH                       \
        -:   24:        ? (char *)str                            \
        -:   25:        : (char *)apr_psprintf(p, "%s...",       \
        -:   26:                               apr_pstrmemdup(p, str, IO_DUMP_LENGTH))
        -:   27:
        -:   28:#ifdef MP_IO_TIE_PERLIO
        -:   29:
        -:   30:/***************************
        -:   31: * The PerlIO Apache layer *
        -:   32: ***************************/
        -:   33:
        -:   34:/* PerlIO ":Apache" layer is used to use the Apache callbacks to read
        -:   35: * from STDIN and write to STDOUT. The PerlIO API is documented in
        -:   36: * perliol.pod */
        -:   37:
        -:   38:typedef struct {
        -:   39:    struct _PerlIO base;
        -:   40:    request_rec *r;
        -:   41:} PerlIOApache;
        -:   42:
        -:   43:/* _open just allocates the layer, _pushed does the real job of
        -:   44: * filling the data in */
        -:   45:static PerlIO *
        -:   46:PerlIOApache_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n,
        -:   47:                  const char *mode, int fd, int imode, int perm,
        -:   48:                  PerlIO *f, int narg, SV **args)
      255:   49:{
      255:   50:    if (!f) {
      255:   51:        f = PerlIO_allocate(aTHX);
        -:   52:    }
      255:   53:    if ( (f = PerlIO_push(aTHX_ f, self, mode, args[0])) ) {
      255:   54:        PerlIOBase(f)->flags |= PERLIO_F_OPEN;
        -:   55:    }
        -:   56:
      255:   57:    MP_TRACE_o(MP_FUNC, "mode %s", mode);
        -:   58:
      255:   59:    return f;
        -:   60:}
        -:   61:
        -:   62:/* this callback is used by pushed() and binmode() to add the layer */
        -:   63:static IV
        -:   64:PerlIOApache_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg,
        -:   65:                    PerlIO_funcs *tab)
      271:   66:{
      271:   67:    IV code;
      271:   68:    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
        -:   69:
      271:   70:    if (arg) {
      271:   71:        st->r = modperl_sv2request_rec(aTHX_ arg);
      271:   72:        MP_TRACE_o(MP_FUNC, "stored request_rec obj: 0x%lx", st->r);
        -:   73:    }
        -:   74:    else {
    #####:   75:        Perl_croak(aTHX_"failed to insert the :Apache layer. "
        -:   76:                   "Apache::RequestRec object argument is required");
        -:   77:        /* XXX: try to get Apache->request? */
        -:   78:    }
        -:   79:    
        -:   80:    /* this method also sets the right flags according to the
        -:   81:     * 'mode' */
      271:   82:    code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
        -:   83:    
      271:   84:    return code;
        -:   85:}
        -:   86:
        -:   87:static SV *
        -:   88:PerlIOApache_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
       16:   89:{
       16:   90:    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
       16:   91:    SV *sv;
        -:   92:
       16:   93:    if (!st->r) {
    #####:   94:        Perl_croak(aTHX_ "an attempt to getarg from a stale io handle");
        -:   95:    }
        -:   96:    
       16:   97:    sv = newSV(0);
       16:   98:    sv_setref_pv(sv, "Apache::RequestRec", (void*)(st->r));
        -:   99:
       16:  100:    MP_TRACE_o(MP_FUNC, "retrieved request_rec obj: 0x%lx", st->r);
        -:  101:    
       16:  102:    return sv;
        -:  103:}
        -:  104:
        -:  105:static IV
        -:  106:PerlIOApache_fileno(pTHX_ PerlIO *f)
      289:  107:{
        -:  108:    /* XXX: we could return STDIN => 0, STDOUT => 1, but that wouldn't
        -:  109:     * be correct, as the IO goes through the socket, may be we should
        -:  110:     * return the filedescriptor of the socket? 
        -:  111:     *
        -:  112:     * -1 in this case indicates that the layer cannot provide fileno
        -:  113:     */
      289:  114:    MP_TRACE_o(MP_FUNC, "did nothing");
      289:  115:    return -1;
        -:  116:}
        -:  117:
        -:  118:static SSize_t
        -:  119:PerlIOApache_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
        3:  120:{
        3:  121:    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
        3:  122:    request_rec *r = st->r;
        3:  123:    long total = 0;
        -:  124:
        3:  125:    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
        -:  126:        PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
    #####:  127:        return 0;
        -:  128:    }
        -:  129:
        3:  130:    total = modperl_request_read(aTHX_ r, (char*)vbuf, count);
        -:  131:
        3:  132:    if (total < 0) {
    #####:  133:        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
        -:  134:        /* modperl_request_read takes care of setting ERRSV */
        -:  135:    }
        -:  136:
        3:  137:    return total;
        -:  138:}
        -:  139:
        -:  140:static SSize_t
        -:  141:PerlIOApache_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
    13526:  142:{
    13526:  143:    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
    13526:  144:    modperl_config_req_t *rcfg = modperl_config_req_get(st->r);
    13526:  145:    apr_size_t bytes = 0;
    13526:  146:    apr_status_t rv;
        -:  147:
    13526:  148:    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
    #####:  149:        return 0;
        -:  150:    }
        -:  151:    
    13526:  152:    MP_CHECK_WBUCKET_INIT("print");
        -:  153:
    13526:  154:    MP_TRACE_o(MP_FUNC, "%4db [%s]", count,
        -:  155:               IO_DUMP_FIRST_CHUNK(rcfg->wbucket->pool, vbuf, count));
        -:  156:        
    13526:  157:    rv = modperl_wbucket_write(aTHX_ rcfg->wbucket, vbuf, &count);
    13526:  158:    if (rv != APR_SUCCESS) {
    #####:  159:        Perl_croak(aTHX_ modperl_apr_strerror(rv)); 
        -:  160:    }
    13526:  161:    bytes += count;
        -:  162:    
    13526:  163:    return (SSize_t) bytes;
        -:  164:}
        -:  165:
        -:  166:static IV
        -:  167:PerlIOApache_flush(pTHX_ PerlIO *f)
      424:  168:{
      424:  169:    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
      424:  170:    modperl_config_req_t *rcfg;
        -:  171:
      424:  172:    if (!st->r) {
    #####:  173:        Perl_warn(aTHX_ "an attempt to flush a stale IO handle");
    #####:  174:        return -1;
        -:  175:    }
        -:  176:
        -:  177:    /* no flush on readonly io handle */
      424:  178:    if (! (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) ) {
      141:  179:        return -1;
        -:  180:    }
        -:  181:
      283:  182:    rcfg = modperl_config_req_get(st->r);
        -:  183:
      283:  184:    MP_CHECK_WBUCKET_INIT("flush");
        -:  185:
      283:  186:    MP_TRACE_o(MP_FUNC, "%4db [%s]", rcfg->wbucket->outcnt,
        -:  187:               IO_DUMP_FIRST_CHUNK(rcfg->wbucket->pool,
        -:  188:                                   apr_pstrmemdup(rcfg->wbucket->pool,
        -:  189:                                                  rcfg->wbucket->outbuf,
        -:  190:                                                  rcfg->wbucket->outcnt),
        -:  191:                                   rcfg->wbucket->outcnt));
        -:  192:
      283:  193:    MP_FAILURE_CROAK(modperl_wbucket_flush(rcfg->wbucket, FALSE));
        -:  194:
      283:  195:    return 0;
        -:  196:}
        -:  197:
        -:  198:/* 5.8.0 doesn't export PerlIOBase_noop_fail, so we duplicate it here */
        -:  199:static IV PerlIOApache_noop_fail(pTHX_ PerlIO *f)
    #####:  200:{
    #####:  201:    return -1;
        -:  202:}
        -:  203:
        -:  204:static IV
        -:  205:PerlIOApache_close(pTHX_ PerlIO *f)
      271:  206:{
      271:  207:    IV code = PerlIOBase_close(aTHX_ f);
      271:  208:    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
        -:  209:
      271:  210:    MP_TRACE_o(MP_FUNC, "done with request_rec obj: 0x%lx", st->r);
        -:  211:    /* prevent possible bugs where a stale r will be attempted to be
        -:  212:     * reused (e.g. dupped filehandle) */
      271:  213:    st->r = NULL;
        -:  214:
      271:  215:    return code;
        -:  216:}
        -:  217:
        -:  218:static IV
        -:  219:PerlIOApache_popped(pTHX_ PerlIO *f)
      271:  220:{
        -:  221:    /* XXX: just temp for tracing */
      271:  222:    MP_TRACE_o(MP_FUNC, "done");
      271:  223:    return PerlIOBase_popped(aTHX_ f);
        -:  224:}
        -:  225:
        -:  226:
        -:  227:static PerlIO_funcs PerlIO_Apache = {
        -:  228:    sizeof(PerlIO_funcs),
        -:  229:    "Apache",
        -:  230:    sizeof(PerlIOApache),
        -:  231:    PERLIO_K_MULTIARG | PERLIO_K_RAW,
        -:  232:    PerlIOApache_pushed,
        -:  233:    PerlIOApache_popped,
        -:  234:    PerlIOApache_open,
        -:  235:    PerlIOBase_binmode,
        -:  236:    PerlIOApache_getarg,
        -:  237:    PerlIOApache_fileno,
        -:  238:    PerlIOBase_dup,
        -:  239:    PerlIOApache_read,
        -:  240:    PerlIOBase_unread,
        -:  241:    PerlIOApache_write,
        -:  242:    NULL,                       /* can't seek on STD{IN|OUT}, fail on call*/
        -:  243:    NULL,                       /* can't tell on STD{IN|OUT}, fail on call*/
        -:  244:    PerlIOApache_close,
        -:  245:    PerlIOApache_flush,        
        -:  246:    PerlIOApache_noop_fail,     /* fill */
        -:  247:    PerlIOBase_eof,
        -:  248:    PerlIOBase_error,
        -:  249:    PerlIOBase_clearerr,
        -:  250:    PerlIOBase_setlinebuf,
        -:  251:    NULL,                       /* get_base */
        -:  252:    NULL,                       /* get_bufsiz */
        -:  253:    NULL,                       /* get_ptr */
        -:  254:    NULL,                       /* get_cnt */
        -:  255:    NULL,                       /* set_ptrcnt */
        -:  256:};
        -:  257:
        -:  258:/* ***** End of PerlIOApache tab ***** */
        -:  259:
        -:  260:MP_INLINE void modperl_io_apache_init(pTHX)
       20:  261:{
       20:  262:    PerlIO_define_layer(aTHX_ &PerlIO_Apache);
        -:  263:}
        -:  264:
        -:  265:#endif /* defined MP_IO_TIE_PERLIO */
        -:  266:
        -:  267:/******  Other request IO functions  *******/
        -:  268:
        -:  269:
        -:  270:MP_INLINE SSize_t modperl_request_read(pTHX_ request_rec *r,
        -:  271:                                       char *buffer, Size_t len)
      366:  272:{
      366:  273:    long total = 0;
      366:  274:    int wanted = len;
      366:  275:    int seen_eos = 0;
      366:  276:    char *tmp = buffer;
      366:  277:    apr_bucket_brigade *bb;
        -:  278:
      366:  279:    if (len <= 0) {
    #####:  280:        return 0;
        -:  281:    }
        -:  282:
      366:  283:    bb = apr_brigade_create(r->pool, r->connection->bucket_alloc);
      366:  284:    if (bb == NULL) {
    #####:  285:        r->connection->keepalive = AP_CONN_CLOSE;
    #####:  286:        return -1;
        -:  287:    }
        -:  288:
      530:  289:    do {
      530:  290:        apr_size_t read;
      530:  291:        int rc;
        -:  292:
      530:  293:        rc = ap_get_brigade(r->input_filters, bb, AP_MODE_READBYTES,
        -:  294:                            APR_BLOCK_READ, len);
      530:  295:        if (rc != APR_SUCCESS) { 
        1:  296:            char *error;
        -:  297:            /* if we fail here, we want to just return and stop trying
        -:  298:             * to read data from the client.
        -:  299:             */
        1:  300:            r->connection->keepalive = AP_CONN_CLOSE;
        1:  301:            apr_brigade_destroy(bb);
        -:  302:
        1:  303:            if (SvTRUE(ERRSV)) {
        1:  304:                STRLEN n_a;
        1:  305:                error = SvPV(ERRSV, n_a);
        -:  306:            }
        -:  307:            else {
    #####:  308:                error = modperl_apr_strerror(rc);
        -:  309:            }
        1:  310:            sv_setpv(ERRSV,
        -:  311:                     (char *)apr_psprintf(r->pool, 
        -:  312:                                          "failed to get bucket brigade: %s",
        -:  313:                                          error));
        1:  314:            return -1;
        -:  315:        }
        -:  316:
        -:  317:        /* If this fails, it means that a filter is written
        -:  318:         * incorrectly and that it needs to learn how to properly
        -:  319:         * handle APR_BLOCK_READ requests by returning data when
        -:  320:         * requested.
        -:  321:         */
      529:  322:        if (APR_BRIGADE_EMPTY(bb)) {
    #####:  323:            apr_brigade_destroy(bb);
        -:  324:            /* we can't tell which filter is broken, since others may
        -:  325:             * just pass data through */
    #####:  326:            sv_setpv(ERRSV, "Aborting read from client. "
        -:  327:                     "One of the input filters is broken. "
        -:  328:                     "It returned an empty bucket brigade for "
        -:  329:                     "the APR_BLOCK_READ mode request");
    #####:  330:            return -1;
        -:  331:        }
        -:  332:
      529:  333:        if (APR_BUCKET_IS_EOS(APR_BRIGADE_LAST(bb))) {
       26:  334:            seen_eos = 1;
        -:  335:        }
        -:  336:
      529:  337:        read = len;
      529:  338:        rc = apr_brigade_flatten(bb, tmp, &read);
      529:  339:        if (rc != APR_SUCCESS) {
    #####:  340:            apr_brigade_destroy(bb);
    #####:  341:            sv_setpv(ERRSV,
        -:  342:                     (char *)apr_psprintf(r->pool, 
        -:  343:                                          "failed to read: %s",
        -:  344:                                          modperl_apr_strerror(rc)));
    #####:  345:            return -1;
        -:  346:        }
      529:  347:        total += read;
      529:  348:        tmp   += read;
      529:  349:        len   -= read;
        -:  350:
        -:  351:        /* XXX: what happens if the downstream filter returns more
        -:  352:         * data than the caller has asked for? We can't return more
        -:  353:         * data that requested, so it needs to be stored somewhere and
        -:  354:         * dealt with on the subsequent calls to this function. or may
        -:  355:         * be we should just assert, blaming a bad filter. at the
        -:  356:         * moment I couldn't find a spec telling whether it's wrong
        -:  357:         * for the filter to return more data than it was asked for in
        -:  358:         * the AP_MODE_READBYTES mode.
        -:  359:         */
        -:  360:        
      529:  361:        apr_brigade_cleanup(bb);
        -:  362:
      529:  363:    } while (len > 0 && !seen_eos);
        -:  364:
      365:  365:    apr_brigade_destroy(bb);
        -:  366:
      365:  367:    MP_TRACE_o(MP_FUNC, "wanted %db, read %db [%s]", wanted, total,
        -:  368:               IO_DUMP_FIRST_CHUNK(r->pool, buffer, total));
        -:  369:
      365:  370:    return total;
        -:  371:}
        -:  372:
        -:  373:
        -:  374:
        -:  375: