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.)

7 files changed, 460 insertions, 74 deletions

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 35533fcf8e..2f2a8a7d18 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -15,6 +15,8 @@ typedef struct {
     SV *sv;
     GV *cscgv;
     AV *cscav;
+    AV *bhkav;
+    bool bhk_record;
 } my_cxt_t;
 
 START_MY_CXT
@@ -245,7 +247,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);
@@ -265,7 +267,7 @@ blockhook_start(pTHX_ int full)
 }
 
 STATIC void
-blockhook_pre_end(pTHX_ OP **o)
+blockhook_csc_pre_end(pTHX_ OP **o)
 {
     dMY_CXT;
 
@@ -277,6 +279,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
@@ -629,19 +679,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
@@ -650,8 +708,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)
@@ -1022,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 0000000000..29914eb634
--- /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 0000000000..30679e4877
--- /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 0000000000..56409c5215
--- /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 0000000000..0afc6045cf
--- /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 0000000000..54b3e5c837
--- /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 54b3e5c837..a39c3f5274 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";
+}