This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tests for caller_cx, cop_hints_*.
authorBen Morrow <ben@morrow.me.uk>
Tue, 31 Aug 2010 08:01:03 +0000 (09:01 +0100)
committerRafael Garcia-Suarez <rgs@consttype.org>
Tue, 7 Sep 2010 10:10:19 +0000 (12:10 +0200)
It seems that the runtime hinthash isn't returned correctly when running
under the debugger, so mark those tests TODO for now.

MANIFEST
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/caller.t [new file with mode: 0644]

index 4925ab3..7900589 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3327,6 +3327,7 @@ ext/XS-APItest/t/BHK.pm           Helper for ./blockhooks.t
 ext/XS-APItest/t/blockhooks-csc.t      XS::APItest: more tests for PL_blockhooks
 ext/XS-APItest/t/blockhooks.t  XS::APItest: tests for PL_blockhooks
 ext/XS-APItest/t/Block.pm      Helper for ./blockhooks.t
+ext/XS-APItest/t/caller.t      XS::APItest: tests for caller_cx
 ext/XS-APItest/t/call.t                XS::APItest extension
 ext/XS-APItest/t/exception.t   XS::APItest extension
 ext/XS-APItest/t/hash.t                XS::APItest: tests for hash related APIs
index 23ce3ed..5ce9bfa 100644 (file)
@@ -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 (file)
index 0000000..d3365ff
--- /dev/null
@@ -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;