-:    0:Source:modperl_util.c
        -:    0:Object:modperl_util.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_require_module(pTHX_ const char *pv, int logfailure)
      439:   19:{
      439:   20:    SV *sv;
        -:   21:
      439:   22:    dSP;
      439:   23:    PUSHSTACKi(PERLSI_REQUIRE);
      439:   24:    PUTBACK;
      439:   25:    sv = sv_newmortal();
      439:   26:    sv_setpv(sv, "require ");
      439:   27:    sv_catpv(sv, pv);
      439:   28:    eval_sv(sv, G_DISCARD);
      439:   29:    SPAGAIN;
      439:   30:    POPSTACK;
        -:   31:
      439:   32:    if (SvTRUE(ERRSV)) {
        1:   33:        if (logfailure) {
    #####:   34:            (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
        -:   35:                                NULL, NULL);
        -:   36:        }
        1:   37:        return FALSE;
        -:   38:    }
        -:   39:        
      438:   40:    return TRUE;
        -:   41:}
        -:   42:
        -:   43:int modperl_require_file(pTHX_ const char *pv, int logfailure)
       36:   44:{
       36:   45:    require_pv(pv);
        -:   46:
       36:   47:    if (SvTRUE(ERRSV)) {
    #####:   48:        if (logfailure) {
    #####:   49:            (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
        -:   50:                                NULL, NULL);
        -:   51:        }
    #####:   52:        return FALSE;
        -:   53:    }
        -:   54:
       36:   55:    return TRUE;
        -:   56:}
        -:   57:
        -:   58:static SV *modperl_hv_request_find(pTHX_ SV *in, char *classname, CV *cv)
       18:   59:{
       19:   60:    static char *r_keys[] = { "r", "_r", NULL };
       19:   61:    HV *hv = (HV *)SvRV(in);
       19:   62:    SV *sv = Nullsv;
       19:   63:    int i;
        -:   64:
       23:   65:    for (i=0; r_keys[i]; i++) {
       21:   66:        int klen = i + 1; /* assumes r_keys[] will never change */
       21:   67:        SV **svp;
        -:   68:
       21:   69:        if ((svp = hv_fetch(hv, r_keys[i], klen, FALSE)) && (sv = *svp)) {
       17:   70:            if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) {
        -:   71:                /* dig deeper */
        1:   72:                return modperl_hv_request_find(aTHX_ sv, classname, cv);
        -:   73:            }
        4:   74:            break;
        -:   75:        }
        -:   76:    }
        -:   77:
       18:   78:    if (!sv) {
    #####:   79:        Perl_croak(aTHX_
        -:   80:                   "method `%s' invoked by a `%s' object with no `r' key!",
        -:   81:                   cv ? GvNAME(CvGV(cv)) : "unknown",
        -:   82:                   HvNAME(SvSTASH(SvRV(in))));
        -:   83:    }
        -:   84:
       16:   85:    return SvROK(sv) ? SvRV(sv) : sv;
        -:   86:}
        -:   87:
        -:   88:MP_INLINE server_rec *modperl_sv2server_rec(pTHX_ SV *sv)
       14:   89:{
       14:   90:    return SvOBJECT(sv) ?
        -:   91:        (server_rec *)SvObjIV(sv) :
        -:   92:        modperl_global_get_server_rec();
        -:   93:}
        -:   94:
        -:   95:MP_INLINE request_rec *modperl_sv2request_rec(pTHX_ SV *sv)
     3278:   96:{
     3278:   97:    return modperl_xs_sv2request_rec(aTHX_ sv, NULL, Nullcv);
        -:   98:}
        -:   99:
        -:  100:request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv)
     7922:  101:{
     7922:  102:    SV *sv = Nullsv;
     7922:  103:    MAGIC *mg;
        -:  104:
     7922:  105:    if (SvROK(in)) {
     7921:  106:        SV *rv = (SV*)SvRV(in);
        -:  107:
     7921:  108:        switch (SvTYPE(rv)) {
        -:  109:          case SVt_PVMG:
     7905:  110:            sv = rv;
     7905:  111:            break;
        -:  112:          case SVt_PVHV:
       15:  113:            sv = modperl_hv_request_find(aTHX_ in, classname, cv);
       14:  114:            break;
        -:  115:          default:
        1:  116:            Perl_croak(aTHX_ "panic: unsupported request_rec type %d",
        -:  117:                       SvTYPE(rv));
        -:  118:        }
        -:  119:    }
        -:  120:
     7919:  121:    if (!sv) {
        1:  122:        request_rec *r = NULL;
        1:  123:        (void)modperl_tls_get_request_rec(&r);
        -:  124:
        1:  125:        if (!r) {
        1:  126:            if (classname && SvPOK(in) && !strEQ(classname, SvPVX(in))) {
        -:  127:                /* might be Apache::{Server,RequestRec}-> dual method */
        1:  128:                return NULL;
        -:  129:            }
    #####:  130:            Perl_croak(aTHX_
        -:  131:                       "Apache->%s called without setting Apache->request!",
        -:  132:                       cv ? GvNAME(CvGV(cv)) : "unknown");
        -:  133:        }
        -:  134:
    #####:  135:        return r;
        -:  136:    }
        -:  137:
     7919:  138:    if ((mg = mg_find(sv, PERL_MAGIC_ext))) {
    #####:  139:        return (request_rec *)mg->mg_ptr;
        -:  140:    }
        -:  141:    else {
     7919:  142:        if (classname && !sv_derived_from(in, classname)) {
        -:  143:            /* XXX: find something faster than sv_derived_from */
        3:  144:            return NULL;
        -:  145:        }
     7916:  146:        return (request_rec *)SvIV(sv);
        -:  147:    }
        -:  148:
     7920:  149:    return NULL;
        -:  150:}
        -:  151:
        -:  152:MP_INLINE SV *modperl_newSVsv_obj(pTHX_ SV *stashsv, SV *obj)
       99:  153:{
       99:  154:    SV *newobj;
        -:  155:
       99:  156:    if (!obj) {
       99:  157:        obj = stashsv;
       99:  158:        stashsv = Nullsv;
        -:  159:    }
        -:  160:
       99:  161:    newobj = newSVsv(obj);
        -:  162:
       99:  163:    if (stashsv) {
    #####:  164:        HV *stash = gv_stashsv(stashsv, TRUE);
    #####:  165:        return sv_bless(newobj, stash);
        -:  166:    }
        -:  167:
       99:  168:    return newobj;
        -:  169:}
        -:  170:
        -:  171:MP_INLINE SV *modperl_ptr2obj(pTHX_ char *classname, void *ptr)
     2187:  172:{
     2187:  173:    SV *sv = newSV(0);
        -:  174:
     2187:  175:    MP_TRACE_h(MP_FUNC, "sv_setref_pv(%s, 0x%lx)\n",
        -:  176:               classname, (unsigned long)ptr);
     2187:  177:    sv_setref_pv(sv, classname, ptr);
        -:  178:
     2187:  179:    return sv;
        -:  180:}
        -:  181:
        -:  182:/* XXX: sv_setref_uv does not exist in 5.6.x */
        -:  183:MP_INLINE SV *modperl_perl_sv_setref_uv(pTHX_ SV *rv,
        -:  184:                                        const char *classname, UV uv)
    #####:  185:{
    #####:  186:    sv_setuv(newSVrv(rv, classname), uv);
    #####:  187:    return rv;
        -:  188:}
        -:  189:
        -:  190:static apr_pool_t *modperl_sv2pool(pTHX_ SV *obj, CV *method)
       57:  191:{
       57:  192:    apr_pool_t *p = NULL;
       57:  193:    char *classname = NULL;
       57:  194:    IV ptr = 0;
        -:  195:
       57:  196:    if ((SvROK(obj) && (SvTYPE(SvRV(obj)) == SVt_PVMG))) {
        -:  197:        /* standard classes */
       55:  198:        classname = SvCLASS(obj);
       55:  199:        ptr = SvObjIV(obj);
        -:  200:    }
        2:  201:    else if ((SvROK(obj) && (SvTYPE(SvRV(obj)) == SVt_PVHV))) {
        -:  202:        /* Apache::RequestRec subclass */
        2:  203:        classname = SvCLASS(obj);
        2:  204:        ptr = SvIV(modperl_hv_request_find(aTHX_ obj, classname, method));
        -:  205:
        -:  206:        /* if modperl_hv_request_find succeeeds then the class is an 
        -:  207:         * Apache::RequestRec subclass (the only subclass we support).
        -:  208:         * so, fake things a bit so we can dig out the proper pool below
        -:  209:         */
        1:  210:         classname = "Apache::RequestRec";
        -:  211:    }
        -:  212:    else {
    #####:  213:        MP_TRACE_m(MP_FUNC, "SV not a recognized object");
    #####:  214:        return NULL;
        -:  215:    }
        -:  216:
       56:  217:    if (strnEQ(classname, "APR::", 5)) {
       43:  218:        classname += 5;
       43:  219:        switch (*classname) {
        -:  220:          case 'P':
       43:  221:            if (strEQ(classname, "Pool")) {
       43:  222:                p = (apr_pool_t *)SvObjIV(obj);
        -:  223:            }
    #####:  224:            break;
        -:  225:          default:
    #####:  226:            MP_TRACE_m(MP_FUNC, "class %s not recognized", classname);
    #####:  227:            break;
        -:  228:        };
        -:  229:    }
       13:  230:    else if (strnEQ(classname, "Apache::", 8)) {
       13:  231:        classname += 8;
       13:  232:        switch (*classname) {
        -:  233:          case 'C':
        1:  234:            if (strEQ(classname, "Connection")) {
        1:  235:                p = ((conn_rec *)ptr)->pool;
        -:  236:            }
        1:  237:            break;
        -:  238:          case 'R':
        9:  239:            if (strEQ(classname, "RequestRec")) {
        9:  240:                p = ((request_rec *)ptr)->pool;
        -:  241:            }
        9:  242:            break;
        -:  243:          case 'S':
        3:  244:            if (strEQ(classname, "Server")) {
        3:  245:                p = ((server_rec *)ptr)->process->pconf;
        -:  246:            }
        3:  247:            break;
        -:  248:          default:
    #####:  249:            MP_TRACE_m(MP_FUNC, "class %s not recognised", classname);
    #####:  250:            break;
        -:  251:        };
        -:  252:    }
        -:  253:    else {
    #####:  254:        MP_TRACE_m(MP_FUNC, "class %s not recognised", classname);
        -:  255:    }
        -:  256:
       56:  257:    if (p == NULL) {
    #####:  258:        MP_TRACE_m(MP_FUNC, "unable to derive pool from object");
        -:  259:    }
        -:  260:
       56:  261:    return p;
        -:  262:}
        -:  263:
        -:  264:char *modperl_apr_strerror(apr_status_t rv)
    #####:  265:{
    #####:  266:    dTHX;
    #####:  267:    char buf[256];
    #####:  268:    apr_strerror(rv, buf, sizeof(buf));
    #####:  269:    return Perl_form(aTHX_ "%d:%s", rv, buf);
        -:  270:}
        -:  271:
        -:  272:int modperl_errsv(pTHX_ int status, request_rec *r, server_rec *s)
      122:  273:{
      122:  274:    SV *sv = ERRSV;
      122:  275:    STRLEN n_a;
        -:  276:
      122:  277:    if (SvTRUE(sv)) {
        5:  278:        if (SvMAGICAL(sv) && (SvCUR(sv) > 4) &&
        -:  279:            strnEQ(SvPVX(sv), " at ", 4))
        -:  280:        {
        -:  281:            /* ModPerl::Util::exit was called */
    #####:  282:            return DECLINED;
        -:  283:        }
        -:  284:#if 0
        -:  285:        if (modperl_sv_is_http_code(ERRSV, &status)) {
        -:  286:            return status;
        -:  287:        }
        -:  288:#endif
        5:  289:        if (r) {
        5:  290:            ap_log_rerror(APLOG_MARK, APLOG_ERR, 0, r, "%s", SvPV(sv, n_a));
        -:  291:        }
        -:  292:        else {
    #####:  293:            ap_log_error(APLOG_MARK, APLOG_ERR, 0, s, "%s", SvPV(sv, n_a));
        -:  294:        }
        -:  295:
        5:  296:        return status;
        -:  297:    }
        -:  298:
      117:  299:    return status;
        -:  300:}
        -:  301:
        -:  302:char *modperl_server_desc(server_rec *s, apr_pool_t *p)
      264:  303:{
      264:  304:    return apr_psprintf(p, "%s:%u", s->server_hostname, s->port);
        -:  305:}
        -:  306:
        -:  307:/* used in debug traces */
        -:  308:MP_INLINE char *modperl_pid_tid(apr_pool_t *p)
    #####:  309:{
    #####:  310:    return apr_psprintf(p, "%lu"
        -:  311:#if APR_HAS_THREADS
        -:  312:                 "/%lu"
        -:  313:#endif /* APR_HAS_THREADS */
        -:  314:                 , (unsigned long)getpid()
        -:  315:#if APR_HAS_THREADS
        -:  316:                 , (unsigned long)apr_os_thread_current()
        -:  317:#endif /* APR_HAS_THREADS */
        -:  318:        );
        -:  319:}
        -:  320:
        -:  321:    
        -:  322:#define dl_librefs "DynaLoader::dl_librefs"
        -:  323:#define dl_modules "DynaLoader::dl_modules"
        -:  324:
        -:  325:void modperl_xs_dl_handles_clear(pTHX)
    #####:  326:{
    #####:  327:    AV *librefs = get_av(dl_librefs, FALSE);
    #####:  328:    if (librefs) {
    #####:  329:        av_clear(librefs);
        -:  330:    }
        -:  331:}
        -:  332:
        -:  333:void **modperl_xs_dl_handles_get(pTHX)
       10:  334:{
       10:  335:    I32 i;
       10:  336:    AV *librefs = get_av(dl_librefs, FALSE);
       10:  337:    AV *modules = get_av(dl_modules, FALSE);
       10:  338:    void **handles;
        -:  339:
       10:  340:    if (!librefs) {
    #####:  341:	MP_TRACE_g(MP_FUNC,
        -:  342:                   "Could not get @%s for unloading.\n",
        -:  343:                   dl_librefs);
    #####:  344:	return NULL;
        -:  345:    }
        -:  346:
       10:  347:    if (!(AvFILL(librefs) >= 0)) {
        -:  348:        /* dl_librefs and dl_modules are empty */
        4:  349:        return NULL;
        -:  350:    }
        -:  351:
        6:  352:    handles = (void **)malloc(sizeof(void *) * (AvFILL(librefs)+2));
        -:  353:
      120:  354:    for (i=0; i<=AvFILL(librefs); i++) {
      114:  355:	void *handle;
      114:  356:	SV *handle_sv = *av_fetch(librefs, i, FALSE);
      114:  357:	SV *module_sv = *av_fetch(modules, i, FALSE);
        -:  358:
      114:  359:	if(!handle_sv) {
    #####:  360:	    MP_TRACE_g(MP_FUNC,
        -:  361:                       "Could not fetch $%s[%d]!\n",
        -:  362:                       dl_librefs, (int)i);
    #####:  363:	    continue;
        -:  364:	}
      114:  365:	handle = (void *)SvIV(handle_sv);
        -:  366:
      114:  367:	MP_TRACE_g(MP_FUNC, "%s dl handle == 0x%lx\n",
        -:  368:                   SvPVX(module_sv), (unsigned long)handle);
      114:  369:	if (handle) {
      114:  370:	    handles[i] = handle;
        -:  371:	}
        -:  372:    }
        -:  373:
        6:  374:    av_clear(modules);
        6:  375:    av_clear(librefs);
        -:  376:
        6:  377:    handles[i] = (void *)0;
        -:  378:
        6:  379:    return handles;
        -:  380:}
        -:  381:
        -:  382:void modperl_xs_dl_handles_close(void **handles)
       10:  383:{
       10:  384:    int i;
        -:  385:
       10:  386:    if (!handles) {
        6:  387:	return;
        -:  388:    }
        -:  389:
      120:  390:    for (i=0; handles[i]; i++) {
      114:  391:        MP_TRACE_g(MP_FUNC, "close 0x%lx\n", (unsigned long)handles[i]);
      114:  392:        modperl_sys_dlclose(handles[i]);
        -:  393:    }
        -:  394:
        6:  395:    free(handles);
        -:  396:}
        -:  397:
        -:  398:modperl_cleanup_data_t *modperl_cleanup_data_new(apr_pool_t *p, void *data)
    #####:  399:{
    #####:  400:    modperl_cleanup_data_t *cdata =
    #####:  401:        (modperl_cleanup_data_t *)apr_pcalloc(p, sizeof(*cdata));
    #####:  402:    cdata->pool = p;
    #####:  403:    cdata->data = data;
    #####:  404:    return cdata;
        -:  405:}
        -:  406:
        -:  407:MP_INLINE modperl_uri_t *modperl_uri_new(apr_pool_t *p)
        5:  408:{
        5:  409:    modperl_uri_t *uri = (modperl_uri_t *)apr_pcalloc(p, sizeof(*uri));
        5:  410:    uri->pool = p;
        5:  411:    return uri;
        -:  412:}
        -:  413:
        -:  414:MP_INLINE SV *modperl_hash_tie(pTHX_ 
        -:  415:                               const char *classname,
        -:  416:                               SV *tsv, void *p)
     1023:  417:{
     1023:  418:    SV *hv = (SV*)newHV();
     1023:  419:    SV *rsv = sv_newmortal();
        -:  420:
     1023:  421:    sv_setref_pv(rsv, classname, p);
     1023:  422:    sv_magic(hv, rsv, PERL_MAGIC_tied, Nullch, 0);
        -:  423:
     1023:  424:    return SvREFCNT_inc(sv_bless(sv_2mortal(newRV_noinc(hv)),
        -:  425:                                 gv_stashpv(classname, TRUE)));
        -:  426:}
        -:  427:
        -:  428:MP_INLINE void *modperl_hash_tied_object(pTHX_ 
        -:  429:                                         const char *classname,
        -:  430:                                         SV *tsv)
     1186:  431:{
     1186:  432:    if (sv_derived_from(tsv, classname)) {
     1186:  433:        if (SVt_PVHV == SvTYPE(SvRV(tsv))) {
      819:  434:            SV *hv = SvRV(tsv);
      819:  435:            MAGIC *mg;
        -:  436:
      819:  437:            if (SvMAGICAL(hv)) {
      819:  438:                if ((mg = mg_find(hv, PERL_MAGIC_tied))) {
      819:  439:                    return (void *)MgObjIV(mg);
        -:  440:                }
        -:  441:                else {
    #####:  442:                    Perl_warn(aTHX_ "Not a tied hash: (magic=%c)", mg);
        -:  443:                }
        -:  444:            }
        -:  445:            else {
    #####:  446:                Perl_warn(aTHX_ "SV is not tied");
        -:  447:            }
        -:  448:        }
        -:  449:        else {
      367:  450:            return (void *)SvObjIV(tsv);
        -:  451:        }
        -:  452:    }
        -:  453:    else {
    #####:  454:        Perl_croak(aTHX_
        -:  455:                   "argument is not a blessed reference "
        -:  456:                   "(expecting an %s derived object)", classname);
        -:  457:    }
        -:  458:
    #####:  459:    return NULL;
        -:  460:}
        -:  461:
        -:  462:MP_INLINE void modperl_perl_av_push_elts_ref(pTHX_ AV *dst, AV *src)
      127:  463:{
      127:  464:    I32 i, j, src_fill = AvFILLp(src), dst_fill = AvFILLp(dst);
        -:  465:
      127:  466:    av_extend(dst, src_fill);
      127:  467:    AvFILLp(dst) += src_fill+1;
        -:  468:
     7894:  469:    for (i=dst_fill+1, j=0; j<=AvFILLp(src); i++, j++) {
     7767:  470:        AvARRAY(dst)[i] = SvREFCNT_inc(AvARRAY(src)[j]);
        -:  471:    }
        -:  472:}
        -:  473:
        -:  474:/*
        -:  475: * similar to hv_fetch_ent, but takes string key and key len rather than SV
        -:  476: * also skips magic and utf8 fu, since we are only dealing with internal tables
        -:  477: */
        -:  478:HE *modperl_perl_hv_fetch_he(pTHX_ HV *hv,
        -:  479:                             register char *key,
        -:  480:                             register I32 klen,
        -:  481:                             register U32 hash)
     6593:  482:{
     6593:  483:    register XPVHV *xhv;
     6593:  484:    register HE *entry;
        -:  485:
     6593:  486:    xhv = (XPVHV *)SvANY(hv);
     6593:  487:    if (!xhv->xhv_array) {
        3:  488:        return 0;
        -:  489:    }
        -:  490:
        -:  491:#ifdef HvREHASH
     6590:  492:    if (HvREHASH(hv)) {
        4:  493:	PERL_HASH_INTERNAL(hash, key, klen);
        -:  494:    }
        -:  495:    else
        -:  496:#endif
     6586:  497:    if (!hash) {
      156:  498:	PERL_HASH(hash, key, klen);
        -:  499:    }
        -:  500:
     6590:  501:    entry = ((HE**)xhv->xhv_array)[hash & (I32)xhv->xhv_max];
        -:  502:
     7492:  503:    for (; entry; entry = HeNEXT(entry)) {
     7343:  504:        if (HeHASH(entry) != hash) {
     6441:  505:            continue;
        -:  506:        }
     6441:  507:        if (HeKLEN(entry) != klen) {
     6441:  508:            continue;
        -:  509:        }
     6441:  510:        if (HeKEY(entry) != key && memNE(HeKEY(entry), key, klen)) {
     6441:  511:            continue;
        -:  512:        }
     6441:  513:        return entry;
        -:  514:    }
        -:  515:
      149:  516:    return 0;
        -:  517:}
        -:  518:
        -:  519:void modperl_str_toupper(char *str)
    #####:  520:{
    #####:  521:    while (*str) {
    #####:  522:        *str = apr_toupper(*str);
    #####:  523:        ++str;
        -:  524:    }
        -:  525:}
        -:  526:
        -:  527:/* XXX: same as Perl_do_sprintf(); 
        -:  528: * but Perl_do_sprintf() is not part of the "public" api
        -:  529: */
        -:  530:void modperl_perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
      128:  531:{
      128:  532:    STRLEN patlen;
      128:  533:    char *pat = SvPV(*sarg, patlen);
      128:  534:    bool do_taint = FALSE;
        -:  535:
      128:  536:    sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
      128:  537:    SvSETMAGIC(sv);
      128:  538:    if (do_taint) {
    #####:  539:        SvTAINTED_on(sv);
        -:  540:    }
        -:  541:}
        -:  542:
        -:  543:void modperl_perl_call_list(pTHX_ AV *subs, const char *name)
       26:  544:{
       26:  545:    I32 i, oldscope = PL_scopestack_ix;
       26:  546:    SV **ary = AvARRAY(subs);
        -:  547:    
       60:  548:    for (i=0; i<=AvFILLp(subs); i++) {
       34:  549:	CV *cv = (CV*)ary[i];
       34:  550:	SV *atsv = ERRSV;
        -:  551:
       34:  552:	PUSHMARK(PL_stack_sp);
       34:  553:	call_sv((SV*)cv, G_EVAL|G_DISCARD);
        -:  554:
       34:  555:	if (SvCUR(atsv)) {
    #####:  556:            Perl_sv_catpvf(aTHX_ atsv, "%s failed--call queue aborted",
        -:  557:                           name);
    #####:  558:	    while (PL_scopestack_ix > oldscope) {
    #####:  559:		LEAVE;
        -:  560:            }
    #####:  561:            Perl_croak(aTHX_ "%s", SvPVX(atsv));
        -:  562:	}
        -:  563:    }
        -:  564:}
        -:  565:
        -:  566:void modperl_perl_exit(pTHX_ int status)
        3:  567:{
        3:  568:    const char *pat = NULL;
        3:  569:    ENTER;
        3:  570:    SAVESPTR(PL_diehook);
        3:  571:    PL_diehook = Nullsv; 
        3:  572:    sv_setpv(ERRSV, "");
        -:  573:#ifdef MP_PERL_5_6_0
        -:  574:    pat = ""; /* NULL segvs in 5.6.0 */
        -:  575:#endif
        3:  576:    Perl_croak(aTHX_ pat);
        -:  577:}
        -:  578:
        -:  579:MP_INLINE SV *modperl_dir_config(pTHX_ request_rec *r, server_rec *s,
        -:  580:                                 char *key, SV *sv_val)
      868:  581:{
      868:  582:    SV *retval = &PL_sv_undef;
        -:  583:
      868:  584:    if (r && r->per_dir_config) {				   
      680:  585:        MP_dDCFG;
      680:  586:        retval = modperl_table_get_set(aTHX_ dcfg->configvars,
        -:  587:                                       key, sv_val, FALSE);
        -:  588:    }
        -:  589:
      868:  590:    if (!SvOK(retval)) {
      625:  591:        if (s && s->module_config) {
      625:  592:            MP_dSCFG(s);
      625:  593:            SvREFCNT_dec(retval); /* in case above did newSV(0) */
      625:  594:            retval = modperl_table_get_set(aTHX_ scfg->configvars,
        -:  595:                                           key, sv_val, FALSE);
        -:  596:        }
        -:  597:        else {
    #####:  598:            retval = &PL_sv_undef;
        -:  599:        }
        -:  600:    }
        -:  601:        
      868:  602:    return retval;
        -:  603:}
        -:  604:
        -:  605:SV *modperl_table_get_set(pTHX_ apr_table_t *table, char *key,
        -:  606:                          SV *sv_val, int do_taint)
     1355:  607:{
     1355:  608:    SV *retval = &PL_sv_undef;
        -:  609:
     1355:  610:    if (table == NULL) { 
        -:  611:        /* do nothing */
        -:  612:    }
     1355:  613:    else if (key == NULL) { 
      250:  614:        retval = modperl_hash_tie(aTHX_ "APR::Table",
        -:  615:                                  Nullsv, (void*)table); 
        -:  616:    }
     1105:  617:    else if (!sv_val) { /* no val was passed */
     1096:  618:        char *val; 
     1096:  619:        if ((val = (char *)apr_table_get(table, key))) { 
      225:  620:            retval = newSVpv(val, 0); 
        -:  621:        } 
        -:  622:        else { 
      871:  623:            retval = newSV(0); 
        -:  624:        } 
     1096:  625:        if (do_taint) { 
        8:  626:            SvTAINTED_on(retval); 
        -:  627:        } 
        -:  628:    }
        9:  629:    else if (!SvOK(sv_val)) { /* val was passed in as undef */
        3:  630:        apr_table_unset(table, key); 
        -:  631:    }
        -:  632:    else { 
        6:  633:        apr_table_set(table, key, SvPV_nolen(sv_val));
        -:  634:    } 
        -:  635:
     1355:  636:    return retval;
        -:  637:}
        -:  638:
        -:  639:MP_INLINE int modperl_perl_module_loaded(pTHX_ const char *name)
        3:  640:{
        3:  641:    return (*name && gv_stashpv(name, FALSE)) ? 1 : 0;
        -:  642:}
        -:  643:
        -:  644:/* same as Symbol::gensym() */
        -:  645:SV *modperl_perl_gensym(pTHX_ char *pack)
    #####:  646:{
    #####:  647:    GV *gv = newGVgen(pack);
    #####:  648:    SV *rv = newRV((SV*)gv);
    #####:  649:    (void)hv_delete(gv_stashpv(pack, TRUE), 
        -:  650:                    GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
    #####:  651:    return rv;
        -:  652:}
        -:  653:
        -:  654:static int modperl_gvhv_is_stash(GV *gv)
        4:  655:{
        4:  656:    int len = GvNAMELEN(gv);
        4:  657:    char *name = GvNAME(gv);
        -:  658:
        4:  659:    if ((len > 2) && (name[len - 1] == ':') && (name[len - 2] == ':')) {
    #####:  660:        return 1;
        -:  661:    }
        -:  662:
        4:  663:    return 0;
        -:  664:}
        -:  665:
        -:  666:/*
        -:  667: * we do not clear symbols within packages, the desired behavior
        -:  668: * for directive handler classes.  and there should never be a package
        -:  669: * within the %Apache::ReadConfig.  nothing else that i'm aware of calls
        -:  670: * this function, so we should be ok.
        -:  671: */
        -:  672:
        -:  673:void modperl_clear_symtab(pTHX_ HV *symtab) 
       12:  674:{
       12:  675:    SV *val;
       12:  676:    char *key;
       12:  677:    I32 klen;
        -:  678:
       12:  679:    hv_iterinit(symtab);
        -:  680:    
       12:  681:    while ((val = hv_iternextsv(symtab, &key, &klen))) {
       20:  682:        SV *sv;
       20:  683:        HV *hv;
       20:  684:        AV *av;
       20:  685:        CV *cv;
        -:  686:
       20:  687:        if ((SvTYPE(val) != SVt_PVGV) || GvIMPORTED((GV*)val)) {
       20:  688:            continue;
        -:  689:        }
       20:  690:        if ((sv = GvSV((GV*)val))) {
       20:  691:            sv_setsv(GvSV((GV*)val), &PL_sv_undef);
        -:  692:        }
       20:  693:        if ((hv = GvHV((GV*)val)) && !modperl_gvhv_is_stash((GV*)val)) {
        4:  694:            hv_clear(hv);
        -:  695:        }
       20:  696:        if ((av = GvAV((GV*)val))) {
       16:  697:            av_clear(av);
        -:  698:        }
       20:  699:        if ((cv = GvCV((GV*)val)) && (GvSTASH((GV*)val) == GvSTASH(CvGV(cv)))) {
    #####:  700:            GV *gv = CvGV(cv);
    #####:  701:            cv_undef(cv);
    #####:  702:            CvGV(cv) = gv;
    #####:  703:            GvCVGEN(gv) = 1; /* invalidate method cache */
        -:  704:        }
        -:  705:    }
        -:  706:}
        -:  707:
        -:  708:#define SLURP_SUCCESS(action) \
        -:  709:    if (rc != APR_SUCCESS) { \
        -:  710:        SvREFCNT_dec(sv); \
        -:  711:        Perl_croak(aTHX_ "Error " action " '%s': %s ", r->filename, \
        -:  712:                   modperl_apr_strerror(rc)); \
        -:  713:    }
        -:  714:
        -:  715:MP_INLINE SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted)
       50:  716:{
       50:  717:    SV *sv;
       50:  718:    apr_status_t rc;
       50:  719:    apr_size_t size;
       50:  720:    apr_file_t *file;
        -:  721:    
       50:  722:    size = r->finfo.size;
       50:  723:    sv = newSV(size);
        -:  724:
       50:  725:    if (!size) {
    #####:  726:        sv_setpvn(sv, "", 0);
    #####:  727:        return newRV_noinc(sv);
        -:  728:    }
        -:  729:
        -:  730:    /* XXX: could have checked whether r->finfo.filehand is valid and
        -:  731:     * save the apr_file_open call, but apache gives us no API to
        -:  732:     * check whether filehand is valid. we can't test whether it's
        -:  733:     * NULL or not, as it may contain garbagea
        -:  734:     */
       50:  735:    rc = apr_file_open(&file, r->filename, APR_READ|APR_BINARY,
        -:  736:                       APR_OS_DEFAULT, r->pool);
       50:  737:    SLURP_SUCCESS("opening");
        -:  738:
       50:  739:    rc = apr_file_read(file, SvPVX(sv), &size);
       50:  740:    SLURP_SUCCESS("reading");
        -:  741:
       50:  742:    MP_TRACE_o(MP_FUNC, "read %d bytes from '%s'\n", size, r->filename);
        -:  743:    
       50:  744:    if (r->finfo.size != size) {
    #####:  745:        SvREFCNT_dec(sv); 
    #####:  746:        Perl_croak(aTHX_ "Error: read %d bytes, expected %d ('%s')",
        -:  747:                   size, r->finfo.size, r->filename);
        -:  748:    }
        -:  749:
       50:  750:    rc = apr_file_close(file);
       50:  751:    SLURP_SUCCESS("closing");
        -:  752:    
       50:  753:    SvPVX(sv)[size] = '\0';
       50:  754:    SvCUR_set(sv, size);
       50:  755:    SvPOK_on(sv);
        -:  756:
       50:  757:    if (tainted) {
        1:  758:        SvTAINTED_on(sv);
        -:  759:    }
        -:  760:    else {
       49:  761:        SvTAINTED_off(sv);
        -:  762:    }
        -:  763:    
       50:  764:    return newRV_noinc(sv);
        -:  765:}
        -:  766:
        -:  767:#ifdef MP_TRACE
        -:  768:/* XXX: internal debug function */
        -:  769:/* any non-false value for MOD_PERL_TRACE/PerlTrace enables this function */
        -:  770:void modperl_apr_table_dump(pTHX_ apr_table_t *table, char *name)
    #####:  771:{
    #####:  772:    int i;
    #####:  773:    const apr_array_header_t *array;
    #####:  774:    apr_table_entry_t *elts;
        -:  775:
    #####:  776:    array = apr_table_elts(table);
    #####:  777:    elts  = (apr_table_entry_t *)array->elts;
    #####:  778:    modperl_trace(MP_FUNC, "Contents of table %s", name);
    #####:  779:    for (i = 0; i < array->nelts; i++) {
    #####:  780:        if (!elts[i].key || !elts[i].val) {
    #####:  781:            continue;
        -:  782:        }
    #####:  783:        modperl_trace(MP_FUNC, "%s => %s", elts[i].key, elts[i].val);
        -:  784:    }    
        -:  785:}
        -:  786:#endif
        -:  787:
        -:  788:#define MP_VALID_PKG_CHAR(c) (isalnum(c) ||(c) == '_')
        -:  789:#define MP_VALID_PATH_DELIM(c) ((c) == '/' || (c) =='\\')
        -:  790:char *modperl_file2package(apr_pool_t *p, const char *file)
       32:  791:{
       32:  792:    char *package;
       32:  793:    char *c;
       32:  794:    const char *f;
       32:  795:    int len = strlen(file)+1;
        -:  796:
        -:  797:    /* First, skip invalid prefix characters */
       32:  798:    while (!MP_VALID_PKG_CHAR(*file)) {
       24:  799:        file++;
       24:  800:        len--;
        -:  801:    }
        -:  802:
        -:  803:    /* Then figure out how big the package name will be like */
     1756:  804:    for (f = file; *f; f++) {
     1724:  805:        if (MP_VALID_PATH_DELIM(*f)) {
      240:  806:            len++;
        -:  807:        }
        -:  808:    }
        -:  809:
       32:  810:    package = apr_pcalloc(p, len);
        -:  811:
        -:  812:    /* Then, replace bad characters with '_' */
     1756:  813:    for (c = package; *file; c++, file++) {
     1724:  814:        if (MP_VALID_PKG_CHAR(*file)) {
     1392:  815:            *c = *file;
        -:  816:        }
      332:  817:        else if (MP_VALID_PATH_DELIM(*file)) {
        -:  818:
        -:  819:            /* Eliminate subsequent duplicate path delim */
      240:  820:            while (*(file+1) && MP_VALID_PATH_DELIM(*(file+1))) {
    #####:  821:                file++;
        -:  822:            }
        -:  823: 
        -:  824:            /* path delim not until end of line */
      240:  825:            if (*(file+1)) {
      240:  826:                *c = *(c+1) = ':';
      240:  827:                c++;
        -:  828:            }
        -:  829:        }
        -:  830:        else {
       92:  831:            *c = '_';
        -:  832:        }
        -:  833:    }
        -:  834:   
       32:  835:    return package;
        -:  836:}
        -:  837:
        -:  838:/* this is used across server_root_relative() in the
        -:  839: * Apache, Apache::Server, Apache::RequestRec, and 
        -:  840: * Apache::Connection classes
        -:  841: */
        -:  842:SV *modperl_server_root_relative(pTHX_ SV *sv, const char *fname)
       57:  843:{
       57:  844:    apr_pool_t *p;
        -:  845:
       57:  846:    if (!sv_isobject(sv)) {
    #####:  847:        Perl_croak(aTHX_ "usage: Apache::Server::server_root_relative(obj, name)");
        -:  848:    }
        -:  849:
       57:  850:    p = modperl_sv2pool(aTHX_ sv, get_cv("Apache::Server::server_root_relative", 0));
        -:  851:
       56:  852:    if (p == NULL) {
    #####:  853:        MP_TRACE_a(MP_FUNC,
        -:  854:                   "unable to isolate pool for ap_server_root_relative()");
    #####:  855:        return &PL_sv_undef;
        -:  856:    }
        -:  857:
        -:  858:    /* copy the SV in case the pool goes out of scope before the perl scalar */
       56:  859:    return newSVpv(ap_server_root_relative(p, fname), 0);
        -:  860:}