| /* 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" |
| |
| modperl_handler_t *modperl_handler_new(apr_pool_t *p, const char *name) |
| { |
| modperl_handler_t *handler = |
| (modperl_handler_t *)apr_pcalloc(p, sizeof(*handler)); |
| |
| switch (*name) { |
| case '+': |
| ++name; |
| MpHandlerAUTOLOAD_On(handler); |
| break; |
| case '-': |
| ++name; |
| /* XXX: currently a noop; should disable autoload of given handler |
| * if PerlOptions +AutoLoad is configured |
| * see: modperl_hash_handlers in modperl_mgv.c |
| */ |
| MpHandlerAUTOLOAD_Off(handler); |
| break; |
| } |
| |
| /* not necessary due to apr_pcalloc */ |
| /* handler->cv = NULL; */ |
| handler->name = name; |
| MP_TRACE_h(MP_FUNC, "new handler %s", handler->name); |
| |
| return handler; |
| } |
| |
| /* How anon-subs are handled: |
| * We have two ways anon-subs can be registered |
| * A) at startup from httpd.conf: |
| * PerlTransHandler 'sub { ... }' |
| * B) run-time perl code |
| * $r->push_handlers(PerlTransHandler => sub { .... }); |
| * $s->push_handlers(PerlTransHandler => sub { .... }); |
| * |
| * In the case of non-threaded perl, we just compile A or grab B and |
| * store it in the mod_perl struct and call it when it's used. No |
| * problems here |
| * |
| * In the case of threads, things get more complicated. we no longer |
| * can store the CV value of the compiled anon-sub, since when |
| * perl_clone is called each interpreter will have a different CV |
| * value. since we need to be able to have 1 entry for each anon-sub |
| * across all interpreters a different solution is needed. to remind |
| * in the case of named subs, we just store the name of the sub and |
| * look its corresponding CV when we need it. |
| * |
| * The used solution: each process has a global counter, which always |
| * grows. Every time a new anon-sub is encountered, a new ID is |
| * allocated from that process-global counter and that ID is stored in |
| * the mod_perl struct. The compiled CV is stored as |
| * $PL_modglobal{ANONSUB}{$id} = CV; |
| * when perl_clone is called, each clone will clone that CV value, but |
| * we will still be able to find it, since we stored it in the |
| * hash. so we retrieve the CV value, whatever it is and we run it. |
| * |
| * that explanation can be written and run in perl: |
| * |
| * use threads; |
| * our %h; |
| * $h{x} = eval 'sub { print qq[this is sub @_\n] }'; |
| * $h{x}->("main"); |
| * threads->new(sub { $h{x}->(threads->self->tid)}); |
| * |
| * XXX: more nuances will follow |
| */ |
| |
| void modperl_handler_anon_init(pTHX_ apr_pool_t *p) |
| { |
| modperl_modglobal_key_t *gkey = |
| modperl_modglobal_lookup(aTHX_ "ANONSUB"); |
| MP_TRACE_h(MP_FUNC, "init $PL_modglobal{ANONSUB} = []"); |
| (void)MP_MODGLOBAL_STORE_HV(gkey); |
| } |
| |
| /* allocate and populate the anon handler sub-struct */ |
| MP_INLINE modperl_mgv_t *modperl_handler_anon_next(pTHX_ apr_pool_t *p) |
| { |
| /* re-use modperl_mgv_t entry which is otherwise is not used |
| * by anon handlers */ |
| modperl_mgv_t *anon = |
| (modperl_mgv_t *)apr_pcalloc(p, sizeof(*anon)); |
| |
| anon->name = apr_psprintf(p, "anon%d", modperl_global_anon_cnt_next()); |
| anon->len = strlen(anon->name); |
| PERL_HASH(anon->hash, anon->name, anon->len); |
| |
| MP_TRACE_h(MP_FUNC, "new anon handler: '%s'", anon->name); |
| return anon; |
| } |
| |
| MP_INLINE void modperl_handler_anon_add(pTHX_ modperl_mgv_t *anon, CV *cv) |
| { |
| modperl_modglobal_key_t *gkey = |
| modperl_modglobal_lookup(aTHX_ "ANONSUB"); |
| HE *he = MP_MODGLOBAL_FETCH(gkey); |
| HV *hv; |
| |
| if (!(he && (hv = (HV*)HeVAL(he)))) { |
| Perl_croak(aTHX_ "modperl_handler_anon_add: " |
| "can't find ANONSUB top entry (get)"); |
| } |
| |
| SvREFCNT_inc(cv); |
| if (!(*hv_store(hv, anon->name, anon->len, (SV*)cv, anon->hash))) { |
| SvREFCNT_dec(cv); |
| Perl_croak(aTHX_ "hv_store of anonsub '%s' has failed!", anon->name); |
| } |
| |
| MP_TRACE_h(MP_FUNC, "anonsub '%s' added", anon->name); |
| } |
| |
| MP_INLINE CV *modperl_handler_anon_get(pTHX_ modperl_mgv_t *anon) |
| { |
| modperl_modglobal_key_t *gkey = |
| modperl_modglobal_lookup(aTHX_ "ANONSUB"); |
| HE *he = MP_MODGLOBAL_FETCH(gkey); |
| HV *hv; |
| SV *sv; |
| |
| if (!(he && (hv = (HV*)HeVAL(he)))) { |
| Perl_croak(aTHX_ "modperl_handler_anon_get: " |
| "can't find ANONSUB top entry (get)"); |
| } |
| |
| if ((he = hv_fetch_he(hv, anon->name, anon->len, anon->hash))) { |
| sv = HeVAL(he); |
| MP_TRACE_h(MP_FUNC, "anonsub gets name '%s'", anon->name); |
| } |
| else { |
| Perl_croak(aTHX_ "can't find ANONSUB's '%s' entry", anon->name); |
| } |
| |
| return (CV*)sv; |
| } |
| |
| static |
| modperl_handler_t *modperl_handler_new_anon(pTHX_ apr_pool_t *p, CV *cv) |
| { |
| modperl_handler_t *handler = |
| (modperl_handler_t *)apr_pcalloc(p, sizeof(*handler)); |
| MpHandlerPARSED_On(handler); |
| MpHandlerANON_On(handler); |
| |
| #ifdef USE_ITHREADS |
| handler->cv = NULL; |
| handler->name = NULL; |
| handler->mgv_obj = modperl_handler_anon_next(aTHX_ p); |
| modperl_handler_anon_add(aTHX_ handler->mgv_obj, cv); |
| #else |
| /* it's safe to cache and later use the cv, since the same perl |
| * interpeter is always used */ |
| SvREFCNT_inc((SV*)cv); |
| handler->cv = cv; |
| handler->name = NULL; |
| |
| MP_TRACE_h(MP_FUNC, "new cached cv anon handler"); |
| #endif |
| |
| return handler; |
| } |
| |
| MP_INLINE |
| const char *modperl_handler_name(modperl_handler_t *handler) |
| { |
| /* a handler containing an anonymous sub doesn't have a normal sub |
| * name */ |
| if (handler->name) { |
| return handler->name; |
| } |
| else { |
| /* anon sub stores the internal modperl name in mgv_obj */ |
| return handler->mgv_obj ? handler->mgv_obj->name : "anonsub"; |
| } |
| } |
| |
| |
| int modperl_handler_resolve(pTHX_ modperl_handler_t **handp, |
| apr_pool_t *p, server_rec *s) |
| { |
| int duped=0; |
| modperl_handler_t *handler = *handp; |
| |
| #ifdef USE_ITHREADS |
| if (modperl_threaded_mpm() && p && |
| !MpHandlerPARSED(handler) && !MpHandlerDYNAMIC(handler)) { |
| /* |
| * under threaded mpm we cannot update the handler structure |
| * at request time without locking, so just copy it |
| */ |
| handler = *handp = modperl_handler_dup(p, handler); |
| duped = 1; |
| } |
| #endif |
| |
| MP_TRACE_h_do(MpHandler_dump_flags(handler, |
| modperl_handler_name(handler))); |
| |
| if (!MpHandlerPARSED(handler)) { |
| apr_pool_t *rp = duped ? p : s->process->pconf; |
| MpHandlerAUTOLOAD_On(handler); |
| |
| MP_TRACE_h(MP_FUNC, |
| "[%s] handler %s hasn't yet been resolved, " |
| "attempting to resolve using %s pool 0x%lx", |
| modperl_server_desc(s, p), |
| modperl_handler_name(handler), |
| duped ? "current" : "server conf", |
| (unsigned long)rp); |
| |
| if (!modperl_mgv_resolve(aTHX_ handler, rp, handler->name, FALSE)) { |
| modperl_errsv_prepend(aTHX_ |
| "failed to resolve handler `%s': ", |
| handler->name); |
| return HTTP_INTERNAL_SERVER_ERROR; |
| } |
| } |
| |
| return OK; |
| } |
| |
| modperl_handler_t *modperl_handler_dup(apr_pool_t *p, |
| modperl_handler_t *h) |
| { |
| MP_TRACE_h(MP_FUNC, "dup handler %s", modperl_handler_name(h)); |
| return modperl_handler_new(p, h->name); |
| } |
| |
| int modperl_handler_equal(modperl_handler_t *h1, modperl_handler_t *h2) |
| { |
| if (h1->mgv_cv && h2->mgv_cv) { |
| return modperl_mgv_equal(h1->mgv_cv, h2->mgv_cv); |
| } |
| return strEQ(h1->name, h2->name); |
| } |
| |
| MpAV *modperl_handler_array_merge(apr_pool_t *p, MpAV *base_a, MpAV *add_a) |
| { |
| int i, j; |
| modperl_handler_t **base_h, **add_h; |
| MpAV *mrg_a; |
| |
| if (!add_a) { |
| return base_a; |
| } |
| |
| if (!base_a) { |
| return add_a; |
| } |
| |
| mrg_a = apr_array_copy(p, base_a); |
| |
| base_h = (modperl_handler_t **)base_a->elts; |
| add_h = (modperl_handler_t **)add_a->elts; |
| |
| for (i=0; i<base_a->nelts; i++) { |
| for (j=0; j<add_a->nelts; j++) { |
| if (modperl_handler_equal(base_h[i], add_h[j])) { |
| MP_TRACE_d(MP_FUNC, "both base and new config contain %s", |
| add_h[j]->name); |
| } |
| else { |
| modperl_handler_array_push(mrg_a, add_h[j]); |
| MP_TRACE_d(MP_FUNC, "base does not contain %s", |
| add_h[j]->name); |
| } |
| } |
| } |
| |
| return mrg_a; |
| } |
| |
| void modperl_handler_make_args(pTHX_ AV **avp, ...) |
| { |
| va_list args; |
| |
| if (!*avp) { |
| *avp = newAV(); /* XXX: cache an intialized AV* per-request */ |
| } |
| |
| va_start(args, avp); |
| |
| for (;;) { |
| char *classname = va_arg(args, char *); |
| void *ptr; |
| SV *sv; |
| |
| if (classname == NULL) { |
| break; |
| } |
| |
| ptr = va_arg(args, void *); |
| |
| switch (*classname) { |
| case 'A': |
| if (strEQ(classname, "APR::Table")) { |
| sv = modperl_hash_tie(aTHX_ classname, (SV *)NULL, ptr); |
| break; |
| } |
| case 'I': |
| if (strEQ(classname, "IV")) { |
| sv = ptr ? newSViv(PTR2IV(ptr)) : &PL_sv_undef; |
| break; |
| } |
| case 'P': |
| if (strEQ(classname, "PV")) { |
| sv = ptr ? newSVpv((char *)ptr, 0) : &PL_sv_undef; |
| break; |
| } |
| case 'H': |
| if (strEQ(classname, "HV")) { |
| sv = newRV_noinc((SV*)ptr); |
| break; |
| } |
| default: |
| sv = modperl_ptr2obj(aTHX_ classname, ptr); |
| break; |
| } |
| |
| av_push(*avp, sv); |
| } |
| |
| va_end(args); |
| } |
| |
| #define set_desc(dtype) \ |
| if (desc) *desc = modperl_handler_desc_##dtype(idx) |
| |
| /* We should be able to use PERL_GET_CONTEXT here. The rcfg condition |
| * makes sure there is a request being processed. The action > GET part |
| * means it is a $r->set_handlers or $r->push_handlers operation. This |
| * can only happen if called by perl code. |
| */ |
| #define check_modify(dtype) \ |
| if ((action > MP_HANDLER_ACTION_GET) && rcfg) { \ |
| dTHXa(PERL_GET_CONTEXT); \ |
| MP_ASSERT(aTHX+0); \ |
| Perl_croak(aTHX_ "too late to modify %s handlers", \ |
| modperl_handler_desc_##dtype(idx)); \ |
| } |
| |
| /* |
| * generic function to lookup handlers for use in modperl_callback(), |
| * $r->{push,set,get}_handlers, $s->{push,set,get}_handlers |
| * $s->push/set at startup time are the same as configuring Perl*Handlers |
| * $r->push/set at request time will create entries in r->request_config |
| * push will first merge with configured handlers, unless an entry |
| * in r->request_config already exists. in this case, push or set has |
| * already been called for the given handler, |
| * r->request_config entries then override those in r->per_dir_config |
| */ |
| |
| MpAV **modperl_handler_lookup_handlers(modperl_config_dir_t *dcfg, |
| modperl_config_srv_t *scfg, |
| modperl_config_req_t *rcfg, |
| apr_pool_t *p, |
| int type, int idx, |
| modperl_handler_action_e action, |
| const char **desc) |
| { |
| MpAV **avp = NULL, **ravp = NULL; |
| |
| switch (type) { |
| case MP_HANDLER_TYPE_PER_DIR: |
| avp = &dcfg->handlers_per_dir[idx]; |
| if (rcfg) { |
| ravp = &rcfg->handlers_per_dir[idx]; |
| } |
| set_desc(per_dir); |
| break; |
| case MP_HANDLER_TYPE_PER_SRV: |
| avp = &scfg->handlers_per_srv[idx]; |
| if (rcfg) { |
| ravp = &rcfg->handlers_per_srv[idx]; |
| } |
| set_desc(per_srv); |
| break; |
| case MP_HANDLER_TYPE_PRE_CONNECTION: |
| avp = &scfg->handlers_pre_connection[idx]; |
| check_modify(pre_connection); |
| set_desc(pre_connection); |
| break; |
| case MP_HANDLER_TYPE_CONNECTION: |
| avp = &scfg->handlers_connection[idx]; |
| check_modify(connection); |
| set_desc(connection); |
| break; |
| case MP_HANDLER_TYPE_FILES: |
| avp = &scfg->handlers_files[idx]; |
| check_modify(files); |
| set_desc(files); |
| break; |
| case MP_HANDLER_TYPE_PROCESS: |
| avp = &scfg->handlers_process[idx]; |
| check_modify(files); |
| set_desc(process); |
| break; |
| }; |
| |
| if (!avp) { |
| /* should never happen */ |
| #if 0 |
| fprintf(stderr, "PANIC: no such handler type: %d\n", type); |
| #endif |
| return NULL; |
| } |
| |
| switch (action) { |
| case MP_HANDLER_ACTION_GET: |
| /* just a lookup */ |
| break; |
| case MP_HANDLER_ACTION_PUSH: |
| if (ravp) { |
| if (!*ravp) { |
| if (*avp) { |
| /* merge with existing configured handlers */ |
| *ravp = apr_array_copy(p, *avp); |
| } |
| else { |
| /* no request handlers have been previously pushed or set */ |
| *ravp = modperl_handler_array_new(p); |
| } |
| } |
| } |
| else if (!*avp) { |
| /* directly modify the configuration at startup time */ |
| *avp = modperl_handler_array_new(p); |
| } |
| break; |
| case MP_HANDLER_ACTION_SET: |
| if (ravp) { |
| if (*ravp) { |
| /* wipe out existing pushed/set request handlers */ |
| (*ravp)->nelts = 0; |
| } |
| else { |
| /* no request handlers have been previously pushed or set */ |
| *ravp = modperl_handler_array_new(p); |
| } |
| } |
| else if (*avp) { |
| /* wipe out existing configuration, only at startup time */ |
| (*avp)->nelts = 0; |
| } |
| else { |
| /* no configured handlers for this phase */ |
| *avp = modperl_handler_array_new(p); |
| } |
| break; |
| } |
| |
| return (ravp && *ravp) ? ravp : avp; |
| } |
| |
| MpAV **modperl_handler_get_handlers(request_rec *r, conn_rec *c, server_rec *s, |
| apr_pool_t *p, const char *name, |
| modperl_handler_action_e action) |
| { |
| MP_dSCFG(s); |
| MP_dDCFG; |
| MP_dRCFG; |
| |
| int idx, type; |
| |
| if (!r) { |
| /* so $s->{push,set}_handlers can configured request-time handlers */ |
| dcfg = modperl_config_dir_get_defaults(s); |
| } |
| |
| if ((idx = modperl_handler_lookup(name, &type)) == DECLINED) { |
| return FALSE; |
| } |
| |
| return modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p, |
| type, idx, |
| action, NULL); |
| } |
| |
| modperl_handler_t *modperl_handler_new_from_sv(pTHX_ apr_pool_t *p, SV *sv) |
| { |
| char *name = NULL; |
| GV *gv; |
| |
| if (SvROK(sv)) { |
| sv = SvRV(sv); |
| } |
| |
| switch (SvTYPE(sv)) { |
| case SVt_PV: |
| name = SvPVX(sv); |
| return modperl_handler_new(p, apr_pstrdup(p, name)); |
| break; |
| case SVt_PVCV: |
| if (CvANON((CV*)sv)) { |
| return modperl_handler_new_anon(aTHX_ p, (CV*)sv); |
| } |
| if (!(gv = CvGV((CV*)sv))) { |
| Perl_croak(aTHX_ "can't resolve the code reference"); |
| } |
| name = apr_pstrcat(p, HvNAME(GvSTASH(gv)), "::", GvNAME(gv), NULL); |
| return modperl_handler_new(p, name); |
| default: |
| break; |
| }; |
| |
| return NULL; |
| } |
| |
| int modperl_handler_push_handlers(pTHX_ apr_pool_t *p, |
| MpAV *handlers, SV *sv) |
| { |
| modperl_handler_t *handler = modperl_handler_new_from_sv(aTHX_ p, sv); |
| |
| if (handler) { |
| modperl_handler_array_push(handlers, handler); |
| return TRUE; |
| } |
| |
| MP_TRACE_h(MP_FUNC, "unable to push_handler 0x%lx", |
| (unsigned long)sv); |
| |
| return FALSE; |
| } |
| |
| /* convert array header of modperl_handlers_t's to AV ref of CV refs */ |
| SV *modperl_handler_perl_get_handlers(pTHX_ MpAV **handp, apr_pool_t *p) |
| { |
| AV *av = newAV(); |
| int i; |
| modperl_handler_t **handlers; |
| |
| if (!(handp && *handp)) { |
| return &PL_sv_undef; |
| } |
| |
| av_extend(av, (*handp)->nelts - 1); |
| |
| handlers = (modperl_handler_t **)(*handp)->elts; |
| |
| for (i=0; i<(*handp)->nelts; i++) { |
| modperl_handler_t *handler = NULL; |
| GV *gv; |
| |
| if (MpHandlerPARSED(handlers[i])) { |
| handler = handlers[i]; |
| } |
| else { |
| #ifdef USE_ITHREADS |
| if (!MpHandlerDYNAMIC(handlers[i])) { |
| handler = modperl_handler_dup(p, handlers[i]); |
| } |
| #endif |
| if (!handler) { |
| handler = handlers[i]; |
| } |
| |
| if (!modperl_mgv_resolve(aTHX_ handler, p, handler->name, TRUE)) { |
| MP_TRACE_h(MP_FUNC, "failed to resolve handler %s", |
| handler->name); |
| } |
| |
| } |
| |
| if (handler->mgv_cv) { |
| if ((gv = modperl_mgv_lookup(aTHX_ handler->mgv_cv))) { |
| CV *cv = modperl_mgv_cv(gv); |
| av_push(av, newRV_inc((SV*)cv)); |
| } |
| } |
| else { |
| av_push(av, newSVpv(handler->name, 0)); |
| } |
| } |
| |
| return newRV_noinc((SV*)av); |
| } |
| |
| #define push_sv_handler \ |
| if ((modperl_handler_push_handlers(aTHX_ p, *handlers, sv))) { \ |
| MpHandlerDYNAMIC_On(modperl_handler_array_last(*handlers)); \ |
| } |
| |
| /* allow push/set of single cv ref or array ref of cv refs */ |
| int modperl_handler_perl_add_handlers(pTHX_ |
| request_rec *r, |
| conn_rec *c, |
| server_rec *s, |
| apr_pool_t *p, |
| const char *name, |
| SV *sv, |
| modperl_handler_action_e action) |
| { |
| I32 i; |
| AV *av = (AV *)NULL; |
| MpAV **handlers = |
| modperl_handler_get_handlers(r, c, s, |
| p, name, action); |
| |
| if (!(handlers && *handlers)) { |
| return FALSE; |
| } |
| |
| if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV)) { |
| av = (AV*)SvRV(sv); |
| |
| for (i=0; i <= AvFILL(av); i++) { |
| sv = *av_fetch(av, i, FALSE); |
| push_sv_handler; |
| } |
| } |
| else { |
| push_sv_handler; |
| } |
| |
| return TRUE; |
| } |
| |
| /* |
| * Local Variables: |
| * c-basic-offset: 4 |
| * indent-tabs-mode: nil |
| * End: |
| */ |
