/* 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:
 */