| #include "mod_perl.h" |
| |
| static char *modperl_cmd_unclosed_directive(cmd_parms *parms) |
| { |
| return apr_pstrcat(parms->pool, parms->cmd->name, |
| "> directive missing closing '>'", NULL); |
| } |
| |
| static char *modperl_cmd_too_late(cmd_parms *parms) |
| { |
| return apr_pstrcat(parms->pool, "mod_perl is already running, " |
| "too late for ", parms->cmd->name, NULL); |
| } |
| |
| char *modperl_cmd_push_handlers(MpAV **handlers, const char *name, |
| apr_pool_t *p) |
| { |
| modperl_handler_t *h = modperl_handler_new(p, name); |
| |
| if (!*handlers) { |
| *handlers = modperl_handler_array_new(p); |
| MP_TRACE_d(MP_FUNC, "created handler stack\n"); |
| } |
| |
| /* XXX parse_handler if Perl is running */ |
| |
| modperl_handler_array_push(*handlers, h); |
| MP_TRACE_d(MP_FUNC, "pushed handler: %s\n", h->name); |
| |
| return NULL; |
| } |
| |
| char *modperl_cmd_push_httpd_filter_handlers(MpAV **handlers, |
| const char *name, |
| apr_pool_t *p) |
| { |
| modperl_handler_t *h = modperl_handler_new(p, name); |
| |
| /* this is not a real mod_perl handler, we just re-use the |
| * handlers structure to be able to mix mod_perl and non-mod_perl |
| * filters */ |
| MpHandlerFAKE_On(h); |
| h->attrs = MP_FILTER_HTTPD_HANDLER; |
| |
| if (!*handlers) { |
| *handlers = modperl_handler_array_new(p); |
| MP_TRACE_d(MP_FUNC, "created handler stack\n"); |
| } |
| |
| modperl_handler_array_push(*handlers, h); |
| MP_TRACE_d(MP_FUNC, "pushed httpd filter handler: %s\n", h->name); |
| |
| return NULL; |
| } |
| |
| |
| #define MP_CMD_SRV_TRACE \ |
| MP_TRACE_d(MP_FUNC, "%s %s\n", parms->cmd->name, arg) |
| |
| #define MP_CMD_SRV_CHECK \ |
| MP_CMD_SRV_TRACE; \ |
| { \ |
| const char *err = ap_check_cmd_context(parms, GLOBAL_ONLY); \ |
| if (err) return err; \ |
| } |
| |
| MP_CMD_SRV_DECLARE(trace) |
| { |
| MP_CMD_SRV_CHECK; |
| modperl_trace_level_set(parms->server, arg); |
| return NULL; |
| } |
| |
| static int modperl_vhost_is_running(server_rec *s) |
| { |
| #ifdef USE_ITHREADS |
| MP_dSCFG(s); |
| int is_vhost = (s != modperl_global_get_server_rec()); |
| |
| if (is_vhost && scfg->mip) { |
| return TRUE; |
| } |
| else { |
| return FALSE; |
| } |
| #else |
| return modperl_is_running(); |
| #endif |
| } |
| |
| MP_CMD_SRV_DECLARE(switches) |
| { |
| server_rec *s = parms->server; |
| MP_dSCFG(s); |
| if (s->is_virtual |
| ? modperl_vhost_is_running(s) |
| : modperl_is_running() ) { |
| return modperl_cmd_too_late(parms); |
| } |
| MP_TRACE_d(MP_FUNC, "arg = %s\n", arg); |
| modperl_config_srv_argv_push(arg); |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE(modules) |
| { |
| MP_dSCFG(parms->server); |
| |
| if (modperl_is_running() && |
| modperl_init_vhost(parms->server, parms->pool, NULL) != OK) |
| { |
| return "init mod_perl vhost failed"; |
| } |
| |
| if (modperl_is_running()) { |
| #ifdef USE_ITHREADS |
| /* XXX: .htaccess support cannot use this perl with threaded MPMs */ |
| dTHXa(scfg->mip->parent->perl); |
| #endif |
| MP_TRACE_d(MP_FUNC, "load PerlModule %s\n", arg); |
| |
| if (!modperl_require_module(aTHX_ arg, FALSE)) { |
| return SvPVX(ERRSV); |
| } |
| } |
| else { |
| MP_TRACE_d(MP_FUNC, "push PerlModule %s\n", arg); |
| *(const char **)apr_array_push(scfg->PerlModule) = arg; |
| } |
| |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE(requires) |
| { |
| MP_dSCFG(parms->server); |
| |
| if (modperl_is_running() && |
| modperl_init_vhost(parms->server, parms->pool, NULL) != OK) |
| { |
| return "init mod_perl vhost failed"; |
| } |
| |
| if (modperl_is_running()) { |
| #ifdef USE_ITHREADS |
| /* XXX: .htaccess support cannot use this perl with threaded MPMs */ |
| dTHXa(scfg->mip->parent->perl); |
| #endif |
| |
| MP_TRACE_d(MP_FUNC, "load PerlRequire %s\n", arg); |
| |
| if (!modperl_require_file(aTHX_ arg, FALSE)) { |
| return SvPVX(ERRSV); |
| } |
| } |
| else { |
| MP_TRACE_d(MP_FUNC, "push PerlRequire %s\n", arg); |
| *(const char **)apr_array_push(scfg->PerlRequire) = arg; |
| } |
| |
| return NULL; |
| } |
| |
| static MP_CMD_SRV_DECLARE2(handle_vars) |
| { |
| MP_dSCFG(parms->server); |
| modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig; |
| const char *name = parms->cmd->name; |
| |
| modperl_table_modify_t func = |
| strEQ(name, "PerlSetVar") ? apr_table_setn : apr_table_addn; |
| |
| func(dcfg->vars, arg1, arg2); |
| |
| MP_TRACE_d(MP_FUNC, "%s DIR: arg1 = %s, arg2 = %s\n", |
| name, arg1, arg2); |
| |
| /* make available via Apache->server->dir_config */ |
| if (!parms->path) { |
| func(scfg->vars, arg1, arg2); |
| |
| MP_TRACE_d(MP_FUNC, "%s SRV: arg1 = %s, arg2 = %s\n", |
| name, arg1, arg2); |
| } |
| |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE2(set_var) |
| { |
| return modperl_cmd_handle_vars(parms, mconfig, arg1, arg2); |
| } |
| |
| MP_CMD_SRV_DECLARE2(add_var) |
| { |
| return modperl_cmd_handle_vars(parms, mconfig, arg1, arg2); |
| } |
| |
| MP_CMD_SRV_DECLARE2(set_env) |
| { |
| MP_dSCFG(parms->server); |
| modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig; |
| |
| #ifdef ENV_IS_CASELESS /* i.e. WIN32 */ |
| /* we turn off env magic during hv_store later, so do this now, |
| * else lookups on keys with lowercase characters will fails |
| * because Perl will uppercase them prior to lookup. |
| */ |
| modperl_str_toupper((char *)arg1); |
| #endif |
| |
| MP_TRACE_d(MP_FUNC, "arg1 = %s, arg2 = %s\n", arg1, arg2); |
| |
| if (!parms->path) { |
| /* will be propagated to environ */ |
| apr_table_setn(scfg->SetEnv, arg1, arg2); |
| } |
| |
| apr_table_setn(dcfg->SetEnv, arg1, arg2); |
| |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE(pass_env) |
| { |
| MP_dSCFG(parms->server); |
| char *val = getenv(arg); |
| |
| #ifdef ENV_IS_CASELESS /* i.e. WIN32 */ |
| /* we turn off env magic during hv_store later, so do this now, |
| * else lookups on keys with lowercase characters will fails |
| * because Perl will uppercase them prior to lookup. |
| */ |
| modperl_str_toupper((char *)arg); |
| #endif |
| |
| if (val) { |
| apr_table_setn(scfg->PassEnv, arg, apr_pstrdup(parms->pool, val)); |
| MP_TRACE_d(MP_FUNC, "arg = %s, val = %s\n", arg, val); |
| } |
| else { |
| MP_TRACE_d(MP_FUNC, "arg = %s: not found via getenv()\n", arg); |
| } |
| |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE(options) |
| { |
| MP_dSCFG(parms->server); |
| modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig; |
| int is_per_dir = parms->path ? 1 : 0; |
| modperl_options_t *opts = is_per_dir ? dcfg->flags : scfg->flags; |
| apr_pool_t *p = parms->pool; |
| const char *error; |
| |
| MP_TRACE_d(MP_FUNC, "arg = %s\n", arg); |
| if ((error = modperl_options_set(p, opts, arg)) && !is_per_dir) { |
| /* maybe a per-directory option outside of a container */ |
| if (modperl_options_set(p, dcfg->flags, arg) == NULL) { |
| error = NULL; |
| } |
| } |
| |
| if (error) { |
| return error; |
| } |
| |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE(init_handlers) |
| { |
| if (parms->path) { |
| return modperl_cmd_header_parser_handlers(parms, mconfig, arg); |
| } |
| |
| return modperl_cmd_post_read_request_handlers(parms, mconfig, arg); |
| } |
| |
| static const char *modperl_cmd_parse_args(apr_pool_t *p, |
| const char *args, |
| apr_table_t **t) |
| { |
| const char *orig_args = args; |
| char *pair, *key, *val; |
| *t = apr_table_make(p, 2); |
| |
| while (*(pair = ap_getword(p, &args, ',')) != '\0') { |
| key = ap_getword_nc(p, &pair, '='); |
| val = pair; |
| |
| if (!(*key && *val)) { |
| return apr_pstrcat(p, "invalid args spec: ", |
| orig_args, NULL); |
| } |
| |
| apr_table_set(*t, key, val); |
| } |
| |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE(perl) |
| { |
| apr_pool_t *p = parms->pool; |
| const char *endp = ap_strrchr_c(arg, '>'); |
| const char *errmsg; |
| char *code = ""; |
| char line[MAX_STRING_LEN]; |
| apr_table_t *args; |
| ap_directive_t **current = mconfig; |
| |
| if (!endp) { |
| return modperl_cmd_unclosed_directive(parms); |
| } |
| |
| arg = apr_pstrndup(p, arg, endp - arg); |
| |
| if ((errmsg = modperl_cmd_parse_args(p, arg, &args))) { |
| return errmsg; |
| } |
| |
| while (!ap_cfg_getline(line, sizeof(line), parms->config_file)) { |
| /*XXX: Not sure how robust this is */ |
| if (strEQ(line, "</Perl>")) { |
| break; |
| } |
| |
| /*XXX: Less than optimal */ |
| code = apr_pstrcat(p, code, line, "\n", NULL); |
| } |
| |
| /* Here, we have to replace our current config node for the next pass */ |
| if (!*current) { |
| *current = apr_pcalloc(p, sizeof(**current)); |
| } |
| |
| (*current)->filename = parms->config_file->name; |
| (*current)->line_num = parms->config_file->line_number; |
| (*current)->directive = apr_pstrdup(p, "Perl"); |
| (*current)->args = code; |
| (*current)->data = args; |
| |
| return NULL; |
| } |
| |
| #define MP_DEFAULT_PERLSECTION_HANDLER "Apache::PerlSection" |
| #define MP_DEFAULT_PERLSECTION_PACKAGE "Apache::ReadConfig" |
| #define MP_STRICT_PERLSECTIONS_SV \ |
| get_sv("Apache::Server::StrictPerlSections", FALSE) |
| #define MP_PERLSECTIONS_SAVECONFIG_SV \ |
| get_sv("Apache::Server::SaveConfig", FALSE) |
| |
| MP_CMD_SRV_DECLARE(perldo) |
| { |
| apr_pool_t *p = parms->pool; |
| server_rec *s = parms->server; |
| apr_table_t *options = NULL; |
| const char *handler_name = NULL; |
| modperl_handler_t *handler = NULL; |
| const char *package_name = NULL; |
| int status = OK; |
| AV *args = Nullav; |
| #ifdef USE_ITHREADS |
| MP_dSCFG(s); |
| pTHX; |
| #endif |
| |
| if (!(arg && *arg)) { |
| return NULL; |
| } |
| |
| /* we must init earlier than normal */ |
| modperl_run(); |
| |
| if (modperl_init_vhost(s, p, NULL) != OK) { |
| return "init mod_perl vhost failed"; |
| } |
| |
| #ifdef USE_ITHREADS |
| /* XXX: .htaccess support cannot use this perl with threaded MPMs */ |
| aTHX = scfg->mip->parent->perl; |
| #endif |
| |
| /* data will be set by a <Perl> section */ |
| if ((options = parms->directive->data)) { |
| if (!(handler_name = apr_table_get(options, "handler"))) { |
| handler_name = apr_pstrdup(p, MP_DEFAULT_PERLSECTION_HANDLER); |
| apr_table_set(options, "handler", handler_name); |
| } |
| |
| handler = modperl_handler_new(p, handler_name); |
| |
| if (!(package_name = apr_table_get(options, "package"))) { |
| package_name = apr_pstrdup(p, MP_DEFAULT_PERLSECTION_PACKAGE); |
| apr_table_set(options, "package", package_name); |
| } |
| |
| /* put the code about to be executed in the configured package */ |
| arg = apr_pstrcat(p, "package ", package_name, ";", arg, NULL); |
| } |
| |
| eval_pv(arg, FALSE); |
| |
| if (SvTRUE(ERRSV)) { |
| SV *strict; |
| if ((strict = MP_STRICT_PERLSECTIONS_SV) && SvTRUE(strict)) { |
| return SvPVX(ERRSV); |
| } |
| else { |
| modperl_log_warn(s, apr_psprintf(p, "Syntax error at %s:%d %s", |
| parms->directive->filename, |
| parms->directive->line_num, |
| SvPVX(ERRSV))); |
| |
| } |
| } |
| |
| if (handler) { |
| SV *saveconfig; |
| modperl_handler_make_args(aTHX_ &args, |
| "Apache::CmdParms", parms, |
| "APR::Table", options, |
| NULL); |
| |
| status = modperl_callback(aTHX_ handler, p, NULL, s, args); |
| |
| SvREFCNT_dec((SV*)args); |
| |
| if (!(saveconfig = MP_PERLSECTIONS_SAVECONFIG_SV) || !SvTRUE(saveconfig)) { |
| HV *symtab = (HV*)gv_stashpv(package_name, FALSE); |
| if (symtab) { |
| modperl_clear_symtab(aTHX_ symtab); |
| } |
| } |
| |
| if (status != OK) { |
| return SvTRUE(ERRSV) ? SvPVX(ERRSV) : |
| apr_psprintf(p, "<Perl> handler %s failed with status=%d", |
| handler->name, status); |
| } |
| } |
| |
| return NULL; |
| } |
| |
| #define MP_POD_FORMAT(s) \ |
| (ap_strstr_c(s, "httpd") || ap_strstr_c(s, "apache")) |
| |
| MP_CMD_SRV_DECLARE(pod) |
| { |
| char line[MAX_STRING_LEN]; |
| |
| if (arg && *arg && !(MP_POD_FORMAT(arg) || strstr("pod", arg))) { |
| return "Unknown =back format"; |
| } |
| |
| while (!ap_cfg_getline(line, sizeof(line), parms->config_file)) { |
| if (strEQ(line, "=cut")) { |
| break; |
| } |
| if (strnEQ(line, "=over", 5) && MP_POD_FORMAT(line)) { |
| break; |
| } |
| } |
| |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE(pod_cut) |
| { |
| return "=cut without =pod"; |
| } |
| |
| MP_CMD_SRV_DECLARE(END) |
| { |
| char line[MAX_STRING_LEN]; |
| |
| while (!ap_cfg_getline(line, sizeof(line), parms->config_file)) { |
| /* soak up rest of the file */ |
| } |
| |
| return NULL; |
| } |
| |
| /* |
| * XXX: the name of this directive may or may not stay. |
| * need a way to note that a module has config directives. |
| * don't want to start mod_perl when we see a non-special PerlModule. |
| */ |
| MP_CMD_SRV_DECLARE(load_module) |
| { |
| apr_pool_t *p = parms->pool; |
| server_rec *s = parms->server; |
| const char *errmsg; |
| |
| MP_TRACE_d(MP_FUNC, "PerlLoadModule %s\n", arg); |
| |
| /* we must init earlier than normal */ |
| modperl_run(); |
| |
| if ((errmsg = modperl_cmd_modules(parms, mconfig, arg))) { |
| return errmsg; |
| } |
| |
| return modperl_module_add(p, s, arg); |
| } |
| |
| /* propogate filters insertion ala SetInputFilter */ |
| MP_CMD_SRV_DECLARE(set_input_filter) |
| { |
| MP_dSCFG(parms->server); |
| modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig; |
| char *filter; |
| |
| if (!MpSrvENABLE(scfg)) { |
| return apr_pstrcat(parms->pool, |
| "Perl is disabled for server ", |
| parms->server->server_hostname, NULL); |
| } |
| if (!MpSrvINPUT_FILTER(scfg)) { |
| return apr_pstrcat(parms->pool, |
| "PerlSetInputFilter is disabled for server ", |
| parms->server->server_hostname, NULL); |
| } |
| |
| while (*arg && (filter = ap_getword(parms->pool, &arg, ';'))) { |
| modperl_cmd_push_httpd_filter_handlers( |
| &(dcfg->handlers_per_dir[MP_INPUT_FILTER_HANDLER]), |
| filter, parms->pool); |
| } |
| |
| return NULL; |
| } |
| |
| /* propogate filters insertion ala SetOutputFilter */ |
| MP_CMD_SRV_DECLARE(set_output_filter) |
| { |
| MP_dSCFG(parms->server); |
| modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig; |
| char *filter; |
| |
| if (!MpSrvENABLE(scfg)) { |
| return apr_pstrcat(parms->pool, |
| "Perl is disabled for server ", |
| parms->server->server_hostname, NULL); |
| } |
| if (!MpSrvINPUT_FILTER(scfg)) { |
| return apr_pstrcat(parms->pool, |
| "PerlSetOutputFilter is disabled for server ", |
| parms->server->server_hostname, NULL); |
| } |
| |
| while (*arg && (filter = ap_getword(parms->pool, &arg, ';'))) { |
| modperl_cmd_push_httpd_filter_handlers( |
| &(dcfg->handlers_per_dir[MP_OUTPUT_FILTER_HANDLER]), |
| filter, parms->pool); |
| } |
| |
| return NULL; |
| } |
| |
| |
| #ifdef MP_COMPAT_1X |
| |
| MP_CMD_SRV_DECLARE_FLAG(taint_check) |
| { |
| if (flag_on) { |
| return modperl_cmd_switches(parms, mconfig, "-T"); |
| } |
| |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE_FLAG(warn) |
| { |
| if (flag_on) { |
| return modperl_cmd_switches(parms, mconfig, "-w"); |
| } |
| |
| return NULL; |
| } |
| |
| MP_CMD_SRV_DECLARE_FLAG(send_header) |
| { |
| char *arg = flag_on ? "+ParseHeaders" : "-ParseHeaders"; |
| return modperl_cmd_options(parms, mconfig, arg); |
| } |
| |
| MP_CMD_SRV_DECLARE_FLAG(setup_env) |
| { |
| char *arg = flag_on ? "+SetupEnv" : "-SetupEnv"; |
| return modperl_cmd_options(parms, mconfig, arg); |
| } |
| |
| #endif /* MP_COMPAT_1X */ |
| |
| #ifdef USE_ITHREADS |
| |
| #define MP_INTERP_SCOPE_USAGE "PerlInterpScope must be one of " |
| |
| #define MP_INTERP_SCOPE_DIR_OPTS \ |
| "handler, subrequest or request" |
| |
| #define MP_INTERP_SCOPE_DIR_USAGE \ |
| MP_INTERP_SCOPE_USAGE MP_INTERP_SCOPE_DIR_OPTS |
| |
| #define MP_INTERP_SCOPE_SRV_OPTS \ |
| "connection, " MP_INTERP_SCOPE_DIR_OPTS |
| |
| #define MP_INTERP_SCOPE_SRV_USAGE \ |
| MP_INTERP_SCOPE_USAGE MP_INTERP_SCOPE_SRV_OPTS |
| |
| MP_CMD_SRV_DECLARE(interp_scope) |
| { |
| modperl_interp_scope_e *scope; |
| modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig; |
| MP_dSCFG(parms->server); |
| int is_per_dir = parms->path ? 1 : 0; |
| |
| scope = is_per_dir ? &dcfg->interp_scope : &scfg->interp_scope; |
| |
| switch (toLOWER(*arg)) { |
| case 'h': |
| if (strcaseEQ(arg, "handler")) { |
| *scope = MP_INTERP_SCOPE_HANDLER; |
| break; |
| } |
| case 's': |
| if (strcaseEQ(arg, "subrequest")) { |
| *scope = MP_INTERP_SCOPE_SUBREQUEST; |
| break; |
| } |
| case 'r': |
| if (strcaseEQ(arg, "request")) { |
| *scope = MP_INTERP_SCOPE_REQUEST; |
| break; |
| } |
| case 'c': |
| if (!is_per_dir && strcaseEQ(arg, "connection")) { |
| *scope = MP_INTERP_SCOPE_CONNECTION; |
| break; |
| } |
| default: |
| return is_per_dir ? |
| MP_INTERP_SCOPE_DIR_USAGE : MP_INTERP_SCOPE_SRV_USAGE; |
| }; |
| |
| return NULL; |
| } |
| |
| #define MP_CMD_INTERP_POOL_IMP(xitem) \ |
| const char *modperl_cmd_interp_##xitem(cmd_parms *parms, \ |
| void *mconfig, const char *arg) \ |
| { \ |
| MP_dSCFG(parms->server); \ |
| int item = atoi(arg); \ |
| scfg->interp_pool_cfg->xitem = item; \ |
| MP_TRACE_d(MP_FUNC, "%s %d\n", parms->cmd->name, item); \ |
| return NULL; \ |
| } |
| |
| MP_CMD_INTERP_POOL_IMP(start); |
| MP_CMD_INTERP_POOL_IMP(max); |
| MP_CMD_INTERP_POOL_IMP(max_spare); |
| MP_CMD_INTERP_POOL_IMP(min_spare); |
| MP_CMD_INTERP_POOL_IMP(max_requests); |
| |
| #endif /* USE_ITHREADS */ |