-:    0:Source:modperl_callback.c
        -:    0:Object:modperl_callback.bb
        -:    1:/* Copyright 2000-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:int modperl_callback(pTHX_ modperl_handler_t *handler, apr_pool_t *p,
        -:   19:                     request_rec *r, server_rec *s, AV *args)
     2050:   20:{
     2050:   21:    CV *cv=Nullcv;
     2050:   22:    I32 flags = G_EVAL|G_SCALAR;
     2050:   23:    dSP;
     2050:   24:    int count, status = OK;
        -:   25:
     2050:   26:    if ((status = modperl_handler_resolve(aTHX_ &handler, p, s)) != OK) {
     2049:   27:        return status;
        -:   28:    }
        -:   29:
     2049:   30:    ENTER;SAVETMPS;
     2049:   31:    PUSHMARK(SP);
        -:   32:
     2049:   33:    if (MpHandlerMETHOD(handler)) {
      118:   34:        GV *gv;
      118:   35:        if (!handler->mgv_obj) {
    #####:   36:            Perl_croak(aTHX_ "panic: %s method handler object is NULL!",
        -:   37:                       handler->name);
        -:   38:        }
      118:   39:        gv = modperl_mgv_lookup(aTHX_ handler->mgv_obj);
      118:   40:        XPUSHs(modperl_mgv_sv(gv));
        -:   41:    }
        -:   42:
     2049:   43:    if (args) {
     2049:   44:        I32 items = AvFILLp(args) + 1;
        -:   45:
     2049:   46:        EXTEND(SP, items);
     2049:   47:        Copy(AvARRAY(args), SP + 1, items, SV*);
     2049:   48:        SP += items;
        -:   49:    }
        -:   50:
     2049:   51:    PUTBACK;
        -:   52:
     2049:   53:    if (MpHandlerANON(handler)) {
        -:   54:#ifdef USE_ITHREADS
        -:   55:        /* it's possible that the interpreter that is running the anon
        -:   56:         * cv, isn't the one that compiled it. so to be safe need to
        -:   57:         * re-eval the deparsed form before using it.
        -:   58:         * XXX: possible optimizations, see modperl_handler_new_anon */
        6:   59:        SV *sv = eval_pv(handler->name, TRUE); 
        6:   60:        cv = (CV*)SvRV(sv);
        -:   61:#else
        -:   62:        /* the same interpreter that has compiled the anon cv is used
        -:   63:         * to run it */
        -:   64:        if (!handler->cv) {
        -:   65:            SV *sv = eval_pv(handler->name, TRUE); 
        -:   66:            handler->cv = (CV*)SvRV(sv); /* cache */
        -:   67:        }
        -:   68:        cv = handler->cv;
        -:   69:#endif
        -:   70:    }
        -:   71:    else {
     2043:   72:        GV *gv = modperl_mgv_lookup_autoload(aTHX_ handler->mgv_cv, s, p);
     2043:   73:        if (gv) {
     2043:   74:            cv = modperl_mgv_cv(gv);
        -:   75:        }
        -:   76:        else {
        -:   77:            
    #####:   78:            const char *name;
    #####:   79:            modperl_mgv_t *symbol = handler->mgv_cv;
        -:   80:            
        -:   81:             /* XXX: need to validate *symbol */
    #####:   82:            if (symbol && symbol->name) {
    #####:   83:                name = modperl_mgv_as_string(aTHX_ symbol, p, 0);
        -:   84:            }
        -:   85:            else {
    #####:   86:                name = handler->name;
        -:   87:            }
        -:   88:            
    #####:   89:            MP_TRACE_h(MP_FUNC, "[%s %s] lookup of %s failed\n",
        -:   90:                       modperl_pid_tid(p),
        -:   91:                       modperl_server_desc(s, p), name);
    #####:   92:            ap_log_error(APLOG_MARK, APLOG_ERR, 0, s,
        -:   93:                         "lookup of '%s' failed", name);
    #####:   94:            status = HTTP_INTERNAL_SERVER_ERROR;
        -:   95:        }
        -:   96:    }
        -:   97:
     2049:   98:    if (status == OK) {
     2049:   99:        count = call_sv((SV*)cv, flags);
        -:  100:
     2049:  101:        SPAGAIN;
        -:  102:
     2049:  103:        if (count != 1) {
        -:  104:            /* XXX can this really happen with G_EVAL|G_SCALAR? */
     2049:  105:            status = OK;
        -:  106:        }
        -:  107:        else {
     2049:  108:            SV *status_sv = POPs;
        -:  109:
     2049:  110:            if (SvIOK(status_sv)) {
        -:  111:                /* normal IV return (e.g., Apache::OK) */
     2030:  112:                status = SvIVX(status_sv);
        -:  113:            }
       19:  114:            else if (status_sv == &PL_sv_undef) {
        -:  115:                /* ModPerl::Util::exit() and Perl_croak internally
        -:  116:                 * arrange to return PL_sv_undef with G_EVAL|G_SCALAR */
       11:  117:                status = OK; 
        -:  118:            }
       11:  119:            else if (SvPOK(status_sv)) {
        -:  120:                /* PV return that ought to be treated as IV ("0") */
       11:  121:                status = SvIVx(status_sv);
       11:  122:                MP_TRACE_h(MP_FUNC,
        -:  123:                           "coercing handler %s's return value '%s' into %d",
        -:  124:                           handler->name, SvPVX(status_sv), status);
        -:  125:            }
        -:  126:            else {
        -:  127:                /* any other return types are considered as errors */
    #####:  128:                status = HTTP_INTERNAL_SERVER_ERROR;
    #####:  129:                ap_log_error(APLOG_MARK, APLOG_ERR, 0, s,
        -:  130:                             "handler %s didn't return a valid return value!",
        -:  131:                             handler->name);
        -:  132:            }
        -:  133:        }
        -:  134:
     2049:  135:        PUTBACK;
        -:  136:    }
        -:  137:    
     2049:  138:    FREETMPS;LEAVE;
        -:  139:
     2049:  140:    if (SvTRUE(ERRSV)) {
        4:  141:        MP_TRACE_h(MP_FUNC, "$@ = %s", SvPVX(ERRSV));
        4:  142:        status = HTTP_INTERNAL_SERVER_ERROR;
        -:  143:    }
        -:  144:
     2050:  145:    return status;
        -:  146:}
        -:  147:
        -:  148:int modperl_callback_run_handlers(int idx, int type,
        -:  149:                                  request_rec *r, conn_rec *c,
        -:  150:                                  server_rec *s,
        -:  151:                                  apr_pool_t *pconf,
        -:  152:                                  apr_pool_t *plog,
        -:  153:                                  apr_pool_t *ptemp,
        -:  154:                                  modperl_hook_run_mode_e run_mode)
     5090:  155:{
        -:  156:#ifdef USE_ITHREADS
     5090:  157:    pTHX;
     5090:  158:    modperl_interp_t *interp = NULL;
        -:  159:#endif
     5090:  160:    MP_dSCFG(s);
     5090:  161:    MP_dDCFG;
     5090:  162:    MP_dRCFG;
     5090:  163:    modperl_handler_t **handlers;
     5090:  164:    apr_pool_t *p = NULL;
     5090:  165:    MpAV *av, **avp;
     5090:  166:    int i, status = OK;
     5090:  167:    const char *desc = NULL;
     5090:  168:    AV *av_args = Nullav;
        -:  169:
     5090:  170:    if (!MpSrvENABLE(scfg)) {
    #####:  171:        MP_TRACE_h(MP_FUNC, "PerlOff for server %s\n",
        -:  172:                   s->server_hostname);
    #####:  173:        return DECLINED;
        -:  174:    }
        -:  175:
     5090:  176:    if (r || c) {
     4254:  177:        p = c ? c->pool : r->pool;
        -:  178:    }
        -:  179:    else {
       24:  180:        p = pconf;
        -:  181:    }
        -:  182:
     5090:  183:    avp = modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p,
        -:  184:                                          type, idx, FALSE, &desc);
        -:  185:
     5090:  186:    if (!(avp && (av = *avp))) {
     3778:  187:        MP_TRACE_h(MP_FUNC, "no %s handlers configured (%s)\n",
        -:  188:                   desc, r ? r->uri : "");
     3778:  189:        return DECLINED;
        -:  190:    }
        -:  191:
        -:  192:#ifdef USE_ITHREADS
     1312:  193:    if (r && !c && modperl_interp_scope_connection(scfg)) {
    #####:  194:        c = r->connection;
        -:  195:    }
     1296:  196:    if (r || c) {
     1302:  197:        interp = modperl_interp_select(r, c, s);
     1302:  198:        aTHX = interp->perl;
        -:  199:    }
        -:  200:    else {
        -:  201:        /* Child{Init,Exit}, OpenLogs */
       10:  202:        aTHX = scfg->mip->parent->perl;
       10:  203:        PERL_SET_CONTEXT(aTHX);
        -:  204:    }
        -:  205:#endif
        -:  206:
        -:  207:    /* XXX: would like to do this in modperl_hook_create_request()
        -:  208:     * but modperl_interp_select() is what figures out if
        -:  209:     * PerlInterpScope eq handler, in which case we do not register
        -:  210:     * a cleanup.  modperl_hook_create_request() is also currently always
        -:  211:     * run even if modperl isn't handling any part of the request
        -:  212:     */
     1312:  213:    modperl_config_req_cleanup_register(r, rcfg);
        -:  214:
     1312:  215:    switch (type) {
        -:  216:      case MP_HANDLER_TYPE_PER_SRV:
      760:  217:        modperl_handler_make_args(aTHX_ &av_args,
        -:  218:                                  "Apache::RequestRec", r, NULL);
        -:  219:
        -:  220:        /* per-server PerlSetEnv and PerlPassEnv - only once per-request */
      760:  221:        if (! MpReqPERL_SET_ENV_SRV(rcfg)) {
      447:  222:            modperl_env_configure_request_srv(aTHX_ r);
        -:  223:        }
        -:  224:
      447:  225:        break;
        -:  226:      case MP_HANDLER_TYPE_PER_DIR:
      536:  227:        modperl_handler_make_args(aTHX_ &av_args,
        -:  228:                                  "Apache::RequestRec", r, NULL);
        -:  229:
        -:  230:        /* per-directory PerlSetEnv - only once per-request */
      536:  231:        if (! MpReqPERL_SET_ENV_DIR(rcfg)) {
      416:  232:            modperl_env_configure_request_dir(aTHX_ r);
        -:  233:        }
        -:  234:
      416:  235:        break;
        -:  236:      case MP_HANDLER_TYPE_PRE_CONNECTION:
        -:  237:      case MP_HANDLER_TYPE_CONNECTION:
        6:  238:        modperl_handler_make_args(aTHX_ &av_args,
        -:  239:                                  "Apache::Connection", c, NULL);
        6:  240:        break;
        -:  241:      case MP_HANDLER_TYPE_FILES:
        8:  242:        modperl_handler_make_args(aTHX_ &av_args,
        -:  243:                                  "Apache::Pool", pconf,
        -:  244:                                  "Apache::Pool", plog,
        -:  245:                                  "Apache::Pool", ptemp,
        -:  246:                                  "Apache::Server", s, NULL);
        8:  247:        break;
        -:  248:      case MP_HANDLER_TYPE_PROCESS:
        2:  249:        modperl_handler_make_args(aTHX_ &av_args,
        -:  250:                                  "Apache::Pool", pconf,
        -:  251:                                  "Apache::Server", s, NULL);
        -:  252:        break;
        -:  253:    };
        -:  254:
     1312:  255:    modperl_callback_current_callback_set(desc);
        -:  256:    
     1312:  257:    MP_TRACE_h(MP_FUNC, "[%s] running %d %s handlers\n",
        -:  258:               modperl_pid_tid(p), av->nelts, desc);
     1312:  259:    handlers = (modperl_handler_t **)av->elts;
        -:  260:
     2556:  261:    for (i=0; i<av->nelts; i++) {
     1676:  262:        status = modperl_callback(aTHX_ handlers[i], p, r, s, av_args);
        -:  263:        
     1676:  264:        MP_TRACE_h(MP_FUNC, "%s returned %d\n",
        -:  265:                   handlers[i]->name, status);
        -:  266:
        -:  267:        /* follow Apache's lead and let OK terminate the phase for
        -:  268:         * MP_HOOK_RUN_FIRST handlers.  MP_HOOK_RUN_ALL handlers keep
        -:  269:         * going on OK.  MP_HOOK_VOID handlers ignore all errors.
        -:  270:         */
        -:  271:
     1676:  272:        if (run_mode == MP_HOOK_RUN_ALL) {
        -:  273:            /* the normal case:
        -:  274:             *   OK and DECLINED continue 
        -:  275:             *   errors end the phase
        -:  276:             */
      597:  277:            if ((status != OK) && (status != DECLINED)) {
        -:  278:
       48:  279:                status = modperl_errsv(aTHX_ status, r, s);
        -:  280:#ifdef MP_TRACE
       48:  281:                if (i+1 != av->nelts) {
    #####:  282:                    MP_TRACE_h(MP_FUNC, "error status %d leaves %d "
        -:  283:                               "uncalled handlers\n",
        -:  284:                               status, desc, av->nelts-i-1);
        -:  285:                }
        -:  286:#endif
    #####:  287:                break;
        -:  288:            }
        -:  289:        }
     1079:  290:        else if (run_mode == MP_HOOK_RUN_FIRST) {
        -:  291:            /* the exceptional case:
        -:  292:             *   OK and errors end the phase
        -:  293:             *   DECLINED continues
        -:  294:             */
        -:  295:
     1077:  296:            if (status == OK) {
        -:  297:#ifdef MP_TRACE
      339:  298:                if (i+1 != av->nelts) {
        7:  299:                    MP_TRACE_h(MP_FUNC, "OK ends the %s stack, "
        -:  300:                               "leaving %d uncalled handlers\n",
        -:  301:                               desc, av->nelts-i-1);
        -:  302:                }
        -:  303:#endif
    #####:  304:                break;
        -:  305:            }
      738:  306:            if (status != DECLINED) {
       45:  307:                status = modperl_errsv(aTHX_ status, r, s);
        -:  308:#ifdef MP_TRACE
       45:  309:                if (i+1 != av->nelts) {
        1:  310:                    MP_TRACE_h(MP_FUNC, "error status %d leaves %d "
        -:  311:                               "uncalled handlers\n",
        -:  312:                               status, desc, av->nelts-i-1);
        -:  313:                }
        -:  314:#endif
    #####:  315:                break;
        -:  316:            }
        -:  317:        }
        -:  318:        else {
        -:  319:            /* the rare case.
        -:  320:             * MP_HOOK_VOID handlers completely ignore the return status
        -:  321:             * Apache should handle whatever mod_perl returns, 
        -:  322:             * so there is no need to mess with the status
        -:  323:             */
        -:  324:        }
        -:  325:
        -:  326:        /* it's possible that during the last callback a new handler
        -:  327:         * was pushed onto the same phase it's running from. av needs
        -:  328:         * to be updated.
        -:  329:         *
        -:  330:         * XXX: would be nice to somehow optimize that
        -:  331:         */
     1244:  332:        avp = modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p,
        -:  333:                                              type, idx, FALSE, NULL);
     1244:  334:        if (avp && (av = *avp)) {
     1244:  335:            handlers = (modperl_handler_t **)av->elts;
        -:  336:        }
        -:  337:    }
        -:  338:
     1312:  339:    SvREFCNT_dec((SV*)av_args);
        -:  340:
        -:  341:    /* PerlInterpScope handler */
     1312:  342:    MP_INTERP_PUTBACK(interp);
        -:  343:
     1312:  344:    return status;
        -:  345:}
        -:  346:
        -:  347:int modperl_callback_per_dir(int idx, request_rec *r,
        -:  348:                             modperl_hook_run_mode_e run_mode)
     2940:  349:{
     2940:  350:    return modperl_callback_run_handlers(idx, MP_HANDLER_TYPE_PER_DIR,
        -:  351:                                         r, NULL, r->server,
        -:  352:                                         NULL, NULL, NULL, run_mode);
        -:  353:}
        -:  354:
        -:  355:int modperl_callback_per_srv(int idx, request_rec *r, 
        -:  356:                             modperl_hook_run_mode_e run_mode)
     1314:  357:{
     1314:  358:    return modperl_callback_run_handlers(idx,
        -:  359:                                         MP_HANDLER_TYPE_PER_SRV,
        -:  360:                                         r, NULL, r->server,
        -:  361:                                         NULL, NULL, NULL, run_mode);
        -:  362:}
        -:  363:
        -:  364:int modperl_callback_connection(int idx, conn_rec *c, 
        -:  365:                                modperl_hook_run_mode_e run_mode)
      405:  366:{
      405:  367:    return modperl_callback_run_handlers(idx,
        -:  368:                                         MP_HANDLER_TYPE_CONNECTION,
        -:  369:                                         NULL, c, c->base_server,
        -:  370:                                         NULL, NULL, NULL, run_mode);
        -:  371:}
        -:  372:
        -:  373:int modperl_callback_pre_connection(int idx, conn_rec *c, void *csd,
        -:  374:                                    modperl_hook_run_mode_e run_mode)
      407:  375:{
      407:  376:    return modperl_callback_run_handlers(idx,
        -:  377:                                         MP_HANDLER_TYPE_PRE_CONNECTION,
        -:  378:                                         NULL, c, c->base_server,
        -:  379:                                         NULL, NULL, NULL, run_mode);
        -:  380:}
        -:  381:
        -:  382:void modperl_callback_process(int idx, apr_pool_t *p, server_rec *s,
        -:  383:                              modperl_hook_run_mode_e run_mode)
        8:  384:{
        8:  385:    modperl_callback_run_handlers(idx, MP_HANDLER_TYPE_PROCESS,
        -:  386:                                  NULL, NULL, s,
        -:  387:                                  p, NULL, NULL, run_mode);
        -:  388:}
        -:  389:
        -:  390:int modperl_callback_files(int idx,
        -:  391:                           apr_pool_t *pconf, apr_pool_t *plog,
        -:  392:                           apr_pool_t *ptemp, server_rec *s,
        -:  393:                           modperl_hook_run_mode_e run_mode)
       16:  394:{
       16:  395:    return modperl_callback_run_handlers(idx, MP_HANDLER_TYPE_FILES,
        -:  396:                                         NULL, NULL, s,
        -:  397:                                         pconf, plog, ptemp, run_mode);
        -:  398:}