/* ====================================================================
 * 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.
 * ====================================================================
 */
/* 
 * And so it was decided the camel should be given magical multi-colored
 * feathers so it could fly and journey to once unknown worlds.
 * And so it was done...
 */
#define CORE_PRIVATE 
#include "mod_perl.h"
#ifdef WIN32
void *mod_perl_mutex = &mod_perl_mutex;
#else
void *mod_perl_dummy_mutex = &mod_perl_dummy_mutex;
#endif
static IV mp_request_rec;
static int seqno = 0;
static int perl_is_running = 0;
int mod_perl_socketexitoption = 3;
int mod_perl_weareaforkedchild = 0;     
static int callbacks_this_request = 0;
static PerlInterpreter *perl = NULL;
static AV *orig_inc = Nullav;
static AV *cleanup_av = Nullav;
#ifdef PERL_STACKED_HANDLERS
static HV *stacked_handlers = Nullhv;
#endif
#ifdef PERL_OBJECT
CPerlObj *pPerl;
#endif
typedef const char* (*crft)(); /* command_req_func_t */
static command_rec perl_cmds[] = {
#ifdef PERL_SECTIONS
    { "<Perl>", (crft) perl_section, NULL, SECTION_ALLOWED, RAW_ARGS, "Perl code" },
    { "</Perl>", (crft) perl_end_section, NULL, SECTION_ALLOWED, NO_ARGS, "End Perl code" },
#endif
    { "=pod", (crft) perl_pod_section, NULL, OR_ALL, RAW_ARGS, "Start of POD" },
    { "=back", (crft) perl_pod_section, NULL, OR_ALL, RAW_ARGS, "End of =over" },
    { "=cut", (crft) perl_pod_end_section, NULL, OR_ALL, NO_ARGS, "End of POD" },
    { "__END__", (crft) perl_config_END, NULL, OR_ALL, RAW_ARGS, "Stop reading config" },
    { "PerlFreshRestart", (crft) perl_cmd_fresh_restart,
      NULL,
      RSRC_CONF, FLAG, "Tell mod_perl to reload modules and flush Apache::Registry cache on restart" },
    { "PerlTaintCheck", (crft) perl_cmd_tainting,
      NULL,
      RSRC_CONF, FLAG, "Turn on -T switch" },
#ifdef PERL_SAFE_STARTUP
    { "PerlOpmask", (crft) perl_cmd_opmask,
      NULL,
      RSRC_CONF, TAKE1, "Opmask File" },
#endif
    { "PerlWarn", (crft) perl_cmd_warn,
      NULL,
      RSRC_CONF, FLAG, "Turn on -w switch" },
    { "PerlScript", (crft) perl_cmd_require,
      NULL,
      OR_ALL, ITERATE, "this directive is deprecated, use `PerlRequire'" },
    { "PerlRequire", (crft) perl_cmd_require,
      NULL,
      OR_ALL, ITERATE, "A Perl script name, pulled in via require" },
    { "PerlModule", (crft) perl_cmd_module,
      NULL,
      OR_ALL, ITERATE, "List of Perl modules" },
    { "PerlSetVar", (crft) perl_cmd_var,
      NULL,
      OR_ALL, TAKE2, "Perl config var and value" },
    { "PerlAddVar", (crft) perl_cmd_var,
      (void*)1,
      OR_ALL, ITERATE2, "Perl config var and value" },
    { "PerlSetEnv", (crft) perl_cmd_setenv,
      NULL,
      OR_ALL, TAKE2, "Perl %ENV key and value" },
    { "PerlPassEnv", (crft) perl_cmd_pass_env, 
      NULL,
      RSRC_CONF, ITERATE, "pass environment variables to %ENV"},  
    { "PerlSendHeader", (crft) perl_cmd_sendheader,
      NULL,
      OR_ALL, FLAG, "Tell mod_perl to parse and send HTTP headers" },
    { "PerlSetupEnv", (crft) perl_cmd_env,
      NULL,
      OR_ALL, FLAG, "Tell mod_perl to setup %ENV by default" },
    { "PerlHandler", (crft) perl_cmd_handler_handlers,
      NULL,
      OR_ALL, ITERATE, "the Perl handler routine name" },
#ifdef PERL_TRANS
    { PERL_TRANS_CMD_ENTRY },
#endif
#ifdef PERL_AUTHEN
    { PERL_AUTHEN_CMD_ENTRY },
#endif
#ifdef PERL_AUTHZ
    { PERL_AUTHZ_CMD_ENTRY },
#endif
#ifdef PERL_ACCESS
    { PERL_ACCESS_CMD_ENTRY },
#endif
#ifdef PERL_TYPE
    { PERL_TYPE_CMD_ENTRY },
#endif
#ifdef PERL_FIXUP
    { PERL_FIXUP_CMD_ENTRY },
#endif
#ifdef PERL_LOG
    { PERL_LOG_CMD_ENTRY },
#endif
#ifdef PERL_CLEANUP
    { PERL_CLEANUP_CMD_ENTRY },
#endif
#ifdef PERL_INIT
    { PERL_INIT_CMD_ENTRY },
#endif
#ifdef PERL_HEADER_PARSER
    { PERL_HEADER_PARSER_CMD_ENTRY },
#endif
#ifdef PERL_CHILD_INIT
    { PERL_CHILD_INIT_CMD_ENTRY },
#endif
#ifdef PERL_CHILD_EXIT
    { PERL_CHILD_EXIT_CMD_ENTRY },
#endif
#ifdef PERL_POST_READ_REQUEST
    { PERL_POST_READ_REQUEST_CMD_ENTRY },
#endif
#ifdef PERL_DISPATCH
    { PERL_DISPATCH_CMD_ENTRY },
#endif
#ifdef PERL_RESTART
    { PERL_RESTART_CMD_ENTRY },
#endif
    { NULL }
};
static handler_rec perl_handlers [] = {
    { "perl-script", perl_handler },
    { DIR_MAGIC_TYPE, perl_handler },
    { NULL }
};
module MODULE_VAR_EXPORT perl_module = {
    STANDARD_MODULE_STUFF,
    perl_module_init,                 /* initializer */
    perl_create_dir_config,    /* create per-directory config structure */
    perl_merge_dir_config,     /* merge per-directory config structures */
    perl_create_server_config, /* create per-server config structure */
    perl_merge_server_config,  /* merge per-server config structures */
    perl_cmds,                 /* command table */
    perl_handlers,             /* handlers */
    PERL_TRANS_HOOK,           /* translate_handler */
    PERL_AUTHEN_HOOK,          /* check_user_id */
    PERL_AUTHZ_HOOK,           /* check auth */
    PERL_ACCESS_HOOK,          /* check access */
    PERL_TYPE_HOOK,            /* type_checker */
    PERL_FIXUP_HOOK,           /* pre-run fixups */
    PERL_LOG_HOOK,          /* logger */
#if MODULE_MAGIC_NUMBER >= 19970103
    PERL_HEADER_PARSER_HOOK,   /* header parser */
#endif
#if MODULE_MAGIC_NUMBER >= 19970719
    PERL_CHILD_INIT_HOOK,   /* child_init */
#endif
#if MODULE_MAGIC_NUMBER >= 19970728
    NULL,   /* child_exit *//* mod_perl uses register_cleanup() */
#endif
#if MODULE_MAGIC_NUMBER >= 19970825
    PERL_POST_READ_REQUEST_HOOK,   /* post_read_request */
#endif
};
#if defined(STRONGHOLD) && !defined(APACHE_SSL)
#define APACHE_SSL
#endif
int PERL_RUNNING (void) 
{
    return (perl_is_running);
}
static void seqno_check_max(request_rec *r, int seqno)
{
    dPPDIR;
    char *max = NULL;
    array_header *vars = (array_header *)cld->vars;
    /* XXX: what triggers such a condition ?*/
    if(vars && (vars->nelts > 100000)) {
        fprintf(stderr, "[warning] PerlSetVar->nelts = %d\n", vars->nelts);
    }
    else {
      if(cld->vars)
          max = (char *)table_get(cld->vars, "MaxModPerlRequestsPerChild");
    }
#if (MODULE_MAGIC_NUMBER >= 19970912) && !defined(WIN32)
    if(max && (seqno >= atoi(max))) {
        child_terminate(r);
        MP_TRACE_g(fprintf(stderr, "mod_perl: terminating child %d after serving %d requests\n", 
                (int)getpid(), seqno));
    }
#endif
    max = NULL; 
}
void perl_shutdown (server_rec *s, pool *p)
{
    char *pdl = NULL;
    if((pdl = getenv("PERL_DESTRUCT_LEVEL")))
        perl_destruct_level = atoi(pdl);
    if(perl_destruct_level < 0) {
        MP_TRACE_g(fprintf(stderr, 
                           "skipping destruction of Perl interpreter\n"));
        return;
    }
    /* execute END blocks we suspended during perl_startup() */
    perl_run_endav("perl_shutdown"); 
    MP_TRACE_g(fprintf(stderr, 
                     "destructing and freeing Perl interpreter (level=%d)...",
               perl_destruct_level));
    perl_util_cleanup();
    mp_request_rec = 0;
    av_undef(orig_inc);
    SvREFCNT_dec((SV*)orig_inc);
    orig_inc = Nullav;
    av_undef(cleanup_av);
    SvREFCNT_dec((SV*)cleanup_av);
    cleanup_av = Nullav;
#ifdef PERL_STACKED_HANDLERS
    hv_undef(stacked_handlers);
    SvREFCNT_dec((SV*)stacked_handlers);
    stacked_handlers = Nullhv;
#endif
     
    perl_destruct(perl);
    perl_free(perl);
#ifdef USE_THREADS
    PERL_SYS_TERM();
#endif
    perl_is_running = 0;
    MP_TRACE_g(fprintf(stderr, "ok\n"));
}
request_rec *mp_fake_request_rec(server_rec *s, pool *p, char *hook)
{
    request_rec *r = (request_rec *)pcalloc(p, sizeof(request_rec));
    r->pool = p; 
    r->server = s;
    r->per_dir_config = NULL;
    r->uri = hook;
    r->notes = NULL;
    return r;
}
#ifdef PERL_RESTART
void perl_restart_handler(server_rec *s, pool *p)
{
    char *hook = "PerlRestartHandler";
    dSTATUS;
    dPSRV(s);
    request_rec *r = mp_fake_request_rec(s, p, hook);
    PERL_CALLBACK(hook, cls->PerlRestartHandler);   
}
#endif
void perl_restart(server_rec *s, pool *p)
{
    /* restart as best we can */
    SV *rgy_cache = perl_get_sv("Apache::Registry", FALSE);
    HV *rgy_symtab = (HV*)gv_stashpv("Apache::ROOT", FALSE);
    ENTER;
    SAVESPTR(warnhook);
    warnhook = perl_eval_pv("sub {}", TRUE);
    /* the file-stat cache */
    if(rgy_cache)
        sv_setsv(rgy_cache, &sv_undef);
    /* the symbol table we compile registry scripts into */
    if(rgy_symtab)
        hv_clear(rgy_symtab);
    if(endav) {
        SvREFCNT_dec(endav);
        endav = Nullav;
    }
#ifdef STACKED_HANDLERS
    if(stacked_handlers) 
        hv_clear(stacked_handlers);
#endif
    /* reload %INC */
    perl_reload_inc(s, p);
    LEAVE;
    /*mod_perl_notice(s, "mod_perl restarted"); */
    MP_TRACE_g(fprintf(stderr, "perl_restart: ok\n"));
}
U32 mp_debug = 0;
static void mod_perl_set_cwd(void)
{
    char *name = "Apache::Server::CWD";
    GV *gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PV);
    char *pwd = getenv("PWD");
    if(pwd) 
        sv_setpv(GvSV(gv), pwd);
    else 
        sv_setsv(GvSV(gv), 
                 perl_eval_pv("require Cwd; Cwd::getcwd()", TRUE));
    mod_perl_untaint(GvSV(gv));
}
#ifdef PERL_TIE_SCRIPTNAME
static PERL_MG_UFUNC(scriptname_val, ix, sv)
{ 
    dTHR;
    request_rec *r = perl_request_rec(NULL);
    if(r) 
        sv_setpv(sv, r->filename);
    else if(strNE(SvPVX(GvSV(CopFILEGV(curcop))), "-e"))
        sv_setsv(sv, GvSV(CopFILEGV(curcop)));
    else {
        SV *file = perl_eval_pv("(caller())[1]",TRUE);
        sv_setsv(sv, file);
    }
    MP_TRACE_g(fprintf(stderr, "FETCH $0 => %s\n", SvPV(sv,na)));
    return TRUE;
}
static void mod_perl_tie_scriptname(void)
{
    SV *sv = perl_get_sv("0",TRUE);
    struct ufuncs umg;
    umg.uf_val = scriptname_val;
    umg.uf_set = NULL;
    umg.uf_index = (IV)0;
    sv_unmagic(sv, 'U');
    sv_magic(sv, Nullsv, 'U', (char*) &umg, sizeof(umg));
}
#else
#define mod_perl_tie_scriptname()
#endif
#define saveINC \
    if(orig_inc) SvREFCNT_dec(orig_inc); \
    orig_inc = av_copy_array(GvAV(incgv))
#define dl_librefs "DynaLoader::dl_librefs"
#define dl_modules "DynaLoader::dl_modules"
static array_header *xs_dl_librefs(pool *p)
{
    I32 i;
    AV *librefs = perl_get_av(dl_librefs, FALSE);
    AV *modules = perl_get_av(dl_modules, FALSE);
    array_header *arr;
    if (!librefs) {
        MP_TRACE_g(fprintf(stderr, 
                           "Could not get @%s for unloading.\n",
                           dl_librefs));
        return NULL;
    }
    arr = ap_make_array(p, AvFILL(librefs)-1, sizeof(void *));
    for (i=0; i<=AvFILL(librefs); i++) {
        void *handle;
        SV *handle_sv = *av_fetch(librefs, i, FALSE);
        SV *module_sv = *av_fetch(modules, i, FALSE);
        if(!handle_sv) {
            MP_TRACE_g(fprintf(stderr, 
                               "Could not fetch $%s[%d]!\n",
                               dl_librefs, (int)i));
            continue;
        }
        handle = (void *)SvIV(handle_sv);
        MP_TRACE_g(fprintf(stderr, "%s dl handle == 0x%lx\n",
                           SvPVX(module_sv), (unsigned long)handle));
        if (handle) {
            *(void **)ap_push_array(arr) = handle;
        }
    }
    av_clear(modules);
    av_clear(librefs);
    return arr;
}
static void unload_xs_so(array_header *librefs)
{
    int i;
    if (!librefs) {
        return;
    }
    for (i=0; i < librefs->nelts; i++) {
        void *handle = ((void **)librefs->elts)[i];
        MP_TRACE_g(fprintf(stderr, "unload_xs_so: 0x%lx\n",
                           (unsigned long)handle));
#ifdef _AIX
        /* make sure Perl's dlclose is used, instead of Apache's */
        dlclose(handle);
#else
        ap_os_dso_unload(handle);
#endif
    }
}
static void mp_dso_unload(void *data) 
{ 
    array_header *librefs;
    librefs = xs_dl_librefs((pool *)data);
    perl_destruct_level = 2;
    perl_shutdown(NULL, NULL);
    unload_xs_so(librefs);
} 
static void mp_server_notstarting(void *data) 
{
    saveINC;
    require_Apache(NULL); 
    Apache__ServerStarting(FALSE);
}
#define Apache__ServerStarting_on() \
    Apache__ServerStarting(PERL_RUNNING()); \
    if(!PERL_IS_DSO) \
        register_cleanup(p, NULL, mp_server_notstarting, mod_perl_noop) 
#define MP_APACHE_VERSION "1.27"
void mp_check_version(void)
{
    I32 i;
    SV *namesv;
    SV *version;
    STRLEN n_a;
    require_Apache(NULL);
    if(!(version = perl_get_sv("Apache::VERSION", FALSE)))
        croak("Apache.pm failed to load!"); /*should never happen*/
    if(strEQ(SvPV(version,n_a), MP_APACHE_VERSION)) /*no worries*/
        return;
    fprintf(stderr, "Apache.pm version %s required!\n", 
            MP_APACHE_VERSION);
    fprintf(stderr, "%s", form("%_ is version %_\n", 
                               *hv_fetch(GvHV(incgv), "Apache.pm", 9, FALSE),
                               version));
    fprintf(stderr, 
            "Perhaps you forgot to 'make install' or need to uninstall an old version?\n");
    namesv = NEWSV(806, 0);
    for(i=0; i<=AvFILL(GvAV(incgv)); i++) {
        char *tryname;
        PerlIO *tryrsfp = 0;
        SV *dir = *av_fetch(GvAV(incgv), i, TRUE);
        sv_setpvf(namesv, "%_/Apache.pm", dir);
        tryname = SvPVX(namesv);
        if((tryrsfp = PerlIO_open(tryname, "r"))) {
            fprintf(stderr, "Found: %s\n", tryname);
            PerlIO_close(tryrsfp);
        }
    }
    SvREFCNT_dec(namesv);
    exit(1);
}
#if !HAS_MMN_136
static void set_sigpipe(void)
{
    char *dargs[] = { NULL };
    perl_require_module("Apache::SIG", NULL);
    perl_call_argv("Apache::SIG::set", G_DISCARD, dargs);
}
#endif
void perl_module_init(server_rec *s, pool *p)
{
#if HAS_MMN_130
    ap_add_version_component(MOD_PERL_STRING_VERSION);
    if(PERL_RUNNING()) {
#ifdef PERL_IS_5_6
        char *version = form("Perl/v%vd", PL_patchlevel);
#else
        char *version = form("Perl/%_", perl_get_sv("]", TRUE));
#endif
        if(perl_get_sv("Apache::Server::AddPerlVersion", FALSE)) {
            ap_add_version_component(version);
        }
    }
#endif
    perl_startup(s, p);
}
void perl_startup (server_rec *s, pool *p)
{
    char *argv[] = { NULL, NULL, NULL, NULL, NULL, NULL, NULL };
    char **entries, *dstr;
    int status, i, argc=1;
    dPSRV(s);
    SV *pool_rv, *server_rv;
    GV *gv, *shgv;
#ifndef WIN32
    argv[0] = server_argv0;
#endif
#ifdef PERL_TRACE
    if((dstr = getenv("MOD_PERL_TRACE"))) {
        if(strEQ(dstr, "all")) {
            mp_debug = 0xffffffff;
        }
        else if (isALPHA(dstr[0])) {
            static char debopts[] = "dshgc";
            char *d;
            for (; *dstr && (d = strchr(debopts,*dstr)); dstr++) 
                mp_debug |= 1 << (d - debopts);
        }
        else {
            mp_debug = atoi(dstr);
        }
        mp_debug |= 0x80000000;
    }
#else
    dstr = NULL;
#endif
    if(PERL_RUNNING()) {
        saveINC;
        mp_check_version();
#if !HAS_MMN_136
        set_sigpipe();
#endif
    }
     
    if(perl_is_running == 0) {
        /* we'll boot Perl below */
    }
    else if(perl_is_running < PERL_DONE_STARTUP) {
        /* skip the -HUP at server-startup */
        perl_is_running++;
        Apache__ServerStarting_on();
        MP_TRACE_g(fprintf(stderr, "perl_startup: perl aleady running...ok\n"));
        return;
    }
    else {
        Apache__ServerReStarting(TRUE);
#ifdef PERL_RESTART
        perl_restart_handler(s, p);
#endif
        if(cls->FreshRestart)
            perl_restart(s, p);
        Apache__ServerReStarting(FALSE);
        return;
    }
    perl_is_running++;
    /* fake-up what the shell usually gives perl */
    if(cls->PerlTaintCheck) 
        argv[argc++] = "-T";
    if(cls->PerlWarn)
        argv[argc++] = "-w";
#ifdef WIN32
    argv[argc++] = "nul";
#else
    argv[argc++] = "/dev/null";
#endif
    MP_TRACE_g(fprintf(stderr, "perl_parse args: "));
    for(i=1; i<argc; i++)
        MP_TRACE_g(fprintf(stderr, "'%s' ", argv[i]));
    MP_TRACE_g(fprintf(stderr, "..."));
#ifdef USE_THREADS
# ifdef PERL_SYS_INIT
    PERL_SYS_INIT(&argc,&argv);
# endif
#endif
#ifndef perl_init_i18nl10n
    perl_init_i18nl10n(1);
#else
    /* 5.6 calls during perl_construct() */
#endif
    MP_TRACE_g(fprintf(stderr, "allocating perl interpreter..."));
    if((perl = perl_alloc()) == NULL) {
        MP_TRACE_g(fprintf(stderr, "not ok\n"));
        perror("alloc");
        exit(1);
    }
    MP_TRACE_g(fprintf(stderr, "ok\n"));
   
    MP_TRACE_g(fprintf(stderr, "constructing perl interpreter...ok\n"));
    perl_construct(perl);
    status = perl_parse(perl, xs_init, argc, argv, NULL);
    if (status != OK) {
        MP_TRACE_g(fprintf(stderr,"not ok, status=%d\n", status));
        perror("parse");
        exit(1);
    }
    MP_TRACE_g(fprintf(stderr, "ok\n"));
    perl_clear_env();
    mod_perl_pass_env(p, cls);
    mod_perl_set_cwd();
    mod_perl_tie_scriptname();
    MP_TRACE_g(fprintf(stderr, "running perl interpreter..."));
    pool_rv = perl_get_sv("Apache::__POOL", TRUE);
    sv_setref_pv(pool_rv, Nullch, (void*)p);
    server_rv = perl_get_sv("Apache::__SERVER", TRUE);
    sv_setref_pv(server_rv, Nullch, (void*)s);
    gv = GvSV_init("Apache::ERRSV_CAN_BE_HTTP");
#ifdef ERRSV_CAN_BE_HTTP
    GvSV_setiv(gv, TRUE);
#endif
    perl_tainting_set(s, cls->PerlTaintCheck);
    (void)GvSV_init("Apache::__SendHeader");
    (void)GvSV_init("Apache::__CurrentCallback");
    Apache__ServerReStarting(FALSE); /* just for -w */
    Apache__ServerStarting_on();
#ifdef PERL_STACKED_HANDLERS
    if(!stacked_handlers) {
        stacked_handlers = newHV();
        shgv = GvHV_init("Apache::PerlStackedHandlers");
        GvHV(shgv) = stacked_handlers;
    }
#endif 
#ifdef MULTITHREAD
    mod_perl_mutex = create_mutex(NULL);
#endif
    if ((status = perl_run(perl)) != OK) {
        MP_TRACE_g(fprintf(stderr,"not ok, status=%d\n", status));
        perror("run");
        exit(1);
    }
    MP_TRACE_g(fprintf(stderr, "ok\n"));
    /* Force the environment to be copied out of its original location
       above argv[].  This fixes a crash caused when a module called putenv()
       before any Perl modified the environment - environ would change to a
       new value, and the check in my_setenv() to duplicate the environment
       would fail, and then setting some environment value which had a previous
       value would cause perl to try to free() something from the original env.
       This crashed free(). */
    my_setenv("MODPERL_ENV_FIXUP", "0");
    my_setenv("MODPERL_ENV_FIXUP", NULL);
    {
        dTHR;
        TAINT_NOT; /* At this time all is safe */
    }
#ifdef MOD_PERL_PREFIX
        av_unshift(GvAV(incgv),1);
        av_store(GvAV(incgv), 0, newSVpv(MOD_PERL_PREFIX,0));
#endif
         
#ifdef APACHE_PERL5LIB
    perl_incpush(APACHE_PERL5LIB);
#else
    av_push(GvAV(incgv), newSVpv(server_root_relative(p,""),0));
    av_push(GvAV(incgv), newSVpv(server_root_relative(p,"lib/perl"),0));
#endif
    /* *CORE::GLOBAL::exit = \&Apache::exit */
    if(gv_stashpv("CORE::GLOBAL", FALSE)) {
        GV *exitgp = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
        GvCV(exitgp) = perl_get_cv("Apache::exit", TRUE);
        GvIMPORTED_CV_on(exitgp);
    }
    ENTER_SAFE(s,p);
    MP_TRACE_g(mod_perl_dump_opmask());
    entries = (char **)cls->PerlRequire->elts;
    for(i = 0; i < cls->PerlRequire->nelts; i++) {
        if(perl_load_startup_script(s, p, entries[i], TRUE) != OK) {
            fprintf(stderr, "Require of Perl file `%s' failed, exiting...\n", 
                    entries[i]);
            exit(1);
        }
    }
    entries = (char **)cls->PerlModule->elts;
    for(i = 0; i < cls->PerlModule->nelts; i++) {
        if(perl_require_module(entries[i], s) != OK) {
            fprintf(stderr, "Can't load Perl module `%s', exiting...\n", 
                    entries[i]);
            exit(1);
        }
    }
    LEAVE_SAFE;
    MP_TRACE_g(fprintf(stderr, 
             "mod_perl: %d END blocks encountered during server startup\n",
             endav ? (int)AvFILL(endav)+1 : 0));
#if MODULE_MAGIC_NUMBER < 19970728
    if(endav)
        MP_TRACE_g(fprintf(stderr, "mod_perl: cannot run END blocks encoutered at server startup without apache_1.3.0+\n"));
#endif
    saveINC;
    if (PERL_IS_DSO) {
        register_cleanup(p, p, mp_dso_unload, null_cleanup);
    }
}
int mod_perl_sent_header(request_rec *r, int val)
{
    dPPDIR;
    if (val == DONE) {
        val = r->assbackwards = 1; /* so apache does not send another header */
    }
    if(val) MP_SENTHDR_on(cld);
    val = MP_SENTHDR(cld) ? 1 : 0;
    return MP_SENDHDR(cld) ? val : 1;
}
#ifndef perl_init_ids
#define perl_init_ids mod_perl_init_ids()
#endif
int perl_handler(request_rec *r)
{
    dSTATUS;
    dPPDIR;
    dPPREQ;
    dTHR;
    GV *gv;
#ifdef USE_ITHREADS
    dTHX;
    if (!aTHX) {
        PERL_SET_CONTEXT(perl);
    }
#endif
    (void)acquire_mutex(mod_perl_mutex);
    gv = gv_fetchpv("SIG", TRUE, SVt_PVHV);
    
#if 0
    /* force 'PerlSendHeader On' for sub-requests
     * e.g. Apache::Sandwich 
     */
    if(r->main != NULL)
        MP_SENDHDR_on(cld); 
#endif
    if(MP_SENDHDR(cld)) 
        MP_SENTHDR_off(cld);
    (void)perl_request_rec(r); 
    MP_TRACE_g(fprintf(stderr, "perl_handler ENTER: SVs = %5d, OBJs = %5d\n",
                     (int)sv_count, (int)sv_objcount));
    ENTER;
    SAVETMPS;
    if (gv) {
        save_hptr(&GvHV(gv)); 
    }
    if (endav) {
        save_aptr(&endav); 
        endav = Nullav;
    }
    /* hookup STDIN & STDOUT to the client */
    perl_stdout2client(r);
    perl_stdin2client(r);
    if(!cfg) {
        cfg = perl_create_request_config(r->pool, r->server);
        set_module_config(r->request_config, &perl_module, cfg);
    }
    cfg->setup_env = 1;
    PERL_CALLBACK("PerlHandler", cld->PerlHandler);
    cfg->setup_env = 0;
    FREETMPS;
    LEAVE;
    MP_TRACE_g(fprintf(stderr, "perl_handler LEAVE: SVs = %5d, OBJs = %5d\n", 
                     (int)sv_count, (int)sv_objcount));
    if (r->prev && (r->prev->status != HTTP_OK) &&
        mod_perl_sent_header(r, 0))
    {
        /* avoid recursive error for ErrorDocuments */
        status = OK;
    }
    (void)release_mutex(mod_perl_mutex);
    return status;
}
#ifdef PERL_CHILD_INIT
typedef struct {
    server_rec *server;
    pool *pool;
} server_hook_args;
static void perl_child_exit_cleanup(void *data)
{
    server_hook_args *args = (server_hook_args *)data;
    PERL_CHILD_EXIT_HOOK(args->server, args->pool);
}
void PERL_CHILD_INIT_HOOK(server_rec *s, pool *p)
{
    char *hook = "PerlChildInitHandler";
    dSTATUS;
    dPSRV(s);
    request_rec *r = mp_fake_request_rec(s, p, hook);
    server_hook_args *args = 
        (server_hook_args *)palloc(p, sizeof(server_hook_args));
    args->server = s;
    args->pool = p;
    register_cleanup(p, args, perl_child_exit_cleanup, null_cleanup);
    mod_perl_init_ids();
    Apache__ServerStarting(FALSE);
    PERL_CALLBACK(hook, cls->PerlChildInitHandler);
}
#endif
#ifdef PERL_CHILD_EXIT
void PERL_CHILD_EXIT_HOOK(server_rec *s, pool *p)
{
    char *hook = "PerlChildExitHandler";
    dSTATUS;
    dPSRV(s);
    request_rec *r = mp_fake_request_rec(s, p, hook);
    PERL_CALLBACK(hook, cls->PerlChildExitHandler);
    perl_shutdown(s,p);
}
#endif
static int do_proxy (request_rec *r)
{
    return r->parsed_uri.scheme &&
        !(r->parsed_uri.hostname
          && strEQ(r->parsed_uri.scheme, ap_http_method(r))
          && ap_matches_request_vhost(r, r->parsed_uri.hostname,
                                      r->parsed_uri.port_str ? 
                                      r->parsed_uri.port : 
                                      ap_default_port(r)));
}
#ifdef PERL_POST_READ_REQUEST
int PERL_POST_READ_REQUEST_HOOK(request_rec *r)
{
    dSTATUS;
    dPSRV(r->server);
#ifdef PERL_TRANS
#if MODULE_MAGIC_NUMBER > 19980270
    if (cls->PerlTransHandler && do_proxy(r)) {
        r->proxyreq = 1;
        r->uri = r->unparsed_uri;
    }
#endif
#endif
#ifdef PERL_INIT
    PERL_CALLBACK("PerlInitHandler", cls->PerlInitHandler);
#endif
    PERL_CALLBACK("PerlPostReadRequestHandler", cls->PerlPostReadRequestHandler);
    return status;
}
#endif
#ifdef PERL_TRANS
int PERL_TRANS_HOOK(request_rec *r)
{
    dSTATUS;
    dPSRV(r->server);
    PERL_CALLBACK("PerlTransHandler", cls->PerlTransHandler);
    return status;
}
#endif
#ifdef PERL_HEADER_PARSER
int PERL_HEADER_PARSER_HOOK(request_rec *r)
{
    dSTATUS;
    dPPDIR;
#ifdef PERL_INIT
    PERL_CALLBACK("PerlInitHandler", 
                         cld->PerlInitHandler);
#endif
    PERL_CALLBACK("PerlHeaderParserHandler", 
                         cld->PerlHeaderParserHandler);
    return status;
}
#endif
#ifdef PERL_AUTHEN
int PERL_AUTHEN_HOOK(request_rec *r)
{
    dSTATUS;
    dPPDIR;
    PERL_CALLBACK("PerlAuthenHandler", cld->PerlAuthenHandler);
    return status;
}
#endif
#ifdef PERL_AUTHZ
int PERL_AUTHZ_HOOK(request_rec *r)
{
    dSTATUS;
    dPPDIR;
    PERL_CALLBACK("PerlAuthzHandler", cld->PerlAuthzHandler);
    return status;
}
#endif
#ifdef PERL_ACCESS
int PERL_ACCESS_HOOK(request_rec *r)
{
    dSTATUS;
    dPPDIR;
    PERL_CALLBACK("PerlAccessHandler", cld->PerlAccessHandler);
    return status;
}
#endif
#ifdef PERL_TYPE
int PERL_TYPE_HOOK(request_rec *r)
{
    dSTATUS;
    dPPDIR;
    PERL_CALLBACK("PerlTypeHandler", cld->PerlTypeHandler);
    return status;
}
#endif
#ifdef PERL_FIXUP
int PERL_FIXUP_HOOK(request_rec *r)
{
    dSTATUS;
    dPPDIR;
    PERL_CALLBACK("PerlFixupHandler", cld->PerlFixupHandler);
    return status;
}
#endif
#ifdef PERL_LOG
int PERL_LOG_HOOK(request_rec *r)
{
    dSTATUS;
    dPPDIR;
    PERL_CALLBACK("PerlLogHandler", cld->PerlLogHandler);
    return status;
}
#endif
#ifdef PERL_STACKED_HANDLERS
#define CleanupHandler \
((cld->PerlCleanupHandler && SvREFCNT(cld->PerlCleanupHandler)) ? cld->PerlCleanupHandler : Nullav)
#else
#define CleanupHandler cld->PerlCleanupHandler
#endif
#ifdef PERL_TRACE
static char *my_signame(I32 num)
{
#ifdef psig_name
    return Perl_psig_name[num] ?
        SvPV(Perl_psig_name[num],na) : "?";
#else
    return PL_sig_name[num];
#endif
}
#endif
static void per_request_cleanup(request_rec *r)
{
    dPPREQ;
    perl_request_sigsave **sigs;
    int i;
    if(!cfg) {
        return;
    }
    if(cfg->pnotes) {
        hv_clear(cfg->pnotes);
        SvREFCNT_dec(cfg->pnotes);
        cfg->pnotes = Nullhv;
    }
#ifndef WIN32
    sigs = (perl_request_sigsave **)cfg->sigsave->elts;
    for (i=0; i < cfg->sigsave->nelts; i++) {
        MP_TRACE_g(fprintf(stderr, 
                           "mod_perl: restoring SIG%s (%d) handler from: 0x%lx to: 0x%lx\n",
                           my_signame(sigs[i]->signo), (int)sigs[i]->signo,
                           (unsigned long)rsignal_state(sigs[i]->signo),
                           (unsigned long)sigs[i]->h));
        rsignal(sigs[i]->signo, sigs[i]->h);
    }
#endif
}
void mod_perl_end_cleanup(void *data)
{
    request_rec *r = (request_rec *)data;
    dSTATUS;
    dPPDIR;
#ifdef PERL_CLEANUP
    PERL_CALLBACK("PerlCleanupHandler", CleanupHandler);
#endif
    MP_TRACE_g(fprintf(stderr, "perl_end_cleanup..."));
    perl_run_rgy_endav(r->uri);
    per_request_cleanup(r);
    /* clear %ENV */
    perl_clear_env();
    /* reset @INC */
    av_undef(GvAV(incgv));
    SvREFCNT_dec(GvAV(incgv));
    GvAV(incgv) = Nullav;
    GvAV(incgv) = av_copy_array(orig_inc);
    /* reset $/ */
    sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
    {
        dTHR;
        /* %@ */
        hv_clear(ERRHV);
    }
    callbacks_this_request = 0;
#ifdef PERL_STACKED_HANDLERS
    /* reset Apache->push_handlers, but don't clear ExitHandler */
#define CH_EXIT_KEY "PerlChildExitHandler"
    {
        SV *exith = Nullsv;
        if(hv_exists(stacked_handlers, CH_EXIT_KEY, 20)) {
            exith = *hv_fetch(stacked_handlers, CH_EXIT_KEY, 20, FALSE);
            /* inc the refcnt since hv_clear will dec it */
            ++SvREFCNT(exith);
        }
        hv_clear(stacked_handlers);
        if(exith) 
            hv_store(stacked_handlers, CH_EXIT_KEY, 20, exith, FALSE);
    }
#endif
#ifdef USE_SFIO
    PerlIO_flush(PerlIO_stdout());
#endif
    MP_TRACE_g(fprintf(stderr, "ok\n"));
    (void)release_mutex(mod_perl_mutex); 
}
void mod_perl_cleanup_handler(void *data)
{
    request_rec *r = (request_rec *)data;
    SV *cv;
    I32 i;
    dPPDIR;
    (void)acquire_mutex(mod_perl_mutex); 
    MP_TRACE_h(fprintf(stderr, "running registered cleanup handlers...\n")); 
    for(i=0; i<=AvFILL(cleanup_av); i++) { 
        cv = *av_fetch(cleanup_av, i, 0);
        MARK_WHERE("registered cleanup", cv);
        perl_call_handler(cv, (request_rec *)r, Nullav);
        UNMARK_WHERE;
    }
    av_clear(cleanup_av);
#ifndef WIN32
    if(cld) MP_RCLEANUP_off(cld);
#endif
    (void)release_mutex(mod_perl_mutex); 
}
#ifdef PERL_METHOD_HANDLERS
int perl_handler_ismethod(HV *pclass, char *sub)
{
    CV *cv;
    HV *stash;
    GV *gv;
    SV *sv;
    int is_method=0;
    if(!sub) return 0;
    sv = newSVpv(sub,0);
    if(!(cv = sv_2cv(sv, &stash, &gv, FALSE))) {
        GV *gvp = gv_fetchmethod(pclass, sub);
        if (gvp) cv = GvCV(gvp);
    }
#ifdef CVf_METHOD
    if (cv && (CvFLAGS(cv) & CVf_METHOD)) {
        is_method = 1;
    }
#endif
    if (!is_method && (cv && SvPOK(cv))) {
        is_method = strnEQ(SvPVX(cv), "$$", 2);
    }
    MP_TRACE_h(fprintf(stderr, "checking if `%s' is a method...%s\n", 
           sub, (is_method ? "yes" : "no")));
    SvREFCNT_dec(sv);
    return is_method;
}
#endif
void mod_perl_noop(void *data) {}
void mod_perl_register_cleanup(request_rec *r, SV *sv)
{
    dPPDIR;
    if(!MP_RCLEANUP(cld)) {
        (void)perl_request_rec(r); 
        register_cleanup(r->pool, (void*)r,
                         mod_perl_cleanup_handler, mod_perl_noop);
        MP_RCLEANUP_on(cld);
        if(cleanup_av == Nullav) cleanup_av = newAV();
    }
    MP_TRACE_h(fprintf(stderr, "registering PerlCleanupHandler\n"));
     
    ++SvREFCNT(sv); av_push(cleanup_av, sv);
}
#ifdef PERL_STACKED_HANDLERS
int mod_perl_push_handlers(SV *self, char *hook, SV *sub, AV *handlers)
{
    int do_store=0, len=strlen(hook);
    SV **svp;
    if(self && SvTRUE(sub)) {
        if(handlers == Nullav) {
            svp = hv_fetch(stacked_handlers, hook, len, 0);
            MP_TRACE_h(fprintf(stderr, "fetching %s stack\n", hook));
            if(svp && SvTRUE(*svp) && SvROK(*svp)) {
                handlers = (AV*)SvRV(*svp);
            }
            else {
                MP_TRACE_h(fprintf(stderr, "%s handlers stack undef, creating\n", hook));
                handlers = newAV();
                do_store = 1;
            }
        }
             
        if(SvROK(sub) && (SvTYPE(SvRV(sub)) == SVt_PVCV)) {
            MP_TRACE_h(fprintf(stderr, "pushing CODE ref into `%s' handlers\n", hook));
        }
        else if(SvPOK(sub)) {
            if(do_store) {
                MP_TRACE_h(fprintf(stderr, 
                                   "pushing `%s' into `%s' handlers\n", 
                                   SvPV(sub,na), hook));
            }
            else {
                MP_TRACE_d(fprintf(stderr, 
                                   "pushing `%s' into `%s' handlers\n", 
                                   SvPV(sub,na), hook));
            }
        }
        else {
            warn("mod_perl_push_handlers: Not a subroutine name or CODE reference!");
        }
        ++SvREFCNT(sub); av_push(handlers, sub);
        if(do_store) 
            hv_store(stacked_handlers, hook, len, 
                     (SV*)newRV_noinc((SV*)handlers), 0);
        return 1;
    }
    return 0;
}
int perl_run_stacked_handlers(char *hook, request_rec *r, AV *handlers)
{
    dSTATUS;
    I32 i, do_clear=FALSE;
    SV *sub, **svp; 
    int hook_len = strlen(hook);
#ifdef USE_ITHREADS
    dTHX;
    if (!aTHX) {
        PERL_SET_CONTEXT(perl);
    }
#endif
    if(handlers == Nullav) {
        if(hv_exists(stacked_handlers, hook, hook_len)) {
           svp = hv_fetch(stacked_handlers, hook, hook_len, 0);
           if(svp && SvROK(*svp)) 
               handlers = (AV*)SvRV(*svp);
        }
        else {
            MP_TRACE_h(fprintf(stderr, "`%s' push_handlers() stack is empty\n", hook));
            return NO_HANDLERS;
        }
        do_clear = TRUE;
        MP_TRACE_h(fprintf(stderr, 
                 "running %d pushed (stacked) handlers for %s...\n", 
                         (int)AvFILL(handlers)+1, r->uri)); 
    }
    else {
#ifdef PERL_STACKED_HANDLERS
      /* XXX: bizarre, 
         I only see this with httpd.conf.pl and PerlAccessHandler */
        if(SvTYPE((SV*)handlers) != SVt_PVAV) {
#if MODULE_MAGIC_NUMBER > 19970909 
            aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_DEBUG, r->server,
#else
            fprintf(stderr, 
#endif
                    "[warning] %s stack is not an ARRAY!\n", hook);
            sv_dump((SV*)handlers);
            return DECLINED;
        }
#endif
        MP_TRACE_h(fprintf(stderr, 
                 "running %d server configured stacked handlers for %s...\n", 
                         (int)AvFILL(handlers)+1, r->uri)); 
    }
    for(i=0; i<=AvFILL(handlers); i++) {
        MP_TRACE_h(fprintf(stderr, "calling &{%s->[%d]} (%d total)\n", 
                           hook, (int)i, (int)AvFILL(handlers)+1));
        if(!(sub = *av_fetch(handlers, i, FALSE))) {
            MP_TRACE_h(fprintf(stderr, "sub not defined!\n"));
        }
        else {
            if(!SvTRUE(sub)) {
                MP_TRACE_h(fprintf(stderr, "sub undef!  skipping callback...\n"));
                continue;
            }
            MARK_WHERE(hook, sub);
            status = perl_call_handler(sub, r, Nullav);
            UNMARK_WHERE;
            MP_TRACE_h(fprintf(stderr, "&{%s->[%d]} returned status=%d\n",
                               hook, (int)i, status));
            if((status != OK) && (status != DECLINED)) {
                if(do_clear)
                    av_clear(handlers); 
                return status;
            }
        }
    }
    if(do_clear)
        av_clear(handlers);     
    return status;
}
#endif /* PERL_STACKED_HANDLERS */
/* things to do once per-request */
void perl_per_request_init(request_rec *r)
{
    dPPDIR;
    dPPREQ;
     
    /* PerlSendHeader */
    if(MP_SENDHDR(cld)) {
        MP_SENTHDR_off(cld);
        table_set(r->subprocess_env, 
                  "PERL_SEND_HEADER", "On");
    }
    else
        MP_SENTHDR_on(cld);
    if(!cfg) {
        cfg = perl_create_request_config(r->pool, r->server);
        set_module_config(r->request_config, &perl_module, cfg);
    }
    else if (cfg->setup_env && MP_ENV(cld)) { 
        perl_setup_env(r);
        cfg->setup_env = 0; /* just once per-request */
    }
    if (cfg->dir_env != cld->env) {
        /* PerlSetEnv
         * update only if the table changes across a request
         */
        mod_perl_dir_env(r, cld);
        cfg->dir_env = cld->env;
    }
    if(callbacks_this_request++ > 0) return;
    if (!r->main) {
        /* so Apache->request will work before PerlHandler with CGI.pm
         * XXX: triggers core dump in subrequests, 
         * so just do in the main request for now
         */
        (void)perl_request_rec(r);
    }
    /* SetEnv PERL5LIB */
    if (!MP_INCPUSH(cld)) {
        char *path = (char *)table_get(r->subprocess_env, "PERL5LIB");
        if (path) {
            perl_incpush(path);
            MP_INCPUSH_on(cld);
        }
    }
    {
        dPSRV(r->server);
        mod_perl_pass_env(r->pool, cls);
    }
    mod_perl_tie_scriptname();
    /* will be released in mod_perl_end_cleanup */
    (void)acquire_mutex(mod_perl_mutex); 
    register_cleanup(r->pool, (void*)r, mod_perl_end_cleanup, mod_perl_noop);
#ifdef WIN32
    sv_setpvf(perl_get_sv("Apache::CurrentThreadId", TRUE), "0x%lx",
              (unsigned long)GetCurrentThreadId());
#endif
    /* hookup stderr to error_log */
#ifndef PERL_TRACE
    if(r->server->error_log) 
        error_log2stderr(r->server);
#endif
    seqno++;
    MP_TRACE_g(fprintf(stderr, "mod_perl: inc seqno to %d for %s\n", seqno, r->uri));
    seqno_check_max(r, seqno);
    /* set $$, $>, etc., if 1.3a1+, this really happens during child_init */
    perl_init_ids; 
}
/* XXX this still needs work, getting there... */
int perl_call_handler(SV *sv, request_rec *r, AV *args)
{
    int count, status, is_method=0;
    dSP;
    perl_dir_config *cld = NULL;
    HV *stash = Nullhv;
    SV *pclass = newSVsv(sv), *dispsv = Nullsv;
    CV *cv = Nullcv;
    char *method = "handler";
    int defined_sub = 0, anon = 0;
    char *dispatcher = NULL;
    if(r->per_dir_config)
        cld = (perl_dir_config *) get_module_config(r->per_dir_config, &perl_module);
#ifdef PERL_DISPATCH
    if(cld && (dispatcher = cld->PerlDispatchHandler)) {
        if(!(dispsv = (SV*)perl_get_cv(dispatcher, FALSE))) {
            if(strlen(dispatcher) > 0) { /* XXX */
                fprintf(stderr, 
                        "mod_perl: unable to fetch PerlDispatchHandler `%s'\n",
                        dispatcher); 
            }
            dispatcher = NULL;
        }
    }
#endif
    if(r->per_dir_config)
        perl_per_request_init(r);
    if(!dispatcher && (SvTYPE(sv) == SVt_PV)) {
        char *imp = pstrdup(r->pool, (char *)SvPV(pclass,na));
        if((anon = strnEQ(imp,"sub ",4))) {
            sv = perl_eval_pv(imp, FALSE);
            MP_TRACE_h(fprintf(stderr, "perl_call: caching CV pointer to `__ANON__'\n"));
            defined_sub++;
            goto callback; /* XXX, I swear I've never used goto before! */
        }
#ifdef PERL_METHOD_HANDLERS
        {
            char *end_pclass = NULL;
            if ((end_pclass = strstr(imp, "->"))) {
                end_pclass[0] = '\0';
                if(pclass)
                    SvREFCNT_dec(pclass);
                pclass = newSVpv(imp, 0);
                end_pclass[0] = ':';
                end_pclass[1] = ':';
                method = &end_pclass[2];
                imp = method;
                ++is_method;
            }
        }
        if(*SvPVX(pclass) == '$') {
            SV *obj = perl_eval_pv(SvPVX(pclass), TRUE);
            if(SvROK(obj) && sv_isobject(obj)) {
                MP_TRACE_h(fprintf(stderr, "handler object %s isa %s\n",
                                   SvPVX(pclass),  HvNAME(SvSTASH((SV*)SvRV(obj)))));
                SvREFCNT_dec(pclass);
                pclass = obj;
                ++SvREFCNT(pclass); /* this will _dec later */
                stash = SvSTASH((SV*)SvRV(pclass));
            }
        }
        if(pclass && !stash) stash = gv_stashpv(SvPV(pclass,na),FALSE);
            
#if 0
        MP_TRACE_h(fprintf(stderr, "perl_call: pclass=`%s'\n", SvPV(pclass,na)));
        MP_TRACE_h(fprintf(stderr, "perl_call: imp=`%s'\n", imp));
        MP_TRACE_h(fprintf(stderr, "perl_call: method=`%s'\n", method));
        MP_TRACE_h(fprintf(stderr, "perl_call: stash=`%s'\n", 
                         stash ? HvNAME(stash) : "unknown"));
#endif
#else
        method = NULL; /* avoid warning */
#endif
    /* if a Perl*Handler is not a defined function name,
     * default to the class implementor's handler() function
     * attempt to load the class module if it is not already
     */
        if(!imp) imp = SvPV(sv,na);
        if(!stash) stash = gv_stashpv(imp,FALSE);
        if(!is_method)
            defined_sub = (cv = perl_get_cv(imp, FALSE)) ? TRUE : FALSE;
#ifdef PERL_METHOD_HANDLERS
        if(!defined_sub && stash) {
            GV *gvp;
            MP_TRACE_h(fprintf(stderr, 
                   "perl_call: trying method lookup on `%s' in class `%s'...", 
                   method, HvNAME(stash)));
            /* XXX Perl caches method lookups internally, 
             * should we cache this lookup?
             */
            if((gvp = gv_fetchmethod(stash, method))) {
                cv = GvCV(gvp);
                MP_TRACE_h(fprintf(stderr, "found\n"));
                is_method = perl_handler_ismethod(stash, method);
            }
            else {
                MP_TRACE_h(fprintf(stderr, "not found\n"));
            }
        }
#endif
        if(!stash && !defined_sub) {
            MP_TRACE_h(fprintf(stderr, "%s symbol table not found, loading...\n", imp));
            if(perl_require_module(imp, r->server) == OK)
                stash = gv_stashpv(imp,FALSE);
#ifdef PERL_METHOD_HANDLERS
            if(stash) /* check again */
                is_method = perl_handler_ismethod(stash, method);
#endif
            SPAGAIN; /* reset stack pointer after require() */
        }
         
        if(!is_method && !defined_sub) {
            MP_TRACE_h(fprintf(stderr, 
                             "perl_call: defaulting to %s::handler\n", imp));
            sv_catpv(sv, "::handler");
        }
         
#if 0 /* XXX: CV lookup cache disabled for now */
        if(!is_method && defined_sub) { /* cache it */
            MP_TRACE_h(fprintf(stderr, 
                             "perl_call: caching CV pointer to `%s'\n", 
                             (anon ? "__ANON__" : SvPV(sv,na))));
            SvREFCNT_dec(sv);
            sv = (SV*)newRV((SV*)cv); /* let newRV inc the refcnt */
        }
#endif
    }
    else {
        MP_TRACE_h(fprintf(stderr, "perl_call: handler is a %s\n", 
                         dispatcher ? "dispatcher" : "cached CV"));
    }
callback:
    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
#ifdef PERL_METHOD_HANDLERS
    if(is_method)
        XPUSHs(sv_2mortal(pclass));
    else
        SvREFCNT_dec(pclass);
#else
    SvREFCNT_dec(pclass);
#endif
    XPUSHs((SV*)perl_bless_request_rec(r)); 
    if(dispatcher) {
        MP_TRACE_h(fprintf(stderr, 
                 "mod_perl: handing off to PerlDispatchHandler `%s'\n", 
                         dispatcher));
        /*XPUSHs(sv_mortalcopy(sv));*/
        XPUSHs(sv);
        sv = dispsv;
    }
    {
        I32 i, len = (args ? AvFILL(args) : 0);
        if(args) {
            EXTEND(sp, len);
            for(i=0; i<=len; i++)
                PUSHs(sv_2mortal(*av_fetch(args, i, FALSE)));
        }
    }
    PUTBACK;
     
    /* use G_EVAL so we can trap errors */
#ifdef PERL_METHOD_HANDLERS
    if(is_method)
        count = perl_call_method(method, G_EVAL | G_SCALAR);
    else
#endif
        count = perl_call_sv(sv, G_EVAL | G_SCALAR);
     
    SPAGAIN;
    if ((status = perl_eval_ok(r->server)) != OK) {
        dTHRCTX;
        if (status == SERVER_ERROR) {
            MP_STORE_ERROR(r->uri, ERRSV);
            if (r->notes) {
                ap_table_set(r->notes, "error-notes", SvPVX(ERRSV));
            }
        }
        else if (status == DECLINED) {
            status = r->status == 200 ? OK : r->status;
        }
    }
    else if(count != 1) {
        mod_perl_error(r->server,
                       "perl_call did not return a status arg, assuming OK");
        status = OK;
    }
    else {
        status = POPi;
        if((status == 1) || (status == 200) || (status > 600)) 
            status = OK; 
        if((status == SERVER_ERROR) && ERRSV_CAN_BE_HTTP) {
            SV *errsv = Nullsv;
            if(MP_EXISTS_ERROR(r->uri) && (errsv = MP_FETCH_ERROR(r->uri))) {
                (void)perl_sv_is_http_code(errsv, &status);
            }
        }
    }
    PUTBACK;
    FREETMPS;
    LEAVE;
    MP_TRACE_g(fprintf(stderr, "perl_call_handler: SVs = %5d, OBJs = %5d\n", 
            (int)sv_count, (int)sv_objcount));
    {
        dTHRCTX;
        if(SvMAGICAL(ERRSV))
            sv_unmagic(ERRSV, 'U'); /* Apache::exit was called */
    }
    return status;
}
request_rec *perl_request_rec(request_rec *r)
{
    if(r != NULL) {
        mp_request_rec = (IV)r;
        return NULL;
    }
    else
        return (request_rec *)mp_request_rec;
}
SV *perl_bless_request_rec(request_rec *r)
{
    SV *sv = sv_newmortal();
    sv_setref_pv(sv, "Apache", (void*)r);
    MP_TRACE_g(fprintf(stderr, "blessing request_rec=(0x%lx)\n",
                     (unsigned long)r));
    return sv;
}
void perl_setup_env(request_rec *r)
{ 
    int i;
    array_header *arr = perl_cgi_env_init(r);
    table_entry *elts = (table_entry *)arr->elts;
    for (i = 0; i < arr->nelts; ++i) {
        if (!elts[i].key || !elts[i].val) continue;
        mp_setenv(elts[i].key, elts[i].val);
    }
    MP_TRACE_g(fprintf(stderr, "perl_setup_env...%d keys\n", i));
}
int mod_perl_seqno(SV *self, int inc)
{
    self = self; /*avoid warning*/
    if(inc) seqno += inc;
    return seqno;
}