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