This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add tests for PL_peepp/PL_rpeepp
authorFlorian Ragwitz <rafl@debian.org>
Mon, 13 Sep 2010 20:46:44 +0000 (22:46 +0200)
committerFlorian Ragwitz <rafl@debian.org>
Sun, 19 Sep 2010 23:17:50 +0000 (01:17 +0200)
MANIFEST
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/peep.t [new file with mode: 0644]

index 623c48a..3e9583a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3340,6 +3340,7 @@ ext/XS-APItest/t/my_cxt.t XS::APItest: test MY_CXT interface
 ext/XS-APItest/t/my_exit.t     XS::APItest: test my_exit
 ext/XS-APItest/t/Null.pm       Helper for ./blockhooks.t
 ext/XS-APItest/t/op.t          XS::APItest: tests for OP related APIs
+ext/XS-APItest/t/peep.t                test PL_peepp/PL_rpeepp
 ext/XS-APItest/t/pmflag.t      Test removal of Perl_pmflag()
 ext/XS-APItest/t/printf.t      XS::APItest extension
 ext/XS-APItest/t/ptr_table.t   Test ptr_table_* APIs
index f8033e8..dcdd84c 100644 (file)
@@ -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 (file)
index 0000000..3db5812
--- /dev/null
@@ -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');