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

 /* ====================================================================
  * 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_set(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;
 	    }
 	    hv_delete_ent(hash, keysv, G_DISCARD, 0);
 	    MP_TRACE_g(fprintf(stderr, "reloading %s\n", elts[i].key));
 	    perl_require_pv(elts[i].key);
 	}
 	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
 #if (PERL_REVISION == 5) && (PERL_VERSION <= 15)
     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
 #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
	/* ====================================================================
	* 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_set(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;
	}
	hv_delete_ent(hash, keysv, G_DISCARD, 0);
	MP_TRACE_g(fprintf(stderr, "reloading %s\n", elts[i].key));
	perl_require_pv(elts[i].key);
	}
	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
	#if (PERL_REVISION == 5) && (PERL_VERSION <= 15)
	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
	#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