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