/* ====================================================================
 * 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;
    U8 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, U8 my_warn)
{
    dTHR;
    U8 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 retval = FALSE;
    STRLEN i=0, http_code=0;
    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_inc_unshift(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_unshift(GvAV(incgv), 1);
       av_store(GvAV(incgv), 0, 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)), "");
    if (name) {
        sv_catpvf(GvSV(CopFILEGV(curcop)), "%s subroutine `%_'", where, name);
        SvREFCNT_dec(name);
    }
    else {
        sv_catpvf(GvSV(CopFILEGV(curcop)), "%s subroutine <unknown>", where);
    }
    
    CopLINE_set(curcop, 1);

}
#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