In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/31be325893db1b4bd951b7e64f1557d4c5ca6246?hp=3e2d3818e517e0037c1ab6a482f31d50271f9e27>
- Log ----------------------------------------------------------------- commit 31be325893db1b4bd951b7e64f1557d4c5ca6246 Author: Ben Morrow <[email protected]> Date: Wed Dec 9 10:37:14 2009 +0000 Update MANIFEST. M MANIFEST commit fd85fad2cd9375073457ad3f1e13e90d7d79f23f Author: Ben Morrow <[email protected]> Date: Wed Dec 9 10:32:23 2009 +0000 Document the blockhook functions and macros. M embed.fnc M op.c M op.h M pod/perlguts.pod commit 5afac1ebc358bec5c061fc10d4c7122f0efebb22 Author: Ben Morrow <[email protected]> Date: Wed Dec 9 10:24:33 2009 +0000 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. M autodoc.pl commit 13b6b3bc35857242218431a6326dd7a59703afdd Author: Ben Morrow <[email protected]> Date: Mon Dec 7 19:00:04 2009 +0000 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.) M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/BHK.pm A ext/XS-APItest/t/Block.pm A ext/XS-APItest/t/Markers.pm A ext/XS-APItest/t/Null.pm A ext/XS-APItest/t/blockhooks-csc.t M ext/XS-APItest/t/blockhooks.t commit bb6c22e795117e6d984471c0be74c8b3302b3b9a Author: Ben Morrow <[email protected]> Date: Mon Dec 7 12:55:57 2009 +0000 Wrap PL_blockhooks in an API function. This should help prevent people from thinking they can get cute with the contents. M embed.fnc M embed.h M ext/XS-APItest/APItest.xs M global.sym M op.c M proto.h commit 52db365a88f7ab3b9b091f983a05054164499982 Author: Ben Morrow <[email protected]> Date: Mon Dec 7 11:52:23 2009 +0000 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. M ext/XS-APItest/APItest.xs M op.h M perl.h M pp_ctl.c commit 03569ecfc8c82939dcc47b586a8e22c613c158b2 Author: Ben Morrow <[email protected]> Date: Thu Nov 26 17:22:22 2009 +0000 Initial very basic tests for PL_blockhooks. This is taken directly from rafl's @{^COMPILE_SCOPE_CONTAINER} implementation posted on p5p. M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/blockhooks.t commit 1930840b26541ab67ff111a47ceab4753d798617 Author: Ben Morrow <[email protected]> Date: Thu Nov 26 17:18:29 2009 +0000 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. M embedvar.h M intrpvar.h M op.c M op.h M perlapi.h M sv.c ----------------------------------------------------------------------- Summary of changes: MANIFEST | 2 + autodoc.pl | 6 + embed.fnc | 1 + embed.h | 4 + embedvar.h | 2 + ext/XS-APItest/APItest.xs | 116 ++++++++ ext/XS-APItest/t/BHK.pm | 16 ++ ext/XS-APItest/t/Block.pm | 2 + ext/XS-APItest/t/Markers.pm | 13 + .../test_use_14937.pm => ext/XS-APItest/t/Null.pm | 0 ext/XS-APItest/t/blockhooks-csc.t | 98 +++++++ ext/XS-APItest/t/blockhooks.t | 286 ++++++++++++++++++++ global.sym | 1 + intrpvar.h | 3 + op.c | 33 +++- op.h | 68 +++++ perl.h | 2 + perlapi.h | 2 + pod/perlguts.pod | 68 +++++ pp_ctl.c | 2 + proto.h | 5 + sv.c | 1 + 22 files changed, 729 insertions(+), 2 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 copy t/lib/test_use_14937.pm => ext/XS-APItest/t/Null.pm (100%) create mode 100644 ext/XS-APItest/t/blockhooks-csc.t create mode 100644 ext/XS-APItest/t/blockhooks.t diff --git a/MANIFEST b/MANIFEST index 1f6ed93..81c5754 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3250,6 +3250,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 diff --git a/autodoc.pl b/autodoc.pl index 285bc3a..91963ca 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) . ")"; diff --git a/embed.fnc b/embed.fnc index d3f14b1..15bd938 100644 --- a/embed.fnc +++ b/embed.fnc @@ -214,6 +214,7 @@ pR |OP* |block_end |I32 floor|NULLOK OP* seq ApR |I32 |block_gimme : Used in perly.y pR |int |block_start |int full +Aodp |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 df31c37..5e79e58 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 @@ -2531,6 +2533,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/embedvar.h b/embedvar.h index 428147f..dde1f27 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) @@ -400,6 +401,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/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 2abc7c2..2f2a8a7 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -13,6 +13,10 @@ typedef PTR_TBL_t *XS__APItest__PtrTable; typedef struct { int i; SV *sv; + GV *cscgv; + AV *cscav; + AV *bhkav; + bool bhk_record; } my_cxt_t; START_MY_CXT @@ -242,6 +246,87 @@ rmagical_a_dummy(pTHX_ IV idx, SV *sv) { STATIC MGVTBL rmagical_b = { 0 }; +STATIC void +blockhook_csc_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_csc_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 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 @@ -595,8 +680,26 @@ PROTOTYPES: DISABLE BOOT: { 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_ADDMULTI, SVt_PVAV); + MY_CXT.cscav = GvAV(MY_CXT.cscgv); + + 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 @@ -604,6 +707,11 @@ CLONE(...) CODE: MY_CXT_CLONE; MY_CXT.sv = newSVpv("initial_clone",0); + MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", + 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) @@ -974,3 +1082,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/t/lib/test_use_14937.pm b/ext/XS-APItest/t/Null.pm similarity index 100% copy from t/lib/test_use_14937.pm copy to ext/XS-APItest/t/Null.pm 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 new file mode 100644 index 0000000..a39c3f5 --- /dev/null +++ b/ext/XS-APItest/t/blockhooks.t @@ -0,0 +1,286 @@ +#!/usr/bin/perl + +use warnings; +use strict; +use Test::More tests => 17; + +use XS::APItest; +use t::BHK (); # make sure it gets compiled early + +BEGIN { package XS::APItest; *main::bhkav = \...@xs::APItest::bhkav } + +# '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 { diag "## COMPILE TIME ##" } +diag "## RUN TIME ##"; + +use t::BHK; + 1; +no t::BHK; + +BEGIN { is_deeply \...@bhkav, [], "no blocks" } + +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; + +BEGIN { is_deeply \...@bhkav, + [ + [start => 1], + [start => 0], + qw/pre_end post_end/, + qw/pre_end post_end/, + ], + "if block"; +} + +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; + +BEGIN { is_deeply \...@bhkav, + [ + [start => 1], + [start => 1], + qw/pre_end post_end/, + qw/pre_end post_end/, + ], + "nested blocks"; +} + +use t::BHK; + use t::BHK push => "before"; + { + use t::BHK push => "inside"; + } + use t::BHK push => "after"; +no t::BHK; + +BEGIN { is_deeply \...@bhkav, + [ + "before", + [start => 1], + "inside", + qw/pre_end post_end/, + "after" + ], + "hooks called in the correct places"; +} + +use t::BHK; + BEGIN { 1 } +no t::BHK; + +BEGIN { is_deeply \...@bhkav, + [ + [start => 1], + qw/pre_end post_end/, + ], + "BEGIN block"; +} + +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)"; +} + +BEGIN { delete $INC{"t/Markers.pm"} } + +use t::BHK; + use t::BHK push => "compile/main/before"; + use t::Markers; + use t::BHK push => "compile/main/after"; +no t::BHK; + +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"; +} + +# OK, now some *really* evil stuff... + +BEGIN { + package EvalDestroy; + + sub DESTROY { $_[0]->() } +} + +use t::BHK; + { + BEGIN { + # grumbleSCOPECHECKgrumble + push @XS::APItest::COMPILE_SCOPE_CONTAINER, + bless sub { + push @bhkav, "DESTROY"; + }, "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", + "DESTROY", + "post_end", + ], + "compile-time DESTROY comes between pre_ and post_end"; +} + +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"; +} diff --git a/global.sym b/global.sym index f7fb28d..db01b92 100644 --- a/global.sym +++ b/global.sym @@ -56,6 +56,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/intrpvar.h b/intrpvar.h index 138895a..1e01e43 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -722,6 +722,9 @@ PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */ retrieve a C<struct mro_alg *> */ 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 c50111c..d832c99 100644 --- a/op.c +++ b/op.c @@ -2305,17 +2305,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; } @@ -2324,15 +2328,40 @@ 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; } +/* +=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<perlguts/"Compile-time scope hooks">. + +=cut +*/ + +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/op.h b/op.h index 712039c..30a41c8 100644 --- a/op.h +++ b/op.h @@ -645,6 +645,74 @@ struct loop { #define FreeOp(p) PerlMemShared_free(p) #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); +}; + +/* +=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<which> 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<which> is a preprocessing token indicating which entry to set. +The type of I<ptr> depends on the entry. + +=for apidoc m|void|CALL_BLOCK_HOOKS|which|arg +Call all the registered block hooks for type I<which>. I<which> is a +preprocessing token; the type of I<arg> depends on I<which>. + +=cut +*/ + +#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]; \ + BHK *hk; \ + \ + assert(SvIOK(sv)); \ + if (SvUOK(sv)) \ + hk = INT2PTR(BHK *, SvUVX(sv)); \ + else \ + hk = INT2PTR(BHK *, SvIVX(sv)); \ + \ + if (BhkENTRY(hk, which)) \ + CALL_FPTR(BhkENTRY(hk, which))(aTHX_ arg); \ + } \ + } \ + } STMT_END + #ifdef PERL_MAD # define MAD_NULL 1 # define MAD_PV 2 diff --git a/perl.h b/perl.h index 3d60a33..0d4a891 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 <ksync.h> has struct sv */ diff --git a/perlapi.h b/perlapi.h index 506d72c..742bb3a 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/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<Perl_blockhook_register>. 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<my_start_hook> called at the start of +compiling every lexical scope. The available hooks are: + +=over 4 + +=item C<void start(pTHX_ int full)> + +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<full == 1>, +the second starts at the C<{> and has C<full == 0>. Both end at the +C<}>, so calls to C<start> and C<pre/post_end> will match. Anything +pushed onto the save stack by this hook will be popped just before the +scope ends (between the C<pre_> and C<post_end> hooks, in fact). + +=item C<void pre_end(pTHX_ OP **o)> + +This is called at the end of a lexical scope, just before unwinding the +stack. I<o> 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<void post_end(pTHX_ OP **o)> + +This is called at the end of a lexical scope, just after unwinding the +stack. I<o> is as above. Note that it is possible for calls to C<pre_> +and C<post_end> to nest, if there is something on the save stack that +calls string eval. + +=item C<void eval(pTHX_ OP *const o)> + +This is called just before starting to compile an C<eval STRING>, C<do +FILE>, C<require> or C<use>, after the eval has been set up. I<o> is the +OP that requested the eval, and will normally be an C<OP_ENTEREVAL>, +C<OP_DOFILE> or C<OP_REQUIRE>. + +=back + +Once you have your hook functions, you need a C<BHK> 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<BhkENTRY_set> macro, which will also set +flags indicating which entries are valid. If you do need to allocate +your C<BHK> 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<pre/post_end> pairs that didn't have a matching C<start>. + =head1 Examining internal data structures with the C<dump> functions To aid debugging, the source file F<dump.c> contains a number of diff --git a/pp_ctl.c b/pp_ctl.c index 912e934..1bac360 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3131,6 +3131,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<BEGIN{die}>, * so honour CATCH_GET and trap it here if necessary */ diff --git a/proto.h b/proto.h index c1c0f05..535dc78 100644 --- a/proto.h +++ b/proto.h @@ -289,6 +289,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) diff --git a/sv.c b/sv.c index 2f13091..3e99d9c 100644 --- a/sv.c +++ b/sv.c @@ -12649,6 +12649,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. -- Perl5 Master Repository
