search

Perl / perl5

🐪 The Perl programming language
https://dev.perl.org/perl5/
Other
1.96k stars 556 forks source link

[PATCH] Compile-time hooks into lexical scoping #10474

Closed p5pRT closed 14 years ago

p5pRT commented 14 years ago

Migrated from rt.perl.org#76390 (status was 'resolved')

Searchable as RT76390$

p5pRT commented 14 years ago

From ben@morrow.me.uk

[As requested by Jesse\, I'm forwarding these patches to RT so they don't get lost. For the record\, the patches are against commit 23a23683.]

The attached patches make it possible for extensions to hook into perl's lexical scope mechanism at compile time. This would allow things like my SCOPECHECK and Florian's @​{^COMPILE_SCOPE_CONTAINER} to be implemented as CPAN modules[1]. Usage is like this (from XS)​:

  STATIC void my_start_hook(pTHX_ int full);   STATIC void my_pre_end_hook(pTHX_ OP **o);   STATIC void my_post_end_hook(pTHX_ OP **o);   STATIC void my_eval_hook(pTHX_ OP *const o);   STATIC BHK my_hooks;

  BOOT​:   BhkENTRY_set(&my_hooks\, start\, my_start_hook);   BhkENTRY_set(&my_hooks\, pre_end\, my_pre_end_hook);   BhkENTRY_set(&my_hooks\, post_end\, my_post_end_hook);   BhkENTRY_set(&my_hooks\, eval\, my_eval_hook);   Perl_blockhook_register(aTHX_ &my_hooks);

This will cause

  - my_start_hook to be called at the start of compiling every lexical   scope\, with the 'full' parameter from Perl_block_start.

  - my_pre_end_hook to be called at the end of compiling every lexical   scope\, *before* the compile-time stack is unwound\, with o pointing   to the root OP for the scope. It is a double pointer so the hook   can substitute a different OP if it needs to.

  - my_post_end_hook to be called *after* the stack is unwound.

  - my_eval_hook to be called just before compiling an   eval/do/require\, with o set to the OP that requested the eval.

The patches are rebased against current blead\, and the branch has been pushed to http​://github.com/mauzo/perl/tree/blockhooks . I hope including a whole lot of patches in one mail like this is OK​: it seemed easier than separate mails for each patch\, since they all go together.

Ben

[1] Implementing the rest of the Perl 6 blocks on CPAN would require at least one more patch\, to allow extensions to create pad entries.

p5pRT commented 14 years ago

From ben@morrow.me.uk

0001-Generic-hooks-into-Perl_block_-start-end.patch ```diff From 52cb37bfb29a85e4a69cf316a48a12fde59ddedb Mon Sep 17 00:00:00 2001 From: Ben Morrow Date: Thu, 26 Nov 2009 17:18:29 +0000 Subject: [PATCH 1/8] Generic hooks into Perl_block_{start,end}. These take the form of a vtable pushed onto the new PL_blockhooks array. This could probably do with a API around it later. Separate pre_end and post_end hooks are needed to capture globals before the stack is unwound (like needblockscope in the existing code). The intention is that once a vtable is installed it never gets removed, so where necessary extensions using this will need to use a hinthv element to determine whether to do anything or not. --- embedvar.h | 2 ++ intrpvar.h | 3 +++ op.c | 14 ++++++++++++-- op.h | 26 ++++++++++++++++++++++++++ perlapi.h | 2 ++ sv.c | 1 + 6 files changed, 46 insertions(+), 2 deletions(-) diff --git a/embedvar.h b/embedvar.h index 63ed46e..51d136b 100644 --- a/embedvar.h +++ b/embedvar.h @@ -71,6 +71,7 @@ #define PL_basetime (vTHX->Ibasetime) #define PL_beginav (vTHX->Ibeginav) #define PL_beginav_save (vTHX->Ibeginav_save) +#define PL_blockhooks (vTHX->Iblockhooks) #define PL_body_arenas (vTHX->Ibody_arenas) #define PL_body_roots (vTHX->Ibody_roots) #define PL_bodytarget (vTHX->Ibodytarget) @@ -398,6 +399,7 @@ #define PL_Ibasetime PL_basetime #define PL_Ibeginav PL_beginav #define PL_Ibeginav_save PL_beginav_save +#define PL_Iblockhooks PL_blockhooks #define PL_Ibody_arenas PL_body_arenas #define PL_Ibody_roots PL_body_roots #define PL_Ibodytarget PL_bodytarget diff --git a/intrpvar.h b/intrpvar.h index 8fe641c..2e2e42e 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -719,6 +719,9 @@ PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */ retrieve a C */ PERLVAR(Iregistered_mros, HV *) +/* Compile-time block start/end hooks */ +PERLVAR(Iblockhooks, AV *) + /* If you are adding a U8 or U16, check to see if there are 'Space' comments * above on where there are gaps which currently will be structure padding. */ diff --git a/op.c b/op.c index 76eb16f..87b01b0 100644 --- a/op.c +++ b/op.c @@ -2287,17 +2287,21 @@ Perl_scope(pTHX_ OP *o) } return o; } - + int Perl_block_start(pTHX_ int full) { dVAR; const int retval = PL_savestack_ix; + pad_block_start(full); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; SAVECOMPILEWARNINGS(); PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); + + CALL_BLOCK_HOOKS(start, full); + return retval; } @@ -2306,12 +2310,18 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) { dVAR; const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; - OP* const retval = scalarseq(seq); + OP* retval = scalarseq(seq); + + CALL_BLOCK_HOOKS(pre_end, &retval); + LEAVE_SCOPE(floor); CopHINTS_set(&PL_compiling, PL_hints); if (needblockscope) PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ pad_leavemy(); + + CALL_BLOCK_HOOKS(post_end, &retval); + return retval; } diff --git a/op.h b/op.h index 2109891..4b5a686 100644 --- a/op.h +++ b/op.h @@ -641,6 +641,32 @@ struct loop { #define FreeOp(p) PerlMemShared_free(p) #endif +struct block_hooks { + void (*bhk_start) (pTHX_ int full); + void (*bhk_pre_end) (pTHX_ OP **seq); + void (*bhk_post_end) (pTHX_ OP **seq); +}; + +#define CALL_BLOCK_HOOKS(which, arg) \ + STMT_START { \ + if (PL_blockhooks) { \ + I32 i; \ + for (i = av_len(PL_blockhooks); i >= 0; i--) { \ + SV *sv = AvARRAY(PL_blockhooks)[i]; \ + struct block_hooks *hk; \ + \ + assert(SvIOK(sv)); \ + if (SvUOK(sv)) \ + hk = INT2PTR(struct block_hooks *, SvUVX(sv)); \ + else \ + hk = INT2PTR(struct block_hooks *, SvIVX(sv)); \ + \ + if (hk->bhk_ ## which) \ + CALL_FPTR(hk->bhk_ ## which)(aTHX_ arg); \ + } \ + } \ + } STMT_END + #ifdef PERL_MAD # define MAD_NULL 1 # define MAD_PV 2 diff --git a/perlapi.h b/perlapi.h index 54ddab0..56caf8c 100644 --- a/perlapi.h +++ b/perlapi.h @@ -178,6 +178,8 @@ END_EXTERN_C #define PL_beginav (*Perl_Ibeginav_ptr(aTHX)) #undef PL_beginav_save #define PL_beginav_save (*Perl_Ibeginav_save_ptr(aTHX)) +#undef PL_blockhooks +#define PL_blockhooks (*Perl_Iblockhooks_ptr(aTHX)) #undef PL_body_arenas #define PL_body_arenas (*Perl_Ibody_arenas_ptr(aTHX)) #undef PL_body_roots diff --git a/sv.c b/sv.c index 21d0a8e..45d2672 100644 --- a/sv.c +++ b/sv.c @@ -12534,6 +12534,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param); + PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param); /* Call the ->CLONE method, if it exists, for each of the stashes identified by sv_dup() above. -- 1.6.6.1 ```
p5pRT commented 14 years ago

From ben@morrow.me.uk

0002-Initial-very-basic-tests-for-PL_blockhooks.patch ```diff From a84c297ec183185710342cedd1cd1ba917fcf57e Mon Sep 17 00:00:00 2001 From: Ben Morrow Date: Thu, 26 Nov 2009 17:22:22 +0000 Subject: [PATCH 2/8] Initial very basic tests for PL_blockhooks. This is taken directly from rafl's @{^COMPILE_SCOPE_CONTAINER} implementation posted on p5p. --- ext/XS-APItest/APItest.xs | 51 +++++++++++++++++++++ ext/XS-APItest/t/blockhooks.t | 98 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 149 insertions(+), 0 deletions(-) create mode 100644 ext/XS-APItest/t/blockhooks.t diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 328ddea..5d55223 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -11,6 +11,8 @@ typedef struct { int i; SV *sv; + GV *cscgv; + AV *cscav; } my_cxt_t; START_MY_CXT @@ -240,6 +242,44 @@ rmagical_a_dummy(pTHX_ IV idx, SV *sv) { STATIC MGVTBL rmagical_b = { 0 }; +STATIC void +blockhook_start(pTHX_ int full) +{ + dMY_CXT; + AV *const cur = GvAV(MY_CXT.cscgv); + + SAVEGENERICSV(GvAV(MY_CXT.cscgv)); + + if (cur) { + I32 i; + AV *const new = newAV(); + + for (i = 0; i <= av_len(cur); i++) { + av_store(new, i, newSVsv(*av_fetch(cur, i, 0))); + } + + GvAV(MY_CXT.cscgv) = new; + } +} + +STATIC void +blockhook_pre_end(pTHX_ OP **o) +{ + dMY_CXT; + + /* if we hit the end of a scope we missed the start of, we need to + * unconditionally clear @CSC */ + if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) + av_clear(MY_CXT.cscav); + +} + +STATIC struct block_hooks my_block_hooks = { + blockhook_start, + blockhook_pre_end, + NULL +}; + #include "const-c.inc" MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash @@ -554,8 +594,16 @@ PROTOTYPES: DISABLE BOOT: { MY_CXT_INIT; + MY_CXT.i = 99; MY_CXT.sv = newSVpv("initial",0); + MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", + GV_ADD, SVt_PVAV); + MY_CXT.cscav = GvAV(MY_CXT.cscgv); + + if (!PL_blockhooks) + PL_blockhooks = newAV(); + av_push(PL_blockhooks, newSViv(PTR2IV(&my_block_hooks))); } void @@ -563,6 +611,9 @@ CLONE(...) CODE: MY_CXT_CLONE; MY_CXT.sv = newSVpv("initial_clone",0); + MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", + GV_ADD, SVt_PVAV); + MY_CXT.cscav = NULL; void print_double(val) diff --git a/ext/XS-APItest/t/blockhooks.t b/ext/XS-APItest/t/blockhooks.t new file mode 100644 index 0000000..54b3e5c --- /dev/null +++ b/ext/XS-APItest/t/blockhooks.t @@ -0,0 +1,98 @@ +#!./perl + +# Tests for @{^COMPILE_SCOPE_CONTAINER} + +use strict; +use warnings; +use Test::More tests => 12; +use XS::APItest; + +BEGIN { + # this has to be a full glob alias, since the GvAV gets replaced + *COMPILE_SCOPE_CONTAINER = \*XS::APItest::COMPILE_SCOPE_CONTAINER; +} +our @COMPILE_SCOPE_CONTAINER; + +my %destroyed; + +BEGIN { + package CounterObject; + + sub new { + my ($class, $name) = @_; + return bless { name => $name }, $class; + } + + sub name { + my ($self) = @_; + return $self->{name}; + } + + sub DESTROY { + my ($self) = @_; + $destroyed{ $self->name }++; + } + + + package ReplaceCounter; + $INC{'ReplaceCounter.pm'} = __FILE__; + + sub import { + my ($self, $counter) = @_; + $COMPILE_SCOPE_CONTAINER[-1] = CounterObject->new($counter); + } + + package InstallCounter; + $INC{'InstallCounter.pm'} = __FILE__; + + sub import { + my ($class, $counter) = @_; + push @COMPILE_SCOPE_CONTAINER, CounterObject->new($counter); + } + + package TestCounter; + $INC{'TestCounter.pm'} = __FILE__; + + sub import { + my ($class, $counter, $number, $message) = @_; + + $number = 1 + unless defined $number; + $message = "counter $counter is found $number times" + unless defined $message; + + ::is scalar(grep { $_->name eq $counter } @{COMPILE_SCOPE_CONTAINER}), + $number, + $message; + } +} + +{ + use InstallCounter 'root'; + use InstallCounter '3rd-party'; + + { + BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); } + + use ReplaceCounter 'replace'; + + BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); } + + use TestCounter '3rd-party', 0, '3rd-party no longer visible'; + use TestCounter 'replace', 1, 'replacement now visible'; + use TestCounter 'root'; + + BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); } + } + + BEGIN { + ok $destroyed{replace}, 'replacement has been destroyed after end of outer scope'; + } + + use TestCounter 'root', 1, 'root visible again'; + use TestCounter 'replace', 0, 'lower replacement no longer visible'; + use TestCounter '3rd-party'; +} + +ok $destroyed{ $_ }, "$_ has been destroyed after end of outer scope" + for 'root', '3rd-party'; -- 1.6.6.1 ```
p5pRT commented 14 years ago

From ben@morrow.me.uk

0003-Macroify-the-block_hooks-structure.patch ```diff From 50e9a426f7582d590dc92d0f5d9f522c6c0b4418 Mon Sep 17 00:00:00 2001 From: Ben Morrow Date: Mon, 7 Dec 2009 11:52:23 +0000 Subject: [PATCH 3/8] Macroify the block_hooks structure. Add a flags member, so it can be extended later if necessary. Add a bhk_eval member, called from doeval to catch requires and string evals. --- ext/XS-APItest/APItest.xs | 16 ++++++++-------- op.h | 28 +++++++++++++++++++++++----- perl.h | 2 ++ pp_ctl.c | 2 ++ 4 files changed, 35 insertions(+), 13 deletions(-) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 5d55223..f0b872a 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -269,17 +269,12 @@ blockhook_pre_end(pTHX_ OP **o) /* if we hit the end of a scope we missed the start of, we need to * unconditionally clear @CSC */ - if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) + if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) { av_clear(MY_CXT.cscav); + } } -STATIC struct block_hooks my_block_hooks = { - blockhook_start, - blockhook_pre_end, - NULL -}; - #include "const-c.inc" MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash @@ -593,6 +588,7 @@ PROTOTYPES: DISABLE BOOT: { + BHK *bhk; MY_CXT_INIT; MY_CXT.i = 99; @@ -601,9 +597,13 @@ BOOT: GV_ADD, SVt_PVAV); MY_CXT.cscav = GvAV(MY_CXT.cscgv); + Newxz(bhk, 1, BHK); + BhkENTRY_set(bhk, start, blockhook_start); + BhkENTRY_set(bhk, pre_end, blockhook_pre_end); + if (!PL_blockhooks) PL_blockhooks = newAV(); - av_push(PL_blockhooks, newSViv(PTR2IV(&my_block_hooks))); + av_push(PL_blockhooks, newSViv(PTR2IV(bhk))); } void diff --git a/op.h b/op.h index 4b5a686..0b891a6 100644 --- a/op.h +++ b/op.h @@ -642,27 +642,45 @@ struct loop { #endif struct block_hooks { + U32 bhk_flags; void (*bhk_start) (pTHX_ int full); void (*bhk_pre_end) (pTHX_ OP **seq); void (*bhk_post_end) (pTHX_ OP **seq); + void (*bhk_eval) (pTHX_ OP *const saveop); }; +#define BhkFLAGS(hk) ((hk)->bhk_flags) + +#define BHKf_start 0x01 +#define BHKf_pre_end 0x02 +#define BHKf_post_end 0x04 +#define BHKf_eval 0x08 + +#define BhkENTRY(hk, which) \ + ((BhkFLAGS(hk) & BHKf_ ## which) ? ((hk)->bhk_ ## which) : NULL) + +#define BhkENTRY_set(hk, which, ptr) \ + STMT_START { \ + (hk)->bhk_ ## which = ptr; \ + (hk)->bhk_flags |= BHKf_ ## which; \ + } STMT_END + #define CALL_BLOCK_HOOKS(which, arg) \ STMT_START { \ if (PL_blockhooks) { \ I32 i; \ for (i = av_len(PL_blockhooks); i >= 0; i--) { \ SV *sv = AvARRAY(PL_blockhooks)[i]; \ - struct block_hooks *hk; \ + BHK *hk; \ \ assert(SvIOK(sv)); \ if (SvUOK(sv)) \ - hk = INT2PTR(struct block_hooks *, SvUVX(sv)); \ + hk = INT2PTR(BHK *, SvUVX(sv)); \ else \ - hk = INT2PTR(struct block_hooks *, SvIVX(sv)); \ + hk = INT2PTR(BHK *, SvIVX(sv)); \ \ - if (hk->bhk_ ## which) \ - CALL_FPTR(hk->bhk_ ## which)(aTHX_ arg); \ + if (BhkENTRY(hk, which)) \ + CALL_FPTR(BhkENTRY(hk, which))(aTHX_ arg); \ } \ } \ } STMT_END diff --git a/perl.h b/perl.h index 960ba1a..380a344 100644 --- a/perl.h +++ b/perl.h @@ -2385,6 +2385,8 @@ typedef struct padop PADOP; typedef struct pvop PVOP; typedef struct loop LOOP; +typedef struct block_hooks BHK; + typedef struct interpreter PerlInterpreter; /* Amdahl's has struct sv */ diff --git a/pp_ctl.c b/pp_ctl.c index d62d58a..40b3b23 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3151,6 +3151,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) else CLEAR_ERRSV(); + CALL_BLOCK_HOOKS(eval, saveop); + /* note that yyparse() may raise an exception, e.g. C, * so honour CATCH_GET and trap it here if necessary */ -- 1.6.6.1 ```
p5pRT commented 14 years ago

From ben@morrow.me.uk

0004-Wrap-PL_blockhooks-in-an-API-function.patch ```diff From f36bc7c737d680b78836e86288d53cbf94c0b01d Mon Sep 17 00:00:00 2001 From: Ben Morrow Date: Mon, 7 Dec 2009 12:55:57 +0000 Subject: [PATCH 4/8] Wrap PL_blockhooks in an API function. This should help prevent people from thinking they can get cute with the contents. --- embed.fnc | 1 + embed.h | 4 ++++ ext/XS-APItest/APItest.xs | 5 +---- global.sym | 1 + op.c | 8 ++++++++ proto.h | 5 +++++ 6 files changed, 20 insertions(+), 4 deletions(-) diff --git a/embed.fnc b/embed.fnc index f93d27c..113a43d 100644 --- a/embed.fnc +++ b/embed.fnc @@ -212,6 +212,7 @@ pR |OP* |block_end |I32 floor|NULLOK OP* seq ApR |I32 |block_gimme : Used in perly.y pR |int |block_start |int full +Aop |void |blockhook_register |NN BHK *hk : Used in perl.c p |void |boot_core_UNIVERSAL : Used in perl.c diff --git a/embed.h b/embed.h index 663cb6b..e1440c4 100644 --- a/embed.h +++ b/embed.h @@ -84,6 +84,8 @@ #define block_gimme Perl_block_gimme #ifdef PERL_CORE #define block_start Perl_block_start +#endif +#ifdef PERL_CORE #define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL #define boot_core_PerlIO Perl_boot_core_PerlIO #endif @@ -2501,6 +2503,8 @@ #define block_gimme() Perl_block_gimme(aTHX) #ifdef PERL_CORE #define block_start(a) Perl_block_start(aTHX_ a) +#endif +#ifdef PERL_CORE #define boot_core_UNIVERSAL() Perl_boot_core_UNIVERSAL(aTHX) #define boot_core_PerlIO() Perl_boot_core_PerlIO(aTHX) #endif diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index f0b872a..3d2041f 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -600,10 +600,7 @@ BOOT: Newxz(bhk, 1, BHK); BhkENTRY_set(bhk, start, blockhook_start); BhkENTRY_set(bhk, pre_end, blockhook_pre_end); - - if (!PL_blockhooks) - PL_blockhooks = newAV(); - av_push(PL_blockhooks, newSViv(PTR2IV(bhk))); + Perl_blockhook_register(aTHX_ bhk); } void diff --git a/global.sym b/global.sym index 7788338..edf97fa 100644 --- a/global.sym +++ b/global.sym @@ -54,6 +54,7 @@ Perl_av_unshift Perl_av_arylen_p Perl_av_iter_p Perl_block_gimme +Perl_blockhook_register Perl_call_list Perl_cast_ulong Perl_cast_i32 diff --git a/op.c b/op.c index 87b01b0..2e5e407 100644 --- a/op.c +++ b/op.c @@ -2325,6 +2325,14 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) return retval; } +void +Perl_blockhook_register(pTHX_ BHK *hk) +{ + PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER; + + Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk))); +} + STATIC OP * S_newDEFSVOP(pTHX) { diff --git a/proto.h b/proto.h index 979076f..47e2457 100644 --- a/proto.h +++ b/proto.h @@ -287,6 +287,11 @@ PERL_CALLCONV I32 Perl_block_gimme(pTHX) PERL_CALLCONV int Perl_block_start(pTHX_ int full) __attribute__warn_unused_result__; +PERL_CALLCONV void Perl_blockhook_register(pTHX_ BHK *hk) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER \ + assert(hk) + PERL_CALLCONV void Perl_boot_core_UNIVERSAL(pTHX); PERL_CALLCONV void Perl_boot_core_PerlIO(pTHX); PERL_CALLCONV void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) -- 1.6.6.1 ```
p5pRT commented 14 years ago

From ben@morrow.me.uk

0005-Systematic-tests-for-the-block-hooks.patch ```diff From c5369a7c7a58a0abebe65f17de758e4067397d61 Mon Sep 17 00:00:00 2001 From: Ben Morrow Date: Mon, 7 Dec 2009 19:00:04 +0000 Subject: [PATCH 5/8] Systematic tests for the block hooks. I've left the dummy implementation of @{^C_S_C} in, as it's actually useful for some of the other tests. (Something simpler would work just as well, of course.) --- ext/XS-APItest/APItest.xs | 86 +++++++++- ext/XS-APItest/t/BHK.pm | 16 ++ ext/XS-APItest/t/Block.pm | 2 + ext/XS-APItest/t/Markers.pm | 13 ++ ext/XS-APItest/t/Null.pm | 1 + ext/XS-APItest/t/blockhooks-csc.t | 98 ++++++++++++ ext/XS-APItest/t/blockhooks.t | 318 +++++++++++++++++++++++++++++-------- 7 files changed, 460 insertions(+), 74 deletions(-) create mode 100644 ext/XS-APItest/t/BHK.pm create mode 100644 ext/XS-APItest/t/Block.pm create mode 100644 ext/XS-APItest/t/Markers.pm create mode 100644 ext/XS-APItest/t/Null.pm create mode 100644 ext/XS-APItest/t/blockhooks-csc.t diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 3d2041f..4ae4e29 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -13,6 +13,8 @@ typedef struct { SV *sv; GV *cscgv; AV *cscav; + AV *bhkav; + bool bhk_record; } my_cxt_t; START_MY_CXT @@ -243,7 +245,7 @@ rmagical_a_dummy(pTHX_ IV idx, SV *sv) { STATIC MGVTBL rmagical_b = { 0 }; STATIC void -blockhook_start(pTHX_ int full) +blockhook_csc_start(pTHX_ int full) { dMY_CXT; AV *const cur = GvAV(MY_CXT.cscgv); @@ -263,7 +265,7 @@ blockhook_start(pTHX_ int full) } STATIC void -blockhook_pre_end(pTHX_ OP **o) +blockhook_csc_pre_end(pTHX_ OP **o) { dMY_CXT; @@ -275,6 +277,54 @@ blockhook_pre_end(pTHX_ OP **o) } +STATIC void +blockhook_test_start(pTHX_ int full) +{ + dMY_CXT; + AV *av; + + if (MY_CXT.bhk_record) { + av = newAV(); + av_push(av, newSVpvs("start")); + av_push(av, newSViv(full)); + av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av))); + } +} + +STATIC void +blockhook_test_pre_end(pTHX_ OP **o) +{ + dMY_CXT; + + if (MY_CXT.bhk_record) + av_push(MY_CXT.bhkav, newSVpvs("pre_end")); +} + +STATIC void +blockhook_test_post_end(pTHX_ OP **o) +{ + dMY_CXT; + + if (MY_CXT.bhk_record) + av_push(MY_CXT.bhkav, newSVpvs("post_end")); +} + +STATIC void +blockhook_test_eval(pTHX_ OP *const o) +{ + dMY_CXT; + AV *av; + + if (MY_CXT.bhk_record) { + av = newAV(); + av_push(av, newSVpvs("eval")); + av_push(av, newSVpv(OP_NAME(o), 0)); + av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av))); + } +} + +STATIC BHK bhk_csc, bhk_test; + #include "const-c.inc" MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash @@ -588,19 +638,27 @@ PROTOTYPES: DISABLE BOOT: { - BHK *bhk; MY_CXT_INIT; MY_CXT.i = 99; MY_CXT.sv = newSVpv("initial",0); + + MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI); + MY_CXT.bhk_record = 0; + + BhkENTRY_set(&bhk_test, start, blockhook_test_start); + BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end); + BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end); + BhkENTRY_set(&bhk_test, eval, blockhook_test_eval); + Perl_blockhook_register(aTHX_ &bhk_test); + MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", - GV_ADD, SVt_PVAV); + GV_ADDMULTI, SVt_PVAV); MY_CXT.cscav = GvAV(MY_CXT.cscgv); - Newxz(bhk, 1, BHK); - BhkENTRY_set(bhk, start, blockhook_start); - BhkENTRY_set(bhk, pre_end, blockhook_pre_end); - Perl_blockhook_register(aTHX_ bhk); + BhkENTRY_set(&bhk_csc, start, blockhook_csc_start); + BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end); + Perl_blockhook_register(aTHX_ &bhk_csc); } void @@ -609,8 +667,10 @@ CLONE(...) MY_CXT_CLONE; MY_CXT.sv = newSVpv("initial_clone",0); MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", - GV_ADD, SVt_PVAV); + GV_ADDMULTI, SVt_PVAV); MY_CXT.cscav = NULL; + MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI); + MY_CXT.bhk_record = 0; void print_double(val) @@ -991,3 +1051,11 @@ sv_count() RETVAL = PL_sv_count; OUTPUT: RETVAL + +void +bhk_record(bool on) + CODE: + dMY_CXT; + MY_CXT.bhk_record = on; + if (on) + av_clear(MY_CXT.bhkav); diff --git a/ext/XS-APItest/t/BHK.pm b/ext/XS-APItest/t/BHK.pm new file mode 100644 index 0000000..29914eb --- /dev/null +++ b/ext/XS-APItest/t/BHK.pm @@ -0,0 +1,16 @@ +package t::BHK; + +sub import { + shift; + unless (@_) { + XS::APItest::bhk_record(1); + return; + } + if ($_[0] eq "push") { + push @XS::APItest::bhkav, $_[1]; + return; + } +} +sub unimport { XS::APItest::bhk_record(0) } + +1; diff --git a/ext/XS-APItest/t/Block.pm b/ext/XS-APItest/t/Block.pm new file mode 100644 index 0000000..30679e4 --- /dev/null +++ b/ext/XS-APItest/t/Block.pm @@ -0,0 +1,2 @@ +{ 1 } +1; diff --git a/ext/XS-APItest/t/Markers.pm b/ext/XS-APItest/t/Markers.pm new file mode 100644 index 0000000..56409c5 --- /dev/null +++ b/ext/XS-APItest/t/Markers.pm @@ -0,0 +1,13 @@ +package t::Markers; + +push @XS::APItest::bhkav, "run/pm"; + +use t::BHK push => "compile/pm/before"; +sub import { + use t::BHK push => "compile/pm/inside"; + push @XS::APItest::bhkav, "run/import"; +} + +use t::BHK push => "compile/pm/after"; + +1; diff --git a/ext/XS-APItest/t/Null.pm b/ext/XS-APItest/t/Null.pm new file mode 100644 index 0000000..0afc604 --- /dev/null +++ b/ext/XS-APItest/t/Null.pm @@ -0,0 +1 @@ +1; diff --git a/ext/XS-APItest/t/blockhooks-csc.t b/ext/XS-APItest/t/blockhooks-csc.t new file mode 100644 index 0000000..54b3e5c --- /dev/null +++ b/ext/XS-APItest/t/blockhooks-csc.t @@ -0,0 +1,98 @@ +#!./perl + +# Tests for @{^COMPILE_SCOPE_CONTAINER} + +use strict; +use warnings; +use Test::More tests => 12; +use XS::APItest; + +BEGIN { + # this has to be a full glob alias, since the GvAV gets replaced + *COMPILE_SCOPE_CONTAINER = \*XS::APItest::COMPILE_SCOPE_CONTAINER; +} +our @COMPILE_SCOPE_CONTAINER; + +my %destroyed; + +BEGIN { + package CounterObject; + + sub new { + my ($class, $name) = @_; + return bless { name => $name }, $class; + } + + sub name { + my ($self) = @_; + return $self->{name}; + } + + sub DESTROY { + my ($self) = @_; + $destroyed{ $self->name }++; + } + + + package ReplaceCounter; + $INC{'ReplaceCounter.pm'} = __FILE__; + + sub import { + my ($self, $counter) = @_; + $COMPILE_SCOPE_CONTAINER[-1] = CounterObject->new($counter); + } + + package InstallCounter; + $INC{'InstallCounter.pm'} = __FILE__; + + sub import { + my ($class, $counter) = @_; + push @COMPILE_SCOPE_CONTAINER, CounterObject->new($counter); + } + + package TestCounter; + $INC{'TestCounter.pm'} = __FILE__; + + sub import { + my ($class, $counter, $number, $message) = @_; + + $number = 1 + unless defined $number; + $message = "counter $counter is found $number times" + unless defined $message; + + ::is scalar(grep { $_->name eq $counter } @{COMPILE_SCOPE_CONTAINER}), + $number, + $message; + } +} + +{ + use InstallCounter 'root'; + use InstallCounter '3rd-party'; + + { + BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); } + + use ReplaceCounter 'replace'; + + BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); } + + use TestCounter '3rd-party', 0, '3rd-party no longer visible'; + use TestCounter 'replace', 1, 'replacement now visible'; + use TestCounter 'root'; + + BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); } + } + + BEGIN { + ok $destroyed{replace}, 'replacement has been destroyed after end of outer scope'; + } + + use TestCounter 'root', 1, 'root visible again'; + use TestCounter 'replace', 0, 'lower replacement no longer visible'; + use TestCounter '3rd-party'; +} + +ok $destroyed{ $_ }, "$_ has been destroyed after end of outer scope" + for 'root', '3rd-party'; diff --git a/ext/XS-APItest/t/blockhooks.t b/ext/XS-APItest/t/blockhooks.t index 54b3e5c..a39c3f5 100644 --- a/ext/XS-APItest/t/blockhooks.t +++ b/ext/XS-APItest/t/blockhooks.t @@ -1,98 +1,286 @@ -#!./perl +#!/usr/bin/perl -# Tests for @{^COMPILE_SCOPE_CONTAINER} - -use strict; use warnings; -use Test::More tests => 12; +use strict; +use Test::More tests => 17; + use XS::APItest; +use t::BHK (); # make sure it gets compiled early -BEGIN { - # this has to be a full glob alias, since the GvAV gets replaced - *COMPILE_SCOPE_CONTAINER = \*XS::APItest::COMPILE_SCOPE_CONTAINER; -} -our @COMPILE_SCOPE_CONTAINER; +BEGIN { package XS::APItest; *main::bhkav = \@XS::APItest::bhkav } -my %destroyed; +# 'use t::BHK' switches on recording hooks, and clears @bhkav. +# 'no t::BHK' switches recording off again. +# 'use t::BHK push => "foo"' pushes onto @bhkav -BEGIN { - package CounterObject; +BEGIN { diag "## COMPILE TIME ##" } +diag "## RUN TIME ##"; - sub new { - my ($class, $name) = @_; - return bless { name => $name }, $class; - } +use t::BHK; + 1; +no t::BHK; - sub name { - my ($self) = @_; - return $self->{name}; - } +BEGIN { is_deeply \@bhkav, [], "no blocks" } - sub DESTROY { - my ($self) = @_; - $destroyed{ $self->name }++; +use t::BHK; + { + 1; } +no t::BHK; +BEGIN { is_deeply \@bhkav, + [[start => 1], qw/pre_end post_end/], + "plain block"; +} + +use t::BHK; + if (1) { 1 } +no t::BHK; - package ReplaceCounter; - $INC{'ReplaceCounter.pm'} = __FILE__; +BEGIN { is_deeply \@bhkav, + [ + [start => 1], + [start => 0], + qw/pre_end post_end/, + qw/pre_end post_end/, + ], + "if block"; +} - sub import { - my ($self, $counter) = @_; - $COMPILE_SCOPE_CONTAINER[-1] = CounterObject->new($counter); +use t::BHK; + for (1) { 1 } +no t::BHK; + +BEGIN { is_deeply \@bhkav, + [ + [start => 1], + [start => 0], + qw/pre_end post_end/, + qw/pre_end post_end/, + ], + "for loop"; +} + +use t::BHK; + { + { 1; } } +no t::BHK; - package InstallCounter; - $INC{'InstallCounter.pm'} = __FILE__; +BEGIN { is_deeply \@bhkav, + [ + [start => 1], + [start => 1], + qw/pre_end post_end/, + qw/pre_end post_end/, + ], + "nested blocks"; +} - sub import { - my ($class, $counter) = @_; - push @COMPILE_SCOPE_CONTAINER, CounterObject->new($counter); +use t::BHK; + use t::BHK push => "before"; + { + use t::BHK push => "inside"; } + use t::BHK push => "after"; +no t::BHK; - package TestCounter; - $INC{'TestCounter.pm'} = __FILE__; +BEGIN { is_deeply \@bhkav, + [ + "before", + [start => 1], + "inside", + qw/pre_end post_end/, + "after" + ], + "hooks called in the correct places"; +} - sub import { - my ($class, $counter, $number, $message) = @_; +use t::BHK; + BEGIN { 1 } +no t::BHK; - $number = 1 - unless defined $number; - $message = "counter $counter is found $number times" - unless defined $message; +BEGIN { is_deeply \@bhkav, + [ + [start => 1], + qw/pre_end post_end/, + ], + "BEGIN block"; +} - ::is scalar(grep { $_->name eq $counter } @{COMPILE_SCOPE_CONTAINER}), - $number, - $message; - } +use t::BHK; t::BHK->import; + eval "1"; +no t::BHK; t::BHK->unimport; + +BEGIN { is_deeply \@bhkav, [], "string eval (compile)" } +is_deeply \@bhkav, + [ + [eval => "entereval"], + [start => 1], + qw/pre_end post_end/, + ], + "string eval (run)"; + +delete @INC{qw{t/Null.pm t/Block.pm}}; + +t::BHK->import; + do "t/Null.pm"; +t::BHK->unimport; + +is_deeply \@bhkav, + [ + [eval => "dofile"], + [start => 1], + qw/pre_end post_end/, + ], + "do file (null)"; + +t::BHK->import; + do "t/Block.pm"; +t::BHK->unimport; + +is_deeply \@bhkav, + [ + [eval => "dofile"], + [start => 1], + [start => 1], + qw/pre_end post_end/, + qw/pre_end post_end/, + ], + "do file (single block)"; + +delete @INC{qw{t/Null.pm t/Block.pm}}; + +t::BHK->import; + require t::Null; +t::BHK->unimport; + +is_deeply \@bhkav, + [ + [eval => "require"], + [start => 1], + qw/pre_end post_end/, + ], + "require (null)"; + +t::BHK->import; + require t::Block; +t::BHK->unimport; + +is_deeply \@bhkav, + [ + [eval => "require"], + [start => 1], + [start => 1], + qw/pre_end post_end/, + qw/pre_end post_end/, + ], + "require (single block)"; + +BEGIN { delete $INC{"t/Block.pm"} } + +use t::BHK; + use t::Block; +no t::BHK; + +BEGIN { is_deeply \@bhkav, + [ + [eval => "require"], + [start => 1], + [start => 1], + qw/pre_end post_end/, + qw/pre_end post_end/, + ], + "use (single block)"; } -{ - use InstallCounter 'root'; - use InstallCounter '3rd-party'; +BEGIN { delete $INC{"t/Markers.pm"} } - { - BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); } +use t::BHK; + use t::BHK push => "compile/main/before"; + use t::Markers; + use t::BHK push => "compile/main/after"; +no t::BHK; - use ReplaceCounter 'replace'; +BEGIN { is_deeply \@bhkav, + [ + "compile/main/before", + [eval => "require"], + [start => 1], + "compile/pm/before", + [start => 1], + "compile/pm/inside", + qw/pre_end post_end/, + "compile/pm/after", + qw/pre_end post_end/, + "run/pm", + "run/import", + "compile/main/after", + ], + "use with markers"; +} - BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); } +# OK, now some *really* evil stuff... - use TestCounter '3rd-party', 0, '3rd-party no longer visible'; - use TestCounter 'replace', 1, 'replacement now visible'; - use TestCounter 'root'; +BEGIN { + package EvalDestroy; - BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); } - } + sub DESTROY { $_[0]->() } +} - BEGIN { - ok $destroyed{replace}, 'replacement has been destroyed after end of outer scope'; +use t::BHK; + { + BEGIN { + # grumbleSCOPECHECKgrumble + push @XS::APItest::COMPILE_SCOPE_CONTAINER, + bless sub { + push @bhkav, "DESTROY"; + }, "EvalDestroy"; + } + 1; } +no t::BHK; - use TestCounter 'root', 1, 'root visible again'; - use TestCounter 'replace', 0, 'lower replacement no longer visible'; - use TestCounter '3rd-party'; +BEGIN { is_deeply \@bhkav, + [ + [start => 1], # block + [start => 1], # BEGIN + [start => 1], # sub + qw/pre_end post_end/, + qw/pre_end post_end/, + "pre_end", + "DESTROY", + "post_end", + ], + "compile-time DESTROY comes between pre_ and post_end"; } -ok $destroyed{ $_ }, "$_ has been destroyed after end of outer scope" - for 'root', '3rd-party'; +use t::BHK; + { + BEGIN { + push @XS::APItest::COMPILE_SCOPE_CONTAINER, + bless sub { + eval "{1}"; + }, "EvalDestroy"; + } + 1; + } +no t::BHK; + +BEGIN { is_deeply \@bhkav, + [ + [start => 1], # block + [start => 1], # BEGIN + [start => 1], # sub + qw/pre_end post_end/, + qw/pre_end post_end/, + "pre_end", + [eval => "entereval"], + [start => 1], # eval + [start => 1], # block inside eval + qw/pre_end post_end/, + qw/pre_end post_end/, + "post_end", + ], + "evil eval-in-DESTROY tricks"; +} -- 1.6.6.1 ```
p5pRT commented 14 years ago

From ben@morrow.me.uk

0006-Teach-autodoc.pl-about-o-functions.patch ```diff From 4f2c89b9c59b5279be134d5de991a0eb00175c19 Mon Sep 17 00:00:00 2001 From: Ben Morrow Date: Wed, 9 Dec 2009 10:24:33 +0000 Subject: [PATCH 6/8] Teach autodoc.pl about 'o' functions. That is, functions with no #define foo Perl_foo. I'm not certain this is the right way to do it, as I don't really understand which flags autodoc honours from which places; currently, it's necessary to put the 'o' flag on the =for apidoc line or it will be ignored. --- autodoc.pl | 6 ++++++ 1 files changed, 6 insertions(+), 0 deletions(-) diff --git a/autodoc.pl b/autodoc.pl index 2fc0397..8aa408a 100644 --- a/autodoc.pl +++ b/autodoc.pl @@ -132,6 +132,8 @@ sub docout ($$$) { # output the docs for one function removed without notice.\n\n" if $flags =~ /x/; $docs .= "NOTE: the perl_ form of this function is deprecated.\n\n" if $flags =~ /p/; + $docs .= "NOTE: this function must be explicitly called as Perl_$name with an aTHX_ parameter.\n\n" + if $flags =~ /o/; print $fh "=item $name\nX<$name>\n$docs"; @@ -141,6 +143,10 @@ removed without notice.\n\n" if $flags =~ /x/; print $fh "\t\t$name;\n\n"; } elsif ($flags =~ /n/) { # no args print $fh "\t$ret\t$name\n\n"; + } elsif ($flags =~ /o/) { # no #define foo Perl_foo + print $fh "\t$ret\tPerl_$name"; + print $fh "(" . (@args ? "pTHX_ " : "pTHX"); + print $fh join(", ", @args) . ")\n\n"; } else { # full usage print $fh "\t$ret\t$name"; print $fh "(" . join(", ", @args) . ")"; -- 1.6.6.1 ```
p5pRT commented 14 years ago

From ben@morrow.me.uk

0007-Document-the-blockhook-functions-and-macros.patch ```diff From c1c9d54cbfc477a9d40f226a6797c430b0072813 Mon Sep 17 00:00:00 2001 From: Ben Morrow Date: Wed, 9 Dec 2009 10:32:23 +0000 Subject: [PATCH 7/8] Document the blockhook functions and macros. --- embed.fnc | 2 +- op.c | 11 ++++++++ op.h | 24 +++++++++++++++++++ pod/perlguts.pod | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 104 insertions(+), 1 deletions(-) diff --git a/embed.fnc b/embed.fnc index 113a43d..0438ee3 100644 --- a/embed.fnc +++ b/embed.fnc @@ -212,7 +212,7 @@ pR |OP* |block_end |I32 floor|NULLOK OP* seq ApR |I32 |block_gimme : Used in perly.y pR |int |block_start |int full -Aop |void |blockhook_register |NN BHK *hk +Aodp |void |blockhook_register |NN BHK *hk : Used in perl.c p |void |boot_core_UNIVERSAL : Used in perl.c diff --git a/op.c b/op.c index 2e5e407..d587928 100644 --- a/op.c +++ b/op.c @@ -2325,6 +2325,17 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) return retval; } +/* +=head1 Compile-time scope hooks + +=for apidoc Ao||blockhook_register + +Register a set of hooks to be called when the Perl lexical scope changes +at compile time. See L. + +=cut +*/ + void Perl_blockhook_register(pTHX_ BHK *hk) { diff --git a/op.h b/op.h index 0b891a6..fbabb1f 100644 --- a/op.h +++ b/op.h @@ -649,6 +649,30 @@ struct block_hooks { void (*bhk_eval) (pTHX_ OP *const saveop); }; +/* +=head1 Compile-time scope hooks + +=for apidoc m|U32|BhkFLAGS|BHK *hk +Return the BHK's flags. + +=for apidoc m|void *|BhkENTRY|BHK *hk|which +Return an entry from the BHK structure. I is a preprocessor token +indicating which entry to return. If the appropriate flag is not set +this will return NULL. The type of the return value depends on which +entry you ask for. + +=for apidoc Am|void|BhkENTRY_set|BHK *hk|which|void *ptr +Set an entry in the BHK structure, and set the flags to indicate it is +valid. I is a preprocessing token indicating which entry to set. +The type of I depends on the entry. + +=for apidoc m|void|CALL_BLOCK_HOOKS|which|arg +Call all the registered block hooks for type I. I is a +preprocessing token; the type of I depends on I. + +=cut +*/ + #define BhkFLAGS(hk) ((hk)->bhk_flags) #define BHKf_start 0x01 diff --git a/pod/perlguts.pod b/pod/perlguts.pod index b6cec65..d0178e7 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1842,6 +1842,74 @@ file, add the line: This function should be as efficient as possible to keep your programs running as fast as possible. +=head2 Compile-time scope hooks + +As of perl 5.14 it is possible to hook into the compile-time lexical +scope mechanism using C. This is used like +this: + + STATIC void my_start_hook(pTHX_ int full); + STATIC BHK my_hooks; + + BOOT: + BhkENTRY_set(&my_hooks, start, my_start_hook); + Perl_blockhook_register(aTHX_ &my_hooks); + +This will arrange to have C called at the start of +compiling every lexical scope. The available hooks are: + +=over 4 + +=item C + +This is called just after starting a new lexical scope. Note that Perl +code like + + if ($x) { ... } + +creates two scopes: the first starts at the C<(> and has C, +the second starts at the C<{> and has C. Both end at the +C<}>, so calls to C and C
 will match. Anything
+pushed onto the save stack by this hook will be popped just before the
+scope ends (between the C and C hooks, in fact).
+
+=item C
+
+This is called at the end of a lexical scope, just before unwinding the
+stack. I is the root of the optree representing the scope; it is a
+double pointer so you can replace the OP if you need to.
+
+=item C
+
+This is called at the end of a lexical scope, just after unwinding the
+stack. I is as above. Note that it is possible for calls to C
+and C to nest, if there is something on the save stack that
+calls string eval.
+
+=item C
+
+This is called just before starting to compile an C, C, C or C, after the eval has been set up. I is the
+OP that requested the eval, and will normally be an C,
+C or C.
+
+=back
+
+Once you have your hook functions, you need a C structure to put
+them in. It's best to allocate it statically, since there is no way to
+free it once it's registered. The function pointers should be inserted
+into this structure using the C macro, which will also set
+flags indicating which entries are valid. If you do need to allocate
+your C dynamically for some reason, be sure to zero it before you
+start.
+
+Once registered, there is no mechanism to switch these hooks off, so if
+that is necessary you will need to do this yourself. An entry in C<%^H>
+is probably the best way, so the effect is lexically scoped. You should
+also be aware that generally speaking at least one scope will have
+opened before your extension is loaded, so you will see some
+C
 pairs that didn't have a matching C.
+
 =head1 Examining internal data structures with the C functions

 To aid debugging, the source file F contains a number of
-- 
1.6.6.1

```
p5pRT commented 14 years ago

From ben@morrow.me.uk

0008-Update-MANIFEST.patch ```diff From cae6cc133bb183009410dc5f316869359f0c2be6 Mon Sep 17 00:00:00 2001 From: Ben Morrow Date: Wed, 9 Dec 2009 10:37:14 +0000 Subject: [PATCH 8/8] Update MANIFEST. --- MANIFEST | 2 ++ 1 files changed, 2 insertions(+), 0 deletions(-) diff --git a/MANIFEST b/MANIFEST index 5ca4f13..143af78 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3225,6 +3225,8 @@ ext/XS-APItest/Makefile.PL XS::APItest extension ext/XS-APItest/MANIFEST XS::APItest extension ext/XS-APItest/notcore.c Test API functions when PERL_CORE is not defined ext/XS-APItest/README XS::APItest extension +ext/XS-APItest/t/blockhooks-csc.t XS::APItest: more tests for PL_blockhooks +ext/XS-APItest/t/blockhooks.t XS::APItest: tests for PL_blockhooks ext/XS-APItest/t/call.t XS::APItest extension ext/XS-APItest/t/exception.t XS::APItest extension ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs -- 1.6.6.1 ```
p5pRT commented 14 years ago

@rgs - Status changed from 'new' to 'resolved'

p5pRT commented 14 years ago

From @rgarcia

On 6 July 2010 12​:33\, Ben Morrow \perlbug\-followup@&#8203;perl\.org wrote​:

The attached patches make it possible for extensions to hook into perl's lexical scope mechanism at compile time. This would allow things like my SCOPECHECK and Florian's @​{^COMPILE_SCOPE_CONTAINER} to be implemented as CPAN modules[1]. Usage is like this (from XS)​:

   STATIC void my_start_hook(pTHX_ int full);    STATIC void my_pre_end_hook(pTHX_ OP **o);    STATIC void my_post_end_hook(pTHX_ OP **o);    STATIC void my_eval_hook(pTHX_ OP *const o);    STATIC BHK my_hooks;

   BOOT​:        BhkENTRY_set(&my_hooks\, start\, my_start_hook);        BhkENTRY_set(&my_hooks\, pre_end\, my_pre_end_hook);        BhkENTRY_set(&my_hooks\, post_end\, my_post_end_hook);        BhkENTRY_set(&my_hooks\, eval\, my_eval_hook);        Perl_blockhook_register(aTHX_ &my_hooks);

This will cause

   - my_start_hook to be called at the start of compiling every lexical      scope\, with the 'full' parameter from Perl_block_start.

   - my_pre_end_hook to be called at the end of compiling every lexical      scope\, *before* the compile-time stack is unwound\, with o pointing      to the root OP for the scope. It is a double pointer so the hook      can substitute a different OP if it needs to.

   - my_post_end_hook to be called *after* the stack is unwound.

   - my_eval_hook to be called just before compiling an      eval/do/require\, with o set to the OP that requested the eval.

The patches are rebased against current blead\, and the branch has been pushed to http​://github.com/mauzo/perl/tree/blockhooks . I hope including a whole lot of patches in one mail like this is OK​: it seemed easier than separate mails for each patch\, since they all go together.

Ben

[1] Implementing the rest of the Perl 6 blocks on CPAN would require at least one more patch\, to allow extensions to create pad entries.

Thanks\, applied.

A small remark. The docs state​:

  Once registered\, there is no mechanism to switch these hooks off\, so if that is necessary you will need to do this yourself.

but if I'm not mistaken you could always switch the corresponding flag off in the BHK structure for that.