src/modules/perl/modperl_perl_global.c - mod_perl - Git at Google

 /* Licensed to the Apache Software Foundation (ASF) under one or more
  * contributor license agreements.  See the NOTICE file distributed with
  * this work for additional information regarding copyright ownership.
  * The ASF licenses this file to You under the Apache License, Version 2.0
  * (the "License"); you may not use this file except in compliance with
  * the License.  You may obtain a copy of the License at
  *
  *     http://www.apache.org/licenses/LICENSE-2.0
  *
  * Unless required by applicable law or agreed to in writing, software
  * distributed under the License is distributed on an "AS IS" BASIS,
  * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  * See the License for the specific language governing permissions and
  * limitations under the License.
  */

 #include "mod_perl.h"

 /* XXX: PL_modglobal thingers might be useful elsewhere */

 #define MP_MODGLOBAL_ENT(key)                                           \
     {key, "ModPerl::" key, MP_SSTRLEN("ModPerl::") + MP_SSTRLEN(key), 0}

 static modperl_modglobal_key_t MP_modglobal_keys[] = {
     MP_MODGLOBAL_ENT("END"),
     MP_MODGLOBAL_ENT("ANONSUB"),
     { NULL },
 };

 void modperl_modglobal_hash_keys(pTHX)
 {
     modperl_modglobal_key_t *gkey = MP_modglobal_keys;

     while (gkey->name) {
         PERL_HASH(gkey->hash, gkey->val, gkey->len);
         gkey++;
     }
 }

 modperl_modglobal_key_t *modperl_modglobal_lookup(pTHX_ const char *name)
 {
     modperl_modglobal_key_t *gkey = MP_modglobal_keys;

     while (gkey->name) {
         if (strEQ(gkey->name, name)) {
             return gkey;
         }
         gkey++;
     }

     return NULL;
 }

 static void modperl_perl_global_init(pTHX_ modperl_perl_globals_t *globals)
 {
     globals->env.gv    = PL_envgv;
     globals->inc.gv    = PL_incgv;
     globals->defout.gv = PL_defoutgv;
     globals->rs.sv     = &PL_rs;
     globals->end.av    = &PL_endav;
     globals->end.key   = MP_MODGLOBAL_END;
 }

 /*
  * if (exists $PL_modglobal{$key}{$package}) {
  *      return $PL_modglobal{$key}{$package};
  * }
  * elsif ($autovivify) {
  *     return $PL_modglobal{$key}{$package} = [];
  * }
  * else {
  *     return (AV *)NULL; # a null pointer in C of course :)
  * }
  */
 static AV *modperl_perl_global_avcv_fetch(pTHX_ modperl_modglobal_key_t *gkey,
                                           const char *package, I32 packlen,
                                           I32 autovivify)
 {
     HE *he = MP_MODGLOBAL_FETCH(gkey);
     HV *hv;

     if (!(he && (hv = (HV*)HeVAL(he)))) {
         if (autovivify) {
             hv = MP_MODGLOBAL_STORE_HV(gkey);
         }
         else {
             return (AV *)NULL;
         }
     }

     if ((he = hv_fetch_he(hv, (char *)package, packlen, 0))) {
         return (AV*)HeVAL(he);
     }
     else {
         if (autovivify) {
             return (AV*)*hv_store(hv, package, packlen, (SV*)newAV(), 0);
         }
         else {
             return (AV *)NULL;
         }
     }
 }

 /* autovivify $PL_modglobal{$key}{$package} if it doesn't exist yet,
  * so that in modperl_perl_global_avcv_set we will know whether to
  * store blocks in it or keep them in the original list.
  *
  * For example in the case of END blocks, if
  * $PL_modglobal{END}{$package} exists, modperl_perl_global_avcv_set
  * will push newly encountered END blocks to it, otherwise it'll keep
  * them in PL_endav.
  */
 void modperl_perl_global_avcv_register(pTHX_ modperl_modglobal_key_t *gkey,
                                        const char *package, I32 packlen)
 {
     AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey,
                                             package, packlen, TRUE);

     MP_TRACE_g(MP_FUNC, "register PL_modglobal %s::%s (has %d entries)",
                package, (char*)gkey->name, av ? 1+av_len(av) : 0);
 }

 /* if (exists $PL_modglobal{$key}{$package}) {
  *     for my $cv (@{ $PL_modglobal{$key}{$package} }) {
  *         $cv->();
  *     }
  * }
  */
 void modperl_perl_global_avcv_call(pTHX_ modperl_modglobal_key_t *gkey,
                                    const char *package, I32 packlen)
 {
     AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen,
                                             FALSE);

     MP_TRACE_g(MP_FUNC, "run PL_modglobal %s::%s (has %d entries)",
                package, (char*)gkey->name, av ? 1+av_len(av) : 0);

     if (av) {
         modperl_perl_call_list(aTHX_ av, gkey->name);
     }
 }


 /* if (exists $PL_modglobal{$key}{$package}) {
  *     @{ $PL_modglobal{$key}{$package} } = ();
  * }
  */
 void modperl_perl_global_avcv_clear(pTHX_ modperl_modglobal_key_t *gkey,
                                     const char *package, I32 packlen)
 {
     AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey,
                                             package, packlen, FALSE);

     MP_TRACE_g(MP_FUNC, "clear PL_modglobal %s::%s (has %d entries)",
                package, (char*)gkey->name, av ? 1+av_len(av) : 0);

     if (av) {
         av_clear(av);
     }
 }

 static int modperl_perl_global_avcv_set(pTHX_ SV *sv, MAGIC *mg)
 {
     AV *mav, *av = (AV*)sv;
     const char *package = HvNAME(PL_curstash);
     I32 packlen = strlen(package);
     modperl_modglobal_key_t *gkey =
         (modperl_modglobal_key_t *)mg->mg_ptr;

     /* the argument sv, is the original list perl was operating on.
      * (e.g. PL_endav). So now if we find that we have package/cv name
      * (e.g. Foo/END) registered for set-aside, we remove the cv that
      * was just unshifted in and push it into
      * $PL_modglobal{$key}{$package}. Otherwise we do nothing, which
      * keeps the unshifted cv (e.g. END block) in its original av
      * (e.g. PL_endav)
      */

     mav = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen, FALSE);

     if (!mav) {
         MP_TRACE_g(MP_FUNC, "%s::%s is not going to PL_modglobal",
                    package, (char*)gkey->name);
         /* keep it in the tied list (e.g. PL_endav) */
         return 1;
     }

     MP_TRACE_g(MP_FUNC, "%s::%s is going into PL_modglobal",
                package, (char*)gkey->name);

     sv = av_shift(av);

     /* push @{ $PL_modglobal{$key}{$package} }, $cv */
     av_store(mav, AvFILLp(mav)+1, sv);

     /* print scalar @{ $PL_modglobal{$key}{$package} } */
     MP_TRACE_g(MP_FUNC, "%s::%s av now has %d entries",
                package, (char*)gkey->name, 1+av_len(mav));

     return 1;
 }

 static MGVTBL modperl_vtbl_global_avcv_t = {
     0,
     modperl_perl_global_avcv_set,
     0, 0, 0,
 };

 static void modperl_perl_global_avcv_tie(pTHX_ modperl_modglobal_key_e key,
                                          AV *av)
 {
     if (!SvMAGIC((SV*)av)) {
         MAGIC *mg;
         Newxz(mg, 1, MAGIC);
         mg->mg_virtual = &modperl_vtbl_global_avcv_t;
         mg->mg_ptr = (char *)&MP_modglobal_keys[key];
         mg->mg_len = -1; /* prevent free() of mg->mg_ptr */
         SvMAGIC((SV*)av) = mg;
     }

     SvSMAGICAL_on((SV*)av);
 }

 static void modperl_perl_global_avcv_untie(pTHX_ AV *av)
 {
     SvSMAGICAL_off((SV*)av);
 }

 static void
 modperl_perl_global_avcv_save(pTHX_ modperl_perl_global_avcv_t *avcv)
 {
     if (!*avcv->av) {
         *avcv->av = newAV();
     }

     modperl_perl_global_avcv_tie(aTHX_ avcv->key, *avcv->av);
 }

 static void
 modperl_perl_global_avcv_restore(pTHX_ modperl_perl_global_avcv_t *avcv)
 {
     modperl_perl_global_avcv_untie(aTHX_ *avcv->av);
 }

 /*
  * newHVhv is not good enough since it does not copy magic.
  * XXX: 5.8.0+ newHVhv has some code thats faster than hv_iternext
  */
 static HV *copyENV(pTHX_ HV *ohv)
 {
     HE *entry, *hv_eiter;
     I32 hv_riter;
     register HV *hv;
     STRLEN hv_max = HvMAX(ohv);
     STRLEN hv_fill = HvFILL(ohv);

     hv = newHV();
     while (hv_max && hv_max + 1 >= hv_fill * 2) {
         hv_max = hv_max / 2;    /* Is always 2^n-1 */
     }

     HvMAX(hv) = hv_max;

     if (!hv_fill) {
         return hv;
     }

     hv_riter = HvRITER(ohv);    /* current root of iterator */
     hv_eiter = HvEITER(ohv);    /* current entry of iterator */

     hv_iterinit(ohv);
     while ((entry = hv_iternext(ohv))) {
         SV *sv = newSVsv(HeVAL(entry));
         modperl_envelem_tie(sv, HeKEY(entry), HeKLEN(entry));
         (void)hv_store(hv, HeKEY(entry), HeKLEN(entry),
                        sv, HeHASH(entry));
     }

     HvRITER(ohv) = hv_riter;
     HvEITER(ohv) = hv_eiter;

     hv_magic(hv, (GV *)NULL, 'E');

     TAINT_NOT;

     return hv;
 }

 static void
 modperl_perl_global_gvhv_save(pTHX_ modperl_perl_global_gvhv_t *gvhv)
 {
     HV *hv = GvHV(gvhv->gv);
 #if 0
     U32 mg_flags;
     MAGIC *mg = SvMAGIC(hv);

     /*
      * there should only be a small number of entries in %ENV
      * at this point: modperl_env.c:modperl_env_const_vars[],
      * PerlPassEnv and top-level PerlSetEnv
      * XXX: still; could have have something faster than newHVhv()
      * especially if we add another GVHV to the globals table that
      * might have more entries
      */

     /* makes newHVhv() faster in bleedperl */
     MP_magical_untie(hv, mg_flags);

     gvhv->tmphv = newHVhv(hv);
     TAINT_NOT;

     /* reapply magic flags */
     MP_magical_tie(hv, mg_flags);
     MP_magical_tie(gvhv->tmphv, mg_flags);

     if (mg && mg->mg_type && !SvMAGIC(gvhv->tmphv)) {
         /* propagate SvMAGIC(hv) to SvMAGIC(gvhv->tmphv) */
         /* XXX: maybe newHVhv should do this? */
         hv_magic(gvhv->tmphv, (GV *)NULL, mg->mg_type);
     }
 #else
     gvhv->tmphv = copyENV(aTHX_ hv);
 #endif

     gvhv->orighv = hv;
     GvHV(gvhv->gv) = gvhv->tmphv;
 }

 static void
 modperl_perl_global_gvhv_restore(pTHX_ modperl_perl_global_gvhv_t *gvhv)
 {
     U32 mg_flags;

     GvHV(gvhv->gv) = gvhv->orighv;

     /* loose magic for hv_clear()
      * e.g. for %ENV don't want to clear environ array
      */
     MP_magical_untie(gvhv->tmphv, mg_flags);
     SvREFCNT_dec(gvhv->tmphv);

     /* avoiding -Wall warning */
     mg_flags = mg_flags;
 }

 static void
 modperl_perl_global_gvav_save(pTHX_ modperl_perl_global_gvav_t *gvav)
 {
     gvav->origav = GvAV(gvav->gv);
     gvav->tmpav = newAV();
     modperl_perl_av_push_elts_ref(aTHX_ gvav->tmpav, gvav->origav);
     GvAV(gvav->gv) = gvav->tmpav;
 }

 static void
 modperl_perl_global_gvav_restore(pTHX_ modperl_perl_global_gvav_t *gvav)
 {
     GvAV(gvav->gv) = gvav->origav;
     SvREFCNT_dec(gvav->tmpav);
 }

 static void
 modperl_perl_global_gvio_save(pTHX_ modperl_perl_global_gvio_t *gvio)
 {
     gvio->flags = IoFLAGS(GvIOp(gvio->gv));
 }

 static void
 modperl_perl_global_gvio_restore(pTHX_ modperl_perl_global_gvio_t *gvio)
 {
     IoFLAGS(GvIOp(gvio->gv)) = gvio->flags;
 }

 static void
 modperl_perl_global_svpv_save(pTHX_ modperl_perl_global_svpv_t *svpv)
 {
     svpv->cur = SvCUR(*svpv->sv);
     strncpy(svpv->pv, SvPVX(*svpv->sv), sizeof(svpv->pv));
 }

 static void
 modperl_perl_global_svpv_restore(pTHX_ modperl_perl_global_svpv_t *svpv)
 {
     sv_setpvn(*svpv->sv, svpv->pv, svpv->cur);
 }

 typedef enum {
     MP_GLOBAL_AVCV,
     MP_GLOBAL_GVHV,
     MP_GLOBAL_GVAV,
     MP_GLOBAL_GVIO,
     MP_GLOBAL_SVPV
 } modperl_perl_global_types_e;

 typedef struct {
     char *name;
     int offset;
     modperl_perl_global_types_e type;
 } modperl_perl_global_entry_t;

 #define MP_GLOBAL_OFFSET(m) \
     STRUCT_OFFSET(modperl_perl_globals_t, m)

 static modperl_perl_global_entry_t MP_perl_global_entries[] = {
     {"END",    MP_GLOBAL_OFFSET(end),    MP_GLOBAL_AVCV}, /* END */
     {"ENV",    MP_GLOBAL_OFFSET(env),    MP_GLOBAL_GVHV}, /* %ENV */
     {"INC",    MP_GLOBAL_OFFSET(inc),    MP_GLOBAL_GVAV}, /* @INC */
     {"STDOUT", MP_GLOBAL_OFFSET(defout), MP_GLOBAL_GVIO}, /* $| */
     {"/",      MP_GLOBAL_OFFSET(rs),     MP_GLOBAL_SVPV}, /* $/ */
     {NULL}
 };

 #define MP_PERL_GLOBAL_SAVE(type, ptr) \
     modperl_perl_global_##type##_save( \
         aTHX_ (modperl_perl_global_##type##_t *)&(*ptr))

 #define MP_PERL_GLOBAL_RESTORE(type, ptr) \
     modperl_perl_global_##type##_restore( \
         aTHX_ (modperl_perl_global_##type##_t *)&(*ptr))

 #define MP_dGLOBAL_PTR(globals, entries) \
     apr_uint64_t **ptr = (apr_uint64_t **) \
         ((char *)globals + (int)(long)entries->offset)

 static void modperl_perl_global_save(pTHX_ modperl_perl_globals_t *globals,
                                      modperl_perl_global_entry_t *entries)
 {
     modperl_perl_global_init(aTHX_ globals);

     while (entries->name) {
         MP_dGLOBAL_PTR(globals, entries);

         switch (entries->type) {
           case MP_GLOBAL_AVCV:
             MP_PERL_GLOBAL_SAVE(avcv, ptr);
             break;
           case MP_GLOBAL_GVHV:
             MP_PERL_GLOBAL_SAVE(gvhv, ptr);
             break;
           case MP_GLOBAL_GVAV:
             MP_PERL_GLOBAL_SAVE(gvav, ptr);
             break;
           case MP_GLOBAL_GVIO:
             MP_PERL_GLOBAL_SAVE(gvio, ptr);
             break;
           case MP_GLOBAL_SVPV:
             MP_PERL_GLOBAL_SAVE(svpv, ptr);
             break;
         }

         entries++;
     }
 }

 static void modperl_perl_global_restore(pTHX_ modperl_perl_globals_t *globals,
                                         modperl_perl_global_entry_t *entries)
 {
     while (entries->name) {
         MP_dGLOBAL_PTR(globals, entries);

         switch (entries->type) {
           case MP_GLOBAL_AVCV:
             MP_PERL_GLOBAL_RESTORE(avcv, ptr);
             break;
           case MP_GLOBAL_GVHV:
             MP_PERL_GLOBAL_RESTORE(gvhv, ptr);
             break;
           case MP_GLOBAL_GVAV:
             MP_PERL_GLOBAL_RESTORE(gvav, ptr);
             break;
           case MP_GLOBAL_GVIO:
             MP_PERL_GLOBAL_RESTORE(gvio, ptr);
             break;
           case MP_GLOBAL_SVPV:
             MP_PERL_GLOBAL_RESTORE(svpv, ptr);
             break;
         }

         entries++;
     }
 }

 void modperl_perl_global_request_save(pTHX_ request_rec *r)
 {
     MP_dRCFG;
     modperl_perl_global_save(aTHX_ &rcfg->perl_globals,
                              MP_perl_global_entries);
 }

 void modperl_perl_global_request_restore(pTHX_ request_rec *r)
 {
     MP_dRCFG;
     modperl_perl_global_restore(aTHX_ &rcfg->perl_globals,
                                 MP_perl_global_entries);

 }

 /*
  * Local Variables:
  * c-basic-offset: 4
  * indent-tabs-mode: nil
  * End:
  */
	/* Licensed to the Apache Software Foundation (ASF) under one or more
	* contributor license agreements. See the NOTICE file distributed with
	* this work for additional information regarding copyright ownership.
	* The ASF licenses this file to You under the Apache License, Version 2.0
	* (the "License"); you may not use this file except in compliance with
	* the License. You may obtain a copy of the License at
	*
	* http://www.apache.org/licenses/LICENSE-2.0
	*
	* Unless required by applicable law or agreed to in writing, software
	* distributed under the License is distributed on an "AS IS" BASIS,
	* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
	* See the License for the specific language governing permissions and
	* limitations under the License.
	*/

	#include "mod_perl.h"

	/* XXX: PL_modglobal thingers might be useful elsewhere */

	#define MP_MODGLOBAL_ENT(key) \
	{key, "ModPerl::" key, MP_SSTRLEN("ModPerl::") + MP_SSTRLEN(key), 0}

	static modperl_modglobal_key_t MP_modglobal_keys[] = {
	MP_MODGLOBAL_ENT("END"),
	MP_MODGLOBAL_ENT("ANONSUB"),
	{ NULL },
	};

	void modperl_modglobal_hash_keys(pTHX)
	{
	modperl_modglobal_key_t *gkey = MP_modglobal_keys;

	while (gkey->name) {
	PERL_HASH(gkey->hash, gkey->val, gkey->len);
	gkey++;
	}
	}

	modperl_modglobal_key_t modperl_modglobal_lookup(pTHX_ const char name)
	{
	modperl_modglobal_key_t *gkey = MP_modglobal_keys;

	while (gkey->name) {
	if (strEQ(gkey->name, name)) {
	return gkey;
	}
	gkey++;
	}

	return NULL;
	}

	static void modperl_perl_global_init(pTHX_ modperl_perl_globals_t *globals)
	{
	globals->env.gv = PL_envgv;
	globals->inc.gv = PL_incgv;
	globals->defout.gv = PL_defoutgv;
	globals->rs.sv = &PL_rs;
	globals->end.av = &PL_endav;
	globals->end.key = MP_MODGLOBAL_END;
	}

	/*
	* if (exists $PL_modglobal{$key}{$package}) {
	* return $PL_modglobal{$key}{$package};
	* }
	* elsif ($autovivify) {
	* return $PL_modglobal{$key}{$package} = [];
	* }
	* else {
	* return (AV *)NULL; # a null pointer in C of course :)
	* }
	*/
	static AV modperl_perl_global_avcv_fetch(pTHX_ modperl_modglobal_key_t gkey,
	const char *package, I32 packlen,
	I32 autovivify)
	{
	HE *he = MP_MODGLOBAL_FETCH(gkey);
	HV *hv;

	if (!(he && (hv = (HV*)HeVAL(he)))) {
	if (autovivify) {
	hv = MP_MODGLOBAL_STORE_HV(gkey);
	}
	else {
	return (AV *)NULL;
	}
	}

	if ((he = hv_fetch_he(hv, (char *)package, packlen, 0))) {
	return (AV*)HeVAL(he);
	}
	else {
	if (autovivify) {
	return (AV)hv_store(hv, package, packlen, (SV*)newAV(), 0);
	}
	else {
	return (AV *)NULL;
	}
	}
	}

	/* autovivify $PL_modglobal{$key}{$package} if it doesn't exist yet,
	* so that in modperl_perl_global_avcv_set we will know whether to
	* store blocks in it or keep them in the original list.
	*
	* For example in the case of END blocks, if
	* $PL_modglobal{END}{$package} exists, modperl_perl_global_avcv_set
	* will push newly encountered END blocks to it, otherwise it'll keep
	* them in PL_endav.
	*/
	void modperl_perl_global_avcv_register(pTHX_ modperl_modglobal_key_t *gkey,
	const char *package, I32 packlen)
	{
	AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey,
	package, packlen, TRUE);

	MP_TRACE_g(MP_FUNC, "register PL_modglobal %s::%s (has %d entries)",
	package, (char*)gkey->name, av ? 1+av_len(av) : 0);
	}

	/* if (exists $PL_modglobal{$key}{$package}) {
	* for my $cv (@{ $PL_modglobal{$key}{$package} }) {
	* $cv->();
	* }
	* }
	*/
	void modperl_perl_global_avcv_call(pTHX_ modperl_modglobal_key_t *gkey,
	const char *package, I32 packlen)
	{
	AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen,
	FALSE);

	MP_TRACE_g(MP_FUNC, "run PL_modglobal %s::%s (has %d entries)",
	package, (char*)gkey->name, av ? 1+av_len(av) : 0);

	if (av) {
	modperl_perl_call_list(aTHX_ av, gkey->name);
	}
	}


	/* if (exists $PL_modglobal{$key}{$package}) {
	* @{ $PL_modglobal{$key}{$package} } = ();
	* }
	*/
	void modperl_perl_global_avcv_clear(pTHX_ modperl_modglobal_key_t *gkey,
	const char *package, I32 packlen)
	{
	AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey,
	package, packlen, FALSE);

	MP_TRACE_g(MP_FUNC, "clear PL_modglobal %s::%s (has %d entries)",
	package, (char*)gkey->name, av ? 1+av_len(av) : 0);

	if (av) {
	av_clear(av);
	}
	}

	static int modperl_perl_global_avcv_set(pTHX_ SV sv, MAGIC mg)
	{
	AV mav, av = (AV*)sv;
	const char *package = HvNAME(PL_curstash);
	I32 packlen = strlen(package);
	modperl_modglobal_key_t *gkey =
	(modperl_modglobal_key_t *)mg->mg_ptr;

	/* the argument sv, is the original list perl was operating on.
	* (e.g. PL_endav). So now if we find that we have package/cv name
	* (e.g. Foo/END) registered for set-aside, we remove the cv that
	* was just unshifted in and push it into
	* $PL_modglobal{$key}{$package}. Otherwise we do nothing, which
	* keeps the unshifted cv (e.g. END block) in its original av
	* (e.g. PL_endav)
	*/

	mav = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen, FALSE);

	if (!mav) {
	MP_TRACE_g(MP_FUNC, "%s::%s is not going to PL_modglobal",
	package, (char*)gkey->name);
	/* keep it in the tied list (e.g. PL_endav) */
	return 1;
	}

	MP_TRACE_g(MP_FUNC, "%s::%s is going into PL_modglobal",
	package, (char*)gkey->name);

	sv = av_shift(av);

	/* push @{ $PL_modglobal{$key}{$package} }, $cv */
	av_store(mav, AvFILLp(mav)+1, sv);

	/* print scalar @{ $PL_modglobal{$key}{$package} } */
	MP_TRACE_g(MP_FUNC, "%s::%s av now has %d entries",
	package, (char*)gkey->name, 1+av_len(mav));

	return 1;
	}

	static MGVTBL modperl_vtbl_global_avcv_t = {
	0,
	modperl_perl_global_avcv_set,
	0, 0, 0,
	};

	static void modperl_perl_global_avcv_tie(pTHX_ modperl_modglobal_key_e key,
	AV *av)
	{
	if (!SvMAGIC((SV*)av)) {
	MAGIC *mg;
	Newxz(mg, 1, MAGIC);
	mg->mg_virtual = &modperl_vtbl_global_avcv_t;
	mg->mg_ptr = (char *)&MP_modglobal_keys[key];
	mg->mg_len = -1; /* prevent free() of mg->mg_ptr */
	SvMAGIC((SV*)av) = mg;
	}

	SvSMAGICAL_on((SV*)av);
	}

	static void modperl_perl_global_avcv_untie(pTHX_ AV *av)
	{
	SvSMAGICAL_off((SV*)av);
	}

	static void
	modperl_perl_global_avcv_save(pTHX_ modperl_perl_global_avcv_t *avcv)
	{
	if (!*avcv->av) {
	*avcv->av = newAV();
	}

	modperl_perl_global_avcv_tie(aTHX_ avcv->key, *avcv->av);
	}

	static void
	modperl_perl_global_avcv_restore(pTHX_ modperl_perl_global_avcv_t *avcv)
	{
	modperl_perl_global_avcv_untie(aTHX_ *avcv->av);
	}

	/*
	* newHVhv is not good enough since it does not copy magic.
	* XXX: 5.8.0+ newHVhv has some code thats faster than hv_iternext
	*/
	static HV copyENV(pTHX_ HV ohv)
	{
	HE entry, hv_eiter;
	I32 hv_riter;
	register HV *hv;
	STRLEN hv_max = HvMAX(ohv);
	STRLEN hv_fill = HvFILL(ohv);

	hv = newHV();
	while (hv_max && hv_max + 1 >= hv_fill * 2) {
	hv_max = hv_max / 2; /* Is always 2^n-1 */
	}

	HvMAX(hv) = hv_max;

	if (!hv_fill) {
	return hv;
	}

	hv_riter = HvRITER(ohv); /* current root of iterator */
	hv_eiter = HvEITER(ohv); /* current entry of iterator */

	hv_iterinit(ohv);
	while ((entry = hv_iternext(ohv))) {
	SV *sv = newSVsv(HeVAL(entry));
	modperl_envelem_tie(sv, HeKEY(entry), HeKLEN(entry));
	(void)hv_store(hv, HeKEY(entry), HeKLEN(entry),
	sv, HeHASH(entry));
	}

	HvRITER(ohv) = hv_riter;
	HvEITER(ohv) = hv_eiter;

	hv_magic(hv, (GV *)NULL, 'E');

	TAINT_NOT;

	return hv;
	}

	static void
	modperl_perl_global_gvhv_save(pTHX_ modperl_perl_global_gvhv_t *gvhv)
	{
	HV *hv = GvHV(gvhv->gv);
	#if 0
	U32 mg_flags;
	MAGIC *mg = SvMAGIC(hv);

	/*
	* there should only be a small number of entries in %ENV
	* at this point: modperl_env.c:modperl_env_const_vars[],
	* PerlPassEnv and top-level PerlSetEnv
	* XXX: still; could have have something faster than newHVhv()
	* especially if we add another GVHV to the globals table that
	* might have more entries
	*/

	/* makes newHVhv() faster in bleedperl */
	MP_magical_untie(hv, mg_flags);

	gvhv->tmphv = newHVhv(hv);
	TAINT_NOT;

	/* reapply magic flags */
	MP_magical_tie(hv, mg_flags);
	MP_magical_tie(gvhv->tmphv, mg_flags);

	if (mg && mg->mg_type && !SvMAGIC(gvhv->tmphv)) {
	/* propagate SvMAGIC(hv) to SvMAGIC(gvhv->tmphv) */
	/* XXX: maybe newHVhv should do this? */
	hv_magic(gvhv->tmphv, (GV *)NULL, mg->mg_type);
	}
	#else
	gvhv->tmphv = copyENV(aTHX_ hv);
	#endif

	gvhv->orighv = hv;
	GvHV(gvhv->gv) = gvhv->tmphv;
	}

	static void
	modperl_perl_global_gvhv_restore(pTHX_ modperl_perl_global_gvhv_t *gvhv)
	{
	U32 mg_flags;

	GvHV(gvhv->gv) = gvhv->orighv;

	/* loose magic for hv_clear()
	* e.g. for %ENV don't want to clear environ array
	*/
	MP_magical_untie(gvhv->tmphv, mg_flags);
	SvREFCNT_dec(gvhv->tmphv);

	/* avoiding -Wall warning */
	mg_flags = mg_flags;
	}

	static void
	modperl_perl_global_gvav_save(pTHX_ modperl_perl_global_gvav_t *gvav)
	{
	gvav->origav = GvAV(gvav->gv);
	gvav->tmpav = newAV();
	modperl_perl_av_push_elts_ref(aTHX_ gvav->tmpav, gvav->origav);
	GvAV(gvav->gv) = gvav->tmpav;
	}

	static void
	modperl_perl_global_gvav_restore(pTHX_ modperl_perl_global_gvav_t *gvav)
	{
	GvAV(gvav->gv) = gvav->origav;
	SvREFCNT_dec(gvav->tmpav);
	}

	static void
	modperl_perl_global_gvio_save(pTHX_ modperl_perl_global_gvio_t *gvio)
	{
	gvio->flags = IoFLAGS(GvIOp(gvio->gv));
	}

	static void
	modperl_perl_global_gvio_restore(pTHX_ modperl_perl_global_gvio_t *gvio)
	{
	IoFLAGS(GvIOp(gvio->gv)) = gvio->flags;
	}

	static void
	modperl_perl_global_svpv_save(pTHX_ modperl_perl_global_svpv_t *svpv)
	{
	svpv->cur = SvCUR(*svpv->sv);
	strncpy(svpv->pv, SvPVX(*svpv->sv), sizeof(svpv->pv));
	}

	static void
	modperl_perl_global_svpv_restore(pTHX_ modperl_perl_global_svpv_t *svpv)
	{
	sv_setpvn(*svpv->sv, svpv->pv, svpv->cur);
	}

	typedef enum {
	MP_GLOBAL_AVCV,
	MP_GLOBAL_GVHV,
	MP_GLOBAL_GVAV,
	MP_GLOBAL_GVIO,
	MP_GLOBAL_SVPV
	} modperl_perl_global_types_e;

	typedef struct {
	char *name;
	int offset;
	modperl_perl_global_types_e type;
	} modperl_perl_global_entry_t;

	#define MP_GLOBAL_OFFSET(m) \
	STRUCT_OFFSET(modperl_perl_globals_t, m)

	static modperl_perl_global_entry_t MP_perl_global_entries[] = {
	{"END", MP_GLOBAL_OFFSET(end), MP_GLOBAL_AVCV}, /* END */
	{"ENV", MP_GLOBAL_OFFSET(env), MP_GLOBAL_GVHV}, /* %ENV */
	{"INC", MP_GLOBAL_OFFSET(inc), MP_GLOBAL_GVAV}, /* @INC */
	{"STDOUT", MP_GLOBAL_OFFSET(defout), MP_GLOBAL_GVIO}, /* $\| */
	{"/", MP_GLOBAL_OFFSET(rs), MP_GLOBAL_SVPV}, /* $/ */
	{NULL}
	};

	#define MP_PERL_GLOBAL_SAVE(type, ptr) \
	modperl_perl_global_##type##_save( \
	aTHX_ (modperl_perl_global_##type##_t )&(ptr))

	#define MP_PERL_GLOBAL_RESTORE(type, ptr) \
	modperl_perl_global_##type##_restore( \
	aTHX_ (modperl_perl_global_##type##_t )&(ptr))

	#define MP_dGLOBAL_PTR(globals, entries) \
	apr_uint64_t ptr = (apr_uint64_t ) \
	((char *)globals + (int)(long)entries->offset)

	static void modperl_perl_global_save(pTHX_ modperl_perl_globals_t *globals,
	modperl_perl_global_entry_t *entries)
	{
	modperl_perl_global_init(aTHX_ globals);

	while (entries->name) {
	MP_dGLOBAL_PTR(globals, entries);

	switch (entries->type) {
	case MP_GLOBAL_AVCV:
	MP_PERL_GLOBAL_SAVE(avcv, ptr);
	break;
	case MP_GLOBAL_GVHV:
	MP_PERL_GLOBAL_SAVE(gvhv, ptr);
	break;
	case MP_GLOBAL_GVAV:
	MP_PERL_GLOBAL_SAVE(gvav, ptr);
	break;
	case MP_GLOBAL_GVIO:
	MP_PERL_GLOBAL_SAVE(gvio, ptr);
	break;
	case MP_GLOBAL_SVPV:
	MP_PERL_GLOBAL_SAVE(svpv, ptr);
	break;
	}

	entries++;
	}
	}

	static void modperl_perl_global_restore(pTHX_ modperl_perl_globals_t *globals,
	modperl_perl_global_entry_t *entries)
	{
	while (entries->name) {
	MP_dGLOBAL_PTR(globals, entries);

	switch (entries->type) {
	case MP_GLOBAL_AVCV:
	MP_PERL_GLOBAL_RESTORE(avcv, ptr);
	break;
	case MP_GLOBAL_GVHV:
	MP_PERL_GLOBAL_RESTORE(gvhv, ptr);
	break;
	case MP_GLOBAL_GVAV:
	MP_PERL_GLOBAL_RESTORE(gvav, ptr);
	break;
	case MP_GLOBAL_GVIO:
	MP_PERL_GLOBAL_RESTORE(gvio, ptr);
	break;
	case MP_GLOBAL_SVPV:
	MP_PERL_GLOBAL_RESTORE(svpv, ptr);
	break;
	}

	entries++;
	}
	}

	void modperl_perl_global_request_save(pTHX_ request_rec *r)
	{
	MP_dRCFG;
	modperl_perl_global_save(aTHX_ &rcfg->perl_globals,
	MP_perl_global_entries);
	}

	void modperl_perl_global_request_restore(pTHX_ request_rec *r)
	{
	MP_dRCFG;
	modperl_perl_global_restore(aTHX_ &rcfg->perl_globals,
	MP_perl_global_entries);

	}

	/*
	* Local Variables:
	* c-basic-offset: 4
	* indent-tabs-mode: nil
	* End:
	*/