-:    0:Source:modperl_perl_global.c
        -:    0:Object:modperl_perl_global.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:static void modperl_perl_global_init(pTHX_ modperl_perl_globals_t *globals)
      127:   19:{
      127:   20:    globals->env.gv    = PL_envgv;
      127:   21:    globals->inc.gv    = PL_incgv;
      127:   22:    globals->defout.gv = PL_defoutgv;
      127:   23:    globals->rs.sv     = &PL_rs;
      127:   24:    globals->end.av    = &PL_endav;
      127:   25:    globals->end.key   = MP_MODGLOBAL_END;
        -:   26:}
        -:   27:
        -:   28:/* XXX: PL_modglobal thingers might be useful elsewhere */
        -:   29:
        -:   30:#define MP_MODGLOBAL_FETCH(gkey) \
        -:   31:hv_fetch_he(PL_modglobal, (char *)gkey->val, gkey->len, gkey->hash)
        -:   32:
        -:   33:#define MP_MODGLOBAL_STORE_HV(gkey) \
        -:   34:(HV*)*hv_store(PL_modglobal, gkey->val, gkey->len, (SV*)newHV(), gkey->hash)
        -:   35:
        -:   36:#define MP_MODGLOBAL_ENT(key) \
        -:   37:{key, "ModPerl::" key, MP_SSTRLEN("ModPerl::") + MP_SSTRLEN(key), 0}
        -:   38:
        -:   39:static modperl_modglobal_key_t MP_modglobal_keys[] = {
        -:   40:    MP_MODGLOBAL_ENT("END"),
        -:   41:    { NULL },
        -:   42:};
        -:   43:
        -:   44:void modperl_modglobal_hash_keys(pTHX)
        8:   45:{
        8:   46:    modperl_modglobal_key_t *gkey = MP_modglobal_keys;
        -:   47:
        8:   48:    while (gkey->name) {
        8:   49:        PERL_HASH(gkey->hash, gkey->val, gkey->len);
        8:   50:        gkey++;
        -:   51:    }
        -:   52:}
        -:   53:
        -:   54:modperl_modglobal_key_t *modperl_modglobal_lookup(pTHX_ const char *name)
      167:   55:{
      167:   56:    modperl_modglobal_key_t *gkey = MP_modglobal_keys;
        -:   57:
      167:   58:    while (gkey->name) {
      167:   59:        if (strEQ(gkey->name, name)) {
      165:   60:            return gkey;
        -:   61:        }
        2:   62:        gkey++;
        -:   63:    }
        -:   64:
        2:   65:    return NULL;
        -:   66:}
        -:   67:
        -:   68:static AV *modperl_perl_global_avcv_fetch(pTHX_ modperl_modglobal_key_t *gkey,
        -:   69:                                          const char *package, I32 packlen)
      165:   70:{
      165:   71:    HE *he = MP_MODGLOBAL_FETCH(gkey);
      165:   72:    HV *hv;
        -:   73:
      165:   74:    if (!(he && (hv = (HV*)HeVAL(he)))) {
       57:   75:        return Nullav;
        -:   76:    }
        -:   77:
      108:   78:    if (!(he = hv_fetch_he(hv, (char *)package, packlen, 0))) {
       77:   79:        return Nullav;
        -:   80:    }
        -:   81:
       31:   82:    return (AV*)HeVAL(he);
        -:   83:}
        -:   84:
        -:   85:void modperl_perl_global_avcv_call(pTHX_ modperl_modglobal_key_t *gkey,
        -:   86:                                   const char *package, I32 packlen)
       77:   87:{
       77:   88:    AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen);
        -:   89:
       77:   90:    if (!av) {
       22:   91:        return;
        -:   92:    }
        -:   93:
       22:   94:    modperl_perl_call_list(aTHX_ av, gkey->name);
        -:   95:}
        -:   96:
        -:   97:void modperl_perl_global_avcv_clear(pTHX_ modperl_modglobal_key_t *gkey,
        -:   98:                                    const char *package, I32 packlen)
       88:   99:{
       88:  100:    AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen);
        -:  101:
       88:  102:    if (!av) {
        9:  103:        return;
        -:  104:    }
        -:  105:
        9:  106:    av_clear(av);
        -:  107:}
        -:  108:
        -:  109:static int modperl_perl_global_avcv_set(pTHX_ SV *sv, MAGIC *mg)
       15:  110:{
       15:  111:    HE *he;
       15:  112:    HV *hv;
       15:  113:    AV *mav, *av = (AV*)sv;
       15:  114:    const char *package = HvNAME(PL_curstash);
       15:  115:    I32 packlen = strlen(package);
       15:  116:    modperl_modglobal_key_t *gkey =
       15:  117:        (modperl_modglobal_key_t *)mg->mg_ptr;
        -:  118:
       15:  119:    if ((he = MP_MODGLOBAL_FETCH(gkey))) {
       12:  120:        hv = (HV*)HeVAL(he);
        -:  121:    }
        -:  122:    else {
        3:  123:        hv = MP_MODGLOBAL_STORE_HV(gkey);
        -:  124:    }
        -:  125:
       15:  126:    if ((he = hv_fetch_he(hv, (char *)package, packlen, 0))) {
        7:  127:        mav = (AV*)HeVAL(he);
        -:  128:    }
        -:  129:    else {
        8:  130:        mav = (AV*)*hv_store(hv, package, packlen, (SV*)newAV(), 0);
        -:  131:    }
        -:  132:
        -:  133:    /* $cv = pop @av */
       15:  134:    sv = AvARRAY(av)[AvFILLp(av)];
       15:  135:    AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
        -:  136:
        -:  137:    /* push @{ $PL_modglobal{$key}{$package} }, $cv */
       15:  138:    av_store(mav, AvFILLp(av)+1, sv);
        -:  139:
       15:  140:    return 1;
        -:  141:}
        -:  142:
        -:  143:static MGVTBL modperl_vtbl_global_avcv_t = {
        -:  144:    0,
        -:  145:    MEMBER_TO_FPTR(modperl_perl_global_avcv_set),
        -:  146:    0, 0, 0,
        -:  147:};
        -:  148:
        -:  149:/* XXX: Apache::RegistryLoader type things need access to this
        -:  150: * for compiling scripts at startup
        -:  151: */
        -:  152:static void modperl_perl_global_avcv_tie(pTHX_ modperl_modglobal_key_e key,
        -:  153:                                         AV *av)
      127:  154:{
      127:  155:    if (!SvMAGIC((SV*)av)) {
      127:  156:        MAGIC *mg;
      127:  157:        Newz(702, mg, 1, MAGIC);
      127:  158:        mg->mg_virtual = &modperl_vtbl_global_avcv_t;
      127:  159:        mg->mg_ptr = (char *)&MP_modglobal_keys[key];
      127:  160:        mg->mg_len = -1; /* prevent free() of mg->mg_ptr */
      127:  161:        SvMAGIC((SV*)av) = mg;
        -:  162:    }
        -:  163:
      127:  164:    SvSMAGICAL_on((SV*)av);
        -:  165:}
        -:  166:
        -:  167:static void modperl_perl_global_avcv_untie(pTHX_ AV *av)
      127:  168:{
      127:  169:    SvSMAGICAL_off((SV*)av);
        -:  170:}
        -:  171:
        -:  172:static void
        -:  173:modperl_perl_global_avcv_save(pTHX_ modperl_perl_global_avcv_t *avcv)
      127:  174:{
      127:  175:    avcv->origav = *avcv->av;
      127:  176:    *avcv->av = newAV(); /* XXX: only need 1 of these AVs per-interpreter */
      127:  177:    modperl_perl_global_avcv_tie(aTHX_ avcv->key, *avcv->av);
        -:  178:}
        -:  179:
        -:  180:static void
        -:  181:modperl_perl_global_avcv_restore(pTHX_ modperl_perl_global_avcv_t *avcv)
      127:  182:{
      127:  183:    modperl_perl_global_avcv_untie(aTHX_ *avcv->av);
      127:  184:    SvREFCNT_dec(*avcv->av); /* XXX: see XXX above */
      127:  185:    *avcv->av = avcv->origav;
        -:  186:}
        -:  187:
        -:  188:/*
        -:  189: * newHVhv is not good enough since it does not copy magic.
        -:  190: * XXX: 5.8.0+ newHVhv has some code thats faster than hv_iternext
        -:  191: */
        -:  192:static HV *copyENV(pTHX_ HV *ohv)
      127:  193:{
      127:  194:    HE *entry, *hv_eiter;
      127:  195:    I32 hv_riter;
      127:  196:    register HV *hv;
      127:  197:    STRLEN hv_max = HvMAX(ohv);
      127:  198:    STRLEN hv_fill = HvFILL(ohv);
        -:  199:
      127:  200:    hv = newHV();
      127:  201:    while (hv_max && hv_max + 1 >= hv_fill * 2) {
      325:  202:        hv_max = hv_max / 2;    /* Is always 2^n-1 */
        -:  203:    }
        -:  204:
      127:  205:    HvMAX(hv) = hv_max;
        -:  206:
      127:  207:    if (!hv_fill) {
      127:  208:        return hv;
        -:  209:    }
        -:  210:
      127:  211:    hv_riter = HvRITER(ohv);    /* current root of iterator */
      127:  212:    hv_eiter = HvEITER(ohv);    /* current entry of iterator */
        -:  213:        
      127:  214:    hv_iterinit(ohv);
      127:  215:    while ((entry = hv_iternext(ohv))) {
     1114:  216:        SV *sv = newSVsv(HeVAL(entry));
     1114:  217:        modperl_envelem_tie(sv, HeKEY(entry), HeKLEN(entry));
     1114:  218:        hv_store(hv, HeKEY(entry), HeKLEN(entry),
        -:  219:                 sv, HeHASH(entry));
        -:  220:    }
        -:  221:
      127:  222:    HvRITER(ohv) = hv_riter;
      127:  223:    HvEITER(ohv) = hv_eiter;
        -:  224:
      127:  225:    hv_magic(hv, Nullgv, 'E');    
        -:  226:
      127:  227:    TAINT_NOT;
        -:  228:
      127:  229:    return hv;
        -:  230:}
        -:  231:
        -:  232:static void
        -:  233:modperl_perl_global_gvhv_save(pTHX_ modperl_perl_global_gvhv_t *gvhv)
      127:  234:{
      127:  235:    HV *hv = GvHV(gvhv->gv);
        -:  236:#if 0
        -:  237:    U32 mg_flags;
        -:  238:    MAGIC *mg = SvMAGIC(hv);
        -:  239:
        -:  240:    /*
        -:  241:     * there should only be a small number of entries in %ENV
        -:  242:     * at this point: modperl_env.c:modperl_env_const_vars[],
        -:  243:     * PerlPassEnv and top-level PerlSetEnv
        -:  244:     * XXX: still; could have have something faster than newHVhv()
        -:  245:     * especially if we add another GVHV to the globals table that 
        -:  246:     * might have more entries
        -:  247:     */
        -:  248:
        -:  249:    /* makes newHVhv() faster in bleedperl */
        -:  250:    MP_magical_untie(hv, mg_flags);
        -:  251:
        -:  252:    gvhv->tmphv = newHVhv(hv);
        -:  253:    TAINT_NOT;
        -:  254:
        -:  255:    /* reapply magic flags */
        -:  256:    MP_magical_tie(hv, mg_flags);
        -:  257:    MP_magical_tie(gvhv->tmphv, mg_flags);
        -:  258:
        -:  259:    if (mg && mg->mg_type && !SvMAGIC(gvhv->tmphv)) {
        -:  260:        /* propagate SvMAGIC(hv) to SvMAGIC(gvhv->tmphv) */
        -:  261:        /* XXX: maybe newHVhv should do this? */
        -:  262:        hv_magic(gvhv->tmphv, Nullgv, mg->mg_type);
        -:  263:    }
        -:  264:#else
      127:  265:    gvhv->tmphv = copyENV(aTHX_ hv);
        -:  266:#endif
        -:  267:
      127:  268:    gvhv->orighv = hv;
      127:  269:    GvHV(gvhv->gv) = gvhv->tmphv;
        -:  270:}
        -:  271:
        -:  272:static void
        -:  273:modperl_perl_global_gvhv_restore(pTHX_ modperl_perl_global_gvhv_t *gvhv)
      127:  274:{
      127:  275:    U32 mg_flags;
        -:  276:
      127:  277:    GvHV(gvhv->gv) = gvhv->orighv;
        -:  278:
        -:  279:    /* loose magic for hv_clear()
        -:  280:     * e.g. for %ENV don't want to clear environ array
        -:  281:     */
      127:  282:    MP_magical_untie(gvhv->tmphv, mg_flags);
      127:  283:    SvREFCNT_dec(gvhv->tmphv);
        -:  284:}
        -:  285:
        -:  286:static void
        -:  287:modperl_perl_global_gvav_save(pTHX_ modperl_perl_global_gvav_t *gvav)
      127:  288:{
      127:  289:    gvav->origav = GvAV(gvav->gv);
      127:  290:    gvav->tmpav = newAV();
      127:  291:    modperl_perl_av_push_elts_ref(aTHX_ gvav->tmpav, gvav->origav);
      127:  292:    GvAV(gvav->gv) = gvav->tmpav;
        -:  293:}
        -:  294:
        -:  295:static void
        -:  296:modperl_perl_global_gvav_restore(pTHX_ modperl_perl_global_gvav_t *gvav)
      127:  297:{
      127:  298:    GvAV(gvav->gv) = gvav->origav;
      127:  299:    SvREFCNT_dec(gvav->tmpav);
        -:  300:}
        -:  301:
        -:  302:static void
        -:  303:modperl_perl_global_gvio_save(pTHX_ modperl_perl_global_gvio_t *gvio)
      127:  304:{
      127:  305:    gvio->flags = IoFLAGS(GvIOp(gvio->gv));
        -:  306:}
        -:  307:
        -:  308:static void
        -:  309:modperl_perl_global_gvio_restore(pTHX_ modperl_perl_global_gvio_t *gvio)
      127:  310:{
      127:  311:    IoFLAGS(GvIOp(gvio->gv)) = gvio->flags;
        -:  312:}
        -:  313:
        -:  314:static void
        -:  315:modperl_perl_global_svpv_save(pTHX_ modperl_perl_global_svpv_t *svpv)
      127:  316:{
      127:  317:    svpv->cur = SvCUR(*svpv->sv);
      127:  318:    strncpy(svpv->pv, SvPVX(*svpv->sv), sizeof(svpv->pv));
        -:  319:}
        -:  320:
        -:  321:static void
        -:  322:modperl_perl_global_svpv_restore(pTHX_ modperl_perl_global_svpv_t *svpv)
      127:  323:{
      127:  324:    sv_setpvn(*svpv->sv, svpv->pv, svpv->cur);
        -:  325:}
        -:  326:
        -:  327:typedef enum {
        -:  328:    MP_GLOBAL_AVCV,
        -:  329:    MP_GLOBAL_GVHV,
        -:  330:    MP_GLOBAL_GVAV,
        -:  331:    MP_GLOBAL_GVIO,
        -:  332:    MP_GLOBAL_SVPV
        -:  333:} modperl_perl_global_types_e;
        -:  334:
        -:  335:typedef struct {
        -:  336:    char *name;
        -:  337:    int offset;
        -:  338:    modperl_perl_global_types_e type;
        -:  339:} modperl_perl_global_entry_t;
        -:  340:
        -:  341:#define MP_GLOBAL_OFFSET(m) \
        -:  342:    STRUCT_OFFSET(modperl_perl_globals_t, m)
        -:  343:
        -:  344:static modperl_perl_global_entry_t MP_perl_global_entries[] = {
        -:  345:    {"END",    MP_GLOBAL_OFFSET(end),    MP_GLOBAL_AVCV}, /* END */
        -:  346:    {"ENV",    MP_GLOBAL_OFFSET(env),    MP_GLOBAL_GVHV}, /* %ENV */
        -:  347:    {"INC",    MP_GLOBAL_OFFSET(inc),    MP_GLOBAL_GVAV}, /* @INC */
        -:  348:    {"STDOUT", MP_GLOBAL_OFFSET(defout), MP_GLOBAL_GVIO}, /* $| */
        -:  349:    {"/",      MP_GLOBAL_OFFSET(rs),     MP_GLOBAL_SVPV}, /* $/ */
        -:  350:    {NULL}
        -:  351:};
        -:  352:
        -:  353:#define MP_PERL_GLOBAL_SAVE(type, ptr) \
        -:  354:    modperl_perl_global_##type##_save( \
        -:  355:        aTHX_ (modperl_perl_global_##type##_t *)&(*ptr))
        -:  356:
        -:  357:#define MP_PERL_GLOBAL_RESTORE(type, ptr) \
        -:  358:    modperl_perl_global_##type##_restore( \
        -:  359:        aTHX_ (modperl_perl_global_##type##_t *)&(*ptr))
        -:  360:
        -:  361:#define MP_dGLOBAL_PTR(globals, entries) \
        -:  362:    apr_uint64_t **ptr = (apr_uint64_t **) \
        -:  363:        ((char *)globals + (int)(long)entries->offset)
        -:  364:
        -:  365:static void modperl_perl_global_save(pTHX_ modperl_perl_globals_t *globals,
        -:  366:                                     modperl_perl_global_entry_t *entries)
      127:  367:{
      127:  368:    modperl_perl_global_init(aTHX_ globals);
        -:  369:
      127:  370:    while (entries->name) {
      635:  371:        MP_dGLOBAL_PTR(globals, entries);
        -:  372:
      635:  373:        switch (entries->type) {
        -:  374:          case MP_GLOBAL_AVCV:
      127:  375:            MP_PERL_GLOBAL_SAVE(avcv, ptr);
      127:  376:            break;
        -:  377:          case MP_GLOBAL_GVHV:
      127:  378:            MP_PERL_GLOBAL_SAVE(gvhv, ptr);
      127:  379:            break;
        -:  380:          case MP_GLOBAL_GVAV:
      127:  381:            MP_PERL_GLOBAL_SAVE(gvav, ptr);
      127:  382:            break;
        -:  383:          case MP_GLOBAL_GVIO:
      127:  384:            MP_PERL_GLOBAL_SAVE(gvio, ptr);
      127:  385:            break;
        -:  386:          case MP_GLOBAL_SVPV:
      127:  387:            MP_PERL_GLOBAL_SAVE(svpv, ptr);
        -:  388:            break;
        -:  389:        }
        -:  390:
      635:  391:        entries++;
        -:  392:    }
        -:  393:}
        -:  394:
        -:  395:static void modperl_perl_global_restore(pTHX_ modperl_perl_globals_t *globals,
        -:  396:                                        modperl_perl_global_entry_t *entries)
      127:  397:{
      127:  398:    while (entries->name) {
      635:  399:        MP_dGLOBAL_PTR(globals, entries);
        -:  400:
      635:  401:        switch (entries->type) {
        -:  402:          case MP_GLOBAL_AVCV:
      127:  403:            MP_PERL_GLOBAL_RESTORE(avcv, ptr);
      127:  404:            break;
        -:  405:          case MP_GLOBAL_GVHV:
      127:  406:            MP_PERL_GLOBAL_RESTORE(gvhv, ptr);
      127:  407:            break;
        -:  408:          case MP_GLOBAL_GVAV:
      127:  409:            MP_PERL_GLOBAL_RESTORE(gvav, ptr);
      127:  410:            break;
        -:  411:          case MP_GLOBAL_GVIO:
      127:  412:            MP_PERL_GLOBAL_RESTORE(gvio, ptr);
      127:  413:            break;
        -:  414:          case MP_GLOBAL_SVPV:
      127:  415:            MP_PERL_GLOBAL_RESTORE(svpv, ptr);
        -:  416:            break;
        -:  417:        }
        -:  418:
      635:  419:        entries++;
        -:  420:    }
        -:  421:}
        -:  422:
        -:  423:void modperl_perl_global_request_save(pTHX_ request_rec *r)
      127:  424:{
      127:  425:    MP_dRCFG;
      127:  426:    modperl_perl_global_save(aTHX_ &rcfg->perl_globals,
        -:  427:                             MP_perl_global_entries);
        -:  428:}
        -:  429:
        -:  430:void modperl_perl_global_request_restore(pTHX_ request_rec *r)
      127:  431:{
      127:  432:    MP_dRCFG;
      127:  433:    modperl_perl_global_restore(aTHX_ &rcfg->perl_globals,
        -:  434:                                MP_perl_global_entries);
        -:  435:
        -:  436:}