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
19 /*
20 * XXX: this is not the most efficent interpreter pool implementation
21 * but it will do for proof-of-concept
22 */
23
24 #ifdef USE_ITHREADS
25
modperl_interp_clone_init(modperl_interp_t * interp)26 void modperl_interp_clone_init(modperl_interp_t *interp)
27 {
28 dTHXa(interp->perl);
29
30 MpInterpCLONED_On(interp);
31
32 MP_ASSERT_CONTEXT(aTHX);
33
34 /* clear @DynaLoader::dl_librefs so we only dlclose() those
35 * which are opened by the clone
36 */
37 modperl_xs_dl_handles_clear(aTHX);
38 }
39
modperl_interp_new(modperl_interp_pool_t * mip,PerlInterpreter * perl)40 modperl_interp_t *modperl_interp_new(modperl_interp_pool_t *mip,
41 PerlInterpreter *perl)
42 {
43 UV clone_flags = CLONEf_KEEP_PTR_TABLE;
44 modperl_interp_t *interp =
45 (modperl_interp_t *)malloc(sizeof(*interp));
46
47 memset(interp, '\0', sizeof(*interp));
48
49 interp->mip = mip;
50 interp->refcnt = 0;
51
52 if (perl) {
53 #ifdef MP_USE_GTOP
54 MP_dSCFG(mip->server);
55 MP_TRACE_m_do(
56 modperl_gtop_do_proc_mem_before(MP_FUNC, "perl_clone");
57 );
58 #endif
59
60 #if defined(WIN32) && defined(CLONEf_CLONE_HOST)
61 clone_flags |= CLONEf_CLONE_HOST;
62 #endif
63
64 PERL_SET_CONTEXT(perl);
65
66 interp->perl = perl_clone(perl, clone_flags);
67
68 MP_ASSERT_CONTEXT(interp->perl);
69
70 {
71 PTR_TBL_t *source = modperl_module_config_table_get(perl, FALSE);
72 if (source) {
73 PTR_TBL_t *table = modperl_svptr_table_clone(interp->perl,
74 perl,
75 source);
76
77 modperl_module_config_table_set(interp->perl, table);
78 }
79 }
80
81 /*
82 * we keep the PL_ptr_table past perl_clone so it can be used
83 * within modperl_svptr_table_clone. Perl_sv_dup() uses it.
84 * Don't confuse our svptr_table with Perl's ptr_table. They
85 * are different things, although they use the same type.
86 */
87 if ((clone_flags & CLONEf_KEEP_PTR_TABLE)) {
88 dTHXa(interp->perl);
89 ptr_table_free(PL_ptr_table);
90 PL_ptr_table = NULL;
91 }
92
93 modperl_interp_clone_init(interp);
94
95 PERL_SET_CONTEXT(perl);
96
97 #ifdef MP_USE_GTOP
98 MP_TRACE_m_do(
99 modperl_gtop_do_proc_mem_after(MP_FUNC, "perl_clone");
100 );
101 #endif
102 }
103
104 MP_TRACE_i(MP_FUNC, "0x%lx / perl: 0x%lx / parent perl: 0x%lx",
105 (unsigned long)interp, (unsigned long)interp->perl,
106 (unsigned long)perl);
107
108 return interp;
109 }
110
modperl_interp_destroy(modperl_interp_t * interp)111 void modperl_interp_destroy(modperl_interp_t *interp)
112 {
113 void **handles;
114 dTHXa(interp->perl);
115
116 PERL_SET_CONTEXT(interp->perl);
117
118 MP_TRACE_i(MP_FUNC, "interp == 0x%lx / perl: 0x%lx",
119 (unsigned long)interp, (unsigned long)interp->perl);
120
121 if (MpInterpIN_USE(interp)) {
122 MP_TRACE_i(MP_FUNC, "*error - still in use!*");
123 }
124
125 handles = modperl_xs_dl_handles_get(aTHX);
126
127 modperl_perl_destruct(interp->perl);
128
129 modperl_xs_dl_handles_close(handles);
130
131 free(interp);
132 }
133
modperl_interp_cleanup(void * data)134 apr_status_t modperl_interp_cleanup(void *data)
135 {
136 modperl_interp_destroy((modperl_interp_t *)data);
137 return APR_SUCCESS;
138 }
139
modperl_interp_get(server_rec * s)140 modperl_interp_t *modperl_interp_get(server_rec *s)
141 {
142 MP_dSCFG(s);
143 modperl_interp_t *interp = NULL;
144 modperl_interp_pool_t *mip = scfg->mip;
145 modperl_list_t *head;
146
147 head = modperl_tipool_pop(mip->tipool);
148 interp = (modperl_interp_t *)head->data;
149
150 MP_TRACE_i(MP_FUNC, "head == 0x%lx, parent == 0x%lx",
151 (unsigned long)head, (unsigned long)mip->parent);
152
153 MP_TRACE_i(MP_FUNC, "selected 0x%lx (perl==0x%lx)",
154 (unsigned long)interp,
155 (unsigned long)interp->perl);
156
157 #ifdef MP_TRACE
158 interp->tid = MP_TIDF;
159 MP_TRACE_i(MP_FUNC, "thread == 0x%lx", interp->tid);
160 #endif
161
162 MpInterpIN_USE_On(interp);
163
164 return interp;
165 }
166
modperl_interp_pool_destroy(void * data)167 apr_status_t modperl_interp_pool_destroy(void *data)
168 {
169 modperl_interp_pool_t *mip = (modperl_interp_pool_t *)data;
170
171 if (mip->tipool) {
172 modperl_tipool_destroy(mip->tipool);
173 mip->tipool = NULL;
174 }
175
176 if (MpInterpBASE(mip->parent)) {
177 /* multiple mips might share the same parent
178 * make sure its only destroyed once
179 */
180 MP_TRACE_i(MP_FUNC, "parent == 0x%lx",
181 (unsigned long)mip->parent);
182
183 modperl_interp_destroy(mip->parent);
184 }
185
186 return APR_SUCCESS;
187 }
188
interp_pool_grow(modperl_tipool_t * tipool,void * data)189 static void *interp_pool_grow(modperl_tipool_t *tipool, void *data)
190 {
191 modperl_interp_pool_t *mip = (modperl_interp_pool_t *)data;
192 MP_TRACE_i(MP_FUNC, "adding new interpreter to the pool");
193 return (void *)modperl_interp_new(mip, mip->parent->perl);
194 }
195
interp_pool_shrink(modperl_tipool_t * tipool,void * data,void * item)196 static void interp_pool_shrink(modperl_tipool_t *tipool, void *data,
197 void *item)
198 {
199 modperl_interp_destroy((modperl_interp_t *)item);
200 }
201
interp_pool_dump(modperl_tipool_t * tipool,void * data,modperl_list_t * listp)202 static void interp_pool_dump(modperl_tipool_t *tipool, void *data,
203 modperl_list_t *listp)
204 {
205 while (listp) {
206 modperl_interp_t *interp = (modperl_interp_t *)listp->data;
207 MP_TRACE_i(MP_FUNC, "listp==0x%lx, interp==0x%lx, requests=%d",
208 (unsigned long)listp, (unsigned long)interp,
209 interp->num_requests);
210 listp = listp->next;
211 }
212 }
213
214 static modperl_tipool_vtbl_t interp_pool_func = {
215 interp_pool_grow,
216 interp_pool_grow,
217 interp_pool_shrink,
218 interp_pool_shrink,
219 interp_pool_dump,
220 };
221
modperl_interp_init(server_rec * s,apr_pool_t * p,PerlInterpreter * perl)222 void modperl_interp_init(server_rec *s, apr_pool_t *p,
223 PerlInterpreter *perl)
224 {
225 apr_pool_t *server_pool = modperl_server_pool();
226 pTHX;
227 MP_dSCFG(s);
228 modperl_interp_pool_t *mip =
229 (modperl_interp_pool_t *)apr_pcalloc(p, sizeof(*mip));
230
231 MP_TRACE_i(MP_FUNC, "server=%s", modperl_server_desc(s, p));
232
233 if (modperl_threaded_mpm()) {
234 mip->tipool = modperl_tipool_new(p, scfg->interp_pool_cfg,
235 &interp_pool_func, mip);
236 }
237
238 mip->server = s;
239 mip->parent = modperl_interp_new(mip, NULL);
240 aTHX = mip->parent->perl = perl;
241
242 /* this happens post-config in mod_perl.c:modperl_init_clones() */
243 /* modperl_tipool_init(tipool); */
244
245 apr_pool_cleanup_register(server_pool, (void*)mip,
246 modperl_interp_pool_destroy,
247 apr_pool_cleanup_null);
248
249 scfg->mip = mip;
250 }
251
modperl_interp_unselect(void * data)252 apr_status_t modperl_interp_unselect(void *data)
253 {
254 modperl_interp_t *interp = (modperl_interp_t *)data;
255 modperl_interp_pool_t *mip = interp->mip;
256
257 MP_ASSERT(interp && MpInterpIN_USE(interp) && interp->refcnt > 0);
258 MP_TRACE_i(MP_FUNC, "unselect(interp=%pp): refcnt=%d",
259 interp, interp->refcnt);
260
261 --interp->refcnt;
262
263 if (interp->refcnt > 0) {
264 MP_TRACE_i(MP_FUNC, "interp=0x%lx, refcnt=%d -- interp still in use",
265 (unsigned long)interp, interp->refcnt);
266 return APR_SUCCESS;
267 }
268
269 if (!MpInterpIN_USE(interp)){
270 MP_TRACE_i(MP_FUNC, "interp=0x%pp, refcnt=%d -- interp already not in use",
271 interp, interp->refcnt);
272 return APR_SUCCESS;
273 }
274
275 MpInterpIN_USE_Off(interp);
276
277 modperl_thx_interp_set(interp->perl, NULL);
278 #ifdef MP_DEBUG
279 PERL_SET_CONTEXT(NULL);
280 #endif
281
282 if (interp == mip->parent) {
283 MP_TRACE_i(MP_FUNC, "parent interp=%pp freed", interp);
284 }
285 else {
286 interp->ccfg->interp = NULL;
287 modperl_tipool_putback_data(mip->tipool, data, interp->num_requests);
288 MP_TRACE_i(MP_FUNC, "interp=%pp freed, tipool(size=%ld, in_use=%ld)",
289 interp, mip->tipool->size, mip->tipool->in_use);
290 }
291
292 return APR_SUCCESS;
293 }
294
295 /* XXX:
296 * interp is marked as in_use for the scope of the pool it is
297 * stashed in. this is done to avoid the tipool->tlock whenever
298 * possible. neither approach is ideal.
299 */
300 #define MP_INTERP_KEY "MODPERL_INTERP"
301
302 #define get_interp(p) \
303 (void)apr_pool_userdata_get((void **)&interp, MP_INTERP_KEY, p)
304
305 #define set_interp(p) \
306 (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY, \
307 modperl_interp_unselect, \
308 p)
309
modperl_interp_pool_get(apr_pool_t * p)310 modperl_interp_t *modperl_interp_pool_get(apr_pool_t *p)
311 {
312 modperl_interp_t *interp = NULL;
313 get_interp(p);
314 return interp;
315 }
316
modperl_interp_pool_set(apr_pool_t * p,modperl_interp_t * interp)317 void modperl_interp_pool_set(apr_pool_t *p,
318 modperl_interp_t *interp)
319 {
320 (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY, NULL, p);
321 }
322
323 /*
324 * used in the case where we don't have a request_rec or conn_rec,
325 * such as for directive handlers per-{dir,srv} create and merge.
326 * "request time pool" is most likely a request_rec->pool.
327 */
modperl_interp_pool_select(apr_pool_t * p,server_rec * s)328 modperl_interp_t *modperl_interp_pool_select(apr_pool_t *p,
329 server_rec *s)
330 {
331 int is_startup = (p == s->process->pconf);
332 modperl_interp_t *interp = NULL;
333
334 if (is_startup) {
335 MP_dSCFG(s);
336 if (scfg) {
337 MP_TRACE_i(MP_FUNC, "using parent interpreter at startup");
338
339 if (!scfg->mip) {
340 /* we get here if directive handlers are invoked
341 * before server merge.
342 */
343 modperl_init_vhost(s, p, NULL);
344 if (!scfg->mip) {
345 /* FIXME: We get here if global "server_rec" == s, scfg->mip
346 * is not created then. I'm not sure if that's bug or
347 * bad/good design decicision. For now just return NULL.
348 */
349 return NULL;
350 }
351 }
352
353 interp = scfg->mip->parent;
354 }
355 else {
356 if (!(interp = modperl_interp_pool_get(p))) {
357 interp = modperl_interp_get(s);
358 modperl_interp_pool_set(p, interp);
359
360 MP_TRACE_i(MP_FUNC, "set interp %pp in pconf pool %pp",
361 interp, p);
362 }
363 else {
364 MP_TRACE_i(MP_FUNC, "found interp %pp in pconf pool %pp",
365 interp, p);
366 }
367 }
368
369 MpInterpIN_USE_On(interp);
370 interp->refcnt++;
371 /* set context (THX) for this thread */
372 PERL_SET_CONTEXT(interp->perl);
373 /* let the perl interpreter point back to its interp */
374 modperl_thx_interp_set(interp->perl, interp);
375
376 return interp;
377 }
378 else {
379 request_rec *r;
380 apr_pool_userdata_get((void **)&r, "MODPERL_R", p);
381 MP_ASSERT(r);
382 MP_TRACE_i(MP_FUNC, "found userdata MODPERL_R in pool %#lx as %lx",
383 (unsigned long)r->pool, (unsigned long)r);
384 return modperl_interp_select(r, NULL, NULL);
385 }
386 }
387
modperl_interp_select(request_rec * r,conn_rec * c,server_rec * s)388 modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c,
389 server_rec *s)
390 {
391 MP_dSCFG((r ? s=r->server : c ? s=c->base_server : s));
392 MP_dDCFG;
393 modperl_config_con_t *ccfg;
394 const char *desc = NULL;
395 modperl_interp_t *interp = NULL;
396 apr_pool_t *p = NULL;
397
398 /* What does the following condition mean?
399 * (r || c): if true we are at runtime. There is some kind of request
400 * being processed.
401 * threaded_mpm: self-explanatory
402 *
403 * Thus, it is true if we are either at initialization time or at runtime
404 * but with prefork-MPM. */
405 if (!((r || c) && modperl_threaded_mpm())) {
406 interp = scfg->mip->parent;
407 MpInterpIN_USE_On(interp);
408 interp->refcnt++;
409 /* XXX: if no VirtualHosts w/ PerlOptions +Parent we can skip this */
410 PERL_SET_CONTEXT(interp->perl);
411 /* let the perl interpreter point back to its interp */
412 modperl_thx_interp_set(interp->perl, interp);
413
414 MP_TRACE_i(MP_FUNC,
415 "using parent 0x%pp (perl=0x%pp) for %s:%d refcnt set to %d",
416 interp, interp->perl, s->server_hostname, s->port,
417 interp->refcnt);
418 return interp;
419 }
420
421 if(!c) c = r->connection;
422 ccfg = modperl_config_con_get(c);
423
424 if (ccfg && ccfg->interp) {
425 ccfg->interp->refcnt++;
426
427 MP_TRACE_i(MP_FUNC,
428 "found interp 0x%lx in con config, refcnt incremented to %d",
429 (unsigned long)ccfg->interp, ccfg->interp->refcnt);
430 /* set context (THX) for this thread */
431 PERL_SET_CONTEXT(ccfg->interp->perl);
432 /* modperl_thx_interp_set() is not called here because the interp
433 * already belongs to the perl interpreter
434 */
435 return ccfg->interp;
436 }
437
438 MP_TRACE_i(MP_FUNC,
439 "fetching interp for %s:%d", s->server_hostname, s->port);
440 interp = modperl_interp_get(s);
441 MP_TRACE_i(MP_FUNC, " --> got %pp (perl=%pp)", interp, interp->perl);
442 ++interp->num_requests; /* should only get here once per request */
443 interp->refcnt = 1;
444
445 /* set context (THX) for this thread */
446 PERL_SET_CONTEXT(interp->perl);
447 /* let the perl interpreter point back to its interp */
448 modperl_thx_interp_set(interp->perl, interp);
449
450 /* make sure ccfg is initialized */
451 modperl_config_con_init(c, ccfg);
452 ccfg->interp = interp;
453 interp->ccfg = ccfg;
454
455 MP_TRACE_i(MP_FUNC,
456 "pulled interp %pp (perl=%pp) from mip, num_requests is %d",
457 interp, interp->perl, interp->num_requests);
458
459 return interp;
460 }
461
462 /* currently up to the caller if mip needs locking */
modperl_interp_mip_walk(PerlInterpreter * current_perl,PerlInterpreter * parent_perl,modperl_interp_pool_t * mip,modperl_interp_mip_walker_t walker,void * data)463 void modperl_interp_mip_walk(PerlInterpreter *current_perl,
464 PerlInterpreter *parent_perl,
465 modperl_interp_pool_t *mip,
466 modperl_interp_mip_walker_t walker,
467 void *data)
468 {
469 modperl_list_t *head = mip->tipool ? mip->tipool->idle : NULL;
470
471 if (!current_perl) {
472 current_perl = PERL_GET_CONTEXT;
473 }
474
475 if (parent_perl) {
476 PERL_SET_CONTEXT(parent_perl);
477 walker(parent_perl, mip, data);
478 }
479
480 while (head) {
481 PerlInterpreter *perl = ((modperl_interp_t *)head->data)->perl;
482 PERL_SET_CONTEXT(perl);
483 walker(perl, mip, data);
484 head = head->next;
485 }
486
487 PERL_SET_CONTEXT(current_perl);
488 }
489
modperl_interp_mip_walk_servers(PerlInterpreter * current_perl,server_rec * base_server,modperl_interp_mip_walker_t walker,void * data)490 void modperl_interp_mip_walk_servers(PerlInterpreter *current_perl,
491 server_rec *base_server,
492 modperl_interp_mip_walker_t walker,
493 void *data)
494 {
495 server_rec *s = base_server->next;
496 modperl_config_srv_t *base_scfg = modperl_config_srv_get(base_server);
497 PerlInterpreter *base_perl = base_scfg->mip->parent->perl;
498
499 modperl_interp_mip_walk(current_perl, base_perl,
500 base_scfg->mip, walker, data);
501
502 while (s) {
503 MP_dSCFG(s);
504 PerlInterpreter *perl = scfg->mip->parent->perl;
505 modperl_interp_pool_t *mip = scfg->mip;
506
507 /* skip vhosts who share parent perl */
508 if (perl == base_perl) {
509 perl = NULL;
510 }
511
512 /* skip vhosts who share parent mip */
513 if (scfg->mip == base_scfg->mip) {
514 mip = NULL;
515 }
516
517 if (perl || mip) {
518 modperl_interp_mip_walk(current_perl, perl,
519 mip, walker, data);
520 }
521
522 s = s->next;
523 }
524 }
525
526 #define MP_THX_INTERP_KEY "modperl2::thx_interp_key"
modperl_thx_interp_get(pTHX)527 modperl_interp_t *modperl_thx_interp_get(pTHX)
528 {
529 modperl_interp_t *interp;
530 SV **svp = hv_fetch(PL_modglobal, MP_THX_INTERP_KEY,
531 strlen(MP_THX_INTERP_KEY), 0);
532 if (!svp) return NULL;
533 interp = INT2PTR(modperl_interp_t *, SvIV(*svp));
534 return interp;
535 }
536
modperl_thx_interp_set(pTHX_ modperl_interp_t * interp)537 void modperl_thx_interp_set(pTHX_ modperl_interp_t *interp)
538 {
539 (void)hv_store(PL_modglobal, MP_THX_INTERP_KEY, strlen(MP_THX_INTERP_KEY),
540 newSViv(PTR2IV(interp)), 0);
541 return;
542 }
543
544 #else
545
modperl_interp_init(server_rec * s,apr_pool_t * p,PerlInterpreter * perl)546 void modperl_interp_init(server_rec *s, apr_pool_t *p,
547 PerlInterpreter *perl)
548 {
549 MP_dSCFG(s);
550 scfg->perl = perl;
551 }
552
modperl_interp_cleanup(void * data)553 apr_status_t modperl_interp_cleanup(void *data)
554 {
555 return APR_SUCCESS;
556 }
557
558 #endif /* USE_ITHREADS */
559
560 /*
561 * Local Variables:
562 * c-basic-offset: 4
563 * indent-tabs-mode: nil
564 * End:
565 */
566