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  * mgv = ModPerl Glob Value || Mostly Glob Value
21  * as close to GV as we can get without actually using a GV
22  * need config structures to be free of Perl structures
23  */
24 
25 #define modperl_mgv_new_w_name(mgv, p, n, copy)         \
26     mgv = modperl_mgv_new(p);                           \
27     mgv->len = strlen(n);                               \
28     mgv->name = (copy ? apr_pstrndup(p, n, mgv->len) : n)
29 
30 #define modperl_mgv_new_name(mgv, p, n)         \
31     modperl_mgv_new_w_name(mgv, p, n, 1)
32 
33 #define modperl_mgv_new_namen(mgv, p, n)        \
34     modperl_mgv_new_w_name(mgv, p, n, 0)
35 
modperl_mgv_equal(modperl_mgv_t * mgv1,modperl_mgv_t * mgv2)36 int modperl_mgv_equal(modperl_mgv_t *mgv1,
37                       modperl_mgv_t *mgv2)
38 {
39     for (; mgv1 && mgv2; mgv1=mgv1->next, mgv2=mgv2->next) {
40         if (mgv1->hash != mgv2->hash) {
41             return FALSE;
42         }
43         if (mgv1->len != mgv2->len) {
44             return FALSE;
45         }
46         if (memNE(mgv1->name, mgv2->name, mgv1->len)) {
47             return FALSE;
48         }
49     }
50 
51     return TRUE;
52 }
53 
modperl_mgv_new(apr_pool_t * p)54 modperl_mgv_t *modperl_mgv_new(apr_pool_t *p)
55 {
56     return (modperl_mgv_t *)apr_pcalloc(p, sizeof(modperl_mgv_t));
57 }
58 
59 #define modperl_mgv_get_next(mgv)               \
60     if (mgv->name) {                            \
61         mgv->next = modperl_mgv_new(p);         \
62         mgv = mgv->next;                        \
63     }
64 
65 #define modperl_mgv_hash(mgv)                   \
66     PERL_HASH(mgv->hash, mgv->name, mgv->len)
67  /* MP_TRACE_h(MP_FUNC, "%s...hash=%ld", mgv->name, mgv->hash) */
68 
modperl_mgv_compile(pTHX_ apr_pool_t * p,register const char * name)69 modperl_mgv_t *modperl_mgv_compile(pTHX_ apr_pool_t *p,
70                                    register const char *name)
71 {
72     register const char *namend;
73     I32 len;
74     modperl_mgv_t *symbol = modperl_mgv_new(p);
75     modperl_mgv_t *mgv = symbol;
76 
77     /* @mgv = split '::', $name */
78     for (namend = name; *namend; namend++) {
79         if (*namend == ':' && namend[1] == ':') {
80             if ((len = (namend - name)) > 0) {
81                 modperl_mgv_get_next(mgv);
82                 mgv->name = apr_palloc(p, len+3);
83                 Copy(name, mgv->name, len, char);
84                 mgv->name[len++] = ':';
85                 mgv->name[len++] = ':';
86                 mgv->name[len] = '\0';
87                 mgv->len = len;
88                 modperl_mgv_hash(mgv);
89             }
90             name = namend + 2;
91         }
92     }
93 
94     modperl_mgv_get_next(mgv);
95 
96     mgv->len = namend - name;
97     mgv->name = apr_pstrndup(p, name, mgv->len);
98     modperl_mgv_hash(mgv);
99 
100     return symbol;
101 }
102 
modperl_mgv_append(pTHX_ apr_pool_t * p,modperl_mgv_t * symbol,const char * name)103 void modperl_mgv_append(pTHX_ apr_pool_t *p, modperl_mgv_t *symbol,
104                         const char *name)
105 {
106     modperl_mgv_t *mgv = symbol;
107 
108     while (mgv->next) {
109         mgv = mgv->next;
110     }
111 
112     mgv->name = apr_pstrcat(p, mgv->name, "::", NULL);
113     mgv->len += 2;
114     modperl_mgv_hash(mgv);
115 
116     mgv->next = modperl_mgv_compile(aTHX_ p, name);
117 }
118 
119 /* faster replacement for gv_fetchpv() */
modperl_mgv_lookup(pTHX_ modperl_mgv_t * symbol)120 GV *modperl_mgv_lookup(pTHX_ modperl_mgv_t *symbol)
121 {
122     HV *stash = PL_defstash;
123     modperl_mgv_t *mgv;
124 
125     if (!symbol->hash) {
126         /* special case for MyClass->handler */
127         return (GV*)sv_2mortal(newSVpvn(symbol->name, symbol->len));
128     }
129 
130     for (mgv = symbol; mgv; mgv = mgv->next) {
131         HE *he = hv_fetch_he(stash, mgv->name, mgv->len, mgv->hash);
132         if (he) {
133             if (mgv->next) {
134                 stash = GvHV((GV *)HeVAL(he));
135             }
136             else {
137                 return (GV *)HeVAL(he);
138             }
139         }
140         else {
141             return (GV *)NULL;
142         }
143     }
144 
145     return (GV *)NULL;
146 }
147 
148 #ifdef USE_ITHREADS
modperl_mgv_lookup_autoload(pTHX_ modperl_mgv_t * symbol,server_rec * s,apr_pool_t * p)149 MP_INLINE GV *modperl_mgv_lookup_autoload(pTHX_ modperl_mgv_t *symbol,
150                                           server_rec *s, apr_pool_t *p)
151 {
152     MP_dSCFG(s);
153     GV *gv = modperl_mgv_lookup(aTHX_ symbol);
154 
155     if (gv || !MpSrvPARENT(scfg)) {
156         return gv;
157     }
158 
159     /*
160      * this VirtualHost has its own parent interpreter
161      * must require the module again with this server's THX
162      */
163     modperl_mgv_require_module(aTHX_ symbol, s, p);
164 
165     return modperl_mgv_lookup(aTHX_ symbol);
166 }
167 #else
modperl_mgv_lookup_autoload(pTHX_ modperl_mgv_t * symbol,server_rec * s,apr_pool_t * p)168 MP_INLINE GV *modperl_mgv_lookup_autoload(pTHX_ modperl_mgv_t *symbol,
169                                           server_rec *s, apr_pool_t *p)
170 {
171     return modperl_mgv_lookup(aTHX_ symbol);
172 }
173 #endif
174 
175 /* currently used for complex filters attributes parsing */
176 /* XXX: may want to generalize it for any handlers */
177 #define MODPERL_MGV_DEEP_RESOLVE(handler, p)                   \
178     if (handler->attrs & MP_FILTER_HAS_INIT_HANDLER) {         \
179         modperl_filter_resolve_init_handler(aTHX_ handler, p); \
180     }
181 
modperl_mgv_resolve(pTHX_ modperl_handler_t * handler,apr_pool_t * p,const char * name,int logfailure)182 int modperl_mgv_resolve(pTHX_ modperl_handler_t *handler,
183                         apr_pool_t *p, const char *name, int logfailure)
184 {
185     CV *cv;
186     GV *gv;
187     HV *stash = (HV *)NULL;
188     char *handler_name = "handler";
189     char *tmp;
190 
191     if (MpHandlerANON(handler)) {
192         /* already resolved anonymous handler */
193         return 1;
194     }
195 
196     if (strnEQ(name, "sub ", 4)) {
197         SV *sv;
198         CV *cv;
199         MpHandlerPARSED_On(handler);
200         MpHandlerANON_On(handler);
201 
202         ENTER;SAVETMPS;
203         sv = eval_pv(name, TRUE);
204         if (!(SvROK(sv) && (cv = (CV*)SvRV(sv)) && (CvFLAGS(cv) & CVf_ANON))) {
205 
206             Perl_croak(aTHX_ "expected anonymous sub, got '%s'\n", name);
207         }
208 
209 #ifdef USE_ITHREADS
210         handler->cv      = NULL;
211         handler->name    = NULL;
212         handler->mgv_obj = modperl_handler_anon_next(aTHX_ p);
213         modperl_handler_anon_add(aTHX_ handler->mgv_obj, cv);
214         MP_TRACE_h(MP_FUNC, "new anon handler");
215 #else
216         SvREFCNT_inc(cv);
217         handler->cv      = cv;
218         handler->name    = NULL;
219         MP_TRACE_h(MP_FUNC, "new cached-cv anon handler");
220 #endif
221 
222         FREETMPS;LEAVE;
223 
224         return 1;
225     }
226 
227     if ((tmp = strstr((char *)name, "->"))) {
228         int package_len = strlen(name) - strlen(tmp);
229         char *package = apr_pstrndup(p, name, package_len);
230 
231         name = package;
232         handler_name = &tmp[2];
233 
234         MpHandlerMETHOD_On(handler);
235 
236         if (*package == '$') {
237             GV *gv;
238             SV *obj;
239 
240             handler->mgv_obj = modperl_mgv_compile(aTHX_ p, package + 1);
241             gv = modperl_mgv_lookup(aTHX_ handler->mgv_obj);
242             obj = gv ? GvSV(gv) : (SV *)NULL;
243 
244             if (SvTRUE(obj)) {
245                 if (SvROK(obj) && sv_isobject(obj)) {
246                     stash = SvSTASH(SvRV(obj));
247                     MpHandlerOBJECT_On(handler);
248                     MP_TRACE_h(MP_FUNC, "handler object %s isa %s",
249                                package, HvNAME(stash));
250                 }
251                 else {
252                     MP_TRACE_h(MP_FUNC, "%s is not an object, pv=%s",
253                                package, SvPV_nolen(obj));
254                     return 0;
255                 }
256             }
257             else {
258                 MP_TRACE_h(MP_FUNC, "failed to thaw %s", package);
259                 return 0;
260             }
261         }
262 
263         if (!stash) {
264             if ((stash = gv_stashpvn(package, package_len, FALSE))) {
265                 MP_TRACE_h(MP_FUNC, "handler method %s isa %s",
266                            name, HvNAME(stash));
267             }
268         }
269     }
270     else {
271         if ((cv = get_cv(name, FALSE))) {
272             handler->attrs = *modperl_code_attrs(aTHX_ cv);
273             handler->mgv_cv =
274                 modperl_mgv_compile(aTHX_ p, HvNAME(GvSTASH(CvGV(cv))));
275             modperl_mgv_append(aTHX_ p, handler->mgv_cv, GvNAME(CvGV(cv)));
276             MpHandlerPARSED_On(handler);
277             MODPERL_MGV_DEEP_RESOLVE(handler, p);
278             return 1;
279         }
280     }
281 
282     if (!stash && MpHandlerAUTOLOAD(handler)) {
283         if (!modperl_perl_module_loaded(aTHX_ name)) { /* not in %INC */
284             MP_TRACE_h(MP_FUNC,
285                        "package %s not in %INC, attempting to load it",
286                        name);
287 
288             if (modperl_require_module(aTHX_ name, logfailure)) {
289                 MP_TRACE_h(MP_FUNC, "loaded %s package", name);
290             }
291             else {
292                 if (logfailure) {
293                     /* the caller doesn't handle the error checking */
294                     Perl_croak(aTHX_ "failed to load %s package\n", name);
295                 }
296                 else {
297                     /* the caller handles the error checking */
298                     MP_TRACE_h(MP_FUNC, "failed to load %s package", name);
299                     return 0;
300                 }
301             }
302         }
303         else {
304             MP_TRACE_h(MP_FUNC, "package %s seems to be loaded", name);
305         }
306     }
307 
308     /* try to lookup the stash only after loading the module, to avoid
309      * the case where a stash is autovivified by a user before the
310      * module was loaded, preventing from loading the module
311      */
312     if (!(stash || (stash = gv_stashpv(name, FALSE)))) {
313         MP_TRACE_h(MP_FUNC, "%s's stash is not found", name);
314         return 0;
315     }
316 
317     if ((gv = gv_fetchmethod(stash, handler_name)) && (cv = GvCV(gv))) {
318         if (CvFLAGS(cv) & CVf_METHOD) { /* sub foo : method {}; */
319             MpHandlerMETHOD_On(handler);
320         }
321 
322         if (!stash) {
323             return 0;
324         }
325 
326 
327         if (MpHandlerMETHOD(handler) && !handler->mgv_obj) {
328             char *name = HvNAME(stash);
329             if (!name) {
330                 name = "";
331             }
332             modperl_mgv_new_name(handler->mgv_obj, p, name);
333         }
334 
335         handler->attrs = *modperl_code_attrs(aTHX_ cv);
336         /* note: this is the real function after @ISA lookup */
337         handler->mgv_cv = modperl_mgv_compile(aTHX_ p, HvNAME(GvSTASH(gv)));
338         modperl_mgv_append(aTHX_ p, handler->mgv_cv, handler_name);
339 
340         MpHandlerPARSED_On(handler);
341         MP_TRACE_h(MP_FUNC, "found `%s' in class `%s' as a %s",
342                    handler_name, HvNAME(stash),
343                    MpHandlerMETHOD(handler) ? "method" : "function");
344         MODPERL_MGV_DEEP_RESOLVE(handler, p);
345         return 1;
346     }
347 
348     /* at least modperl_hash_handlers needs to verify that an
349      * autoloaded-marked handler needs to be loaded, since it doesn't
350      * check success failure, and handlers marked to be autoloaded are
351      * the same as PerlModule and the failure should be fatal */
352     if (MpHandlerAUTOLOAD(handler)) {
353         Perl_croak(aTHX_ "failed to resolve handler %s\n", name);
354     }
355 
356 #ifdef MP_TRACE
357     /* complain only if the class was actually loaded/created */
358     if (stash) {
359         MP_TRACE_h(MP_FUNC, "`%s' not found in class `%s'",
360                    handler_name, name);
361     }
362 #endif
363 
364     return 0;
365 }
366 
modperl_mgv_last(modperl_mgv_t * symbol)367 modperl_mgv_t *modperl_mgv_last(modperl_mgv_t *symbol)
368 {
369     while (symbol->next) {
370         symbol = symbol->next;
371     }
372 
373     return symbol;
374 }
375 
modperl_mgv_last_name(modperl_mgv_t * symbol)376 char *modperl_mgv_last_name(modperl_mgv_t *symbol)
377 {
378     symbol = modperl_mgv_last(symbol);
379     return symbol->name;
380 }
381 
modperl_mgv_as_string(pTHX_ modperl_mgv_t * symbol,apr_pool_t * p,int package)382 char *modperl_mgv_as_string(pTHX_ modperl_mgv_t *symbol,
383                             apr_pool_t *p, int package)
384 {
385     char *string, *ptr;
386     modperl_mgv_t *mgv;
387     int len = 0;
388 
389     for (mgv = symbol; (package ? mgv->next : mgv); mgv = mgv->next) {
390         len += mgv->len;
391     }
392 
393     ptr = string = apr_palloc(p, len+1);
394 
395     for (mgv = symbol; (package ? mgv->next : mgv); mgv = mgv->next) {
396         Copy(mgv->name, ptr, mgv->len, char);
397         ptr += mgv->len;
398     }
399 
400     if (package) {
401         *(ptr-2) = '\0'; /* trim trailing :: */
402     }
403     else {
404         *ptr = '\0';
405     }
406 
407     return string;
408 }
409 
410 #ifdef USE_ITHREADS
modperl_mgv_require_module(pTHX_ modperl_mgv_t * symbol,server_rec * s,apr_pool_t * p)411 int modperl_mgv_require_module(pTHX_ modperl_mgv_t *symbol,
412                                server_rec *s, apr_pool_t *p)
413 {
414     char *package =
415         modperl_mgv_as_string(aTHX_ symbol, p, 1);
416 
417     if (modperl_require_module(aTHX_ package, TRUE)) {
418         MP_TRACE_h(MP_FUNC, "reloaded %s for server %s",
419                    package, modperl_server_desc(s, p));
420         return TRUE;
421     }
422 
423     return FALSE;
424 }
425 #endif
426 
427 /* precompute the hash(es) for handler names, preload handlers
428  * configured to be autoloaded */
modperl_hash_handlers(pTHX_ apr_pool_t * p,server_rec * s,MpAV * entry,void * data)429 static void modperl_hash_handlers(pTHX_ apr_pool_t *p, server_rec *s,
430                                   MpAV *entry, void *data)
431 {
432     MP_dSCFG(s);
433     int i;
434     modperl_handler_t **handlers;
435 
436     if (!entry) {
437         return;
438     }
439 
440     handlers = (modperl_handler_t **)entry->elts;
441 
442     for (i=0; i < entry->nelts; i++) {
443         modperl_handler_t *handler = handlers[i];
444 
445         if (MpHandlerFAKE(handler)) {
446             /* do nothing with fake handlers */
447         }
448         else if (MpHandlerPARSED(handler)) {
449 #ifdef USE_ITHREADS
450             if ((MpSrvPARENT(scfg) && MpSrvAUTOLOAD(scfg))
451                 && !modperl_mgv_lookup(aTHX_ handler->mgv_cv)) {
452                 /*
453                  * this VirtualHost has its own parent interpreter
454                  * must require the module again with this server's THX
455                  */
456                 modperl_mgv_require_module(aTHX_ handler->mgv_cv,
457                                            s, p);
458             }
459 #endif
460             MP_TRACE_h(MP_FUNC, "%s already resolved in server %s",
461                        modperl_handler_name(handler),
462                        modperl_server_desc(s, p));
463         }
464         else {
465             if (MpSrvAUTOLOAD(scfg)) {
466                 MpHandlerAUTOLOAD_On(handler);
467             }
468 
469             modperl_mgv_resolve(aTHX_ handler, p, handler->name, TRUE);
470         }
471     }
472 }
473 
modperl_hash_handlers_dir(apr_pool_t * p,server_rec * s,void * cfg,char * d,void * data)474 static int modperl_hash_handlers_dir(apr_pool_t *p, server_rec *s,
475                                      void *cfg, char *d, void *data)
476 {
477     int i;
478     modperl_config_dir_t *dir_cfg = (modperl_config_dir_t *)cfg;
479     dTHXa(data);
480 
481     if (!dir_cfg) {
482         return 1;
483     }
484 
485     for (i=0; i < MP_HANDLER_NUM_PER_DIR; i++) {
486         modperl_hash_handlers(aTHX_ p, s, dir_cfg->handlers_per_dir[i], data);
487     }
488 
489     return 1;
490 }
491 
modperl_hash_handlers_srv(apr_pool_t * p,server_rec * s,void * cfg,void * data)492 static int modperl_hash_handlers_srv(apr_pool_t *p, server_rec *s,
493                                      void *cfg, void *data)
494 {
495     int i;
496     modperl_config_srv_t *scfg = (modperl_config_srv_t *)cfg;
497     dTHXa(data);
498 
499     for (i=0; i < MP_HANDLER_NUM_PER_SRV; i++) {
500         modperl_hash_handlers(aTHX_ p, s,
501                               scfg->handlers_per_srv[i], data);
502     }
503 
504     for (i=0; i < MP_HANDLER_NUM_PROCESS; i++) {
505         modperl_hash_handlers(aTHX_ p, s,
506                               scfg->handlers_process[i], data);
507     }
508 
509     for (i=0; i < MP_HANDLER_NUM_CONNECTION; i++) {
510         modperl_hash_handlers(aTHX_ p, s,
511                               scfg->handlers_connection[i], data);
512     }
513 
514     for (i=0; i < MP_HANDLER_NUM_FILES; i++) {
515         modperl_hash_handlers(aTHX_ p, s,
516                               scfg->handlers_files[i], data);
517     }
518 
519     return 1;
520 }
521 
modperl_mgv_hash_handlers(apr_pool_t * p,server_rec * s)522 void modperl_mgv_hash_handlers(apr_pool_t *p, server_rec *s)
523 {
524     MP_dINTERPa(NULL, NULL, s);
525     ap_pcw_walk_config(p, s, &perl_module,
526 #ifdef USE_ITHREADS
527                        aTHX,
528 #else
529                        NULL,
530 #endif
531                        modperl_hash_handlers_dir,
532                        modperl_hash_handlers_srv);
533     MP_INTERP_PUTBACK(interp, aTHX);
534 }
535 
536 /*
537  * Local Variables:
538  * c-basic-offset: 4
539  * indent-tabs-mode: nil
540  * End:
541  */
542