| /* Licensed to the Apache Software Foundation (ASF) under one or more |
| * contributor license agreements. See the NOTICE file distributed with |
| * this work for additional information regarding copyright ownership. |
| * The ASF licenses this file to You under the Apache License, Version 2.0 |
| * (the "License"); you may not use this file except in compliance with |
| * the License. You may obtain a copy of the License at |
| * |
| * http://www.apache.org/licenses/LICENSE-2.0 |
| * |
| * Unless required by applicable law or agreed to in writing, software |
| * distributed under the License is distributed on an "AS IS" BASIS, |
| * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
| * See the License for the specific language governing permissions and |
| * limitations under the License. |
| */ |
| |
| #include "mod_perl.h" |
| |
| /* make sure that mod_perl won't try to start itself, while it's |
| * already starting. If the flag's value is 1 * it's still starting, |
| * when it's 2 it is running */ |
| static int MP_init_status = 0; |
| |
| #define MP_IS_NOT_RUNNING (MP_init_status == 0 ? 1 : 0) |
| #define MP_IS_STARTING (MP_init_status == 1 ? 1 : 0) |
| #define MP_IS_RUNNING (MP_init_status == 2 ? 1 : 0) |
| |
| /* false while there is only the parent process and may be child |
| * processes, but no threads around, useful for allowing things that |
| * don't require locking and won't affect other threads. It should |
| * become true just before the child_init phase */ |
| static int MP_threads_started = 0; |
| |
| int modperl_threads_started(void) |
| { |
| return MP_threads_started; |
| } |
| |
| static int MP_threaded_mpm = 0; |
| |
| int modperl_threaded_mpm(void) |
| { |
| return MP_threaded_mpm; |
| } |
| |
| /* sometimes non-threaded mpm also needs to know whether it's still |
| * starting up or after post_config) */ |
| static int MP_post_post_config_phase = 0; |
| |
| int modperl_post_post_config_phase(void) |
| { |
| return MP_post_post_config_phase; |
| } |
| |
| #ifndef USE_ITHREADS |
| static apr_status_t modperl_shutdown(void *data) |
| { |
| modperl_cleanup_data_t *cdata = (modperl_cleanup_data_t *)data; |
| PerlInterpreter *perl = (PerlInterpreter *)cdata->data; |
| void **handles; |
| |
| handles = modperl_xs_dl_handles_get(aTHX); |
| |
| MP_TRACE_i(MP_FUNC, "destroying interpreter=0x%lx", |
| (unsigned long)perl); |
| |
| modperl_perl_destruct(perl); |
| |
| modperl_xs_dl_handles_close(handles); |
| |
| return APR_SUCCESS; |
| } |
| #endif |
| |
| static const char *MP_xs_loaders[] = { |
| "Apache2", "APR", NULL, |
| }; |
| |
| #define MP_xs_loader_name "%s::XSLoader::BOOTSTRAP" |
| |
| /* ugly hack to have access to startup pool and server during xs_init */ |
| static struct { |
| apr_pool_t *p; |
| server_rec *s; |
| } MP_boot_data = {NULL,NULL}; |
| |
| #define MP_boot_data_set(pool, server) \ |
| MP_boot_data.p = pool; \ |
| MP_boot_data.s = server |
| |
| #define MP_dBOOT_DATA \ |
| apr_pool_t *p = MP_boot_data.p; \ |
| server_rec *s = MP_boot_data.s |
| |
| static void modperl_boot(pTHX_ void *data) |
| { |
| MP_dBOOT_DATA; |
| int i; |
| |
| modperl_env_clear(aTHX); |
| |
| modperl_env_default_populate(aTHX); |
| |
| modperl_env_configure_server(aTHX_ p, s); |
| |
| modperl_perl_core_global_init(aTHX); |
| |
| for (i=0; MP_xs_loaders[i]; i++) { |
| char *name = Perl_form(aTHX_ MP_xs_loader_name, MP_xs_loaders[i]); |
| newCONSTSUB(PL_defstash, name, newSViv(1)); |
| } |
| |
| /* outside mod_perl this is done by ModPerl::Const.xs */ |
| newXS("ModPerl::Const::compile", XS_modperl_const_compile, __FILE__); |
| |
| /* make sure DynaLoader is loaded before XSLoader |
| * - to workaround bug in 5.6.1 that can trigger a segv |
| * when using modperl as a dso |
| * - also needed when <Perl> sections are loaded from +Parent vhost |
| */ |
| modperl_require_module(aTHX_ "DynaLoader", FALSE); |
| |
| IoFLUSH_on(PL_stderrgv); /* unbuffer STDERR */ |
| } |
| |
| static void modperl_xs_init(pTHX) |
| { |
| xs_init(aTHX); /* see modperl_xsinit.c */ |
| |
| /* XXX: in 5.7.2+ we can call the body of modperl_boot here |
| * but in 5.6.1 the Perl runtime is not properly setup yet |
| * so we have to pull this stunt to delay |
| */ |
| SAVEDESTRUCTOR_X(modperl_boot, 0); |
| } |
| |
| /* |
| * the "server_pool" is a subpool of the parent pool (aka "pconf") |
| * this is where we register the cleanups that teardown the interpreter. |
| * the parent process will run the cleanups since server_pool is a subpool |
| * of pconf. we manually clear the server_pool to run cleanups in the |
| * child processes |
| * |
| * the "server_user_pool" is a subpool of the "server_pool", this is |
| * the pool which is exposed to users, so that they can register |
| * cleanup callbacks. This is needed so that the perl cleanups won't |
| * be run before user cleanups are executed. |
| * |
| */ |
| static apr_pool_t *server_pool = NULL; |
| static apr_pool_t *server_user_pool = NULL; |
| |
| apr_pool_t *modperl_server_pool(void) |
| { |
| return server_pool; |
| } |
| |
| apr_pool_t *modperl_server_user_pool(void) |
| { |
| return server_user_pool; |
| } |
| |
| static void set_taint_var(PerlInterpreter *perl) |
| { |
| dTHXa(perl); |
| |
| /* 5.7.3+ has a built-in special ${^TAINT}, backport it to 5.6.0+ */ |
| #if MP_PERL_VERSION_AT_MOST(5, 7, 2) |
| { |
| GV *gv = gv_fetchpv("\024AINT", GV_ADDMULTI, SVt_IV); |
| sv_setiv(GvSV(gv), PL_tainting); |
| SvREADONLY_on(GvSV(gv)); |
| } |
| #endif /* perl v < 5.7.3 */ |
| |
| #ifdef MP_COMPAT_1X |
| { |
| GV *gv = gv_fetchpv("Apache2::__T", GV_ADDMULTI, SVt_PV); |
| sv_setiv(GvSV(gv), PL_tainting); |
| SvREADONLY_on(GvSV(gv)); |
| } |
| #endif /* MP_COMPAT_1X */ |
| |
| } |
| |
| PerlInterpreter *modperl_startup(server_rec *s, apr_pool_t *p) |
| { |
| AV *endav; |
| dTHXa(NULL); |
| MP_dSCFG(s); |
| PerlInterpreter *perl; |
| int status; |
| char **argv; |
| int argc; |
| #ifndef USE_ITHREADS |
| modperl_cleanup_data_t *cdata; |
| #endif |
| |
| /* ensure that we start the base server's perl, before vhost's |
| * one, if modperl_startup was called by vhost before the former |
| * was started */ |
| if (MP_init_status != 2) { |
| server_rec *base_server = modperl_global_get_server_rec(); |
| PerlInterpreter *base_perl; |
| |
| MP_init_status = 2; /* calls itself, so set the flag early */ |
| base_perl = modperl_startup(base_server, p); |
| |
| if (base_server == s ) { |
| return base_perl; |
| } |
| } |
| |
| #ifdef MP_TRACE |
| { |
| server_rec *base_server = modperl_global_get_server_rec(); |
| const char *desc = modperl_server_desc(s, p); |
| if (base_server == s) { |
| MP_init_status = 1; /* temporarily reset MP_init_status */ |
| MP_TRACE_i(MP_FUNC, |
| "starting the parent perl for the base server", desc); |
| MP_init_status = 2; |
| } |
| else { |
| MP_TRACE_i(MP_FUNC, |
| "starting the parent perl for vhost %s", desc); |
| } |
| } |
| #endif |
| |
| #ifdef MP_USE_GTOP |
| MP_TRACE_m_do( |
| modperl_gtop_do_proc_mem_before(MP_FUNC, "perl_parse"); |
| ); |
| #endif |
| |
| argv = modperl_config_srv_argv_init(scfg, &argc); |
| |
| if (!(perl = perl_alloc())) { |
| perror("perl_alloc"); |
| exit(1); |
| } |
| |
| #ifdef USE_ITHREADS |
| aTHX = perl; |
| #endif |
| |
| perl_construct(perl); |
| |
| modperl_hash_seed_set(aTHX); |
| |
| modperl_io_apache_init(aTHX); |
| |
| PL_perl_destruct_level = 2; |
| |
| MP_boot_data_set(p, s); |
| status = perl_parse(perl, modperl_xs_init, argc, argv, NULL); |
| MP_boot_data_set(NULL, NULL); |
| |
| if (status) { |
| perror("perl_parse"); |
| exit(1); |
| } |
| |
| modperl_env_init(aTHX); |
| |
| /* suspend END blocks to be run at server shutdown */ |
| endav = PL_endav; |
| PL_endav = (AV *)NULL; |
| |
| /* This was fixed in 5.9.0/5.8.1 (17775), but won't compile after 19122 */ |
| #if MP_PERL_VERSION(5, 8, 0) && \ |
| defined(USE_REENTRANT_API) && defined(HAS_CRYPT_R) && defined(__GLIBC__) |
| /* workaround perl5.8.0/glibc bug */ |
| PL_reentrant_buffer->_crypt_struct.current_saltbits = 0; |
| #endif |
| |
| /* We need to reset $0 to argv[0] (httpd) since perl_parse() will |
| * have set it to '-e'. Being magic-aware ensures that some |
| * OS-specific magic will happen (i.e. setproctitle() on *BSDs) |
| */ |
| PL_origalen = strlen(argv[0]) + 1; |
| sv_setpv_mg(get_sv("0",0), argv[0]); |
| |
| perl_run(perl); |
| |
| #ifdef USE_ITHREADS |
| /* base server / virtual host w/ +Parent gets its own mip */ |
| modperl_interp_init(s, p, perl); |
| |
| /* mark the parent perl to be destroyed */ |
| MpInterpBASE_On(scfg->mip->parent); |
| #endif |
| |
| PL_endav = endav; |
| |
| set_taint_var(perl); |
| |
| MP_TRACE_i(MP_FUNC, "constructed interpreter=0x%lx", |
| (unsigned long)perl); |
| |
| #ifdef MP_USE_GTOP |
| MP_TRACE_m_do( |
| modperl_gtop_do_proc_mem_after(MP_FUNC, "perl_parse"); |
| ); |
| #endif |
| |
| #ifdef MP_COMPAT_1X |
| { |
| char *path, *path1; |
| apr_finfo_t finfo; |
| /* 1) push @INC, $ServerRoot */ |
| av_push(GvAV(PL_incgv), newSVpv(ap_server_root, 0)); |
| |
| /* 2) push @INC, $ServerRoot/lib/perl only if it exists */ |
| apr_filepath_merge(&path, ap_server_root, "lib", |
| APR_FILEPATH_NATIVE, p); |
| apr_filepath_merge(&path1, path, "perl", |
| APR_FILEPATH_NATIVE, p); |
| if (APR_SUCCESS == apr_stat(&finfo, path1, APR_FINFO_TYPE, p)) { |
| if (finfo.filetype == APR_DIR) { |
| av_push(GvAV(PL_incgv), newSVpv(path1, 0)); |
| } |
| } |
| } |
| #endif /* MP_COMPAT_1X */ |
| |
| /* base perl and each vhost +Parent should have this init'ed */ |
| modperl_handler_anon_init(aTHX_ p); |
| |
| if (!modperl_config_apply_PerlRequire(s, scfg, perl, p)) { |
| exit(1); |
| } |
| |
| if (!modperl_config_apply_PerlModule(s, scfg, perl, p)) { |
| exit(1); |
| } |
| |
| #ifndef USE_ITHREADS |
| cdata = modperl_cleanup_data_new(server_pool, (void*)perl); |
| apr_pool_cleanup_register(server_pool, cdata, |
| modperl_shutdown, apr_pool_cleanup_null); |
| #endif |
| |
| return perl; |
| } |
| |
| int modperl_init_vhost(server_rec *s, apr_pool_t *p, |
| server_rec *base_server) |
| { |
| MP_dSCFG(s); |
| modperl_config_srv_t *base_scfg; |
| PerlInterpreter *base_perl; |
| PerlInterpreter *perl; |
| const char *vhost = modperl_server_desc(s, p); |
| |
| if (!scfg) { |
| MP_TRACE_i(MP_FUNC, "server %s has no mod_perl config", vhost); |
| return OK; |
| } |
| |
| if (base_server == NULL) { |
| base_server = modperl_global_get_server_rec(); |
| } |
| |
| MP_TRACE_i(MP_FUNC, "Init vhost %s: s=0x%lx, base_s=0x%lx", |
| vhost, s, base_server); |
| |
| if (base_server == s) { |
| MP_TRACE_i(MP_FUNC, "base server is not vhost, skipping %s", |
| vhost); |
| return OK; |
| } |
| |
| base_scfg = modperl_config_srv_get(base_server); |
| |
| #ifdef USE_ITHREADS |
| perl = base_perl = base_scfg->mip->parent->perl; |
| #else |
| perl = base_perl = base_scfg->perl; |
| #endif /* USE_ITHREADS */ |
| |
| #ifdef USE_ITHREADS |
| |
| if (scfg->mip) { |
| MP_TRACE_i(MP_FUNC, "server %s already initialized", vhost); |
| return OK; |
| } |
| |
| /* the base server could have mod_perl callbacks disabled, but it |
| * still needs perl to drive the vhosts */ |
| if (!MpSrvENABLE(scfg) && s->is_virtual) { |
| MP_TRACE_i(MP_FUNC, "mod_perl disabled for server %s", vhost); |
| scfg->mip = NULL; |
| return OK; |
| } |
| |
| PERL_SET_CONTEXT(perl); |
| modperl_thx_interp_set(perl, base_scfg->mip->parent); |
| |
| #endif /* USE_ITHREADS */ |
| |
| MP_TRACE_d_do(MpSrv_dump_flags(scfg, s->server_hostname)); |
| |
| /* if alloc flags is On, virtual host gets its own parent perl */ |
| if (MpSrvPARENT(scfg)) { |
| perl = modperl_startup(s, p); |
| MP_TRACE_i(MP_FUNC, |
| "created parent interpreter for VirtualHost %s", |
| modperl_server_desc(s, p)); |
| } |
| else { |
| #ifdef USE_ITHREADS |
| /* virtual host w/ +Clone gets its own mip */ |
| if (MpSrvCLONE(scfg)) { |
| modperl_interp_init(s, p, perl); |
| } |
| #endif |
| |
| if (!modperl_config_apply_PerlRequire(s, scfg, perl, p)) { |
| return HTTP_INTERNAL_SERVER_ERROR; |
| } |
| |
| if (!modperl_config_apply_PerlModule(s, scfg, perl, p)) { |
| return HTTP_INTERNAL_SERVER_ERROR; |
| } |
| } |
| |
| #ifdef USE_ITHREADS |
| if (!scfg->mip) { |
| /* since mips are created after merge_server_configs() |
| * need to point to the base mip here if this vhost |
| * doesn't have its own |
| */ |
| MP_TRACE_i(MP_FUNC, "%s mip inherited from %s", |
| vhost, modperl_server_desc(base_server, p)); |
| scfg->mip = base_scfg->mip; |
| } |
| #endif /* USE_ITHREADS */ |
| |
| return OK; |
| } |
| |
| void modperl_init(server_rec *base_server, apr_pool_t *p) |
| { |
| server_rec *s; |
| PerlInterpreter *base_perl; |
| #if defined(MP_TRACE) || defined(USE_ITHREADS) |
| modperl_config_srv_t *base_scfg = modperl_config_srv_get(base_server); |
| #endif |
| |
| MP_TRACE_d_do(MpSrv_dump_flags(base_scfg, |
| base_server->server_hostname)); |
| |
| #ifndef USE_ITHREADS |
| if (modperl_threaded_mpm()) { |
| ap_log_error(APLOG_MARK, APLOG_ERR, 0, base_server, |
| "cannot use threaded MPM without ithreads enabled Perl"); |
| exit(1); |
| } |
| #endif |
| |
| base_perl = modperl_startup(base_server, p); |
| |
| for (s=base_server->next; s; s=s->next) { |
| if (modperl_init_vhost(s, p, base_server) != OK) { |
| exit(1); /*XXX*/ |
| } |
| } |
| |
| #ifdef USE_ITHREADS |
| /* after other parent perls were started in vhosts, make sure that |
| * the context is set to the base_perl */ |
| PERL_SET_CONTEXT(base_perl); |
| modperl_thx_interp_set(base_perl, base_scfg->mip->parent); |
| #endif |
| |
| } |
| |
| static int modperl_post_config_require(server_rec *s, apr_pool_t *p) |
| { |
| for (; s; s=s->next) { |
| MP_dSCFG(s); |
| if (!modperl_config_apply_PerlPostConfigRequire(s, scfg, p)) { |
| return FALSE; |
| } |
| } |
| return TRUE; |
| } |
| |
| #ifdef USE_ITHREADS |
| static void modperl_init_clones(server_rec *s, apr_pool_t *p) |
| { |
| #ifdef MP_TRACE |
| modperl_config_srv_t *base_scfg = modperl_config_srv_get(s); |
| char *base_name = modperl_server_desc(s, p); |
| #endif /* MP_TRACE */ |
| |
| if (!modperl_threaded_mpm()) { |
| MP_TRACE_i(MP_FUNC, "no clones created for non-threaded mpm"); |
| return; |
| } |
| |
| for (; s; s=s->next) { |
| MP_dSCFG(s); |
| #ifdef MP_TRACE |
| char *name = modperl_server_desc(s, p); |
| #else |
| char *name = NULL; |
| #endif /* MP_TRACE */ |
| |
| if (scfg->mip->tipool->idle) { |
| #ifdef MP_TRACE |
| if (scfg->mip == base_scfg->mip) { |
| MP_TRACE_i(MP_FUNC, |
| "%s interp pool inherited from %s", |
| name, base_name); |
| } |
| else { |
| MP_TRACE_i(MP_FUNC, |
| "%s interp pool already initialized", |
| name); |
| } |
| #endif /* MP_TRACE */ |
| } |
| else { |
| MP_TRACE_i(MP_FUNC, "initializing interp pool for %s", |
| name); |
| modperl_tipool_init(scfg->mip->tipool); |
| } |
| } |
| } |
| #endif /* USE_ITHREADS */ |
| |
| void modperl_init_globals(server_rec *s, apr_pool_t *pconf) |
| { |
| ap_mpm_query(AP_MPMQ_IS_THREADED, &MP_threaded_mpm); |
| |
| MP_TRACE_g(MP_FUNC, "mod_perl globals are configured"); |
| |
| modperl_global_init_pconf(pconf, pconf); |
| modperl_global_init_server_rec(pconf, s); |
| |
| modperl_tls_create_request_rec(pconf); |
| |
| /* init the counter to 0 */ |
| modperl_global_anon_cnt_init(pconf); |
| } |
| |
| /* |
| * modperl_sys_{init,term} are things that happen |
| * once per-parent process, not per-interpreter |
| */ |
| static apr_status_t modperl_sys_init(void) |
| { |
| int argc = 0; |
| char **argv = NULL, **env = NULL; |
| |
| MP_TRACE_i(MP_FUNC, "mod_perl sys init"); |
| |
| /* not every OS uses those vars in PERL_SYS_INIT3 macro */ |
| argc = argc; argv = argv; env = env; |
| |
| PERL_SYS_INIT3(&argc, &argv, &env); |
| |
| #if 0 /*XXX*/ |
| #ifdef PTHREAD_ATFORK |
| if (!ap_exists_config_define("PERL_PTHREAD_ATFORK_DONE")) { |
| PTHREAD_ATFORK(Perl_atfork_lock, |
| Perl_atfork_unlock, |
| Perl_atfork_unlock); |
| *(char **)apr_array_push(ap_server_config_defines) = |
| "PERL_PTHREAD_ATFORK_DONE"; |
| } |
| #endif |
| #endif |
| |
| /* modifies PL_ppaddr */ |
| modperl_perl_pp_set_all(); |
| |
| return APR_SUCCESS; |
| } |
| |
| static apr_status_t modperl_sys_term(void *data) |
| { |
| /* PERL_SYS_TERM() needs 'my_perl' as of 5.9.5 */ |
| #if MP_PERL_VERSION_AT_LEAST(5, 9, 5) && defined(USE_ITHREADS) |
| modperl_cleanup_data_t *cdata = (modperl_cleanup_data_t *)data; |
| PERL_UNUSED_DECL PerlInterpreter *my_perl = cdata == NULL ? NULL : (PerlInterpreter *)cdata->data; |
| #endif |
| MP_init_status = 0; |
| MP_threads_started = 0; |
| MP_post_post_config_phase = 0; |
| |
| MP_PERL_FREE_THREAD_KEY_WORKAROUND; |
| |
| MP_TRACE_i(MP_FUNC, "mod_perl sys term"); |
| |
| modperl_perl_pp_unset_all(); |
| |
| PERL_SYS_TERM(); |
| |
| return APR_SUCCESS; |
| } |
| |
| int modperl_hook_init(apr_pool_t *pconf, apr_pool_t *plog, |
| apr_pool_t *ptemp, server_rec *s) |
| { |
| if (MP_IS_STARTING || MP_IS_RUNNING) { |
| return OK; |
| } |
| |
| MP_init_status = 1; /* now starting */ |
| |
| modperl_restart_count_inc(s); |
| |
| apr_pool_create(&server_pool, pconf); |
| apr_pool_tag(server_pool, "mod_perl server pool"); |
| |
| apr_pool_create(&server_user_pool, pconf); |
| apr_pool_tag(server_user_pool, "mod_perl server user pool"); |
| |
| modperl_sys_init(); |
| apr_pool_cleanup_register(server_pool, NULL, |
| modperl_sys_term, apr_pool_cleanup_null); |
| |
| modperl_init(s, pconf); |
| |
| return OK; |
| } |
| |
| /* |
| * if we need to init earlier than post_config, |
| * e.g. <Perl> sections or directive handlers. |
| */ |
| int modperl_run(void) |
| { |
| return modperl_hook_init(modperl_global_get_pconf(), |
| NULL, |
| NULL, |
| modperl_global_get_server_rec()); |
| } |
| |
| int modperl_is_running(void) |
| { |
| return MP_IS_RUNNING; |
| } |
| |
| int modperl_hook_pre_config(apr_pool_t *p, apr_pool_t *plog, |
| apr_pool_t *ptemp) |
| { |
| #if AP_MODULE_MAGIC_AT_LEAST(20110329,0) |
| ap_reserve_module_slots_directive("PerlLoadModule"); |
| #endif |
| |
| /* we can't have PerlPreConfigHandler without first configuring mod_perl */ |
| |
| /* perl 5.8.1+ */ |
| modperl_hash_seed_init(p); |
| |
| return OK; |
| } |
| |
| static int modperl_hook_pre_connection(conn_rec *c, void *csd) |
| { |
| modperl_input_filter_add_connection(c); |
| modperl_output_filter_add_connection(c); |
| return OK; |
| } |
| |
| static int modperl_hook_post_config_last(apr_pool_t *pconf, apr_pool_t *plog, |
| apr_pool_t *ptemp, server_rec *s) |
| { |
| /* in the threaded environment, no server_rec/process_rec |
| * modifications should be done beyond this point */ |
| #ifdef USE_ITHREADS |
| MP_dSCFG(s); |
| dTHXa(scfg->mip->parent->perl); |
| #endif |
| |
| if (!modperl_post_config_require(s, pconf)) { |
| exit(1); |
| } |
| |
| if (modperl_threaded_mpm()) { |
| MP_threads_started = 1; |
| } |
| |
| MP_post_post_config_phase = 1; |
| |
| #ifdef MP_TRACE |
| /* httpd core open_logs handler re-opens s->error_log, which might |
| * change, even though it still points to the same physical file |
| * (.e.g on win32 the filehandle will be different. Therefore |
| * reset the tracing logfile setting here, since this is the |
| * earliest place, happening after the open_logs phase. |
| * |
| * Moreover, we need to dup the filehandle so that when the server |
| * shuts down, we will be able to log to error_log after Apache |
| * has closed it (which happens too early for our likening). |
| */ |
| { |
| apr_file_t *dup; |
| MP_RUN_CROAK(apr_file_dup(&dup, s->error_log, pconf), |
| "mod_perl core post_config"); |
| modperl_trace_logfile_set(dup); |
| } |
| #endif |
| |
| #if MP_PERL_VERSION_AT_LEAST(5, 9, 0) |
| #define MP_PERL_VERSION_STAMP "Perl/%" SVf |
| #else |
| #define MP_PERL_VERSION_STAMP "Perl/v%vd" |
| #endif |
| |
| ap_add_version_component(pconf, MP_VERSION_STRING); |
| ap_add_version_component(pconf, |
| Perl_form(aTHX_ MP_PERL_VERSION_STAMP, |
| PL_patchlevel)); |
| |
| modperl_mgv_hash_handlers(pconf, s); |
| modperl_modglobal_hash_keys(aTHX); |
| modperl_env_hash_keys(aTHX); |
| #ifdef USE_ITHREADS |
| modperl_init_clones(s, pconf); |
| #endif |
| |
| #ifdef MP_NEED_HASH_SEED_FIXUP |
| ap_log_error(APLOG_MARK, APLOG_INFO, 0, s, |
| "mod_perl: using Perl HASH_SEED: %"UVuf, MP_init_hash_seed); |
| #endif |
| |
| return OK; |
| } |
| |
| static int modperl_hook_create_request(request_rec *r) |
| { |
| MP_dRCFG; |
| |
| #ifdef USE_ITHREADS |
| /* XXX: this is necessary to make modperl_interp_pool_select() work |
| * which is used at runtime only to merge dir-configs by |
| * modperl_module_config_merge(). |
| * |
| * Since most requests won't need it it would be good to add some logic |
| * (cheaper logic in terms of CPU cycles) to identify those cases and |
| * avoid the hash operation. |
| */ |
| MP_TRACE_i(MP_FUNC, "setting userdata MODPERL_R in pool %#lx to %lx", |
| (unsigned long)r->pool, (unsigned long)r); |
| (void)apr_pool_userdata_set((void *)r, "MODPERL_R", NULL, r->pool); |
| #endif |
| |
| modperl_config_req_init(r, rcfg); |
| modperl_config_req_cleanup_register(r, rcfg); |
| |
| /* set the default for cgi header parsing On as early as possible |
| * so $r->content_type in any phase after header_parser could turn |
| * it off. wb->header_parse will be set to 1 only if this flag |
| * wasn't turned off and MpDirPARSE_HEADERS is on |
| */ |
| MpReqPARSE_HEADERS_On(rcfg); |
| |
| return OK; |
| } |
| |
| static int modperl_hook_post_read_request(request_rec *r) |
| { |
| #ifdef USE_ITHREADS |
| MP_TRACE_i(MP_FUNC, "%s %s:%d%s", |
| r->method, r->connection->local_addr->hostname, |
| r->connection->local_addr->port, r->unparsed_uri); |
| #endif |
| |
| /* if 'PerlOptions +GlobalRequest' is outside a container */ |
| modperl_global_request_cfg_set(r); |
| |
| return OK; |
| } |
| |
| static int modperl_hook_header_parser(request_rec *r) |
| { |
| /* if 'PerlOptions +GlobalRequest' is inside a container */ |
| modperl_global_request_cfg_set(r); |
| |
| return OK; |
| } |
| |
| static int modperl_destruct_level = 2; /* default is full tear down */ |
| |
| int modperl_perl_destruct_level(void) |
| { |
| return modperl_destruct_level; |
| } |
| |
| #ifdef USE_ITHREADS |
| |
| static apr_status_t |
| modperl_perl_call_endav_mip(pTHX_ modperl_interp_pool_t *mip, |
| void *data) |
| { |
| modperl_perl_call_endav(aTHX); |
| return APR_SUCCESS; |
| } |
| |
| #endif /* USE_ITHREADS */ |
| |
| static apr_status_t modperl_child_exit(void *data) |
| { |
| char *level = NULL; |
| server_rec *s = (server_rec *)data; |
| |
| modperl_callback_process(MP_CHILD_EXIT_HANDLER, server_pool, s, |
| MP_HOOK_VOID); |
| |
| if ((level = getenv("PERL_DESTRUCT_LEVEL"))) { |
| modperl_destruct_level = atoi(level); |
| } |
| else { |
| /* default to no teardown in the children */ |
| modperl_destruct_level = 0; |
| } |
| |
| if (modperl_destruct_level) { |
| apr_pool_clear(server_pool); |
| } |
| else { |
| /* run the END blocks of this child process if |
| * modperl_perl_destruct is not called for this process */ |
| #ifdef USE_ITHREADS |
| modperl_interp_mip_walk_servers(NULL, s, |
| modperl_perl_call_endav_mip, |
| (void*)NULL); |
| #else |
| modperl_perl_call_endav(aTHX); |
| #endif |
| } |
| |
| server_pool = NULL; |
| |
| return APR_SUCCESS; |
| } |
| |
| static void modperl_hook_child_init(apr_pool_t *p, server_rec *s) |
| { |
| modperl_perl_init_ids_server(s); |
| |
| apr_pool_cleanup_register(p, (void *)s, modperl_child_exit, |
| apr_pool_cleanup_null); |
| } |
| |
| #define MP_FILTER_HANDLER(f) f, NULL |
| |
| void modperl_register_hooks(apr_pool_t *p) |
| { |
| |
| #ifdef USE_ITHREADS |
| APR_REGISTER_OPTIONAL_FN(modperl_interp_unselect); |
| APR_REGISTER_OPTIONAL_FN(modperl_thx_interp_get); |
| #endif |
| |
| /* for <IfDefine MODPERL2> and Apache2->define("MODPERL2") */ |
| *(char **)apr_array_push(ap_server_config_defines) = |
| apr_pstrdup(ap_server_config_defines->pool, "MODPERL2"); |
| |
| ap_hook_pre_config(modperl_hook_pre_config, |
| NULL, NULL, APR_HOOK_MIDDLE); |
| |
| ap_hook_open_logs(modperl_hook_init, |
| NULL, NULL, APR_HOOK_FIRST); |
| |
| ap_hook_post_config(modperl_hook_post_config_last, |
| NULL, NULL, APR_HOOK_REALLY_LAST); |
| |
| ap_hook_handler(modperl_response_handler, |
| NULL, NULL, APR_HOOK_MIDDLE); |
| |
| ap_hook_handler(modperl_response_handler_cgi, |
| NULL, NULL, APR_HOOK_MIDDLE); |
| |
| ap_hook_insert_filter(modperl_output_filter_add_request, |
| NULL, NULL, APR_HOOK_LAST); |
| |
| ap_hook_insert_filter(modperl_input_filter_add_request, |
| NULL, NULL, APR_HOOK_LAST); |
| |
| ap_register_output_filter(MP_FILTER_REQUEST_OUTPUT_NAME, |
| MP_FILTER_HANDLER(modperl_output_filter_handler), |
| AP_FTYPE_RESOURCE); |
| |
| ap_register_input_filter(MP_FILTER_REQUEST_INPUT_NAME, |
| MP_FILTER_HANDLER(modperl_input_filter_handler), |
| AP_FTYPE_RESOURCE); |
| |
| ap_register_output_filter(MP_FILTER_CONNECTION_OUTPUT_NAME, |
| MP_FILTER_HANDLER(modperl_output_filter_handler), |
| AP_FTYPE_CONNECTION); |
| |
| ap_register_input_filter(MP_FILTER_CONNECTION_INPUT_NAME, |
| MP_FILTER_HANDLER(modperl_input_filter_handler), |
| AP_FTYPE_CONNECTION); |
| |
| ap_hook_pre_connection(modperl_hook_pre_connection, |
| NULL, NULL, APR_HOOK_FIRST); |
| |
| ap_hook_create_request(modperl_hook_create_request, |
| NULL, NULL, APR_HOOK_MIDDLE); |
| |
| /* both of these hooks need to run really, really first. |
| * otherwise, the global request_rec will be set up _after_ some |
| * Perl handlers run. |
| */ |
| ap_hook_post_read_request(modperl_hook_post_read_request, |
| NULL, NULL, MODPERL_HOOK_REALLY_REALLY_FIRST); |
| |
| ap_hook_header_parser(modperl_hook_header_parser, |
| NULL, NULL, MODPERL_HOOK_REALLY_REALLY_FIRST); |
| |
| ap_hook_child_init(modperl_hook_child_init, |
| NULL, NULL, MODPERL_HOOK_REALLY_REALLY_FIRST); |
| |
| modperl_register_handler_hooks(); |
| } |
| |
| static const command_rec modperl_cmds[] = { |
| MP_CMD_SRV_ITERATE("PerlSwitches", switches, "Perl Switches"), |
| MP_CMD_DIR_ITERATE("PerlModule", modules, "PerlModule"), |
| MP_CMD_DIR_ITERATE("PerlRequire", requires, "PerlRequire"), |
| MP_CMD_SRV_ITERATE("PerlConfigRequire", config_requires, "PerlConfigRequire"), |
| MP_CMD_SRV_ITERATE("PerlPostConfigRequire", post_config_requires, "PerlPostConfigRequire"), |
| #if AP_SERVER_MAJORVERSION_NUMBER>2 || \ |
| (AP_SERVER_MAJORVERSION_NUMBER == 2 && AP_SERVER_MINORVERSION_NUMBER>=3) |
| MP_CMD_SRV_TAKE2("PerlAddAuthzProvider", authz_provider, "PerlAddAuthzProvider"), |
| MP_CMD_SRV_TAKE2("PerlAddAuthnProvider", authn_provider, "PerlAddAuthnProvider"), |
| #endif |
| MP_CMD_DIR_ITERATE("PerlOptions", options, "Perl Options"), |
| MP_CMD_DIR_ITERATE("PerlInitHandler", init_handlers, "Subroutine name"), |
| MP_CMD_DIR_TAKE2("PerlSetVar", set_var, "PerlSetVar"), |
| MP_CMD_DIR_ITERATE2("PerlAddVar", add_var, "PerlAddVar"), |
| MP_CMD_DIR_TAKE2("PerlSetEnv", set_env, "PerlSetEnv"), |
| MP_CMD_SRV_TAKE1("PerlPassEnv", pass_env, "PerlPassEnv"), |
| MP_CMD_DIR_RAW_ARGS_ON_READ("<Perl", perl, "Perl Code"), |
| MP_CMD_DIR_RAW_ARGS("Perl", perldo, "Perl Code"), |
| |
| MP_CMD_DIR_TAKE1("PerlSetInputFilter", set_input_filter, |
| "filter[;filter]"), |
| MP_CMD_DIR_TAKE1("PerlSetOutputFilter", set_output_filter, |
| "filter[;filter]"), |
| |
| MP_CMD_DIR_RAW_ARGS_ON_READ("=pod", pod, "Start of POD"), |
| MP_CMD_DIR_RAW_ARGS_ON_READ("=back", pod, "End of =over"), |
| MP_CMD_DIR_RAW_ARGS_ON_READ("=cut", pod_cut, "End of POD"), |
| MP_CMD_DIR_RAW_ARGS_ON_READ("__END__", END, "Stop reading config"), |
| |
| MP_CMD_SRV_RAW_ARGS("PerlLoadModule", load_module, "A Perl module"), |
| #ifdef MP_TRACE |
| MP_CMD_SRV_TAKE1("PerlTrace", trace, "Trace level"), |
| #endif |
| #ifdef USE_ITHREADS |
| MP_CMD_SRV_TAKE1("PerlInterpStart", interp_start, |
| "Number of Perl interpreters to start"), |
| MP_CMD_SRV_TAKE1("PerlInterpMax", interp_max, |
| "Max number of running Perl interpreters"), |
| MP_CMD_SRV_TAKE1("PerlInterpMaxSpare", interp_max_spare, |
| "Max number of spare Perl interpreters"), |
| MP_CMD_SRV_TAKE1("PerlInterpMinSpare", interp_min_spare, |
| "Min number of spare Perl interpreters"), |
| MP_CMD_SRV_TAKE1("PerlInterpMaxRequests", interp_max_requests, |
| "Max number of requests per Perl interpreters"), |
| #endif |
| #ifdef MP_COMPAT_1X |
| MP_CMD_DIR_FLAG("PerlSendHeader", send_header, |
| "Tell mod_perl to scan output for HTTP headers"), |
| MP_CMD_DIR_FLAG("PerlSetupEnv", setup_env, |
| "Turn setup of %ENV On or Off"), |
| MP_CMD_DIR_ITERATE("PerlHandler", response_handlers, |
| "Subroutine name"), |
| MP_CMD_SRV_FLAG("PerlTaintCheck", taint_check, |
| "Turn on -T switch"), |
| MP_CMD_SRV_FLAG("PerlWarn", warn, |
| "Turn on -w switch"), |
| #endif |
| MP_CMD_ENTRIES, |
| { NULL }, |
| }; |
| |
| void modperl_response_init(request_rec *r) |
| { |
| MP_dRCFG; |
| MP_dDCFG; |
| modperl_wbucket_t *wb; |
| |
| if (!rcfg->wbucket) { |
| rcfg->wbucket = |
| (modperl_wbucket_t *)apr_palloc(r->pool, |
| sizeof(*rcfg->wbucket)); |
| } |
| |
| wb = rcfg->wbucket; |
| |
| /* setup buffer for output */ |
| wb->pool = r->pool; |
| wb->filters = &r->output_filters; |
| wb->outcnt = 0; |
| wb->header_parse = MpDirPARSE_HEADERS(dcfg) && MpReqPARSE_HEADERS(rcfg) |
| ? 1 : 0; |
| wb->r = r; |
| } |
| |
| apr_status_t modperl_response_finish(request_rec *r) |
| { |
| MP_dRCFG; |
| |
| /* flush output buffer */ |
| return modperl_wbucket_flush(rcfg->wbucket, FALSE); |
| } |
| |
| static int modperl_response_handler_run(request_rec *r) |
| { |
| int retval; |
| |
| modperl_response_init(r); |
| |
| retval = modperl_callback_per_dir(MP_RESPONSE_HANDLER, r, MP_HOOK_RUN_FIRST); |
| |
| if ((retval == DECLINED) && r->content_type) { |
| r->handler = r->content_type; /* let http_core or whatever try */ |
| } |
| |
| return retval; |
| } |
| |
| int modperl_response_handler(request_rec *r) |
| { |
| MP_dDCFG; |
| apr_status_t retval, rc; |
| MP_dINTERP; |
| |
| if (!strEQ(r->handler, "modperl")) { |
| return DECLINED; |
| } |
| |
| MP_INTERPa(r, r->connection, r->server); |
| |
| /* default is -SetupEnv, add if PerlOption +SetupEnv */ |
| if (MpDirSETUP_ENV(dcfg)) { |
| modperl_env_request_populate(aTHX_ r); |
| } |
| |
| retval = modperl_response_handler_run(r); |
| rc = modperl_response_finish(r); |
| if (rc != APR_SUCCESS) { |
| retval = rc; |
| } |
| |
| MP_INTERP_PUTBACK(interp, aTHX); |
| |
| return retval; |
| } |
| |
| int modperl_response_handler_cgi(request_rec *r) |
| { |
| MP_dDCFG; |
| GV *h_stdin, *h_stdout; |
| apr_status_t retval, rc; |
| MP_dRCFG; |
| MP_dINTERP; |
| |
| if (!strEQ(r->handler, "perl-script")) { |
| return DECLINED; |
| } |
| |
| MP_INTERPa(r, r->connection, r->server); |
| |
| modperl_perl_global_request_save(aTHX_ r); |
| |
| /* default is +SetupEnv, skip if PerlOption -SetupEnv */ |
| if (MpDirSETUP_ENV(dcfg) || !MpDirSeenSETUP_ENV(dcfg)) { |
| modperl_env_request_populate(aTHX_ r); |
| } |
| |
| /* default is +GlobalRequest, skip if PerlOption -GlobalRequest */ |
| if (MpDirGLOBAL_REQUEST(dcfg) || !MpDirSeenGLOBAL_REQUEST(dcfg)) { |
| modperl_global_request_set(r); |
| } |
| |
| /* need to create a block around the IO setup so the temp vars |
| * will be automatically cleaned up when we are done with IO */ |
| ENTER;SAVETMPS; |
| h_stdin = modperl_io_override_stdin(aTHX_ r); |
| h_stdout = modperl_io_override_stdout(aTHX_ r); |
| |
| modperl_env_request_tie(aTHX_ r); |
| |
| retval = modperl_response_handler_run(r); |
| |
| modperl_env_request_untie(aTHX_ r); |
| |
| modperl_perl_global_request_restore(aTHX_ r); |
| |
| modperl_io_restore_stdin(aTHX_ h_stdin); |
| modperl_io_restore_stdout(aTHX_ h_stdout); |
| FREETMPS;LEAVE; |
| |
| MP_INTERP_PUTBACK(interp, aTHX); |
| |
| /* flush output buffer after interpreter is putback */ |
| rc = modperl_response_finish(r); |
| if (rc != APR_SUCCESS) { |
| retval = rc; |
| } |
| |
| switch (rcfg->status) { |
| case HTTP_MOVED_TEMPORARILY: |
| /* set by modperl_cgi_header_parse */ |
| retval = HTTP_MOVED_TEMPORARILY; |
| break; |
| } |
| |
| return retval; |
| } |
| |
| /* This ugly hack pulls in any function listed in |
| * modperl_exports.c. Otherwise, the over-zealous |
| * linker would remove unused api functions |
| */ |
| const void *modperl_suck_in_ugly_hack(void); |
| const void *modperl_suck_in_ugly_hack(void) |
| { |
| extern const void *modperl_ugly_hack; |
| return modperl_ugly_hack; |
| } |
| |
| module AP_MODULE_DECLARE_DATA perl_module = { |
| STANDARD20_MODULE_STUFF, |
| modperl_config_dir_create, /* dir config creater */ |
| modperl_config_dir_merge, /* dir merger --- default is to override */ |
| modperl_config_srv_create, /* server config */ |
| modperl_config_srv_merge, /* merge server config */ |
| modperl_cmds, /* table of config file commands */ |
| modperl_register_hooks, /* register hooks */ |
| }; |
| |
| /* |
| * Local Variables: |
| * c-basic-offset: 4 |
| * indent-tabs-mode: nil |
| * End: |
| */ |
