Add tests for PL_peepp/PL_rpeepp

2 files changed, 124 insertions, 0 deletions

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index f8033e89d1..dcdd84c686 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -17,6 +17,11 @@ typedef struct {
     AV *cscav;
     AV *bhkav;
     bool bhk_record;
+    peep_t orig_peep;
+    peep_t orig_rpeep;
+    int peep_recording;
+    AV *peep_recorder;
+    AV *rpeep_recorder;
 } my_cxt_t;
 
 START_MY_CXT
@@ -327,6 +332,46 @@ blockhook_test_eval(pTHX_ OP *const o)
 
 STATIC BHK bhk_csc, bhk_test;
 
+STATIC void
+my_peep (pTHX_ OP *o)
+{
+    dMY_CXT;
+
+    if (!o)
+	return;
+
+    MY_CXT.orig_peep(aTHX_ o);
+
+    if (!MY_CXT.peep_recording)
+	return;
+
+    for (; o; o = o->op_next) {
+	if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
+	    av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
+	}
+    }
+}
+
+STATIC void
+my_rpeep (pTHX_ OP *o)
+{
+    dMY_CXT;
+
+    if (!o)
+	return;
+
+    MY_CXT.orig_rpeep(aTHX_ o);
+
+    if (!MY_CXT.peep_recording)
+	return;
+
+    for (; o; o = o->op_next) {
+	if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
+	    av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
+	}
+    }
+}
+
 #include "const-c.inc"
 
 MODULE = XS::APItest:Hash		PACKAGE = XS::APItest::Hash
@@ -722,6 +767,14 @@ BOOT:
     BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
     BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
     Perl_blockhook_register(aTHX_ &bhk_csc);
+
+    MY_CXT.peep_recorder = newAV();
+    MY_CXT.rpeep_recorder = newAV();
+
+    MY_CXT.orig_peep = PL_peepp;
+    MY_CXT.orig_rpeep = PL_rpeepp;
+    PL_peepp = my_peep;
+    PL_rpeepp = my_rpeep;
 }
 
 void
@@ -734,6 +787,8 @@ CLONE(...)
     MY_CXT.cscav = NULL;
     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
     MY_CXT.bhk_record = 0;
+    MY_CXT.peep_recorder = newAV();
+    MY_CXT.rpeep_recorder = newAV();
 
 void
 print_double(val)
@@ -1213,6 +1268,40 @@ test_copyhints()
 	if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak("fail");
 	LEAVE;
 
+void
+peep_enable ()
+    PREINIT:
+	dMY_CXT;
+    CODE:
+	av_clear(MY_CXT.peep_recorder);
+	av_clear(MY_CXT.rpeep_recorder);
+	MY_CXT.peep_recording = 1;
+
+void
+peep_disable ()
+    PREINIT:
+	dMY_CXT;
+    CODE:
+	MY_CXT.peep_recording = 0;
+
+SV *
+peep_record ()
+    PREINIT:
+	dMY_CXT;
+    CODE:
+	RETVAL = newRV_inc(MY_CXT.peep_recorder);
+    OUTPUT:
+	RETVAL
+
+SV *
+rpeep_record ()
+    PREINIT:
+	dMY_CXT;
+    CODE:
+	RETVAL = newRV_inc(MY_CXT.rpeep_recorder);
+    OUTPUT:
+	RETVAL
+
 BOOT:
 	{
 	HV* stash;
diff --git a/ext/XS-APItest/t/peep.t b/ext/XS-APItest/t/peep.t
new file mode 100644
index 0000000000..3db5812b40
--- /dev/null
+++ b/ext/XS-APItest/t/peep.t
@@ -0,0 +1,35 @@
+#!perl
+
+use strict;
+use warnings;
+use Test::More tests => 9;
+
+use XS::APItest;
+
+use Devel::Peek;
+
+my $record = XS::APItest::peep_record;
+my $rrecord = XS::APItest::rpeep_record;
+
+# our peep got called and remembered the string constant
+XS::APItest::peep_enable;
+eval q[my $foo = q/affe/];
+XS::APItest::peep_disable;
+
+is(scalar @{ $record }, 1);
+is(scalar @{ $rrecord }, 1);
+is($record->[0], 'affe');
+is($rrecord->[0], 'affe');
+
+
+# peep got called for each root op of the branch
+$::moo = $::moo = 0;
+XS::APItest::peep_enable;
+eval q[my $foo = $::moo ? q/x/ : q/y/];
+XS::APItest::peep_disable;
+
+is(scalar @{ $record }, 1);
+is(scalar @{ $rrecord }, 2);
+is($record->[0], 'y');
+is($rrecord->[0], 'x');
+is($rrecord->[1], 'y');