Tests for caller_cx, cop_hints_*.

It seems that the runtime hinthash isn't returned correctly when running
under the debugger, so mark those tests TODO for now.

2 files changed, 109 insertions, 1 deletions

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 23ce3edea5..5ce9bfafd0 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -634,7 +634,6 @@ sub CLEAR    { %{$_[0]} = () }
 
 =cut
 
-
 MODULE = XS::APItest:TempLv		PACKAGE = XS::APItest::TempLv
 
 void
@@ -1033,6 +1032,38 @@ rmagical_flags(sv)
         XSRETURN(3);
 
 void
+my_caller(level)
+        I32 level
+    PREINIT:
+        const PERL_CONTEXT *cx, *dbcx;
+        const char *pv;
+        const GV *gv;
+        HV *hv;
+    PPCODE:
+        cx = caller_cx(level, &dbcx);
+        EXTEND(SP, 8);
+
+        pv = CopSTASHPV(cx->blk_oldcop);
+        ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
+        gv = CvGV(cx->blk_sub.cv);
+        ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
+
+        pv = CopSTASHPV(dbcx->blk_oldcop);
+        ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
+        gv = CvGV(dbcx->blk_sub.cv);
+        ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
+
+        ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo");
+        ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0);
+        ST(6) = cop_hints_fetchsv(cx->blk_oldcop, 
+                sv_2mortal(newSVpvn("foo", 3)), 0);
+
+        hv = cop_hints_2hv(cx->blk_oldcop);
+        ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
+
+        XSRETURN(8);
+
+void
 DPeek (sv)
     SV   *sv
 
diff --git a/ext/XS-APItest/t/caller.t b/ext/XS-APItest/t/caller.t
new file mode 100644
index 0000000000..d3365ffec0
--- /dev/null
+++ b/ext/XS-APItest/t/caller.t
@@ -0,0 +1,77 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use Test::More;
+use XS::APItest;
+use Scalar::Util qw/reftype/;
+
+BEGIN { *my_caller = \&XS::APItest::my_caller }
+
+{
+    package DB;
+    no strict "refs";
+    sub sub { &$DB::sub }
+}
+
+sub try_caller {
+    my @args = @_;
+    my $l   = shift @args;
+    my $n   = pop @args;
+    my $hhv = pop @args;
+
+    my @c  = my_caller $l;
+    my $hh = pop @c;
+
+    is_deeply \@c, [ @args, ($hhv) x 3 ], 
+                                "caller_cx for $n";
+    if (defined $hhv) {
+        ok defined $hh,         "...with defined hinthash";
+        is reftype $hh, "HASH", "...which is a HASH";
+    }
+    is $hh->{foo},  $hhv,       "...with correct hinthash value";
+}
+
+try_caller 0, qw/main try_caller/ x 2, undef, "current sub";
+{
+    BEGIN { $^H{foo} = "bar" }
+    try_caller 0, qw/main try_caller/ x 2, "bar", "current sub w/hinthash";
+}
+
+sub one {
+    my ($hh, $n) = @_;
+    try_caller 1, qw/main one/ x 2, $hh, $n;
+}
+
+one undef, "upper sub";
+{
+    BEGIN { $^H{foo} = "baz" }
+    one "baz", "upper sub w/hinthash";
+}
+
+BEGIN { $^P = 1 }
+# This is really bizarre. One stack frame has the correct CV but the
+# wrong stash, the other the other way round. At least pp_caller knows
+# what to do with them...
+try_caller 0, qw/main sub DB try_caller/, undef, "current sub w/DB::sub";
+{
+    BEGIN { $^H{foo} = "DB" }
+    try_caller 0, qw/main sub DB try_caller/, "DB",
+                                    "current sub w/hinthash, DB::sub";
+}
+
+sub dbone {
+    my ($hh, $n) = @_;
+    try_caller 1, qw/main sub DB dbone/, $hh, $n;
+}
+
+dbone undef, "upper sub w/DB::sub";
+TODO: {
+    local $TODO = "hinthash incorrect under debugger";
+    BEGIN { $^{foo} = "DBu" }
+    dbone "DBu", "upper sub w/hinthash, DB::sub";
+}
+BEGIN { $^P = 0 }
+
+done_testing;