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