/* ====================================================================
 * The Apache Software License, Version 1.1
 *
 * Copyright (c) 1996-2000 The Apache Software Foundation.  All rights
 * reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 *
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in
 *    the documentation and/or other materials provided with the
 *    distribution.
 *
 * 3. The end-user documentation included with the redistribution,
 *    if any, must include the following acknowledgment:
 *       "This product includes software developed by the
 *        Apache Software Foundation (http://www.apache.org/)."
 *    Alternately, this acknowledgment may appear in the software itself,
 *    if and wherever such third-party acknowledgments normally appear.
 *
 * 4. The names "Apache" and "Apache Software Foundation" must
 *    not be used to endorse or promote products derived from this
 *    software without prior written permission. For written
 *    permission, please contact apache@apache.org.
 *
 * 5. Products derived from this software may not be called "Apache",
 *    nor may "Apache" appear in their name, without prior written
 *    permission of the Apache Software Foundation.
 *
 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
 * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 * DISCLAIMED.  IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR
 * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
 * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
 * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
 * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 * ====================================================================
 */
#include "mod_perl.h"
static HV *mod_perl_endhv = Nullhv;
static int set_ids = 0;
void perl_util_cleanup(void)
{
    hv_undef(mod_perl_endhv);
    SvREFCNT_dec((SV*)mod_perl_endhv);
    mod_perl_endhv = Nullhv;
    set_ids = 0;
}
SV *array_header2avrv(array_header *arr)
{
    AV *av;
    int i;
    dTHR;
    iniAV(av);
    if(arr) {
        for (i = 0; i < arr->nelts; i++) {
            av_push(av, newSVpv(((char **) arr->elts)[i], 0));
        }
    }
    return newRV_noinc((SV*)av);
}
array_header *avrv2array_header(SV *avrv, pool *p)
{
    AV *av = (AV*)SvRV(avrv);
    I32 i;
    array_header *arr = make_array(p, AvFILL(av)-1, sizeof(char *));
    for(i=0; i<=AvFILL(av); i++) {
        SV *sv = *av_fetch(av, i, FALSE);    
        char **entry = (char **) push_array(arr);
        *entry = pstrdup(p, SvPV(sv,na));
    }
    return arr;
}
table *hvrv2table(SV *rv)
{
    if(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV) {
        SV *sv = perl_hvrv_magic_obj(rv);
        if(!sv) croak("HV is not magic!");
        return (table *)SvIV((SV*)SvRV(sv));
    }
    return (table *)SvIV((SV*)SvRV(rv));
}
static char *r_keys[] = { "_r", "r", NULL };
static request_rec *r_magic_get(SV *sv)
{
    MAGIC *mg  = mg_find(sv, '~');
    return mg ? (request_rec *)mg->mg_ptr : NULL;
}
request_rec *sv2request_rec(SV *in, char *pclass, CV *cv)
{
    request_rec *r = NULL;
    SV *sv = Nullsv;
    if(in == &sv_undef) return NULL;
    if(SvROK(in) && (SvTYPE(SvRV(in)) == SVt_PVHV)) {
        int i;
        for (i=0; r_keys[i]; i++) {
            int klen = strlen(r_keys[i]);
            if(hv_exists((HV*)SvRV(in), r_keys[i], klen) &&
               (sv = *hv_fetch((HV*)SvRV(in), 
                               r_keys[i], klen, FALSE))) {
                if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) {
                    /* dig deeper */
                    return sv2request_rec(sv, pclass, cv);
                }
                break;
            }
        }
        if(!sv)
            croak("method `%s' invoked by a `%s' object with no `r' key!",
                  GvNAME(CvGV(cv)), HvNAME(SvSTASH(SvRV(in))));
    }
    if(!sv) sv = in;
    if(SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG)) {
        if(sv_derived_from(sv, pclass)) {
            if((r = r_magic_get(SvRV(sv)))) {
                /* ~ magic */
            }
            else {
                r = (request_rec *) SvIV((SV*)SvRV(sv));
            }
        }
        else {
            return NULL;
        }
    }
    else if((r = perl_request_rec(NULL))) {
        /*ok*/
    } 
    else {
        croak("Apache->%s called without setting Apache->request!",
              GvNAME(CvGV(cv)));
    }
    return r;
}
pool *perl_get_util_pool(void)
{
    request_rec *r = NULL;
    if((r = perl_request_rec(NULL)))
        return r->pool;
    else
        return perl_get_startup_pool();
    return NULL;
}
pool *perl_get_startup_pool(void)
{
    SV *sv = perl_get_sv("Apache::__POOL", FALSE);
    if(sv) {
        IV tmp = SvIV((SV*)SvRV(sv));
        return (pool *)tmp;
    }
    return NULL;
}
server_rec *perl_get_startup_server(void)
{
    SV *sv = perl_get_sv("Apache::__SERVER", FALSE);
    if(sv) {
        IV tmp = SvIV((SV*)SvRV(sv));
        return (server_rec *)tmp;
    }
    return NULL;
}
void mod_perl_untaint(SV *sv)
{
    if(!tainting) return;
    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
        MAGIC *mg = mg_find(sv, 't');
        if (mg)
            mg->mg_len &= ~1;
    }
}
/* same as Symbol::gensym() */
SV *mod_perl_gensym (char *pack)
{
    GV *gv = newGVgen(pack);
    SV *rv = newRV((SV*)gv);
    (void)hv_delete(gv_stashpv(pack, TRUE), 
                    GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
    return rv;
}
SV *mod_perl_slurp_filename(request_rec *r)
{
    dTHR;
    PerlIO *fp;
    SV *insv;
    ENTER;
    save_item(rs);
    sv_setsv(rs, &sv_undef); 
    fp = PerlIO_open(r->filename, "r");
    insv = newSV(r->finfo.st_size);
    sv_gets(insv, fp, 0); /*slurp*/
    PerlIO_close(fp);
    LEAVE;
    return newRV_noinc(insv);
}
SV *mod_perl_tie_table(table *t)
{
    HV *hv = newHV();
    SV *sv = sv_newmortal();
    sv_setref_pv(sv, "Apache::table", (void*)t);
    perl_tie_hash(hv, "Apache::Table", sv);
    return sv_bless(sv_2mortal(newRV_noinc((SV*)hv)), 
                    gv_stashpv("Apache::Table", TRUE));
}
SV *perl_hvrv_magic_obj(SV *rv)
{
    HV *hv = (HV*)SvRV(rv); 
    MAGIC *mg;
    if(SvMAGICAL(hv) && (mg = mg_find((SV*)hv, 'P'))) 
        return mg->mg_obj;
    else
        return Nullsv;
}
void perl_tie_hash(HV *hv, char *pclass, SV *sv)
{
    dSP;
    SV *obj, *varsv = (SV*)hv;
    char *methname = "TIEHASH";
    dTHRCTX;
    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
    XPUSHs(sv_2mortal(newSVpv(pclass,0)));
    if(sv) XPUSHs(sv);
    PUTBACK;
    perl_call_method(methname, G_EVAL | G_SCALAR);
    if(SvTRUE(ERRSV)) warn("perl_tie_hash: %s", SvPV(ERRSV,na));
    SPAGAIN;
    obj = POPs;
    sv_unmagic(varsv, 'P');
    sv_magic(varsv, obj, 'P', Nullch, 0);
    PUTBACK;
    FREETMPS;
    LEAVE; 
}
/* execute END blocks */
void perl_run_blocks(I32 oldscope, AV *subs)
{
    STRLEN len;
    I32 i;
    dTHR;
    dTHRCTX;
    for(i=0; i<=AvFILL(subs); i++) {
        CV *cv = (CV*)*av_fetch(subs, i, FALSE);
        SV* atsv = ERRSV;
        MARK_WHERE("END block", (SV*)cv);
        PUSHMARK(stack_sp);
        perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
        UNMARK_WHERE;
        (void)SvPV(atsv, len);
        if (len) {
            if (subs == beginav)
                sv_catpv(atsv, "BEGIN failed--compilation aborted");
            else
                sv_catpv(atsv, "END failed--cleanup aborted");
            while (scopestack_ix > oldscope)
                LEAVE;
        }
    }
}
void mod_perl_clear_rgy_endav(request_rec *r, SV *sv)
{
    STRLEN klen;
    char *key;
    if(!mod_perl_endhv) return;
    key = SvPV(sv,klen);
    if(hv_exists(mod_perl_endhv, key, klen)) {
        SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE);
        AV *av;
        if(!SvTRUE(entry) && !SvROK(entry)) {
            MP_TRACE_g(fprintf(stderr, "endav is empty for %s\n", r->uri));
            return;
        }
        av = (AV*)SvRV(entry);
        av_clear(av);
        SvREFCNT_dec((SV*)av);
        (void)hv_delete(mod_perl_endhv, key, klen, G_DISCARD);
        MP_TRACE_g(fprintf(stderr, 
                         "clearing END blocks for package `%s' (uri=%s)\n",
                         key, r->uri)); 
    }
}
void perl_stash_rgy_endav(char *s, SV *rgystash)
{
    AV *rgyendav = Nullav;
    STRLEN klen;
    char *key;
    dTHR;
    if(!rgystash) 
        rgystash = perl_get_sv("Apache::Registry::curstash", FALSE);
    if(!rgystash || !SvTRUE(rgystash)) {
        MP_TRACE_g(fprintf(stderr, 
        "Apache::Registry::curstash not set, can't stash END blocks for %s\n",
                         s));
        return;
    }
    key = SvPV(rgystash,klen);
    if(mod_perl_endhv == Nullhv)
        mod_perl_endhv = newHV();
    else if(hv_exists(mod_perl_endhv, key, klen)) {
        SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE);
        if(SvTRUE(entry) && SvROK(entry)) 
            rgyendav = (AV*)SvRV(entry);
    }
    if(endav) {
        I32 i;
        if(rgyendav == Nullav)
            rgyendav = newAV();
        if(AvFILL(rgyendav) > -1)
            av_clear(rgyendav);
        else
            av_extend(rgyendav, AvFILL(endav));
        for(i=0; i<=AvFILL(endav); i++) {
            SV **svp = av_fetch(endav, i, FALSE);
            av_store(rgyendav, i, (SV*)newRV((SV*)*svp));
        }
    }
    if(rgyendav)
        hv_store(mod_perl_endhv, key, klen, (SV*)newRV((SV*)rgyendav), FALSE);
}
void perl_run_rgy_endav(char *s) 
{
    SV *rgystash = perl_get_sv("Apache::Registry::curstash", FALSE);
    AV *rgyendav = Nullav;
    STRLEN klen;
    char *key;
    dTHR;
    if(!rgystash || !SvTRUE(rgystash)) {
        MP_TRACE_g(fprintf(stderr, 
        "Apache::Registry::curstash not set, can't run END blocks for %s\n",
                         s));
        return;
    }
    key = SvPV(rgystash,klen);
    if(hv_exists(mod_perl_endhv, key, klen)) {
        SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE);
        if(SvTRUE(entry) && SvROK(entry)) 
            rgyendav = (AV*)SvRV(entry);
    }
    MP_TRACE_g(fprintf(stderr, 
             "running %d END blocks for %s\n", rgyendav ? (int)AvFILL(rgyendav)+1 : 0, s));
    ENTER;
    save_aptr(&endav); 
    if((endav = rgyendav)) 
        perl_run_blocks(scopestack_ix, endav);
    LEAVE;
    sv_setpv(rgystash,"");
}
void perl_run_endav(char *s)
{
    dTHR;
    I32 n = 0;
    if(endav)
        n = AvFILL(endav)+1;
    MP_TRACE_g(fprintf(stderr, "running %d END blocks for %s\n", 
                       (int)n, s));
    if(endav) {
        curstash = defstash;
        call_list(scopestack_ix, endav);
    }
}
static PERL_MG_UFUNC(errgv_empty_set, ix, sv)
{ 
    sv_setsv(sv, &sv_no);
    return TRUE;
}
void perl_call_halt(int status)
{
    dTHR;
    struct ufuncs umg;
    int is_http_code = 
        ((status >= 100) && (status < 600) && ERRSV_CAN_BE_HTTP);
    dTHRCTX;
    umg.uf_val = errgv_empty_set;
    umg.uf_set = errgv_empty_set;
    umg.uf_index = (IV)0;
     
    if(is_http_code) {
        croak("%d\n", status);
    }
    else {
        sv_magic(ERRSV, Nullsv, 'U', (char*) &umg, sizeof(umg));
        ENTER;
        SAVESPTR(diehook);
        diehook = Nullsv; 
        croak("");
        LEAVE; /* we don't get this far, but croak() will rewind */
        sv_unmagic(ERRSV, 'U');
    }
}
/*
 * reload %INC: cannot do so while iterating over %INC incase
 * reloaded modules modify %INC at the file-scope
 * this approach also preserves order for modules loaded via PerlModule
 */
void perl_reload_inc(server_rec *s, pool *sp)
{
    dPSRV(s);
    HV *hash = GvHV(incgv);
    HE *entry;
    I32 old_warn = dowarn;
    pool *p = ap_make_sub_pool(sp);
    table *reload = ap_make_table(p, HvKEYS(hash));
    char **entries;
    int i = 0;
    dowarn = FALSE;
    entries = (char **)cls->PerlModule->elts;
    for (i=0; i < cls->PerlModule->nelts; i++) {
        SV *file = perl_module2file(entries[i]);
        ap_table_set(reload, SvPVX(file), "1");
        SvREFCNT_dec(file);
    }
    hv_iterinit(hash);
    while ((entry = hv_iternext(hash))) {
        ap_table_setn(reload, HeKEY(entry), "1");
    }
    {
        array_header *arr = ap_table_elts(reload);
        table_entry *elts = (table_entry *)arr->elts;
        SV *keysv = newSV(0);
        for (i=0; i < arr->nelts; i++) {
            sv_setpv(keysv, elts[i].key);
            if (!(entry = hv_fetch_ent(hash, keysv, FALSE, 0))) {
                MP_TRACE_g(fprintf(stderr, 
                                   "%s not found in %%INC\n", elts[i].key));
                continue;
            }
            SvREFCNT_dec(HeVAL(entry));
            HeVAL(entry) = &sv_undef;
            MP_TRACE_g(fprintf(stderr, "reloading %s\n", HeKEY(entry)));
            perl_require_pv(HeKEY(entry));
        }
        SvREFCNT_dec(keysv);
    }
    dowarn = old_warn;
    ap_destroy_pool(p);
}
I32 perl_module_is_loaded(char *name)
{
    I32 retval = FALSE;
    SV *key = perl_module2file(name);
    if((key && hv_exists_ent(GvHV(incgv), key, FALSE)))
        retval = TRUE;
    if(key)
        SvREFCNT_dec(key);
    return retval;
}
SV *perl_module2file(char *name)
{
    SV *sv = newSVpv(name,0);
    char *s;
    for (s = SvPVX(sv); *s; s++) {
        if (*s == ':' && s[1] == ':') {
            *s = '/';
            Move(s+2, s+1, strlen(s+2)+1, char);
            --SvCUR(sv);
        }
    }
    sv_catpvn(sv, ".pm", 3);
    return sv;
}
int perl_require_module(char *name, server_rec *s)
{
    dTHR;
    SV *sv = sv_newmortal();
    dTHRCTX;
    sv_setpvn(sv, "require ", 8);
    MP_TRACE_d(fprintf(stderr, "loading perl module '%s'...", name)); 
    sv_catpv(sv, name);
    perl_eval_sv(sv, G_DISCARD);
    if(s) {
        if(perl_eval_ok(s) != OK) {
            MP_TRACE_d(fprintf(stderr, "not ok\n"));
            return -1;
        }
    }
    else if(SvTRUE(ERRSV)) {
        MP_TRACE_d(fprintf(stderr, "not ok\n"));
        return -1;
    }
    MP_TRACE_d(fprintf(stderr, "ok\n"));
    return 0;
}
void perl_do_file(char *pv)
{
    SV* sv = sv_newmortal();
    sv_setpv(sv, "require '");
    sv_catpv(sv, pv);
    sv_catpv(sv, "'");
    perl_eval_sv(sv, G_DISCARD);
    /*(void)hv_delete(GvHV(incgv), pv, strlen(pv), G_DISCARD);*/
}      
int perl_load_startup_script(server_rec *s, pool *p, char *script, I32 my_warn)
{
    dTHR;
    I32 old_warn = dowarn;
    if(!script) {
        MP_TRACE_d(fprintf(stderr, "no Perl script to load\n"));
        return OK;
    }
    MP_TRACE_d(fprintf(stderr, "attempting to require `%s'\n", script));
    dowarn = my_warn;
    curstash = defstash;
    perl_do_file(script);
    dowarn = old_warn;
    return perl_eval_ok(s);
} 
void mp_magic_setenv(char *key, char *val, int is_tainted)
{
    int klen = strlen(key);
    SV **ptr = hv_fetch(GvHV(envgv), key, klen, TRUE);
    if (ptr) {
        SvSetMagicSV(*ptr, newSVpv(val,0));
        if (is_tainted) {
            SvTAINTED_on(*ptr);
        }
    }
}
array_header *perl_cgi_env_init(request_rec *r)
{
    table *envtab = r->subprocess_env; 
    char *tz = NULL; 
    add_common_vars(r); 
    add_cgi_vars(r); 
    /* resetup global request rec, because it may set to an (invalid) subrequest by ap_add_cgi_vars */
    perl_request_rec(r);
    if (!table_get(envtab, "TZ")) {
        if ((tz = getenv("TZ")) != NULL) {
            table_set(envtab, "TZ", tz);
        }
    }
    if (!table_get(envtab, "PATH")) {
        table_set(envtab, "PATH", DEFAULT_PATH);
    }
    table_set(envtab, "GATEWAY_INTERFACE", PERL_GATEWAY_INTERFACE);
    return table_elts(envtab);
}
#define untie_env  sv_unmagic((SV*)GvHV(envgv), 'E')
#define tie_env    sv_magic((SV*)GvHV(envgv), (SV*)envgv, 'E', Nullch, 0)
#define delete_env(ken, klen) \
    (void)hv_delete(GvHV(envgv), key, klen, G_DISCARD)
void perl_clear_env(void)
{
    char *key;
    I32 klen;
    SV *val;
    HV *hv = (HV*)GvHV(envgv);
    untie_env;
    if(!hv_exists(hv, "MOD_PERL", 8)) {
        hv_store(hv, "MOD_PERL", 8,
                 newSVpv(MOD_PERL_STRING_VERSION,0), FALSE);
        hv_store(hv, "GATEWAY_INTERFACE", 17,
                 newSVpv("CGI-Perl/1.1",0), FALSE);
    }
    (void)hv_iterinit(hv);
    while ((val = hv_iternextsv(hv, (char **) &key, &klen))) {
        if((*key == 'G') && strEQ(key, "GATEWAY_INTERFACE"))
            continue;
        else if((*key == 'M') && strnEQ(key, "MOD_PERL", 8))
            continue;
        else if((*key == 'T') && strnEQ(key, "TZ", 2))
            continue;
        else if((*key == 'P') && strEQ(key, "PATH"))
            continue;
        else if((*key == 'H') && strnEQ(key, "HTTP_", 5)) {
            tie_env;
            delete_env(key, klen);
            untie_env;
            continue;
        }
        delete_env(key, klen);
    }
    tie_env;
}
void mod_perl_init_ids(void)  /* $$, $>, $), etc */
{
    if(set_ids++) return;
    sv_setiv(GvSV(gv_fetchpv("$", TRUE, SVt_PV)), (I32)getpid());
#ifndef WIN32
    uid  = (int)getuid(); 
    euid = (int)geteuid(); 
    gid  = (int)getgid(); 
    egid = (int)getegid(); 
    MP_TRACE_g(fprintf(stderr, 
                     "perl_init_ids: uid=%d, euid=%d, gid=%d, egid=%d\n",
                     uid, euid, gid, egid));
#endif
}
int perl_eval_ok(server_rec *s)
{
    int status;
    SV *sv;
    dTHR;
    dTHRCTX;
    sv = ERRSV;
    if (SvTRUE(sv)) {
        if (SvMAGICAL(sv) && (SvCUR(sv) > 4) &&
            strnEQ(SvPVX(sv), " at ", 4))
        {
            /* Apache::exit was called */
            return DECLINED;
        }
        if (perl_sv_is_http_code(ERRSV, &status)) {
            return status;
        }
        MP_TRACE_g(fprintf(stderr, "perl_eval error: %s\n", SvPV(sv,na)));
        mod_perl_error(s, SvPV(sv, na));
        return SERVER_ERROR;
    }
    return OK;
}
int perl_sv_is_http_code(SV *errsv, int *status) 
{
    int i=0, http_code=0, retval = FALSE;
    char *errpv;
    char cpcode[4];
    dTHR;
    if(!SvTRUE(errsv) || !ERRSV_CAN_BE_HTTP)
        return FALSE;
    errpv = SvPVX(errsv);
    for(i=0;i<=2;i++) {
        if(i >= SvCUR(errsv)) 
            break;
        if(isDIGIT(SvPVX(errsv)[i])) 
            http_code++;
        else
            http_code--;
    }
    /* we've looked at the first 3 characters of $@
     * if they're not all digits, $@ is not an HTTP code
     */
    if(http_code != 3) {
        MP_TRACE_g(fprintf(stderr, 
                         "mod_perl: $@ doesn't look like an HTTP code `%s'\n", 
                         errpv));
        return FALSE;
    }
    /* nothin but 3 digits */
    if(SvCUR(errsv) == http_code)
        return TRUE;
    ap_cpystrn((char *)cpcode, errpv, 4);
    MP_TRACE_g(fprintf(stderr, 
                     "mod_perl: possible $@ HTTP code `%s' (cp=`%s')\n", 
                     errpv,cpcode));
    if((SvCUR(errsv) == 4) && (*(SvEND(errsv) - 1) == '\n')) {
        /* nothin but 3 digit code and \n */
        retval = TRUE;
    }
    else {
        char *tmp = errpv;
        tmp += 3;
#ifndef PERL_MARK_WHERE
        if(strNE(SvPVX(GvSV(CopFILEGV(curcop))), "-e")) {
            SV *fake = newSV(0);
            sv_setpv(fake, ""); /* avoid -w warning */
            sv_catpvf(fake, " at %_ line ", GvSV(CopFILEGV(curcop)));
            if(strnEQ(SvPVX(fake), tmp, SvCUR(fake))) 
                /* $@ is nothing but 3 digit code and the mess die tacks on */
                retval = TRUE;
            SvREFCNT_dec(fake);
        }
#endif
        if(!retval && strnEQ(tmp, " at ", 4) && instr(errpv, " line "))
            /* well, close enough */
            retval = TRUE;
    }
    if(retval == TRUE) {
        *status = atoi(cpcode);
        MP_TRACE_g(fprintf(stderr, 
                         "mod_perl: $@ is an HTTP code `%d'\n", *status));
    }
    return retval;
}
#ifndef PERLLIB_SEP
#define PERLLIB_SEP ':'
#endif
void perl_incpush(char *p)
{
    if(!p) return;
    while(p && *p) {
        SV *libdir = newSV(0);
        char *s;
        while(*p == PERLLIB_SEP) p++;
        if((s = strchr(p, PERLLIB_SEP)) != Nullch) {
            sv_setpvn(libdir, p, (STRLEN)(s - p));
            p = s + 1;
        }
        else {
            sv_setpv(libdir, p);
            p = Nullch;
        }
        av_push(GvAV(incgv), libdir);
    }
}
#ifdef PERL_MARK_WHERE
/* XXX find the right place for this! */
static SV *perl_sv_name(SV *svp)
{
    SV *sv = Nullsv;
    SV *RETVAL = Nullsv;
    if(svp && SvROK(svp) && (sv = SvRV(svp))) {
        switch(SvTYPE(sv)) {
        case SVt_PVCV:
            RETVAL = newSV(0);
            gv_fullname(RETVAL, CvGV(sv));
            break;
        default:
            break;
        }
    }
    else if(svp && SvPOK(svp)) {
        RETVAL = newSVsv(svp);
    }
    return RETVAL;
}
void mod_perl_mark_where(char *where, SV *sub)
{
    dTHR;
    SV *name = Nullsv;
    if(CopLINE(curcop)) {
#if 0
        fprintf(stderr, "already know where: %s line %d\n",
                SvPV(GvSV(CopFILEGV(curcop)),na), CopFILEGV(curcop));
#endif
        return;
    }
    SAVECOPFILE(curcop);
    SAVECOPLINE(curcop);
    if(sub) 
        name = perl_sv_name(sub);
    sv_setpv(GvSV(CopFILEGV(curcop)), "");
    sv_catpvf(GvSV(CopFILEGV(curcop)), "%s subroutine `%_'", where, name);
    CopLINE_set(curcop, 1);
    if(name)
        SvREFCNT_dec(name);
}
#endif
#if MODULE_MAGIC_NUMBER < 19971226
char *ap_cpystrn(char *dst, const char *src, size_t dst_size)
{
    char *d, *end;
    if (!dst_size)
        return (dst);
    d = dst;
    end = dst + dst_size - 1;
    for (; d < end; ++d, ++src) {
        if (!(*d = *src)) {
            return (d);
        }
    }
    *d = '\0';  /* always null terminate */
    return (d);
}
#endif
#if defined(WIN32) && defined(PERL_IS_5_6)
void
Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp)
{
    SV **oldmark = mark;
    register I32 items = sp - mark;
    register STRLEN len;
    STRLEN delimlen;
    register char *delim = SvPV(del, delimlen);
    STRLEN tmplen;
    mark++;
    len = (items > 0 ? (delimlen * (items - 1) ) : 0);
    (void)SvUPGRADE(sv, SVt_PV);
    if (SvLEN(sv) < len + items) {   /* current length is way too short */
        while (items-- > 0) {
            if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) {
                SvPV(*mark, tmplen);
                len += tmplen;
            }
            mark++;
        }
        SvGROW(sv, len + 1);            /* so try to pre-extend */
        mark = oldmark;
        items = sp - mark;
        ++mark;
    }
    if (items-- > 0) {
        char *s;
        if (*mark) {
            s = SvPV(*mark, tmplen);
            sv_setpvn(sv, s, tmplen);
        }
        else
            sv_setpv(sv, "");
        mark++;
    }
    else
        sv_setpv(sv,"");
    len = delimlen;
    if (len) {
        for (; items > 0; items--,mark++) {
            sv_catpvn(sv,delim,len);
            sv_catsv(sv,*mark);
        }
    }
    else {
        for (; items > 0; items--,mark++)
            sv_catsv(sv,*mark);
    }
    SvSETMAGIC(sv);
}
#endif