1 /* Licensed to the Apache Software Foundation (ASF) under one or more
2 * contributor license agreements. See the NOTICE file distributed with
3 * this work for additional information regarding copyright ownership.
4 * The ASF licenses this file to You under the Apache License, Version 2.0
5 * (the "License"); you may not use this file except in compliance with
6 * the License. You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 */
16
17 #include "mod_perl.h"
18
modperl_handler_new(apr_pool_t * p,const char * name)19 modperl_handler_t *modperl_handler_new(apr_pool_t *p, const char *name)
20 {
21 modperl_handler_t *handler =
22 (modperl_handler_t *)apr_pcalloc(p, sizeof(*handler));
23
24 switch (*name) {
25 case '+':
26 ++name;
27 MpHandlerAUTOLOAD_On(handler);
28 break;
29 case '-':
30 ++name;
31 /* XXX: currently a noop; should disable autoload of given handler
32 * if PerlOptions +AutoLoad is configured
33 * see: modperl_hash_handlers in modperl_mgv.c
34 */
35 MpHandlerAUTOLOAD_Off(handler);
36 break;
37 }
38
39 /* not necessary due to apr_pcalloc */
40 /* handler->cv = NULL; */
41 handler->name = name;
42 MP_TRACE_h(MP_FUNC, "new handler %s", handler->name);
43
44 return handler;
45 }
46
47 /* How anon-subs are handled:
48 * We have two ways anon-subs can be registered
49 * A) at startup from httpd.conf:
50 * PerlTransHandler 'sub { ... }'
51 * B) run-time perl code
52 * $r->push_handlers(PerlTransHandler => sub { .... });
53 * $s->push_handlers(PerlTransHandler => sub { .... });
54 *
55 * In the case of non-threaded perl, we just compile A or grab B and
56 * store it in the mod_perl struct and call it when it's used. No
57 * problems here
58 *
59 * In the case of threads, things get more complicated. we no longer
60 * can store the CV value of the compiled anon-sub, since when
61 * perl_clone is called each interpreter will have a different CV
62 * value. since we need to be able to have 1 entry for each anon-sub
63 * across all interpreters a different solution is needed. to remind
64 * in the case of named subs, we just store the name of the sub and
65 * look its corresponding CV when we need it.
66 *
67 * The used solution: each process has a global counter, which always
68 * grows. Every time a new anon-sub is encountered, a new ID is
69 * allocated from that process-global counter and that ID is stored in
70 * the mod_perl struct. The compiled CV is stored as
71 * $PL_modglobal{ANONSUB}{$id} = CV;
72 * when perl_clone is called, each clone will clone that CV value, but
73 * we will still be able to find it, since we stored it in the
74 * hash. so we retrieve the CV value, whatever it is and we run it.
75 *
76 * that explanation can be written and run in perl:
77 *
78 * use threads;
79 * our %h;
80 * $h{x} = eval 'sub { print qq[this is sub @_\n] }';
81 * $h{x}->("main");
82 * threads->new(sub { $h{x}->(threads->self->tid)});
83 *
84 * XXX: more nuances will follow
85 */
86
modperl_handler_anon_init(pTHX_ apr_pool_t * p)87 void modperl_handler_anon_init(pTHX_ apr_pool_t *p)
88 {
89 modperl_modglobal_key_t *gkey =
90 modperl_modglobal_lookup(aTHX_ "ANONSUB");
91 MP_TRACE_h(MP_FUNC, "init $PL_modglobal{ANONSUB} = []");
92 (void)MP_MODGLOBAL_STORE_HV(gkey);
93 }
94
95 /* allocate and populate the anon handler sub-struct */
modperl_handler_anon_next(pTHX_ apr_pool_t * p)96 MP_INLINE modperl_mgv_t *modperl_handler_anon_next(pTHX_ apr_pool_t *p)
97 {
98 /* re-use modperl_mgv_t entry which is otherwise is not used
99 * by anon handlers */
100 modperl_mgv_t *anon =
101 (modperl_mgv_t *)apr_pcalloc(p, sizeof(*anon));
102
103 anon->name = apr_psprintf(p, "anon%d", modperl_global_anon_cnt_next());
104 anon->len = strlen(anon->name);
105 PERL_HASH(anon->hash, anon->name, anon->len);
106
107 MP_TRACE_h(MP_FUNC, "new anon handler: '%s'", anon->name);
108 return anon;
109 }
110
modperl_handler_anon_add(pTHX_ modperl_mgv_t * anon,CV * cv)111 MP_INLINE void modperl_handler_anon_add(pTHX_ modperl_mgv_t *anon, CV *cv)
112 {
113 modperl_modglobal_key_t *gkey =
114 modperl_modglobal_lookup(aTHX_ "ANONSUB");
115 HE *he = MP_MODGLOBAL_FETCH(gkey);
116 HV *hv;
117
118 if (!(he && (hv = (HV*)HeVAL(he)))) {
119 Perl_croak(aTHX_ "modperl_handler_anon_add: "
120 "can't find ANONSUB top entry (get)");
121 }
122
123 SvREFCNT_inc(cv);
124 if (!(*hv_store(hv, anon->name, anon->len, (SV*)cv, anon->hash))) {
125 SvREFCNT_dec(cv);
126 Perl_croak(aTHX_ "hv_store of anonsub '%s' has failed!", anon->name);
127 }
128
129 MP_TRACE_h(MP_FUNC, "anonsub '%s' added", anon->name);
130 }
131
modperl_handler_anon_get(pTHX_ modperl_mgv_t * anon)132 MP_INLINE CV *modperl_handler_anon_get(pTHX_ modperl_mgv_t *anon)
133 {
134 modperl_modglobal_key_t *gkey =
135 modperl_modglobal_lookup(aTHX_ "ANONSUB");
136 HE *he = MP_MODGLOBAL_FETCH(gkey);
137 HV *hv;
138 SV *sv;
139
140 if (!(he && (hv = (HV*)HeVAL(he)))) {
141 Perl_croak(aTHX_ "modperl_handler_anon_get: "
142 "can't find ANONSUB top entry (get)");
143 }
144
145 if ((he = hv_fetch_he(hv, anon->name, anon->len, anon->hash))) {
146 sv = HeVAL(he);
147 MP_TRACE_h(MP_FUNC, "anonsub gets name '%s'", anon->name);
148 }
149 else {
150 Perl_croak(aTHX_ "can't find ANONSUB's '%s' entry", anon->name);
151 }
152
153 return (CV*)sv;
154 }
155
156 static
modperl_handler_new_anon(pTHX_ apr_pool_t * p,CV * cv)157 modperl_handler_t *modperl_handler_new_anon(pTHX_ apr_pool_t *p, CV *cv)
158 {
159 modperl_handler_t *handler =
160 (modperl_handler_t *)apr_pcalloc(p, sizeof(*handler));
161 MpHandlerPARSED_On(handler);
162 MpHandlerANON_On(handler);
163
164 #ifdef USE_ITHREADS
165 handler->cv = NULL;
166 handler->name = NULL;
167 handler->mgv_obj = modperl_handler_anon_next(aTHX_ p);
168 modperl_handler_anon_add(aTHX_ handler->mgv_obj, cv);
169 #else
170 /* it's safe to cache and later use the cv, since the same perl
171 * interpeter is always used */
172 SvREFCNT_inc((SV*)cv);
173 handler->cv = cv;
174 handler->name = NULL;
175
176 MP_TRACE_h(MP_FUNC, "new cached cv anon handler");
177 #endif
178
179 return handler;
180 }
181
182 MP_INLINE
modperl_handler_name(modperl_handler_t * handler)183 const char *modperl_handler_name(modperl_handler_t *handler)
184 {
185 /* a handler containing an anonymous sub doesn't have a normal sub
186 * name */
187 if (handler->name) {
188 return handler->name;
189 }
190 else {
191 /* anon sub stores the internal modperl name in mgv_obj */
192 return handler->mgv_obj ? handler->mgv_obj->name : "anonsub";
193 }
194 }
195
196
modperl_handler_resolve(pTHX_ modperl_handler_t ** handp,apr_pool_t * p,server_rec * s)197 int modperl_handler_resolve(pTHX_ modperl_handler_t **handp,
198 apr_pool_t *p, server_rec *s)
199 {
200 int duped=0;
201 modperl_handler_t *handler = *handp;
202
203 #ifdef USE_ITHREADS
204 if (modperl_threaded_mpm() && p &&
205 !MpHandlerPARSED(handler) && !MpHandlerDYNAMIC(handler)) {
206 /*
207 * under threaded mpm we cannot update the handler structure
208 * at request time without locking, so just copy it
209 */
210 handler = *handp = modperl_handler_dup(p, handler);
211 duped = 1;
212 }
213 #endif
214
215 MP_TRACE_h_do(MpHandler_dump_flags(handler,
216 modperl_handler_name(handler)));
217
218 if (!MpHandlerPARSED(handler)) {
219 apr_pool_t *rp = duped ? p : s->process->pconf;
220 MpHandlerAUTOLOAD_On(handler);
221
222 MP_TRACE_h(MP_FUNC,
223 "[%s] handler %s hasn't yet been resolved, "
224 "attempting to resolve using %s pool 0x%lx",
225 modperl_server_desc(s, p),
226 modperl_handler_name(handler),
227 duped ? "current" : "server conf",
228 (unsigned long)rp);
229
230 if (!modperl_mgv_resolve(aTHX_ handler, rp, handler->name, FALSE)) {
231 modperl_errsv_prepend(aTHX_
232 "failed to resolve handler `%s': ",
233 handler->name);
234 return HTTP_INTERNAL_SERVER_ERROR;
235 }
236 }
237
238 return OK;
239 }
240
modperl_handler_dup(apr_pool_t * p,modperl_handler_t * h)241 modperl_handler_t *modperl_handler_dup(apr_pool_t *p,
242 modperl_handler_t *h)
243 {
244 MP_TRACE_h(MP_FUNC, "dup handler %s", modperl_handler_name(h));
245 return modperl_handler_new(p, h->name);
246 }
247
modperl_handler_equal(modperl_handler_t * h1,modperl_handler_t * h2)248 int modperl_handler_equal(modperl_handler_t *h1, modperl_handler_t *h2)
249 {
250 if (h1->mgv_cv && h2->mgv_cv) {
251 return modperl_mgv_equal(h1->mgv_cv, h2->mgv_cv);
252 }
253 return strEQ(h1->name, h2->name);
254 }
255
modperl_handler_array_merge(apr_pool_t * p,MpAV * base_a,MpAV * add_a)256 MpAV *modperl_handler_array_merge(apr_pool_t *p, MpAV *base_a, MpAV *add_a)
257 {
258 int i, j;
259 modperl_handler_t **base_h, **add_h;
260 MpAV *mrg_a;
261
262 if (!add_a) {
263 return base_a;
264 }
265
266 if (!base_a) {
267 return add_a;
268 }
269
270 mrg_a = apr_array_copy(p, base_a);
271
272 base_h = (modperl_handler_t **)base_a->elts;
273 add_h = (modperl_handler_t **)add_a->elts;
274
275 for (i=0; i<base_a->nelts; i++) {
276 for (j=0; j<add_a->nelts; j++) {
277 if (modperl_handler_equal(base_h[i], add_h[j])) {
278 MP_TRACE_d(MP_FUNC, "both base and new config contain %s",
279 add_h[j]->name);
280 }
281 else {
282 modperl_handler_array_push(mrg_a, add_h[j]);
283 MP_TRACE_d(MP_FUNC, "base does not contain %s",
284 add_h[j]->name);
285 }
286 }
287 }
288
289 return mrg_a;
290 }
291
modperl_handler_make_args(pTHX_ AV ** avp,...)292 void modperl_handler_make_args(pTHX_ AV **avp, ...)
293 {
294 va_list args;
295
296 if (!*avp) {
297 *avp = newAV(); /* XXX: cache an intialized AV* per-request */
298 }
299
300 va_start(args, avp);
301
302 for (;;) {
303 char *classname = va_arg(args, char *);
304 void *ptr;
305 SV *sv;
306
307 if (classname == NULL) {
308 break;
309 }
310
311 ptr = va_arg(args, void *);
312
313 switch (*classname) {
314 case 'A':
315 if (strEQ(classname, "APR::Table")) {
316 sv = modperl_hash_tie(aTHX_ classname, (SV *)NULL, ptr);
317 break;
318 }
319 case 'I':
320 if (strEQ(classname, "IV")) {
321 sv = ptr ? newSViv(PTR2IV(ptr)) : &PL_sv_undef;
322 break;
323 }
324 case 'P':
325 if (strEQ(classname, "PV")) {
326 sv = ptr ? newSVpv((char *)ptr, 0) : &PL_sv_undef;
327 break;
328 }
329 case 'H':
330 if (strEQ(classname, "HV")) {
331 sv = newRV_noinc((SV*)ptr);
332 break;
333 }
334 default:
335 sv = modperl_ptr2obj(aTHX_ classname, ptr);
336 break;
337 }
338
339 av_push(*avp, sv);
340 }
341
342 va_end(args);
343 }
344
345 #define set_desc(dtype) \
346 if (desc) *desc = modperl_handler_desc_##dtype(idx)
347
348 /* We should be able to use PERL_GET_CONTEXT here. The rcfg condition
349 * makes sure there is a request being processed. The action > GET part
350 * means it is a $r->set_handlers or $r->push_handlers operation. This
351 * can only happen if called by perl code.
352 */
353 #define check_modify(dtype) \
354 if ((action > MP_HANDLER_ACTION_GET) && rcfg) { \
355 dTHXa(PERL_GET_CONTEXT); \
356 MP_ASSERT(aTHX+0); \
357 Perl_croak(aTHX_ "too late to modify %s handlers", \
358 modperl_handler_desc_##dtype(idx)); \
359 }
360
361 /*
362 * generic function to lookup handlers for use in modperl_callback(),
363 * $r->{push,set,get}_handlers, $s->{push,set,get}_handlers
364 * $s->push/set at startup time are the same as configuring Perl*Handlers
365 * $r->push/set at request time will create entries in r->request_config
366 * push will first merge with configured handlers, unless an entry
367 * in r->request_config already exists. in this case, push or set has
368 * already been called for the given handler,
369 * r->request_config entries then override those in r->per_dir_config
370 */
371
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)372 MpAV **modperl_handler_lookup_handlers(modperl_config_dir_t *dcfg,
373 modperl_config_srv_t *scfg,
374 modperl_config_req_t *rcfg,
375 apr_pool_t *p,
376 int type, int idx,
377 modperl_handler_action_e action,
378 const char **desc)
379 {
380 MpAV **avp = NULL, **ravp = NULL;
381
382 switch (type) {
383 case MP_HANDLER_TYPE_PER_DIR:
384 avp = &dcfg->handlers_per_dir[idx];
385 if (rcfg) {
386 ravp = &rcfg->handlers_per_dir[idx];
387 }
388 set_desc(per_dir);
389 break;
390 case MP_HANDLER_TYPE_PER_SRV:
391 avp = &scfg->handlers_per_srv[idx];
392 if (rcfg) {
393 ravp = &rcfg->handlers_per_srv[idx];
394 }
395 set_desc(per_srv);
396 break;
397 case MP_HANDLER_TYPE_PRE_CONNECTION:
398 avp = &scfg->handlers_pre_connection[idx];
399 check_modify(pre_connection);
400 set_desc(pre_connection);
401 break;
402 case MP_HANDLER_TYPE_CONNECTION:
403 avp = &scfg->handlers_connection[idx];
404 check_modify(connection);
405 set_desc(connection);
406 break;
407 case MP_HANDLER_TYPE_FILES:
408 avp = &scfg->handlers_files[idx];
409 check_modify(files);
410 set_desc(files);
411 break;
412 case MP_HANDLER_TYPE_PROCESS:
413 avp = &scfg->handlers_process[idx];
414 check_modify(files);
415 set_desc(process);
416 break;
417 };
418
419 if (!avp) {
420 /* should never happen */
421 #if 0
422 fprintf(stderr, "PANIC: no such handler type: %d\n", type);
423 #endif
424 return NULL;
425 }
426
427 switch (action) {
428 case MP_HANDLER_ACTION_GET:
429 /* just a lookup */
430 break;
431 case MP_HANDLER_ACTION_PUSH:
432 if (ravp) {
433 if (!*ravp) {
434 if (*avp) {
435 /* merge with existing configured handlers */
436 *ravp = apr_array_copy(p, *avp);
437 }
438 else {
439 /* no request handlers have been previously pushed or set */
440 *ravp = modperl_handler_array_new(p);
441 }
442 }
443 }
444 else if (!*avp) {
445 /* directly modify the configuration at startup time */
446 *avp = modperl_handler_array_new(p);
447 }
448 break;
449 case MP_HANDLER_ACTION_SET:
450 if (ravp) {
451 if (*ravp) {
452 /* wipe out existing pushed/set request handlers */
453 (*ravp)->nelts = 0;
454 }
455 else {
456 /* no request handlers have been previously pushed or set */
457 *ravp = modperl_handler_array_new(p);
458 }
459 }
460 else if (*avp) {
461 /* wipe out existing configuration, only at startup time */
462 (*avp)->nelts = 0;
463 }
464 else {
465 /* no configured handlers for this phase */
466 *avp = modperl_handler_array_new(p);
467 }
468 break;
469 }
470
471 return (ravp && *ravp) ? ravp : avp;
472 }
473
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)474 MpAV **modperl_handler_get_handlers(request_rec *r, conn_rec *c, server_rec *s,
475 apr_pool_t *p, const char *name,
476 modperl_handler_action_e action)
477 {
478 MP_dSCFG(s);
479 MP_dDCFG;
480 MP_dRCFG;
481
482 int idx, type;
483
484 if (!r) {
485 /* so $s->{push,set}_handlers can configured request-time handlers */
486 dcfg = modperl_config_dir_get_defaults(s);
487 }
488
489 if ((idx = modperl_handler_lookup(name, &type)) == DECLINED) {
490 return FALSE;
491 }
492
493 return modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p,
494 type, idx,
495 action, NULL);
496 }
497
modperl_handler_new_from_sv(pTHX_ apr_pool_t * p,SV * sv)498 modperl_handler_t *modperl_handler_new_from_sv(pTHX_ apr_pool_t *p, SV *sv)
499 {
500 char *name = NULL;
501 GV *gv;
502
503 if (SvROK(sv)) {
504 sv = SvRV(sv);
505 }
506
507 switch (SvTYPE(sv)) {
508 case SVt_PV:
509 name = SvPVX(sv);
510 return modperl_handler_new(p, apr_pstrdup(p, name));
511 break;
512 case SVt_PVCV:
513 if (CvANON((CV*)sv)) {
514 return modperl_handler_new_anon(aTHX_ p, (CV*)sv);
515 }
516 if (!(gv = CvGV((CV*)sv))) {
517 Perl_croak(aTHX_ "can't resolve the code reference");
518 }
519 name = apr_pstrcat(p, HvNAME(GvSTASH(gv)), "::", GvNAME(gv), NULL);
520 return modperl_handler_new(p, name);
521 default:
522 break;
523 };
524
525 return NULL;
526 }
527
modperl_handler_push_handlers(pTHX_ apr_pool_t * p,MpAV * handlers,SV * sv)528 int modperl_handler_push_handlers(pTHX_ apr_pool_t *p,
529 MpAV *handlers, SV *sv)
530 {
531 modperl_handler_t *handler = modperl_handler_new_from_sv(aTHX_ p, sv);
532
533 if (handler) {
534 modperl_handler_array_push(handlers, handler);
535 return TRUE;
536 }
537
538 MP_TRACE_h(MP_FUNC, "unable to push_handler 0x%lx",
539 (unsigned long)sv);
540
541 return FALSE;
542 }
543
544 /* convert array header of modperl_handlers_t's to AV ref of CV refs */
modperl_handler_perl_get_handlers(pTHX_ MpAV ** handp,apr_pool_t * p)545 SV *modperl_handler_perl_get_handlers(pTHX_ MpAV **handp, apr_pool_t *p)
546 {
547 AV *av = newAV();
548 int i;
549 modperl_handler_t **handlers;
550
551 if (!(handp && *handp)) {
552 return &PL_sv_undef;
553 }
554
555 av_extend(av, (*handp)->nelts - 1);
556
557 handlers = (modperl_handler_t **)(*handp)->elts;
558
559 for (i=0; i<(*handp)->nelts; i++) {
560 modperl_handler_t *handler = NULL;
561 GV *gv;
562
563 if (MpHandlerPARSED(handlers[i])) {
564 handler = handlers[i];
565 }
566 else {
567 #ifdef USE_ITHREADS
568 if (!MpHandlerDYNAMIC(handlers[i])) {
569 handler = modperl_handler_dup(p, handlers[i]);
570 }
571 #endif
572 if (!handler) {
573 handler = handlers[i];
574 }
575
576 if (!modperl_mgv_resolve(aTHX_ handler, p, handler->name, TRUE)) {
577 MP_TRACE_h(MP_FUNC, "failed to resolve handler %s",
578 handler->name);
579 }
580
581 }
582
583 if (handler->mgv_cv) {
584 if ((gv = modperl_mgv_lookup(aTHX_ handler->mgv_cv))) {
585 CV *cv = modperl_mgv_cv(gv);
586 av_push(av, newRV_inc((SV*)cv));
587 }
588 }
589 else {
590 av_push(av, newSVpv(handler->name, 0));
591 }
592 }
593
594 return newRV_noinc((SV*)av);
595 }
596
597 #define push_sv_handler \
598 if ((modperl_handler_push_handlers(aTHX_ p, *handlers, sv))) { \
599 MpHandlerDYNAMIC_On(modperl_handler_array_last(*handlers)); \
600 }
601
602 /* allow push/set of single cv ref or array ref of cv refs */
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)603 int modperl_handler_perl_add_handlers(pTHX_
604 request_rec *r,
605 conn_rec *c,
606 server_rec *s,
607 apr_pool_t *p,
608 const char *name,
609 SV *sv,
610 modperl_handler_action_e action)
611 {
612 I32 i;
613 AV *av = (AV *)NULL;
614 MpAV **handlers =
615 modperl_handler_get_handlers(r, c, s,
616 p, name, action);
617
618 if (!(handlers && *handlers)) {
619 return FALSE;
620 }
621
622 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV)) {
623 av = (AV*)SvRV(sv);
624
625 for (i=0; i <= AvFILL(av); i++) {
626 sv = *av_fetch(av, i, FALSE);
627 push_sv_handler;
628 }
629 }
630 else {
631 push_sv_handler;
632 }
633
634 return TRUE;
635 }
636
637 /*
638 * Local Variables:
639 * c-basic-offset: 4
640 * indent-tabs-mode: nil
641 * End:
642 */
643