1 /*******************************************************************************
2 *
3 * MODULE: hook.c
4 *
5 ********************************************************************************
6 *
7 * DESCRIPTION: C::B::C hooks
8 *
9 ********************************************************************************
10 *
11 * Copyright (c) 2002-2020 Marcus Holland-Moritz. All rights reserved.
12 * This program is free software; you can redistribute it and/or modify
13 * it under the same terms as Perl itself.
14 *
15 *******************************************************************************/
16
17 /*===== GLOBAL INCLUDES ======================================================*/
18
19 #define PERL_NO_GET_CONTEXT
20 #include <EXTERN.h>
21 #include <perl.h>
22 #include <XSUB.h>
23
24 #include "ppport.h"
25
26
27 /*===== LOCAL INCLUDES =======================================================*/
28
29 #include "cbc/cbc.h"
30 #include "cbc/hook.h"
31 #include "cbc/util.h"
32
33
34 /*===== DEFINES ==============================================================*/
35
36 /*===== TYPEDEFS =============================================================*/
37
38 /*===== STATIC FUNCTION PROTOTYPES ===========================================*/
39
40 static void single_hook_deref(pTHX_ const SingleHook *hook);
41 static void single_hook_ref(pTHX_ const SingleHook *hook);
42
43
44 /*===== EXTERNAL VARIABLES ===================================================*/
45
46 /*===== GLOBAL VARIABLES =====================================================*/
47
48 /*===== STATIC VARIABLES =====================================================*/
49
50 /*===== STATIC FUNCTIONS =====================================================*/
51
52 #include "token/t_hookid.c"
53
54 /*******************************************************************************
55 *
56 * ROUTINE: single_hook_deref
57 *
58 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2006
59 * CHANGED BY: ON:
60 *
61 ********************************************************************************
62 *
63 * DESCRIPTION:
64 *
65 * ARGUMENTS:
66 *
67 * RETURNS:
68 *
69 *******************************************************************************/
70
single_hook_deref(pTHX_ const SingleHook * hook)71 static void single_hook_deref(pTHX_ const SingleHook *hook)
72 {
73 assert(hook != NULL);
74
75 if (hook->sub)
76 SvREFCNT_dec(hook->sub);
77
78 if (hook->arg)
79 SvREFCNT_dec(hook->arg);
80 }
81
82 /*******************************************************************************
83 *
84 * ROUTINE: single_hook_ref
85 *
86 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2006
87 * CHANGED BY: ON:
88 *
89 ********************************************************************************
90 *
91 * DESCRIPTION:
92 *
93 * ARGUMENTS:
94 *
95 * RETURNS:
96 *
97 *******************************************************************************/
98
single_hook_ref(pTHX_ const SingleHook * hook)99 static void single_hook_ref(pTHX_ const SingleHook *hook)
100 {
101 assert(hook != NULL);
102
103 if (hook->sub)
104 SvREFCNT_inc(hook->sub);
105
106 if (hook->arg)
107 SvREFCNT_inc(hook->arg);
108 }
109
110
111 /*===== FUNCTIONS ============================================================*/
112
113 /*******************************************************************************
114 *
115 * ROUTINE: single_hook_fill
116 *
117 * WRITTEN BY: Marcus Holland-Moritz ON: Jun 2004
118 * CHANGED BY: ON:
119 *
120 ********************************************************************************
121 *
122 * DESCRIPTION:
123 *
124 * ARGUMENTS:
125 *
126 * RETURNS:
127 *
128 *******************************************************************************/
129
single_hook_fill(pTHX_ const char * hook,const char * type,SingleHook * sth,SV * sub,U32 allowed_args)130 void single_hook_fill(pTHX_ const char *hook, const char *type, SingleHook *sth,
131 SV *sub, U32 allowed_args)
132 {
133 if (!DEFINED(sub))
134 {
135 sth->sub = NULL;
136 sth->arg = NULL;
137 }
138 else if (SvROK(sub))
139 {
140 SV *sv = SvRV(sub);
141
142 switch (SvTYPE(sv))
143 {
144 case SVt_PVCV:
145 sth->sub = sv;
146 sth->arg = NULL;
147 break;
148
149 case SVt_PVAV:
150 {
151 AV *in = (AV *) sv;
152 I32 len = av_len(in);
153
154 if (len < 0)
155 Perl_croak(aTHX_ "Need at least a code reference in %s hook for "
156 "type '%s'", hook, type);
157 else
158 {
159 SV **pSV = av_fetch(in, 0, 0);
160
161 if (pSV == NULL || !SvROK(*pSV) ||
162 SvTYPE(sv = SvRV(*pSV)) != SVt_PVCV)
163 Perl_croak(aTHX_ "%s hook defined for '%s' is not "
164 "a code reference", hook, type);
165 else
166 {
167 I32 ix;
168 AV *out;
169
170 for (ix = 0; ix < len; ++ix)
171 {
172 pSV = av_fetch(in, ix+1, 0);
173
174 if (pSV == NULL)
175 fatal("NULL returned by av_fetch() in single_hook_fill()");
176
177 if (SvROK(*pSV) && sv_isa(*pSV, ARGTYPE_PACKAGE))
178 {
179 HookArgType argtype = (HookArgType) SvIV(SvRV(*pSV));
180
181 #define CHECK_ARG_TYPE(type) \
182 case HOOK_ARG_ ## type: \
183 if ((allowed_args & SHF_ALLOW_ARG_ ## type) == 0) \
184 Perl_croak(aTHX_ #type " argument not allowed"); \
185 break
186
187 switch (argtype)
188 {
189 CHECK_ARG_TYPE(SELF);
190 CHECK_ARG_TYPE(TYPE);
191 CHECK_ARG_TYPE(DATA);
192 CHECK_ARG_TYPE(HOOK);
193 }
194
195 #undef CHECK_ARG_TYPE
196 }
197 }
198
199 sth->sub = sv;
200
201 out = newAV();
202 av_extend(out, len-1);
203
204 for (ix = 0; ix < len; ++ix)
205 {
206 pSV = av_fetch(in, ix+1, 0);
207
208 if (pSV == NULL)
209 fatal("NULL returned by av_fetch() in single_hook_fill()");
210
211 SvREFCNT_inc(*pSV);
212
213 if (av_store(out, ix, *pSV) == NULL)
214 SvREFCNT_dec(*pSV);
215 }
216
217 sth->arg = (AV *) sv_2mortal((SV *) out);
218 }
219 }
220 }
221 break;
222
223 default:
224 goto not_code_or_array_ref;
225 }
226 }
227 else
228 {
229 not_code_or_array_ref:
230 Perl_croak(aTHX_ "%s hook defined for '%s' is not "
231 "a code or array reference", hook, type);
232 }
233 }
234
235 /*******************************************************************************
236 *
237 * ROUTINE: single_hook_new
238 *
239 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2006
240 * CHANGED BY: ON:
241 *
242 ********************************************************************************
243 *
244 * DESCRIPTION:
245 *
246 * ARGUMENTS:
247 *
248 * RETURNS:
249 *
250 *******************************************************************************/
251
single_hook_new(const SingleHook * src)252 SingleHook *single_hook_new(const SingleHook *src)
253 {
254 dTHX;
255 SingleHook *dst;
256
257 assert(src != NULL);
258
259 New(0, dst, 1, SingleHook);
260
261 *dst = *src;
262
263 single_hook_ref(aTHX_ src);
264
265 return dst;
266 }
267
268 /*******************************************************************************
269 *
270 * ROUTINE: hook_new
271 *
272 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2004
273 * CHANGED BY: ON:
274 *
275 ********************************************************************************
276 *
277 * DESCRIPTION:
278 *
279 * ARGUMENTS:
280 *
281 * RETURNS:
282 *
283 *******************************************************************************/
284
hook_new(const TypeHooks * h)285 TypeHooks *hook_new(const TypeHooks *h)
286 {
287 dTHX;
288 TypeHooks *r;
289 SingleHook *dst;
290 int i;
291
292 New(0, r, 1, TypeHooks);
293
294 dst = &r->hooks[0];
295
296 if (h)
297 {
298 const SingleHook *src = &h->hooks[0];
299
300 for (i = 0; i < HOOKID_COUNT; i++, src++, dst++)
301 {
302 *dst = *src;
303
304 single_hook_ref(aTHX_ src);
305 }
306 }
307 else
308 {
309 for (i = 0; i < HOOKID_COUNT; i++, dst++)
310 {
311 dst->sub = NULL;
312 dst->arg = NULL;
313 }
314 }
315
316 return r;
317 }
318
319 /*******************************************************************************
320 *
321 * ROUTINE: single_hook_update
322 *
323 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2006
324 * CHANGED BY: ON:
325 *
326 ********************************************************************************
327 *
328 * DESCRIPTION:
329 *
330 * ARGUMENTS:
331 *
332 * RETURNS:
333 *
334 *******************************************************************************/
335
single_hook_update(SingleHook * dst,const SingleHook * src)336 void single_hook_update(SingleHook *dst, const SingleHook *src)
337 {
338 dTHX;
339
340 assert(src != NULL);
341 assert(dst != NULL);
342
343 if (dst->sub != src->sub)
344 {
345 if (src->sub)
346 SvREFCNT_inc(src->sub);
347 if (dst->sub)
348 SvREFCNT_dec(dst->sub);
349 }
350
351 if (dst->arg != src->arg)
352 {
353 if (src->arg)
354 SvREFCNT_inc(src->arg);
355 if (dst->arg)
356 SvREFCNT_dec(dst->arg);
357 }
358
359 *dst = *src;
360 }
361
362 /*******************************************************************************
363 *
364 * ROUTINE: hook_update
365 *
366 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2004
367 * CHANGED BY: ON:
368 *
369 ********************************************************************************
370 *
371 * DESCRIPTION:
372 *
373 * ARGUMENTS:
374 *
375 * RETURNS:
376 *
377 *******************************************************************************/
378
hook_update(TypeHooks * dst,const TypeHooks * src)379 void hook_update(TypeHooks *dst, const TypeHooks *src)
380 {
381 dTHX;
382 const SingleHook *hook_src = &src->hooks[0];
383 SingleHook *hook_dst = &dst->hooks[0];
384 int i;
385
386 assert(src != NULL);
387 assert(dst != NULL);
388
389 for (i = 0; i < HOOKID_COUNT; i++, hook_dst++, hook_src++)
390 single_hook_update(hook_dst, hook_src);
391 }
392
393 /*******************************************************************************
394 *
395 * ROUTINE: single_hook_delete
396 *
397 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2006
398 * CHANGED BY: ON:
399 *
400 ********************************************************************************
401 *
402 * DESCRIPTION:
403 *
404 * ARGUMENTS:
405 *
406 * RETURNS:
407 *
408 *******************************************************************************/
409
single_hook_delete(SingleHook * hook)410 void single_hook_delete(SingleHook *hook)
411 {
412 dTHX;
413
414 assert(hook != NULL);
415
416 single_hook_deref(aTHX_ hook);
417
418 Safefree(hook);
419 }
420
421 /*******************************************************************************
422 *
423 * ROUTINE: hook_delete
424 *
425 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2004
426 * CHANGED BY: ON:
427 *
428 ********************************************************************************
429 *
430 * DESCRIPTION:
431 *
432 * ARGUMENTS:
433 *
434 * RETURNS:
435 *
436 *******************************************************************************/
437
hook_delete(TypeHooks * h)438 void hook_delete(TypeHooks *h)
439 {
440 if (h)
441 {
442 dTHX;
443 SingleHook *hook = &h->hooks[0];
444 int i;
445
446 for (i = 0; i < HOOKID_COUNT; i++, hook++)
447 single_hook_deref(aTHX_ hook);
448
449 Safefree(h);
450 }
451 }
452
453 /*******************************************************************************
454 *
455 * ROUTINE: single_hook_call
456 *
457 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2006
458 * CHANGED BY: ON:
459 *
460 ********************************************************************************
461 *
462 * DESCRIPTION:
463 *
464 * ARGUMENTS:
465 *
466 * RETURNS:
467 *
468 *******************************************************************************/
469
470 /* TODO: The hook_call interface is a little ugly, mainly because we cannot
471 * directly influence the arguments. This should probably be refactored.
472 */
473
single_hook_call(pTHX_ SV * self,const char * hook_id_str,const char * id_pre,const char * id,const SingleHook * hook,SV * in,int mortal)474 SV *single_hook_call(pTHX_ SV *self, const char *hook_id_str, const char *id_pre,
475 const char *id, const SingleHook *hook, SV *in, int mortal)
476 {
477 dSP;
478 int count;
479 SV *out;
480
481 CT_DEBUG(MAIN, ("single_hook_call(hid='%s', id='%s%s', hook=%p, in=%p(%d), mortal=%d)",
482 hook_id_str, id_pre, id, hook, in, in ? (int) SvREFCNT(in) : 0, mortal));
483
484 assert(self != NULL);
485 assert(hook != NULL);
486
487 if (hook->sub == NULL)
488 return in;
489
490 ENTER;
491 SAVETMPS;
492
493 PUSHMARK(SP);
494
495 if (hook->arg)
496 {
497 I32 ix, len;
498 len = av_len(hook->arg);
499
500 for (ix = 0; ix <= len; ++ix)
501 {
502 SV **pSV = av_fetch(hook->arg, ix, 0);
503 SV *sv;
504
505 if (pSV == NULL)
506 fatal("NULL returned by av_fetch() in single_hook_call()");
507
508 if (SvROK(*pSV) && sv_isa(*pSV, ARGTYPE_PACKAGE))
509 {
510 HookArgType type = (HookArgType) SvIV(SvRV(*pSV));
511
512 switch (type)
513 {
514 case HOOK_ARG_SELF:
515 sv = sv_mortalcopy(self);
516 break;
517
518 case HOOK_ARG_DATA:
519 assert(in != NULL);
520 sv = sv_mortalcopy(in);
521 break;
522
523 case HOOK_ARG_TYPE:
524 assert(id != NULL);
525 sv = sv_newmortal();
526 if (id_pre)
527 {
528 sv_setpv(sv, id_pre);
529 sv_catpv(sv, CONST_CHAR(id));
530 }
531 else
532 sv_setpv(sv, id);
533 break;
534
535 case HOOK_ARG_HOOK:
536 if (hook_id_str)
537 {
538 sv = sv_newmortal();
539 sv_setpv(sv, hook_id_str);
540 }
541 else
542 {
543 sv = &PL_sv_undef;
544 }
545 break;
546
547 default:
548 fatal("Invalid hook argument type (%d) in single_hook_call()", type);
549 break;
550 }
551 }
552 else
553 sv = sv_mortalcopy(*pSV);
554
555 XPUSHs(sv);
556 }
557 }
558 else
559 {
560 if (in)
561 {
562 /* only push the data argument */
563 XPUSHs(in);
564 }
565 }
566
567 PUTBACK;
568
569 count = call_sv(hook->sub, G_SCALAR);
570
571 SPAGAIN;
572
573 if (count != 1)
574 fatal("Hook returned %d elements instead of 1", count);
575
576 out = POPs;
577
578 CT_DEBUG(MAIN, ("single_hook_call: in=%p(%d), out=%p(%d)",
579 in, in ? (int) SvREFCNT(in) : 0, out, (int) SvREFCNT(out)));
580
581 if (!mortal && in != NULL)
582 SvREFCNT_dec(in);
583 SvREFCNT_inc(out);
584
585 PUTBACK;
586 FREETMPS;
587 LEAVE;
588
589 if (mortal)
590 sv_2mortal(out);
591
592 CT_DEBUG(MAIN, ("single_hook_call: out=%p(%d)", out, (int) SvREFCNT(out)));
593
594 return out;
595 }
596
597 /*******************************************************************************
598 *
599 * ROUTINE: hook_call
600 *
601 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2004
602 * CHANGED BY: ON:
603 *
604 ********************************************************************************
605 *
606 * DESCRIPTION:
607 *
608 * ARGUMENTS:
609 *
610 * RETURNS:
611 *
612 *******************************************************************************/
613
hook_call(pTHX_ SV * self,const char * id_pre,const char * id,const TypeHooks * pTH,enum HookId hook_id,SV * in,int mortal)614 SV *hook_call(pTHX_ SV *self, const char *id_pre, const char *id,
615 const TypeHooks *pTH, enum HookId hook_id, SV *in, int mortal)
616 {
617 CT_DEBUG(MAIN, ("hook_call(id='%s%s', pTH=%p, in=%p(%d), mortal=%d)",
618 id_pre, id, pTH, in, (int) SvREFCNT(in), mortal));
619
620 assert(self != NULL);
621 assert(pTH != NULL);
622 assert(id != NULL);
623 assert(in != NULL);
624
625 return single_hook_call(aTHX_ self, gs_HookIdStr[hook_id], id_pre, id,
626 &pTH->hooks[hook_id], in, mortal);
627 }
628
629 /*******************************************************************************
630 *
631 * ROUTINE: find_hooks
632 *
633 * WRITTEN BY: Marcus Holland-Moritz ON: Dec 2004
634 * CHANGED BY: ON:
635 *
636 ********************************************************************************
637 *
638 * DESCRIPTION:
639 *
640 * ARGUMENTS:
641 *
642 * RETURNS:
643 *
644 *******************************************************************************/
645
find_hooks(pTHX_ const char * type,HV * hooks,TypeHooks * pTH)646 int find_hooks(pTHX_ const char *type, HV *hooks, TypeHooks *pTH)
647 {
648 HE *h;
649 int i, num;
650
651 assert(type != NULL);
652 assert(hooks != NULL);
653 assert(pTH != NULL);
654
655 (void) hv_iterinit(hooks);
656
657 while ((h = hv_iternext(hooks)) != NULL)
658 {
659 const char *key;
660 I32 keylen;
661 SV *sub;
662 enum HookId id;
663
664 key = hv_iterkey(h, &keylen);
665 sub = hv_iterval(hooks, h);
666
667 id = get_hook_id(key);
668
669 if (id >= HOOKID_COUNT)
670 {
671 if (id == HOOKID_INVALID)
672 Perl_croak(aTHX_ "Invalid hook type '%s'", key);
673 else
674 fatal("Invalid hook id %d for hook '%s'", id, key);
675 }
676
677 single_hook_fill(aTHX_ key, type, &pTH->hooks[id], sub, SHF_ALLOW_ARG_SELF |
678 SHF_ALLOW_ARG_TYPE |
679 SHF_ALLOW_ARG_DATA |
680 SHF_ALLOW_ARG_HOOK);
681 }
682
683 for (i = num = 0; i < HOOKID_COUNT; i++)
684 if (pTH->hooks[i].sub)
685 num++;
686
687 return num;
688 }
689
690 /*******************************************************************************
691 *
692 * ROUTINE: get_single_hook
693 *
694 * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2006
695 * CHANGED BY: ON:
696 *
697 ********************************************************************************
698 *
699 * DESCRIPTION:
700 *
701 * ARGUMENTS:
702 *
703 * RETURNS:
704 *
705 *******************************************************************************/
706
get_single_hook(pTHX_ const SingleHook * hook)707 SV *get_single_hook(pTHX_ const SingleHook *hook)
708 {
709 SV *sv;
710
711 assert(hook != NULL);
712
713 sv = hook->sub;
714
715 if (sv == NULL)
716 return NULL;
717
718 sv = newRV_inc(sv);
719
720 if (hook->arg)
721 {
722 AV *av = newAV();
723 int j, len = 1 + av_len(hook->arg);
724
725 av_extend(av, len);
726 if (av_store(av, 0, sv) == NULL)
727 fatal("av_store() failed in get_hooks()");
728
729 for (j = 0; j < len; j++)
730 {
731 SV **pSV = av_fetch(hook->arg, j, 0);
732
733 if (pSV == NULL)
734 fatal("NULL returned by av_fetch() in get_hooks()");
735
736 SvREFCNT_inc(*pSV);
737
738 if (av_store(av, j+1, *pSV) == NULL)
739 fatal("av_store() failed in get_hooks()");
740 }
741
742 sv = newRV_noinc((SV *) av);
743 }
744
745 return sv;
746 }
747
748 /*******************************************************************************
749 *
750 * ROUTINE: get_hooks
751 *
752 * WRITTEN BY: Marcus Holland-Moritz ON: Dec 2004
753 * CHANGED BY: ON:
754 *
755 ********************************************************************************
756 *
757 * DESCRIPTION:
758 *
759 * ARGUMENTS:
760 *
761 * RETURNS:
762 *
763 *******************************************************************************/
764
get_hooks(pTHX_ const TypeHooks * pTH)765 HV *get_hooks(pTHX_ const TypeHooks *pTH)
766 {
767 int i;
768 HV *hv = newHV();
769
770 assert(pTH != NULL);
771
772 for (i = 0; i < HOOKID_COUNT; i++)
773 {
774 SV *sv = get_single_hook(aTHX_ &pTH->hooks[i]);
775 const char *id;
776
777 if (sv == NULL)
778 continue;
779
780 id = gs_HookIdStr[i];
781
782 if (hv_store(hv, id, strlen(id), sv, 0) == 0)
783 fatal("hv_store() failed in get_hooks()");
784 }
785
786 return hv;
787 }
788
789