Initial very basic tests for PL_blockhooks.

This is taken directly from rafl's @{^COMPILE_SCOPE_CONTAINER}
implementation posted on p5p.

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 2abc7c2..012102d 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -13,6 +13,8 @@ typedef PTR_TBL_t *XS__APItest__PtrTable;
 typedef struct {
     int i;
     SV *sv;
+    GV *cscgv;
+    AV *cscav;
 } my_cxt_t;
 
 START_MY_CXT
@@ -242,6 +244,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
@@ -595,8 +635,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
@@ -604,6 +652,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 (file)
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';