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 
modperl_require_module(pTHX_ const char * pv,int logfailure)19 int modperl_require_module(pTHX_ const char *pv, int logfailure)
20 {
21     SV *sv;
22 
23     dSP;
24     PUSHSTACKi(PERLSI_REQUIRE);
25     ENTER;SAVETMPS;
26     PUTBACK;
27     sv = sv_newmortal();
28     sv_setpv(sv, "require ");
29     sv_catpv(sv, pv);
30     eval_sv(sv, G_DISCARD);
31     SPAGAIN;
32     POPSTACK;
33     FREETMPS;LEAVE;
34 
35     if (SvTRUE(ERRSV)) {
36         if (logfailure) {
37             (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
38                                 NULL, NULL);
39         }
40         return FALSE;
41     }
42 
43     return TRUE;
44 }
45 
modperl_require_file(pTHX_ const char * pv,int logfailure)46 int modperl_require_file(pTHX_ const char *pv, int logfailure)
47 {
48     require_pv(pv);
49 
50     if (SvTRUE(ERRSV)) {
51         if (logfailure) {
52             (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
53                                 NULL, NULL);
54         }
55         return FALSE;
56     }
57 
58     return TRUE;
59 }
60 
modperl_hv_request_find(pTHX_ SV * in,char * classname,CV * cv)61 static SV *modperl_hv_request_find(pTHX_ SV *in, char *classname, CV *cv)
62 {
63     static char *r_keys[] = { "r", "_r", NULL };
64     HV *hv = (HV *)SvRV(in);
65     SV *sv = (SV *)NULL;
66     int i;
67 
68     for (i=0; r_keys[i]; i++) {
69         int klen = i + 1; /* assumes r_keys[] will never change */
70         SV **svp;
71 
72         if ((svp = hv_fetch(hv, r_keys[i], klen, FALSE)) && (sv = *svp)) {
73             if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) {
74                 /* dig deeper */
75                 return modperl_hv_request_find(aTHX_ sv, classname, cv);
76             }
77             break;
78         }
79     }
80 
81     if (!sv) {
82         Perl_croak(aTHX_
83                    "method `%s' invoked by a `%s' object with no `r' key!",
84                    cv ? GvNAME(CvGV(cv)) : "unknown",
85                    (SvRV(in) && SvSTASH(SvRV(in)))
86                        ? HvNAME(SvSTASH(SvRV(in)))
87                        : "unknown");
88     }
89 
90     return SvROK(sv) ? SvRV(sv) : sv;
91 }
92 
93 
94 /* notice that if sv is not an Apache2::ServerRec object and
95  * Apache2->request is not available, the returned global object might
96  * be not thread-safe under threaded mpms, so use with care
97  */
98 
modperl_sv2server_rec(pTHX_ SV * sv)99 MP_INLINE server_rec *modperl_sv2server_rec(pTHX_ SV *sv)
100 {
101     if (SvOBJECT(sv) || (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG))) {
102         return INT2PTR(server_rec *, SvObjIV(sv));
103     }
104 
105     /* next see if we have Apache2->request available */
106     {
107         request_rec *r = NULL;
108         (void)modperl_tls_get_request_rec(&r);
109         if (r) {
110             return r->server;
111         }
112     }
113 
114     /* modperl_global_get_server_rec is not thread safe w/o locking */
115     return modperl_global_get_server_rec();
116 }
117 
modperl_sv2request_rec(pTHX_ SV * sv)118 MP_INLINE request_rec *modperl_sv2request_rec(pTHX_ SV *sv)
119 {
120     return modperl_xs_sv2request_rec(aTHX_ sv, NULL, (CV *)NULL);
121 }
122 
modperl_xs_sv2request_rec(pTHX_ SV * in,char * classname,CV * cv)123 request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv)
124 {
125     SV *sv = (SV *)NULL;
126     MAGIC *mg;
127 
128     if (SvROK(in)) {
129         SV *rv = (SV*)SvRV(in);
130 
131         switch (SvTYPE(rv)) {
132           case SVt_PVMG:
133             sv = rv;
134             break;
135           case SVt_PVHV:
136             sv = modperl_hv_request_find(aTHX_ in, classname, cv);
137             break;
138           default:
139             Perl_croak(aTHX_ "panic: unsupported request_rec type %d",
140                        (int)SvTYPE(rv));
141         }
142     }
143 
144     /* might be Apache2::ServerRec::warn method */
145     if (!sv && !(classname && SvPOK(in) && !strEQ(classname, SvPVX(in)))) {
146         request_rec *r = NULL;
147         (void)modperl_tls_get_request_rec(&r);
148 
149         if (!r) {
150             Perl_croak(aTHX_
151                        "Apache2->%s called without setting Apache2->request!",
152                        cv ? GvNAME(CvGV(cv)) : "unknown");
153         }
154 
155         return r;
156     }
157 
158     /* there could be pool magic attached to custom $r object, so make
159      * sure that mg->mg_ptr is set */
160     if ((mg = mg_find(sv, PERL_MAGIC_ext)) && mg->mg_ptr) {
161         return (request_rec *)mg->mg_ptr;
162     }
163     else {
164         if (classname && !sv_derived_from(in, classname)) {
165             /* XXX: find something faster than sv_derived_from */
166             return NULL;
167         }
168         return INT2PTR(request_rec *, SvIV(sv));
169     }
170 
171     return NULL;
172 }
173 
modperl_newSVsv_obj(pTHX_ SV * stashsv,SV * obj)174 MP_INLINE SV *modperl_newSVsv_obj(pTHX_ SV *stashsv, SV *obj)
175 {
176     SV *newobj;
177 
178     if (!obj) {
179         obj = stashsv;
180         stashsv = (SV *)NULL;
181     }
182 
183     newobj = newSVsv(obj);
184 
185     if (stashsv) {
186         HV *stash = gv_stashsv(stashsv, TRUE);
187         return sv_bless(newobj, stash);
188     }
189 
190     return newobj;
191 }
192 
modperl_ptr2obj(pTHX_ char * classname,void * ptr)193 MP_INLINE SV *modperl_ptr2obj(pTHX_ char *classname, void *ptr)
194 {
195     SV *sv = newSV(0);
196 
197     MP_TRACE_h(MP_FUNC, "sv_setref_pv(%s, 0x%lx)",
198                classname, (unsigned long)ptr);
199     sv_setref_pv(sv, classname, ptr);
200 
201     return sv;
202 }
203 
modperl_errsv(pTHX_ int status,request_rec * r,server_rec * s)204 int modperl_errsv(pTHX_ int status, request_rec *r, server_rec *s)
205 {
206     SV *sv = ERRSV;
207     STRLEN n_a;
208 
209     if (SvTRUE(sv)) {
210         if (sv_derived_from(sv, "APR::Error") &&
211             SvIVx(sv) == MODPERL_RC_EXIT) {
212             /* ModPerl::Util::exit was called */
213             return OK;
214         }
215 #if 0
216         if (modperl_sv_is_http_code(ERRSV, &status)) {
217             return status;
218         }
219 #endif
220         if (r) {
221             ap_log_rerror(APLOG_MARK, APLOG_ERR, 0, r, "%s", SvPV(sv, n_a));
222         }
223         else {
224             ap_log_error(APLOG_MARK, APLOG_ERR, 0, s, "%s", SvPV(sv, n_a));
225         }
226 
227         return status;
228     }
229 
230     return status;
231 }
232 
233 /* prepends the passed sprintf-like arguments to ERRSV, which also
234  * gets stringified on the way */
modperl_errsv_prepend(pTHX_ const char * pat,...)235 void modperl_errsv_prepend(pTHX_ const char *pat, ...)
236 {
237     SV *sv;
238     va_list args;
239 
240     va_start(args, pat);
241     sv = vnewSVpvf(pat, &args);
242     va_end(args);
243 
244     sv_catsv(sv, ERRSV);
245     sv_copypv(ERRSV, sv);
246     sv_free(sv);
247 }
248 
249 #define dl_librefs "DynaLoader::dl_librefs"
250 #define dl_modules "DynaLoader::dl_modules"
251 
modperl_xs_dl_handles_clear(pTHX)252 void modperl_xs_dl_handles_clear(pTHX)
253 {
254     AV *librefs = get_av(dl_librefs, FALSE);
255     if (librefs) {
256         av_clear(librefs);
257     }
258 }
259 
modperl_xs_dl_handles_get(pTHX)260 void **modperl_xs_dl_handles_get(pTHX)
261 {
262     I32 i;
263     AV *librefs = get_av(dl_librefs, FALSE);
264     AV *modules = get_av(dl_modules, FALSE);
265     void **handles;
266 
267     if (!librefs) {
268         MP_TRACE_r(MP_FUNC,
269                    "Could not get @%s for unloading.",
270                    dl_librefs);
271         return NULL;
272     }
273 
274     if (!(AvFILL(librefs) >= 0)) {
275         /* dl_librefs and dl_modules are empty */
276         return NULL;
277     }
278 
279     handles = (void **)malloc(sizeof(void *) * (AvFILL(librefs)+2));
280 
281     for (i=0; i<=AvFILL(librefs); i++) {
282         void *handle;
283         SV *handle_sv = *av_fetch(librefs, i, FALSE);
284         SV *module_sv = *av_fetch(modules, i, FALSE);
285 
286         if(!handle_sv) {
287             MP_TRACE_r(MP_FUNC,
288                        "Could not fetch $%s[%d]!",
289                        dl_librefs, (int)i);
290             continue;
291         }
292         handle = INT2PTR(void *, SvIV(handle_sv));
293 
294         MP_TRACE_r(MP_FUNC, "%s dl handle == 0x%lx",
295                    SvPVX(module_sv), (unsigned long)handle);
296         if (handle) {
297             handles[i] = handle;
298         }
299     }
300 
301     av_clear(modules);
302     av_clear(librefs);
303 
304     handles[i] = (void *)0;
305 
306     return handles;
307 }
308 
modperl_xs_dl_handles_close(void ** handles)309 void modperl_xs_dl_handles_close(void **handles)
310 {
311     int i;
312 
313     if (!handles) {
314         return;
315     }
316 
317     for (i=0; handles[i]; i++) {
318         MP_TRACE_r(MP_FUNC, "close 0x%lx", (unsigned long)handles[i]);
319         modperl_sys_dlclose(handles[i]);
320     }
321 
322     free(handles);
323 }
324 
325 /* XXX: There is no XS accessible splice() */
modperl_av_remove_entry(pTHX_ AV * av,I32 index)326 static void modperl_av_remove_entry(pTHX_ AV *av, I32 index)
327 {
328     I32 i;
329     AV *tmpav = newAV();
330 
331     /* stash the entries _before_ the item to delete */
332     for (i=0; i<=index; i++) {
333         av_store(tmpav, i, SvREFCNT_inc(av_shift(av)));
334     }
335 
336     /* make size at the beginning of the array */
337     av_unshift(av, index-1);
338 
339     /* add stashed entries back */
340     for (i=0; i<index; i++) {
341         av_store(av, i, *av_fetch(tmpav, i, 0));
342     }
343 
344     sv_free((SV *)tmpav);
345 }
346 
modperl_package_unload_dynamic(pTHX_ const char * package,I32 dl_index)347 static void modperl_package_unload_dynamic(pTHX_ const char *package,
348                                            I32 dl_index)
349 {
350     AV *librefs = get_av(dl_librefs, 0);
351     SV *libref = *av_fetch(librefs, dl_index, 0);
352 
353     modperl_sys_dlclose(INT2PTR(void *, SvIV(libref)));
354 
355     /* remove package from @dl_librefs and @dl_modules */
356     modperl_av_remove_entry(aTHX_ get_av(dl_librefs, 0), dl_index);
357     modperl_av_remove_entry(aTHX_ get_av(dl_modules, 0), dl_index);
358 
359     return;
360 }
361 
modperl_package_is_dynamic(pTHX_ const char * package,I32 * dl_index)362 static int modperl_package_is_dynamic(pTHX_ const char *package,
363                                       I32 *dl_index)
364 {
365    I32 i;
366    AV *modules = get_av(dl_modules, FALSE);
367 
368    for (i=0; i<av_len(modules); i++) {
369         SV *module = *av_fetch(modules, i, 0);
370         if (strEQ(package, SvPVX(module))) {
371             *dl_index = i;
372             return TRUE;
373         }
374     }
375     return FALSE;
376 }
377 
modperl_cleanup_data_new(apr_pool_t * p,void * data)378 modperl_cleanup_data_t *modperl_cleanup_data_new(apr_pool_t *p, void *data)
379 {
380     modperl_cleanup_data_t *cdata =
381         (modperl_cleanup_data_t *)apr_pcalloc(p, sizeof(*cdata));
382     cdata->pool = p;
383     cdata->data = data;
384     return cdata;
385 }
386 
modperl_perl_av_push_elts_ref(pTHX_ AV * dst,AV * src)387 MP_INLINE void modperl_perl_av_push_elts_ref(pTHX_ AV *dst, AV *src)
388 {
389     I32 i, j, src_fill = AvFILLp(src), dst_fill = AvFILLp(dst);
390 
391     av_extend(dst, src_fill);
392     AvFILLp(dst) += src_fill+1;
393 
394     for (i=dst_fill+1, j=0; j<=AvFILLp(src); i++, j++) {
395         AvARRAY(dst)[i] = SvREFCNT_inc(AvARRAY(src)[j]);
396     }
397 }
398 
399 /*
400  * similar to hv_fetch_ent, but takes string key and key len rather than SV
401  * also skips magic and utf8 fu, since we are only dealing with internal tables
402  */
modperl_perl_hv_fetch_he(pTHX_ HV * hv,register char * key,register I32 klen,register U32 hash)403 HE *modperl_perl_hv_fetch_he(pTHX_ HV *hv,
404                              register char *key,
405                              register I32 klen,
406                              register U32 hash)
407 {
408     register XPVHV *xhv;
409     register HE *entry;
410 
411     xhv = (XPVHV *)SvANY(hv);
412     if (!HvARRAY(hv)) {
413         return 0;
414     }
415 
416 #ifdef HvREHASH
417     if (HvREHASH(hv)) {
418         PERL_HASH_INTERNAL(hash, key, klen);
419     }
420     else
421 #endif
422     if (!hash) {
423         PERL_HASH(hash, key, klen);
424     }
425 
426     entry = ((HE**)HvARRAY(hv))[hash & (I32)xhv->xhv_max];
427 
428     for (; entry; entry = HeNEXT(entry)) {
429         if (HeHASH(entry) != hash) {
430             continue;
431         }
432         if (HeKLEN(entry) != klen) {
433             continue;
434         }
435         if (HeKEY(entry) != key && memNE(HeKEY(entry), key, klen)) {
436             continue;
437         }
438         return entry;
439     }
440 
441     return 0;
442 }
443 
modperl_str_toupper(char * str)444 void modperl_str_toupper(char *str)
445 {
446     while (*str) {
447         *str = apr_toupper(*str);
448         ++str;
449     }
450 }
451 
452 /* XXX: same as Perl_do_sprintf();
453  * but Perl_do_sprintf() is not part of the "public" api
454  */
modperl_perl_do_sprintf(pTHX_ SV * sv,I32 len,SV ** sarg)455 void modperl_perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
456 {
457     STRLEN patlen;
458     char *pat = SvPV(*sarg, patlen);
459     bool do_taint = FALSE;
460 
461     sv_vsetpvfn(sv, pat, patlen, (va_list *)NULL, sarg + 1, len - 1, &do_taint);
462     SvSETMAGIC(sv);
463     if (do_taint) {
464         SvTAINTED_on(sv);
465     }
466 }
467 
modperl_perl_call_list(pTHX_ AV * subs,const char * name)468 void modperl_perl_call_list(pTHX_ AV *subs, const char *name)
469 {
470     I32 i, oldscope = PL_scopestack_ix;
471     SV **ary = AvARRAY(subs);
472 
473     MP_TRACE_g(MP_FUNC, MP_TRACEf_PERLID
474                " running %d %s subs", MP_TRACEv_PERLID_
475                AvFILLp(subs)+1, name);
476 
477     for (i=0; i<=AvFILLp(subs); i++) {
478         CV *cv = (CV*)ary[i];
479         SV *atsv = ERRSV;
480 
481         PUSHMARK(PL_stack_sp);
482         call_sv((SV*)cv, G_EVAL|G_DISCARD);
483 
484         if (SvCUR(atsv)) {
485             Perl_sv_catpvf(aTHX_ atsv, "%s failed--call queue aborted",
486                            name);
487             while (PL_scopestack_ix > oldscope) {
488                 LEAVE;
489             }
490             Perl_croak(aTHX_ "%s", SvPVX(atsv));
491         }
492     }
493 }
494 
modperl_perl_exit(pTHX_ int status)495 void modperl_perl_exit(pTHX_ int status)
496 {
497     ENTER;
498     SAVESPTR(PL_diehook);
499     PL_diehook = (SV *)NULL;
500     modperl_croak(aTHX_ MODPERL_RC_EXIT, "ModPerl::Util::exit");
501 }
502 
modperl_dir_config(pTHX_ request_rec * r,server_rec * s,char * key,SV * sv_val)503 MP_INLINE SV *modperl_dir_config(pTHX_ request_rec *r, server_rec *s,
504                                  char *key, SV *sv_val)
505 {
506     SV *retval = &PL_sv_undef;
507 
508     if (r && r->per_dir_config) {
509         MP_dDCFG;
510         retval = modperl_table_get_set(aTHX_ dcfg->configvars,
511                                        key, sv_val, FALSE);
512     }
513 
514     if (!SvOK(retval)) {
515         if (s && s->module_config) {
516             MP_dSCFG(s);
517             SvREFCNT_dec(retval); /* in case above did newSV(0) */
518             retval = modperl_table_get_set(aTHX_ scfg->configvars,
519                                            key, sv_val, FALSE);
520         }
521         else {
522             retval = &PL_sv_undef;
523         }
524     }
525 
526     return retval;
527 }
528 
modperl_table_get_set(pTHX_ apr_table_t * table,char * key,SV * sv_val,int do_taint)529 SV *modperl_table_get_set(pTHX_ apr_table_t *table, char *key,
530                           SV *sv_val, int do_taint)
531 {
532     SV *retval = &PL_sv_undef;
533 
534     if (table == NULL) {
535         /* do nothing */
536     }
537     else if (key == NULL) {
538         retval = modperl_hash_tie(aTHX_ "APR::Table",
539                                   (SV *)NULL, (void*)table);
540     }
541     else if (!sv_val) { /* no val was passed */
542         char *val;
543         if ((val = (char *)apr_table_get(table, key))) {
544             retval = newSVpv(val, 0);
545         }
546         else {
547             retval = newSV(0);
548         }
549         if (do_taint) {
550             SvTAINTED_on(retval);
551         }
552     }
553     else if (!SvOK(sv_val)) { /* val was passed in as undef */
554         apr_table_unset(table, key);
555     }
556     else {
557         apr_table_set(table, key, SvPV_nolen(sv_val));
558     }
559 
560     return retval;
561 }
562 
package2filename(const char * package,int * len)563 static char *package2filename(const char *package, int *len)
564 {
565     const char *s;
566     char *d;
567     char *filename;
568 
569     filename = malloc((strlen(package)+4)*sizeof(char));
570 
571     for (s = package, d = filename; *s; s++, d++) {
572         if (*s == ':' && s[1] == ':') {
573             *d = '/';
574             s++;
575         }
576         else {
577             *d = *s;
578         }
579     }
580     *d++ = '.';
581     *d++ = 'p';
582     *d++ = 'm';
583     *d   = '\0';
584 
585     *len = d - filename;
586     return filename;
587 }
588 
modperl_perl_module_loaded(pTHX_ const char * name)589 MP_INLINE int modperl_perl_module_loaded(pTHX_ const char *name)
590 {
591     SV **svp;
592     int len;
593     char *filename = package2filename(name, &len);
594     svp = hv_fetch(GvHVn(PL_incgv), filename, len, 0);
595     free(filename);
596 
597     return (svp && *svp != &PL_sv_undef) ? 1 : 0;
598 }
599 
600 #define SLURP_SUCCESS(action)                                           \
601     if (rc != APR_SUCCESS) {                                            \
602         SvREFCNT_dec(sv);                                               \
603         modperl_croak(aTHX_ rc,                                         \
604                       apr_psprintf(r->pool,                             \
605                                    "slurp_filename('%s') / " action,    \
606                                    r->filename));                       \
607     }
608 
modperl_slurp_filename(pTHX_ request_rec * r,int tainted)609 MP_INLINE SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted)
610 {
611     SV *sv;
612     apr_status_t rc;
613     apr_size_t size;
614     apr_file_t *file;
615 
616     size = r->finfo.size;
617     sv = newSV(size);
618 
619     /* XXX: could have checked whether r->finfo.filehand is valid and
620      * save the apr_file_open call, but apache gives us no API to
621      * check whether filehand is valid. we can't test whether it's
622      * NULL or not, as it may contain garbagea
623      */
624     rc = apr_file_open(&file, r->filename, APR_READ|APR_BINARY,
625                        APR_OS_DEFAULT, r->pool);
626     SLURP_SUCCESS("opening");
627 
628     rc = apr_file_read(file, SvPVX(sv), &size);
629     SLURP_SUCCESS("reading");
630 
631     MP_TRACE_o(MP_FUNC, "read %d bytes from '%s'", size, r->filename);
632 
633     if (r->finfo.size != size) {
634         SvREFCNT_dec(sv);
635         Perl_croak(aTHX_ "Error: read %d bytes, expected %d ('%s')",
636                    size, (apr_size_t)r->finfo.size, r->filename);
637     }
638 
639     rc = apr_file_close(file);
640     SLURP_SUCCESS("closing");
641 
642     SvPVX(sv)[size] = '\0';
643     SvCUR_set(sv, size);
644     SvPOK_on(sv);
645 
646     if (tainted) {
647         SvTAINTED_on(sv);
648     }
649     else {
650         SvTAINTED_off(sv);
651     }
652 
653     return newRV_noinc(sv);
654 }
655 
656 #define MP_VALID_PKG_CHAR(c) (isalnum(c) ||(c) == '_')
657 #define MP_VALID_PATH_DELIM(c) ((c) == '/' || (c) =='\\')
modperl_file2package(apr_pool_t * p,const char * file)658 char *modperl_file2package(apr_pool_t *p, const char *file)
659 {
660     char *package;
661     char *c;
662     const char *f;
663     int len = strlen(file)+1;
664 
665     /* First, skip invalid prefix characters */
666     while (!MP_VALID_PKG_CHAR(*file)) {
667         file++;
668         len--;
669     }
670 
671     /* Then figure out how big the package name will be like */
672     for (f = file; *f; f++) {
673         if (MP_VALID_PATH_DELIM(*f)) {
674             len++;
675         }
676     }
677 
678     package = apr_pcalloc(p, len);
679 
680     /* Then, replace bad characters with '_' */
681     for (c = package; *file; c++, file++) {
682         if (MP_VALID_PKG_CHAR(*file)) {
683             *c = *file;
684         }
685         else if (MP_VALID_PATH_DELIM(*file)) {
686 
687             /* Eliminate subsequent duplicate path delim */
688             while (*(file+1) && MP_VALID_PATH_DELIM(*(file+1))) {
689                 file++;
690             }
691 
692             /* path delim not until end of line */
693             if (*(file+1)) {
694                 *c = *(c+1) = ':';
695                 c++;
696             }
697         }
698         else {
699             *c = '_';
700         }
701     }
702 
703     return package;
704 }
705 
modperl_apr_array_header2avrv(pTHX_ apr_array_header_t * array)706 SV *modperl_apr_array_header2avrv(pTHX_ apr_array_header_t *array)
707 {
708     AV *av = newAV();
709 
710     if (array) {
711         int i;
712         for (i = 0; i < array->nelts; i++) {
713             av_push(av, newSVpv(((char **)array->elts)[i], 0));
714         }
715     }
716     return newRV_noinc((SV*)av);
717 }
718 
modperl_avrv2apr_array_header(pTHX_ apr_pool_t * p,SV * avrv)719 apr_array_header_t *modperl_avrv2apr_array_header(pTHX_ apr_pool_t *p,
720                                                   SV *avrv)
721 {
722     AV *av;
723     apr_array_header_t *array;
724     int i, av_size;
725 
726     if (!(SvROK(avrv) && (SvTYPE(SvRV(avrv)) == SVt_PVAV))) {
727         Perl_croak(aTHX_ "Not an array reference");
728     }
729 
730     av = (AV*)SvRV(avrv);
731     av_size = av_len(av);
732     array = apr_array_make(p, av_size+1, sizeof(char *));
733 
734     for (i = 0; i <= av_size; i++) {
735         SV *sv = *av_fetch(av, i, FALSE);
736         char **entry = (char **)apr_array_push(array);
737         *entry = apr_pstrdup(p, SvPV_nolen(sv));
738     }
739 
740     return array;
741 }
742 
743 /* Remove a package from %INC */
modperl_package_delete_from_inc(pTHX_ const char * package)744 static void modperl_package_delete_from_inc(pTHX_ const char *package)
745 {
746     int len;
747     char *filename = package2filename(package, &len);
748     (void)hv_delete(GvHVn(PL_incgv), filename, len, G_DISCARD);
749     free(filename);
750 }
751 
752 /* Destroy a package's stash */
753 #define MP_STASH_SUBSTASH(key, len) ((len >= 2) &&                  \
754                                      (key[len-1] == ':') &&         \
755                                      (key[len-2] == ':'))
756 #define MP_STASH_DEBUGGER(key, len) ((len >= 2) &&                  \
757                                      (key[0] == '_') &&             \
758                                      (key[1] == '<'))
759 #define MP_SAFE_STASH(key, len)     (!(MP_STASH_SUBSTASH(key,len)|| \
760                                       (MP_STASH_DEBUGGER(key, len))))
modperl_package_clear_stash(pTHX_ const char * package)761 static void modperl_package_clear_stash(pTHX_ const char *package)
762 {
763     HV *stash;
764     if ((stash = gv_stashpv(package, FALSE))) {
765         HE *he;
766         I32 len;
767         char *key;
768         hv_iterinit(stash);
769         while ((he = hv_iternext(stash))) {
770             key = hv_iterkey(he, &len);
771             if (MP_SAFE_STASH(key, len)) {
772                 SV *val = hv_iterval(stash, he);
773                 /* The safe thing to do is to skip over stash entries
774                  * that don't come from the package we are trying to
775                  * unload
776                  */
777                 if (GvSTASH(val) == stash) {
778                     (void)hv_delete(stash, key, len, G_DISCARD);
779                 }
780             }
781         }
782     }
783 }
784 
785 /* Unload a module as completely and cleanly as possible */
modperl_package_unload(pTHX_ const char * package)786 void modperl_package_unload(pTHX_ const char *package)
787 {
788     I32 dl_index;
789 
790     modperl_package_clear_stash(aTHX_ package);
791     modperl_package_delete_from_inc(aTHX_ package);
792 
793     if (modperl_package_is_dynamic(aTHX_ package, &dl_index)) {
794         modperl_package_unload_dynamic(aTHX_ package, dl_index);
795     }
796 
797 }
798 
799 #define MP_RESTART_COUNT_KEY "mod_perl_restart_count"
800 
801 /* passing the main server object here, just because we don't have the
802  * modperl_server_pool available yet, later on we can access it
803  * through the modperl_server_pool() call.
804  */
modperl_restart_count_inc(server_rec * base_server)805 void modperl_restart_count_inc(server_rec *base_server)
806 {
807     void *data;
808     int *counter;
809     apr_pool_t *p = base_server->process->pool;
810 
811     apr_pool_userdata_get(&data, MP_RESTART_COUNT_KEY, p);
812     if (data) {
813         counter = data;
814         (*counter)++;
815     }
816     else {
817         counter = apr_palloc(p, sizeof *counter);
818         *counter = 1;
819         apr_pool_userdata_set(counter, MP_RESTART_COUNT_KEY,
820                               apr_pool_cleanup_null, p);
821     }
822 }
823 
modperl_restart_count(void)824 int modperl_restart_count(void)
825 {
826     void *data;
827     apr_pool_userdata_get(&data, MP_RESTART_COUNT_KEY,
828                           modperl_global_get_server_rec()->process->pool);
829     return data ? *(int *)data : 0;
830  }
831 
832 static MP_INLINE
modperl_cleanup_pnotes(void * data)833 apr_status_t modperl_cleanup_pnotes(void *data) {
834     modperl_pnotes_t *pnotes = data;
835 
836     dTHXa(pnotes->interp->perl);
837     MP_ASSERT_CONTEXT(aTHX);
838 
839     SvREFCNT_dec(pnotes->pnotes);
840     pnotes->pnotes = NULL;
841     pnotes->pool = NULL;
842 
843     MP_INTERP_PUTBACK(pnotes->interp, aTHX);
844     return APR_SUCCESS;
845 }
846 
modperl_pnotes_kill(void * data)847 void modperl_pnotes_kill(void *data) {
848     modperl_pnotes_t *pnotes = data;
849 
850     if( !pnotes->pnotes ) return;
851 
852     apr_pool_cleanup_kill(pnotes->pool, pnotes, modperl_cleanup_pnotes);
853     modperl_cleanup_pnotes(pnotes);
854 }
855 
modperl_pnotes(pTHX_ modperl_pnotes_t * pnotes,SV * key,SV * val,apr_pool_t * pool)856 SV *modperl_pnotes(pTHX_ modperl_pnotes_t *pnotes, SV *key, SV *val,
857                    apr_pool_t *pool) {
858     SV *retval = (SV *)NULL;
859 
860     if (!pnotes->pnotes) {
861         pnotes->pool = pool;
862 #ifdef USE_ITHREADS
863         pnotes->interp = modperl_thx_interp_get(aTHX);
864         pnotes->interp->refcnt++;
865         MP_TRACE_i(MP_FUNC, "TO: (0x%lx)->refcnt incremented to %ld",
866                    pnotes->interp, pnotes->interp->refcnt);
867 #endif
868         pnotes->pnotes = newHV();
869         apr_pool_cleanup_register(pool, pnotes,
870                                   modperl_cleanup_pnotes,
871                                   apr_pool_cleanup_null);
872     }
873 
874     if (key) {
875         STRLEN len;
876         char *k = SvPV(key, len);
877 
878         if (val) {
879             retval = *hv_store(pnotes->pnotes, k, len, SvREFCNT_inc(val), 0);
880         }
881         else if (hv_exists(pnotes->pnotes, k, len)) {
882             retval = *hv_fetch(pnotes->pnotes, k, len, FALSE);
883         }
884 
885         return retval ? SvREFCNT_inc(retval) : &PL_sv_undef;
886     }
887     return newRV_inc((SV *)pnotes->pnotes);
888 }
889 
modperl_code_attrs(pTHX_ CV * cv)890 U16 *modperl_code_attrs(pTHX_ CV *cv) {
891     MAGIC *mg;
892 
893     if (!(SvMAGICAL(cv) && (mg = mg_find((SV*)cv, PERL_MAGIC_ext)))) {
894        sv_magic((SV*)cv, (SV *)NULL, PERL_MAGIC_ext, NULL, -1);
895     }
896 
897     mg = mg_find((SV*)cv, PERL_MAGIC_ext);
898     return &(mg->mg_private);
899 }
900 
901 #if AP_SERVER_MAJORVERSION_NUMBER>2 || \
902     (AP_SERVER_MAJORVERSION_NUMBER == 2 && AP_SERVER_MINORVERSION_NUMBER>=3)
903 
904 static apr_hash_t *global_authz_providers = NULL;
905 static apr_hash_t *global_authn_providers = NULL;
906 
907 typedef struct {
908     SV *cb1;
909     SV *cb2;
910     modperl_handler_t *cb1_handler;
911     modperl_handler_t *cb2_handler;
912 } auth_callback;
913 
cleanup_perl_global_providers(void * ctx)914 static apr_status_t cleanup_perl_global_providers(void *ctx)
915 {
916     global_authz_providers = NULL;
917     global_authn_providers = NULL;
918     return APR_SUCCESS;
919 }
920 
perl_check_authorization(request_rec * r,const char * require_args,const void * parsed_require_args)921 static authz_status perl_check_authorization(request_rec *r,
922                                              const char *require_args,
923                                              const void *parsed_require_args)
924 {
925     authz_status ret = AUTHZ_DENIED;
926     int count;
927     AV *args = (AV *)NULL;
928     const char *key;
929     auth_callback *ab;
930     MP_dINTERPa(r, NULL, NULL);
931 
932     if (global_authz_providers == NULL) {
933         MP_INTERP_PUTBACK(interp, aTHX);
934         return ret;
935     }
936 
937     key = apr_table_get(r->notes, AUTHZ_PROVIDER_NAME_NOTE);
938     ab = apr_hash_get(global_authz_providers, key, APR_HASH_KEY_STRING);
939     if (ab == NULL) {
940         MP_INTERP_PUTBACK(interp, aTHX);
941         return ret;
942     }
943 
944     if (ab->cb1 == NULL) {
945         if (ab->cb1_handler == NULL) {
946             MP_INTERP_PUTBACK(interp, aTHX);
947             return ret;
948         }
949 
950         modperl_handler_make_args(aTHX_ &args, "Apache2::RequestRec", r,
951                                   "PV", require_args, NULL);
952         ret = modperl_callback(aTHX_ ab->cb1_handler, r->pool, r, r->server,
953                                args);
954         SvREFCNT_dec((SV*)args);
955         MP_INTERP_PUTBACK(interp, aTHX);
956         return ret;
957     }
958 
959     {
960         dSP;
961         ENTER;
962         SAVETMPS;
963         PUSHMARK(SP);
964         XPUSHs(sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::RequestRec", r)));
965         XPUSHs(sv_2mortal(newSVpv(require_args, 0)));
966         PUTBACK;
967         count = call_sv(ab->cb1, G_SCALAR);
968         SPAGAIN;
969 
970         if (count == 1) {
971             ret = (authz_status) POPi;
972         }
973 
974         PUTBACK;
975         FREETMPS;
976         LEAVE;
977     }
978 
979     MP_INTERP_PUTBACK(interp, aTHX);
980     return ret;
981 }
982 
perl_parse_require_line(cmd_parms * cmd,const char * require_line,const void ** parsed_require_line)983 static const char *perl_parse_require_line(cmd_parms *cmd,
984                                            const char *require_line,
985                                            const void **parsed_require_line)
986 {
987     char *ret = NULL;
988     void *key;
989     auth_callback *ab;
990 
991     if (global_authz_providers == NULL ||
992         apr_hash_count(global_authz_providers) == 0)
993     {
994         return NULL;
995     }
996 
997     apr_pool_userdata_get(&key, AUTHZ_PROVIDER_NAME_NOTE, cmd->temp_pool);
998     ab = apr_hash_get(global_authz_providers, (char *) key, APR_HASH_KEY_STRING);
999     if (ab == NULL || ab->cb2 == NULL) {
1000         return NULL;
1001     }
1002 
1003     {
1004         /* PerlAddAuthzProvider currently does not support an optional second
1005          * handler, so ab->cb2 should always be NULL above and we will never get
1006          * here. If such support is added in the future then this code will be
1007          * reached, but cannot succeed in the absence of an interpreter. The
1008          * second handler would be called at init to check a Require line for
1009          * errors, but in the current design there is no interpreter available
1010          * at that time.
1011          */
1012         MP_dINTERP_POOLa(cmd->pool, cmd->server);
1013         if (!MP_HAS_INTERP(interp)) {
1014 	    return "Require handler is not currently supported in this context";
1015 	}
1016 
1017         {
1018             SV *ret_sv;
1019             int count;
1020             dSP;
1021 
1022             ENTER;
1023             SAVETMPS;
1024             PUSHMARK(SP);
1025             XPUSHs(sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::CmdParms", cmd)));
1026             XPUSHs(sv_2mortal(newSVpv(require_line, 0)));
1027             PUTBACK;
1028             count = call_sv(ab->cb2, G_SCALAR);
1029             SPAGAIN;
1030 
1031             if (count == 1) {
1032                 ret_sv = POPs;
1033                 if (SvOK(ret_sv)) {
1034                     char *tmp = SvPV_nolen(ret_sv);
1035                     if (*tmp != '\0') {
1036                         ret = apr_pstrdup(cmd->pool, tmp);
1037                     }
1038                 }
1039             }
1040 
1041             PUTBACK;
1042             FREETMPS;
1043             LEAVE;
1044         }
1045 
1046         MP_INTERP_PUTBACK(interp, aTHX);
1047     }
1048     return ret;
1049 }
1050 
perl_check_password(request_rec * r,const char * user,const char * password)1051 static authn_status perl_check_password(request_rec *r, const char *user,
1052                                         const char *password)
1053 {
1054     authn_status ret = AUTH_DENIED;
1055     int count;
1056     AV *args = (AV *)NULL;
1057     const char *key;
1058     auth_callback *ab;
1059     MP_dINTERPa(r, NULL, NULL);
1060 
1061     if (global_authn_providers == NULL) {
1062         MP_INTERP_PUTBACK(interp, aTHX);
1063         return ret;
1064     }
1065 
1066     key = apr_table_get(r->notes, AUTHN_PROVIDER_NAME_NOTE);
1067     ab = apr_hash_get(global_authn_providers, key,
1068                                      APR_HASH_KEY_STRING);
1069     if (ab == NULL || ab->cb1) {
1070         MP_INTERP_PUTBACK(interp, aTHX);
1071         return ret;
1072     }
1073 
1074     if (ab->cb1 == NULL) {
1075         if (ab->cb1_handler == NULL) {
1076             MP_INTERP_PUTBACK(interp, aTHX);
1077             return ret;
1078         }
1079 
1080         modperl_handler_make_args(aTHX_ &args, "Apache2::RequestRec", r,
1081                                   "PV", user,
1082                                   "PV", password, NULL);
1083         ret = modperl_callback(aTHX_ ab->cb1_handler, r->pool, r, r->server,
1084                                args);
1085         SvREFCNT_dec((SV*)args);
1086         MP_INTERP_PUTBACK(interp, aTHX);
1087         return ret;
1088     }
1089 
1090     {
1091         dSP;
1092         ENTER;
1093         SAVETMPS;
1094         PUSHMARK(SP);
1095         XPUSHs(sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::RequestRec", r)));
1096         XPUSHs(sv_2mortal(newSVpv(user, 0)));
1097         XPUSHs(sv_2mortal(newSVpv(password, 0)));
1098         PUTBACK;
1099         count = call_sv(ab->cb1, G_SCALAR);
1100         SPAGAIN;
1101 
1102         if (count == 1) {
1103             ret = (authn_status) POPi;
1104         }
1105 
1106         PUTBACK;
1107         FREETMPS;
1108         LEAVE;
1109     }
1110 
1111     MP_INTERP_PUTBACK(interp, aTHX);
1112     return ret;
1113 }
1114 
perl_get_realm_hash(request_rec * r,const char * user,const char * realm,char ** rethash)1115 static authn_status perl_get_realm_hash(request_rec *r, const char *user,
1116                                         const char *realm, char **rethash)
1117 {
1118     authn_status ret = AUTH_USER_NOT_FOUND;
1119     const char *key;
1120     auth_callback *ab;
1121 
1122     if (global_authn_providers == NULL ||
1123         apr_hash_count(global_authn_providers) == 0)
1124     {
1125         return AUTH_GENERAL_ERROR;
1126     }
1127 
1128     key = apr_table_get(r->notes, AUTHN_PROVIDER_NAME_NOTE);
1129     ab = apr_hash_get(global_authn_providers, key, APR_HASH_KEY_STRING);
1130     if (ab == NULL || ab->cb2 == NULL) {
1131         return AUTH_GENERAL_ERROR;
1132     }
1133 
1134     {
1135         /* PerlAddAuthnProvider currently does not support an optional second
1136          * handler, so ab->cb2 should always be NULL above and we will never get
1137          * here. If such support is added in the future then this code will be
1138          * reached. Unlike the PerlAddAuthzProvider case, the second handler here
1139          * would be called during request_rec processing to obtain a password hash
1140          * for the realm so there should be no problem grabbing an interpreter.
1141          */
1142         MP_dINTERPa(r, NULL, NULL);
1143 
1144         {
1145             SV* rh = sv_2mortal(newSVpv("", 0));
1146             int count;
1147             dSP;
1148 
1149             ENTER;
1150             SAVETMPS;
1151             PUSHMARK(SP);
1152             XPUSHs(sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::RequestRec", r)));
1153             XPUSHs(sv_2mortal(newSVpv(user, 0)));
1154             XPUSHs(sv_2mortal(newSVpv(realm, 0)));
1155             XPUSHs(newRV_noinc(rh));
1156             PUTBACK;
1157             count = call_sv(ab->cb2, G_SCALAR);
1158             SPAGAIN;
1159 
1160             if (count == 1) {
1161                 const char *tmp = SvPV_nolen(rh);
1162                 ret = (authn_status) POPi;
1163                 if (*tmp != '\0') {
1164                     *rethash = apr_pstrdup(r->pool, tmp);
1165                 }
1166             }
1167 
1168             PUTBACK;
1169             FREETMPS;
1170             LEAVE;
1171         }
1172 
1173         MP_INTERP_PUTBACK(interp, aTHX);
1174     }
1175 
1176     return ret;
1177 }
1178 
1179 static const authz_provider authz_perl_provider = { perl_check_authorization,
1180                                                     perl_parse_require_line };
1181 
1182 static const authn_provider authn_perl_provider = { perl_check_password,
1183                                                     perl_get_realm_hash };
1184 
register_auth_provider(apr_pool_t * pool,const char * provider_group,const char * provider_name,const char * provider_version,auth_callback * ab,int type)1185 static apr_status_t register_auth_provider(apr_pool_t *pool,
1186                                            const char *provider_group,
1187                                            const char *provider_name,
1188                                            const char *provider_version,
1189                                            auth_callback *ab, int type)
1190 {
1191     void *provider_ = NULL;
1192 
1193     if (global_authz_providers == NULL) {
1194         global_authz_providers = apr_hash_make(pool);
1195         global_authn_providers = apr_hash_make(pool);
1196         /* We have to use pre_cleanup here, otherwise this cleanup method
1197          * would be called after another cleanup method which unloads
1198          * mod_perl module.
1199          */
1200         apr_pool_pre_cleanup_register(pool, NULL,
1201                                       cleanup_perl_global_providers);
1202     }
1203 
1204     if (strcmp(provider_group, AUTHZ_PROVIDER_GROUP) == 0) {
1205         provider_ = (void *) &authz_perl_provider;
1206         apr_hash_set(global_authz_providers, provider_name,
1207                      APR_HASH_KEY_STRING, ab);
1208     }
1209     else {
1210         provider_ = (void *) &authn_perl_provider;
1211         apr_hash_set(global_authn_providers, provider_name,
1212                      APR_HASH_KEY_STRING, ab);
1213     }
1214 
1215     return ap_register_auth_provider(pool, provider_group, provider_name,
1216                                      provider_version, provider_, type);
1217 
1218 }
1219 
modperl_register_auth_provider(apr_pool_t * pool,const char * provider_group,const char * provider_name,const char * provider_version,SV * callback1,SV * callback2,int type)1220 apr_status_t modperl_register_auth_provider(apr_pool_t *pool,
1221                                             const char *provider_group,
1222                                             const char *provider_name,
1223                                             const char *provider_version,
1224                                             SV *callback1, SV *callback2,
1225                                             int type)
1226 {
1227     char *provider_name_dup;
1228     auth_callback *ab = NULL;
1229 
1230     provider_name_dup = apr_pstrdup(pool, provider_name);
1231     ab = apr_pcalloc(pool, sizeof(auth_callback));
1232     ab->cb1 = callback1;
1233     ab->cb2 = callback2;
1234 
1235     return register_auth_provider(pool, provider_group, provider_name_dup,
1236                                   provider_version, ab, type);
1237 }
1238 
modperl_register_auth_provider_name(apr_pool_t * pool,const char * provider_group,const char * provider_name,const char * provider_version,const char * callback1,const char * callback2,int type)1239 apr_status_t modperl_register_auth_provider_name(apr_pool_t *pool,
1240                                                  const char *provider_group,
1241                                                  const char *provider_name,
1242                                                  const char *provider_version,
1243                                                  const char *callback1,
1244                                                  const char *callback2,
1245                                                  int type)
1246 {
1247     char *provider_name_dup;
1248     auth_callback *ab = NULL;
1249 
1250     provider_name_dup = apr_pstrdup(pool, provider_name);
1251     ab = apr_pcalloc(pool, sizeof(auth_callback));
1252     ab->cb1_handler = modperl_handler_new(pool, callback1);
1253     if (callback2) {
1254         ab->cb2_handler = modperl_handler_new(pool, callback2);
1255     }
1256 
1257     return register_auth_provider(pool, provider_group, provider_name_dup,
1258                                   provider_version, ab, type);
1259 }
1260 
1261 #endif /* httpd-2.4 */
1262 
1263 /*
1264  * Local Variables:
1265  * c-basic-offset: 4
1266  * indent-tabs-mode: nil
1267  * End:
1268  */
1269