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 typedef struct {
20     modperl_mgv_t *dir_create;
21     modperl_mgv_t *dir_merge;
22     modperl_mgv_t *srv_create;
23     modperl_mgv_t *srv_merge;
24     int namelen;
25 } modperl_module_info_t;
26 
27 typedef struct {
28     server_rec *server;
29     modperl_module_info_t *minfo;
30 } modperl_module_cfg_t;
31 
32 #define MP_MODULE_INFO(modp) \
33     (modperl_module_info_t *)modp->dynamic_load_handle
34 
35 #define MP_MODULE_CFG_MINFO(ptr) \
36     ((modperl_module_cfg_t *)ptr)->minfo
37 
modperl_module_cfg_new(apr_pool_t * p)38 static modperl_module_cfg_t *modperl_module_cfg_new(apr_pool_t *p)
39 {
40     modperl_module_cfg_t *cfg =
41         (modperl_module_cfg_t *)apr_pcalloc(p, sizeof(*cfg));
42 
43     return cfg;
44 }
45 
modperl_module_cmd_data_new(apr_pool_t * p)46 static modperl_module_cmd_data_t *modperl_module_cmd_data_new(apr_pool_t *p)
47 {
48     modperl_module_cmd_data_t *cmd_data =
49         (modperl_module_cmd_data_t *)apr_pcalloc(p, sizeof(*cmd_data));
50 
51     return cmd_data;
52 }
53 
modperl_module_config_dir_create(apr_pool_t * p,char * dir)54 static void *modperl_module_config_dir_create(apr_pool_t *p, char *dir)
55 {
56     return modperl_module_cfg_new(p);
57 }
58 
modperl_module_config_srv_create(apr_pool_t * p,server_rec * s)59 static void *modperl_module_config_srv_create(apr_pool_t *p, server_rec *s)
60 {
61     return modperl_module_cfg_new(p);
62 }
63 
modperl_module_config_hash_get(pTHX_ int create)64 static SV **modperl_module_config_hash_get(pTHX_ int create)
65 {
66     SV **svp;
67 
68     /* XXX: could make this lookup faster */
69     svp = hv_fetch(PL_modglobal,
70                    "ModPerl::Module::ConfigTable",
71                    MP_SSTRLEN("ModPerl::Module::ConfigTable"),
72                    create);
73 
74     return svp;
75 }
76 
modperl_module_config_table_set(pTHX_ PTR_TBL_t * table)77 void modperl_module_config_table_set(pTHX_ PTR_TBL_t *table)
78 {
79     SV **svp = modperl_module_config_hash_get(aTHX_ TRUE);
80     sv_setiv(*svp, PTR2IV(table));
81 }
82 
modperl_module_config_table_get(pTHX_ int create)83 PTR_TBL_t *modperl_module_config_table_get(pTHX_ int create)
84 {
85     PTR_TBL_t *table = NULL;
86 
87     SV *sv, **svp = modperl_module_config_hash_get(aTHX_ create);
88 
89     if (!svp) {
90         return NULL;
91     }
92 
93     sv = *svp;
94     if (!SvIOK(sv) && create) {
95         table = modperl_svptr_table_new(aTHX);
96         sv_setiv(sv, PTR2IV(table));
97     }
98     else {
99         table = INT2PTR(PTR_TBL_t *, SvIV(sv));
100     }
101 
102     return table;
103 }
104 
105 typedef struct {
106 #ifdef USE_ITHREADS
107     modperl_interp_t *interp;
108 #endif
109     PTR_TBL_t *table;
110     void *ptr;
111 } config_obj_cleanup_t;
112 
113 /*
114  * any per-dir CREATE or MERGE that happens at request time
115  * needs to be removed from the pointer table.
116  */
modperl_module_config_obj_cleanup(void * data)117 static apr_status_t modperl_module_config_obj_cleanup(void *data)
118 {
119     config_obj_cleanup_t *cleanup =
120         (config_obj_cleanup_t *)data;
121 #ifdef USE_ITHREADS
122     dTHXa(cleanup->interp->perl);
123     MP_ASSERT_CONTEXT(aTHX);
124 #endif
125 
126     modperl_svptr_table_delete(aTHX_ cleanup->table, cleanup->ptr);
127 
128     MP_TRACE_c(MP_FUNC, "deleting ptr %pp from table %pp",
129                cleanup->ptr, cleanup->table);
130 
131     MP_INTERP_PUTBACK(cleanup->interp, aTHX);
132 
133     return APR_SUCCESS;
134 }
135 
modperl_module_config_obj_cleanup_register(pTHX_ apr_pool_t * p,PTR_TBL_t * table,void * ptr)136 static void modperl_module_config_obj_cleanup_register(pTHX_
137                                                        apr_pool_t *p,
138                                                        PTR_TBL_t *table,
139                                                        void *ptr)
140 {
141     config_obj_cleanup_t *cleanup =
142         (config_obj_cleanup_t *)apr_palloc(p, sizeof(*cleanup));
143 
144     cleanup->table = table;
145     cleanup->ptr = ptr;
146 #ifdef USE_ITHREADS
147     cleanup->interp = modperl_thx_interp_get(aTHX);
148     MP_INTERP_REFCNT_inc(cleanup->interp);
149 #endif
150 
151     apr_pool_cleanup_register(p, cleanup,
152                               modperl_module_config_obj_cleanup,
153                               apr_pool_cleanup_null);
154 }
155 
156 #define MP_CFG_MERGE_DIR 1
157 #define MP_CFG_MERGE_SRV 2
158 
159 /*
160  * XXX: vhosts may have different parent interpreters.
161  */
modperl_module_config_merge(apr_pool_t * p,void * basev,void * addv,int type)162 static void *modperl_module_config_merge(apr_pool_t *p,
163                                          void *basev, void *addv,
164                                          int type)
165 {
166     GV *gv;
167     modperl_mgv_t *method;
168     modperl_module_cfg_t *mrg = NULL,
169         *tmp,
170         *base = (modperl_module_cfg_t *)basev,
171         *add  = (modperl_module_cfg_t *)addv;
172     server_rec *s;
173     int is_startup;
174     PTR_TBL_t *table;
175     SV *mrg_obj = (SV *)NULL, *base_obj, *add_obj;
176     MP_dINTERP;
177 
178     /* if the module is loaded in vhost, base==NULL */
179     tmp = (base && base->server) ? base : add;
180 
181     if (tmp && !tmp->server) {
182         /* no directives for this module were encountered so far */
183         return basev;
184     }
185 
186     s = tmp->server;
187     is_startup = (p == s->process->pconf);
188 
189     MP_INTERP_POOLa(p, s);
190 
191     table = modperl_module_config_table_get(aTHX_ TRUE);
192     base_obj = modperl_svptr_table_fetch(aTHX_ table, base);
193     add_obj  = modperl_svptr_table_fetch(aTHX_ table, add);
194 
195     if (!base_obj || (base_obj == add_obj)) {
196         MP_INTERP_PUTBACK(interp, aTHX);
197         return addv;
198     }
199 
200     mrg = modperl_module_cfg_new(p);
201     memcpy(mrg, tmp, sizeof(*mrg));
202 
203     method = (type == MP_CFG_MERGE_DIR) ?
204         mrg->minfo->dir_merge :
205         mrg->minfo->srv_merge;
206 
207     if (method && (gv = modperl_mgv_lookup(aTHX_ method))) {
208         int count;
209         dSP;
210 
211         MP_TRACE_c(MP_FUNC, "calling %s->%s",
212                    SvCLASS(base_obj), modperl_mgv_last_name(method));
213 
214         ENTER;SAVETMPS;
215         PUSHMARK(sp);
216         XPUSHs(base_obj);XPUSHs(add_obj);
217 
218         PUTBACK;
219         count = call_sv((SV*)GvCV(gv), G_EVAL|G_SCALAR);
220         SPAGAIN;
221 
222         if (count == 1) {
223             mrg_obj = SvREFCNT_inc(POPs);
224         }
225 
226         PUTBACK;
227         FREETMPS;LEAVE;
228 
229         if (SvTRUE(ERRSV)) {
230             /* XXX: should die here. */
231             (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
232                                 NULL, NULL);
233         }
234     }
235     else {
236         mrg_obj = SvREFCNT_inc(add_obj);
237     }
238 
239     modperl_svptr_table_store(aTHX_ table, mrg, mrg_obj);
240 
241     if (!is_startup) {
242         modperl_module_config_obj_cleanup_register(aTHX_ p, table, mrg);
243     }
244 
245     MP_INTERP_PUTBACK(interp, aTHX);
246 
247     return (void *)mrg;
248 }
249 
modperl_module_config_dir_merge(apr_pool_t * p,void * basev,void * addv)250 static void *modperl_module_config_dir_merge(apr_pool_t *p,
251                                              void *basev, void *addv)
252 {
253     return modperl_module_config_merge(p, basev, addv,
254                                        MP_CFG_MERGE_DIR);
255 }
256 
modperl_module_config_srv_merge(apr_pool_t * p,void * basev,void * addv)257 static void *modperl_module_config_srv_merge(apr_pool_t *p,
258                                              void *basev, void *addv)
259 {
260     return modperl_module_config_merge(p, basev, addv,
261                                        MP_CFG_MERGE_SRV);
262 }
263 
264 #define modperl_bless_cmd_parms(parms) \
265     sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::CmdParms", (void *)parms))
266 
267 static const char *
modperl_module_config_create_obj(pTHX_ apr_pool_t * p,PTR_TBL_t * table,modperl_module_cfg_t * cfg,modperl_module_cmd_data_t * info,modperl_mgv_t * method,cmd_parms * parms,SV ** obj)268 modperl_module_config_create_obj(pTHX_
269                                  apr_pool_t *p,
270                                  PTR_TBL_t *table,
271                                  modperl_module_cfg_t *cfg,
272                                  modperl_module_cmd_data_t *info,
273                                  modperl_mgv_t *method,
274                                  cmd_parms *parms,
275                                  SV **obj)
276 {
277     const char *mname = info->modp->name;
278     modperl_module_info_t *minfo = MP_MODULE_INFO(info->modp);
279     GV *gv;
280     int is_startup = (p == parms->server->process->pconf);
281 
282     /*
283      * XXX: if MPM is not threaded, we could modify the
284      * modperl_module_cfg_t * directly and avoid the ptr_table
285      * altogether.
286      */
287     if ((*obj = (SV*)modperl_svptr_table_fetch(aTHX_ table, cfg))) {
288         /* object already exists */
289         return NULL;
290     }
291 
292     MP_TRACE_c(MP_FUNC, "%s cfg=0x%lx for %s.%s",
293                method ? modperl_mgv_last_name(method) : "NULL",
294                (unsigned long)cfg, mname, parms->cmd->name);
295 
296     /* used by merge functions to get a Perl interp */
297     cfg->server = parms->server;
298     cfg->minfo = minfo;
299 
300     if (method && (gv = modperl_mgv_lookup(aTHX_ method))) {
301         int count;
302         dSP;
303 
304         ENTER;SAVETMPS;
305         PUSHMARK(sp);
306         XPUSHs(sv_2mortal(newSVpv(mname, minfo->namelen)));
307         XPUSHs(modperl_bless_cmd_parms(parms));
308 
309         PUTBACK;
310         count = call_sv((SV*)GvCV(gv), G_EVAL|G_SCALAR);
311         SPAGAIN;
312 
313         if (count == 1) {
314             *obj = SvREFCNT_inc(POPs);
315         }
316 
317         PUTBACK;
318         FREETMPS;LEAVE;
319 
320         if (SvTRUE(ERRSV)) {
321             return SvPVX(ERRSV);
322         }
323     }
324     else {
325         HV *stash = gv_stashpvn(mname, minfo->namelen, FALSE);
326         /* return bless {}, $class */
327         *obj = newRV_noinc((SV*)newHV());
328         *obj = sv_bless(*obj, stash);
329     }
330 
331     if (!is_startup) {
332         modperl_module_config_obj_cleanup_register(aTHX_ p, table, cfg);
333     }
334 
335     modperl_svptr_table_store(aTHX_ table, cfg, *obj);
336 
337     return NULL;
338 }
339 
340 #define PUSH_STR_ARG(arg) \
341     if (arg) XPUSHs(sv_2mortal(newSVpv(arg,0)))
342 
modperl_module_cmd_take123(cmd_parms * parms,void * mconfig,const char * one,const char * two,const char * three)343 static const char *modperl_module_cmd_take123(cmd_parms *parms,
344                                               void *mconfig,
345                                               const char *one,
346                                               const char *two,
347                                               const char *three)
348 {
349     modperl_module_cfg_t *cfg = (modperl_module_cfg_t *)mconfig;
350     const char *retval = NULL, *errmsg;
351     const command_rec *cmd = parms->cmd;
352     server_rec *s = parms->server;
353     apr_pool_t *p = parms->pool;
354     modperl_module_cmd_data_t *info =
355         (modperl_module_cmd_data_t *)cmd->cmd_data;
356     modperl_module_info_t *minfo = MP_MODULE_INFO(info->modp);
357     modperl_module_cfg_t *srv_cfg;
358     int modules_alias = 0;
359     int count;
360     PTR_TBL_t *table;
361     SV *obj = (SV *)NULL;
362     MP_dINTERP_POOLa(p, s);
363 
364     table = modperl_module_config_table_get(aTHX_ TRUE);
365 
366     if (s->is_virtual) {
367         MP_dSCFG(s);
368 
369         /* if the Perl module is loaded in the base server and a vhost
370          * has configuration directives from that module, but no
371          * mod_perl.c directives, scfg == NULL when
372          * modperl_module_cmd_take123 is run. If the directive
373          * callback wants to do something with the mod_perl config
374          * object, it'll segfault, since it doesn't exist yet, because
375          * this happens before server configs are merged. So we create
376          * a temp struct and fill it in with things that might be
377          * needed by the Perl callback.
378          */
379         if (!scfg) {
380             scfg = modperl_config_srv_new(p, s);
381             modperl_set_module_config(s->module_config, scfg);
382             scfg->server = s;
383         }
384 
385         /* if PerlLoadModule Foo is called from the base server, but
386          * Foo's directives are used inside a vhost, we need to
387          * temporary link to the base server config's 'modules'
388          * member. e.g. so Apache2::Module->get_config() can be called
389          * from a custom directive's callback, before the server/vhost
390          * config merge is performed
391          */
392         if (!scfg->modules) {
393             modperl_config_srv_t *base_scfg =
394                 modperl_config_srv_get(modperl_global_get_server_rec());
395             if (base_scfg->modules) {
396                 scfg->modules = base_scfg->modules;
397                 modules_alias = 1;
398             }
399         }
400 
401     }
402 
403     errmsg = modperl_module_config_create_obj(aTHX_ p, table, cfg, info,
404                                               minfo->dir_create,
405                                               parms, &obj);
406 
407     if (errmsg) {
408         MP_INTERP_PUTBACK(interp, aTHX);
409         return errmsg;
410     }
411 
412     if (obj) {
413         MP_TRACE_c(MP_FUNC, "found per-dir obj=0x%lx for %s.%s",
414                    (unsigned long)obj,
415                    info->modp->name, cmd->name);
416     }
417 
418     /* XXX: could delay creation of srv_obj until
419      * Apache2::ModuleConfig->get is called.
420      */
421     srv_cfg = ap_get_module_config(s->module_config, info->modp);
422 
423     if (srv_cfg) {
424         SV *srv_obj;
425         errmsg = modperl_module_config_create_obj(aTHX_ p, table, srv_cfg, info,
426                                                minfo->srv_create,
427                                                parms, &srv_obj);
428         if (errmsg) {
429             MP_INTERP_PUTBACK(interp, aTHX);
430             return errmsg;
431         }
432 
433         if (srv_obj) {
434             MP_TRACE_c(MP_FUNC, "found per-srv obj=0x%lx for %s.%s",
435                        (unsigned long)srv_obj,
436                        info->modp->name, cmd->name);
437         }
438     }
439 
440     {
441         dSP;
442         ENTER;SAVETMPS;
443         PUSHMARK(SP);
444         EXTEND(SP, 2);
445 
446         PUSHs(obj);
447         PUSHs(modperl_bless_cmd_parms(parms));
448 
449         if (cmd->args_how != NO_ARGS) {
450             PUSH_STR_ARG(one);
451             PUSH_STR_ARG(two);
452             PUSH_STR_ARG(three);
453         }
454 
455         PUTBACK;
456         count = call_method(info->func_name, G_EVAL|G_SCALAR);
457         SPAGAIN;
458 
459         if (count == 1) {
460             SV *sv = POPs;
461             if (SvPOK(sv) && strEQ(SvPVX(sv), DECLINE_CMD)) {
462                 retval = DECLINE_CMD;
463             }
464         }
465 
466         PUTBACK;
467         FREETMPS;LEAVE;
468     }
469 
470     if (SvTRUE(ERRSV)) {
471         retval = SvPVX(ERRSV);
472     }
473 
474     MP_INTERP_PUTBACK(interp, aTHX);
475 
476     if (modules_alias) {
477         MP_dSCFG(s);
478         /* unalias the temp aliasing */
479         scfg->modules = NULL;
480     }
481 
482     return retval;
483 }
484 
modperl_module_cmd_take1(cmd_parms * parms,void * mconfig,const char * one)485 static const char *modperl_module_cmd_take1(cmd_parms *parms,
486                                             void *mconfig,
487                                             const char *one)
488 {
489     return modperl_module_cmd_take123(parms, mconfig, one, NULL, NULL);
490 }
491 
modperl_module_cmd_take2(cmd_parms * parms,void * mconfig,const char * one,const char * two)492 static const char *modperl_module_cmd_take2(cmd_parms *parms,
493                                             void *mconfig,
494                                             const char *one,
495                                             const char *two)
496 {
497     return modperl_module_cmd_take123(parms, mconfig, one, two, NULL);
498 }
499 
modperl_module_cmd_flag(cmd_parms * parms,void * mconfig,int flag)500 static const char *modperl_module_cmd_flag(cmd_parms *parms,
501                                            void *mconfig,
502                                            int flag)
503 {
504     char buf[2];
505 
506     apr_snprintf(buf, sizeof(buf), "%d", flag);
507 
508     return modperl_module_cmd_take123(parms, mconfig, buf, NULL, NULL);
509 }
510 
modperl_module_cmd_no_args(cmd_parms * parms,void * mconfig)511 static const char *modperl_module_cmd_no_args(cmd_parms *parms,
512                                               void *mconfig)
513 {
514     return modperl_module_cmd_take123(parms, mconfig, NULL, NULL, NULL);
515 }
516 
517 #define modperl_module_cmd_raw_args modperl_module_cmd_take1
518 #define modperl_module_cmd_iterate  modperl_module_cmd_take1
519 #define modperl_module_cmd_iterate2 modperl_module_cmd_take2
520 #define modperl_module_cmd_take12   modperl_module_cmd_take2
521 #define modperl_module_cmd_take23   modperl_module_cmd_take123
522 #define modperl_module_cmd_take3    modperl_module_cmd_take123
523 #define modperl_module_cmd_take13   modperl_module_cmd_take123
524 
525 #if defined(AP_HAVE_DESIGNATED_INITIALIZER)
526 #   define modperl_module_cmd_func_set(cmd, name) \
527     cmd->func.name = modperl_module_cmd_##name
528 #else
529 #   define modperl_module_cmd_func_set(cmd, name) \
530     cmd->func = modperl_module_cmd_##name
531 #endif
532 
modperl_module_cmd_lookup(command_rec * cmd)533 static int modperl_module_cmd_lookup(command_rec *cmd)
534 {
535     switch (cmd->args_how) {
536       case TAKE1:
537       case ITERATE:
538         modperl_module_cmd_func_set(cmd, take1);
539         break;
540       case TAKE2:
541       case ITERATE2:
542       case TAKE12:
543         modperl_module_cmd_func_set(cmd, take2);
544         break;
545       case TAKE3:
546       case TAKE23:
547       case TAKE123:
548       case TAKE13:
549         modperl_module_cmd_func_set(cmd, take3);
550         break;
551       case RAW_ARGS:
552         modperl_module_cmd_func_set(cmd, raw_args);
553         break;
554       case FLAG:
555         modperl_module_cmd_func_set(cmd, flag);
556         break;
557       case NO_ARGS:
558         modperl_module_cmd_func_set(cmd, no_args);
559         break;
560       default:
561         return FALSE;
562     }
563 
564     return TRUE;
565 }
566 
modperl_module_remove(void * data)567 static apr_status_t modperl_module_remove(void *data)
568 {
569     module *modp = (module *)data;
570 
571     ap_remove_loaded_module(modp);
572 
573     return APR_SUCCESS;
574 }
575 
modperl_module_cmd_fetch(pTHX_ SV * obj,const char * name,SV ** retval)576 static const char *modperl_module_cmd_fetch(pTHX_ SV *obj,
577                                             const char *name, SV **retval)
578 {
579     const char *errmsg = NULL;
580 
581     if (*retval) {
582         SvREFCNT_dec(*retval);
583         *retval = (SV *)NULL;
584     }
585 
586     if (sv_isobject(obj)) {
587         int count;
588         dSP;
589         ENTER;SAVETMPS;
590         PUSHMARK(SP);
591         XPUSHs(obj);
592         PUTBACK;
593 
594         count = call_method(name, G_EVAL|G_SCALAR);
595 
596         SPAGAIN;
597 
598         if (count == 1) {
599             SV *sv = POPs;
600             if (SvTRUE(sv)) {
601                 *retval = SvREFCNT_inc(sv);
602             }
603         }
604 
605         if (!*retval) {
606             errmsg = Perl_form(aTHX_ "%s->%s did not return a %svalue",
607                                SvCLASS(obj), name, count ? "true " : "");
608         }
609 
610         PUTBACK;
611         FREETMPS;LEAVE;
612 
613         if (SvTRUE(ERRSV)) {
614             errmsg = SvPVX(ERRSV);
615         }
616     }
617     else if (SvROK(obj) && (SvTYPE(SvRV(obj)) == SVt_PVHV)) {
618         HV *hv = (HV*)SvRV(obj);
619         SV **svp = hv_fetch(hv, name, strlen(name), 0);
620 
621         if (svp) {
622             *retval = SvREFCNT_inc(*svp);
623         }
624         else {
625             errmsg = Perl_form(aTHX_ "HASH key %s does not exist", name);
626         }
627     }
628     else {
629         errmsg = "command entry is not an object or a HASH reference";
630     }
631 
632     return errmsg;
633 }
634 
modperl_module_add_cmds(apr_pool_t * p,server_rec * s,module * modp,SV * mod_cmds)635 static const char *modperl_module_add_cmds(apr_pool_t *p, server_rec *s,
636                                            module *modp, SV *mod_cmds)
637 {
638     const char *errmsg;
639     apr_array_header_t *cmds;
640     command_rec *cmd;
641     AV *module_cmds;
642     I32 i, fill;
643     MP_dINTERPa(NULL, NULL, s);
644     module_cmds = (AV*)SvRV(mod_cmds);
645 
646     fill = AvFILL(module_cmds);
647     cmds = apr_array_make(p, fill+1, sizeof(command_rec));
648 
649     for (i=0; i<=fill; i++) {
650         SV *val = (SV *)NULL;
651         STRLEN len;
652         SV *obj = AvARRAY(module_cmds)[i];
653         modperl_module_cmd_data_t *info = modperl_module_cmd_data_new(p);
654 
655         info->modp = modp;
656 
657         cmd = apr_array_push(cmds);
658 
659         if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "name", &val))) {
660             MP_INTERP_PUTBACK(interp, aTHX);
661             return errmsg;
662         }
663 
664         cmd->name = apr_pstrdup(p, SvPV(val, len));
665 
666         if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "args_how", &val))) {
667             /* XXX default based on $self->func prototype */
668             cmd->args_how = TAKE1; /* default */
669         }
670         else {
671             if (SvIOK(val)) {
672                 cmd->args_how = SvIV(val);
673             }
674             else {
675                 cmd->args_how =
676                     SvIV(modperl_constants_lookup_apache2_const(aTHX_ SvPV(val, len)));
677             }
678         }
679 
680         if (!modperl_module_cmd_lookup(cmd)) {
681             MP_INTERP_PUTBACK(interp, aTHX);
682             return apr_psprintf(p,
683                                 "no command function defined for args_how=%d",
684                                 cmd->args_how);
685         }
686 
687         if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "func", &val))) {
688             info->func_name = cmd->name;  /* default */
689         }
690         else {
691             info->func_name = apr_pstrdup(p, SvPV(val, len));
692         }
693 
694         if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "req_override", &val))) {
695             cmd->req_override = OR_ALL; /* default */
696         }
697         else {
698             if (SvIOK(val)) {
699                 cmd->req_override = SvIV(val);
700             }
701             else {
702                 cmd->req_override =
703                     SvIV(modperl_constants_lookup_apache2_const(aTHX_ SvPV(val, len)));
704             }
705         }
706 
707         if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "errmsg", &val))) {
708             /* default */
709             /* XXX generate help msg based on args_how */
710             cmd->errmsg = apr_pstrcat(p, cmd->name, " command", NULL);
711         }
712         else {
713             cmd->errmsg = apr_pstrdup(p, SvPV(val, len));
714         }
715 
716         cmd->cmd_data = info;
717 
718         /* no default if undefined */
719         if (!(errmsg = modperl_module_cmd_fetch(aTHX_ obj, "cmd_data", &val))) {
720             info->cmd_data = apr_pstrdup(p, SvPV(val, len));
721         }
722 
723         if (val) {
724             SvREFCNT_dec(val);
725             val = (SV *)NULL;
726         }
727     }
728 
729     cmd = apr_array_push(cmds);
730     cmd->name = NULL;
731 
732     modp->cmds = (command_rec *)cmds->elts;
733 
734     MP_INTERP_PUTBACK(interp, aTHX);
735     return NULL;
736 }
737 
modperl_module_insert(module * modp)738 static void modperl_module_insert(module *modp)
739 {
740     /*
741      * insert after mod_perl, rather the top of the list.
742      * (see ap_add_module; does not insert into ap_top_module list if
743      *  m->next != NULL)
744      * this way, modperl config merging happens before this module.
745      */
746 
747     modp->next = perl_module.next;
748     perl_module.next = modp;
749 }
750 
751 #define MP_isGV(gv) (gv && isGV(gv))
752 
modperl_module_fetch_method(pTHX_ apr_pool_t * p,module * modp,const char * method)753 static modperl_mgv_t *modperl_module_fetch_method(pTHX_
754                                                   apr_pool_t *p,
755                                                   module *modp,
756                                                   const char *method)
757 {
758     modperl_mgv_t *mgv;
759 
760     HV *stash = gv_stashpv(modp->name, FALSE);
761     GV *gv = gv_fetchmethod_autoload(stash, method, FALSE);
762 
763     MP_TRACE_c(MP_FUNC, "looking for method %s in package `%s'...%sfound",
764                method, modp->name,
765                MP_isGV(gv) ? "" : "not ");
766 
767     if (!MP_isGV(gv)) {
768         return NULL;
769     }
770 
771     mgv = modperl_mgv_compile(aTHX_ p,
772                               apr_pstrcat(p,
773                                           modp->name, "::", method, NULL));
774 
775     return mgv;
776 }
777 
modperl_module_add(apr_pool_t * p,server_rec * s,const char * name,SV * mod_cmds)778 const char *modperl_module_add(apr_pool_t *p, server_rec *s,
779                                const char *name, SV *mod_cmds)
780 {
781     MP_dSCFG(s);
782     const char *errmsg;
783     module *modp;
784     modperl_module_info_t *minfo;
785     MP_dINTERPa(NULL, NULL, s);
786     modp = (module *)apr_pcalloc(p, sizeof(*modp));
787     minfo = (modperl_module_info_t *)apr_pcalloc(p, sizeof(*minfo));
788 
789     /* STANDARD20_MODULE_STUFF */
790     modp->version       = MODULE_MAGIC_NUMBER_MAJOR;
791     modp->minor_version = MODULE_MAGIC_NUMBER_MINOR;
792     modp->module_index  = -1;
793     modp->name          = apr_pstrdup(p, name);
794     modp->magic         = MODULE_MAGIC_COOKIE;
795 
796     /* use this slot for our context */
797     modp->dynamic_load_handle = minfo;
798 
799     /*
800      * XXX: we should lookup here if the Perl methods exist,
801      * and set these pointers only if they do.
802      */
803     modp->create_dir_config    = modperl_module_config_dir_create;
804     modp->merge_dir_config     = modperl_module_config_dir_merge;
805     modp->create_server_config = modperl_module_config_srv_create;
806     modp->merge_server_config  = modperl_module_config_srv_merge;
807 
808     minfo->namelen = strlen(name);
809 
810     minfo->dir_create =
811         modperl_module_fetch_method(aTHX_ p, modp, "DIR_CREATE");
812 
813     minfo->dir_merge =
814         modperl_module_fetch_method(aTHX_ p, modp, "DIR_MERGE");
815 
816     minfo->srv_create =
817         modperl_module_fetch_method(aTHX_ p, modp, "SERVER_CREATE");
818 
819     minfo->srv_merge =
820         modperl_module_fetch_method(aTHX_ p, modp, "SERVER_MERGE");
821 
822     modp->cmds = NULL;
823 
824     if ((errmsg = modperl_module_add_cmds(p, s, modp, mod_cmds))) {
825         MP_INTERP_PUTBACK(interp, aTHX);
826         return errmsg;
827     }
828 
829     modperl_module_insert(modp);
830 
831     mp_add_loaded_module(modp, p, modp->name);
832 
833     apr_pool_cleanup_register(p, modp, modperl_module_remove,
834                               apr_pool_cleanup_null);
835 
836     ap_single_module_configure(p, s, modp);
837 
838     if (!scfg->modules) {
839         scfg->modules = apr_hash_make(p);
840     }
841 
842     apr_hash_set(scfg->modules, apr_pstrdup(p, name), APR_HASH_KEY_STRING, modp);
843 
844 #ifdef USE_ITHREADS
845     /*
846      * if the Perl module is loaded in the base server and a vhost
847      * has configuration directives from that module, but no mod_perl.c
848      * directives, scfg == NULL when modperl_module_cmd_take123 is run.
849      * this happens before server configs are merged, so we stash a pointer
850      * to what will be merged as the parent interp later. i.e. "safe hack"
851      */
852     if (!modperl_interp_pool_get(p)) {
853         /* for vhosts */
854         MP_TRACE_i(MP_FUNC, "set interp 0x%lx in pconf pool 0x%lx",
855                    (unsigned long)scfg->mip->parent, (unsigned long)p);
856         modperl_interp_pool_set(p, scfg->mip->parent);
857     }
858 #endif
859 
860     MP_INTERP_PUTBACK(interp, aTHX);
861     return NULL;
862 }
863 
modperl_module_config_get_obj(pTHX_ SV * pmodule,server_rec * s,ap_conf_vector_t * v)864 SV *modperl_module_config_get_obj(pTHX_ SV *pmodule, server_rec *s,
865                                   ap_conf_vector_t *v)
866 {
867     MP_dSCFG(s);
868     module *modp;
869     const char *name;
870     void *ptr;
871     PTR_TBL_t *table;
872     SV *obj;
873 
874     if (!v) {
875         v = s->module_config;
876     }
877 
878     if (SvROK(pmodule)) {
879         name = SvCLASS(pmodule);
880     }
881     else {
882         STRLEN n_a;
883         name = SvPV(pmodule, n_a);
884     }
885 
886     if (!(scfg->modules &&
887           (modp = apr_hash_get(scfg->modules, name, APR_HASH_KEY_STRING)))) {
888         return &PL_sv_undef;
889     }
890 
891     if (!(ptr = ap_get_module_config(v, modp))) {
892         return &PL_sv_undef;
893     }
894 
895     if (!(table = modperl_module_config_table_get(aTHX_ FALSE))) {
896         return &PL_sv_undef;
897     }
898 
899     if (!(obj = modperl_svptr_table_fetch(aTHX_ table, ptr))) {
900         return &PL_sv_undef;
901     }
902 
903     return obj;
904 }
905 
906 /*
907  * Local Variables:
908  * c-basic-offset: 4
909  * indent-tabs-mode: nil
910  * End:
911  */
912