Revert "Make the peep recurse via PL_peepp"

[perl5.git] / ext / XS-APItest / APItest.xs

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index ede6994..23ce3ed 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -3,6 +3,8 @@
 #include "perl.h"
 #include "XSUB.h"
 
+typedef SV *SVREF;
+typedef PTR_TBL_t *XS__APItest__PtrTable;
 
 /* for my_cxt tests */
 
@@ -11,6 +13,10 @@
 typedef struct {
     int i;
     SV *sv;
+    GV *cscgv;
+    AV *cscav;
+    AV *bhkav;
+    bool bhk_record;
 } my_cxt_t;
 
 START_MY_CXT
@@ -240,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_av = newAV();
+
+        for (i = 0; i <= av_len(cur); i++) {
+            av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
+        }
+
+        GvAV(MY_CXT.cscgv) = new_av;
+    }
+}
+
+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
@@ -531,9 +618,9 @@ refcounted_he_fetch(key, level=0)
        SvREFCNT_inc(RETVAL);
        OUTPUT:
        RETVAL
-       
+
 #endif
-       
+
 =pod
 
 sub TIEHASH  { bless {}, $_[0] }
@@ -547,6 +634,68 @@ sub CLEAR    { %{$_[0]} = () }
 
 =cut
 
+
+MODULE = XS::APItest:TempLv            PACKAGE = XS::APItest::TempLv
+
+void
+make_temp_mg_lv(sv)
+SV* sv
+    PREINIT:
+       SV * const lv = newSV_type(SVt_PVLV);
+       STRLEN len;
+    PPCODE:
+        SvPV(sv, len);
+
+       sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
+       LvTYPE(lv) = 'x';
+       LvTARG(lv) = SvREFCNT_inc_simple(sv);
+       LvTARGOFF(lv) = len == 0 ? 0 : 1;
+       LvTARGLEN(lv) = len < 2 ? 0 : len-2;
+
+       EXTEND(SP, 1);
+       ST(0) = sv_2mortal(lv);
+       XSRETURN(1);
+
+
+MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
+
+void
+ptr_table_new(classname)
+const char * classname
+    PPCODE:
+    PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
+
+void
+DESTROY(table)
+XS::APItest::PtrTable table
+    CODE:
+    ptr_table_free(table);
+
+void
+ptr_table_store(table, from, to)
+XS::APItest::PtrTable table
+SVREF from
+SVREF to
+   CODE:
+   ptr_table_store(table, from, to);
+
+UV
+ptr_table_fetch(table, from)
+XS::APItest::PtrTable table
+SVREF from
+   CODE:
+   RETVAL = PTR2UV(ptr_table_fetch(table, from));
+   OUTPUT:
+   RETVAL
+
+void
+ptr_table_split(table)
+XS::APItest::PtrTable table
+
+void
+ptr_table_clear(table)
+XS::APItest::PtrTable table
+
 MODULE = XS::APItest           PACKAGE = XS::APItest
 
 PROTOTYPES: DISABLE
@@ -554,15 +703,38 @@ 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
 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)
@@ -922,17 +1094,36 @@ utf16_to_utf8 (sv, ...)
        ST(0) = dest;
        XSRETURN(1);
 
-U32
-pmflag (flag, before = 0)
-       int flag
-       U32 before
-   CODE:
-       pmflag(&before, flag);
-       RETVAL = before;
-    OUTPUT:
-       RETVAL
-
 void
 my_exit(int exitcode)
         PPCODE:
         my_exit(exitcode);
+
+I32
+sv_count()
+        CODE:
+           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);
+
+BOOT:
+       {
+       HV* stash;
+       SV** meth = NULL;
+       CV* cv;
+       stash = gv_stashpv("XS::APItest::TempLv", 0);
+       if (stash)
+           meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
+       if (!meth)
+           croak("lost method 'make_temp_mg_lv'");
+       cv = GvCV(*meth);
+       CvLVALUE_on(cv);
+       }