1#!/usr/bin/perl
2
3use warnings;
4use strict;
5no warnings 'experimental::builtin';
6use builtin qw(reftype);
7
8use Test::More;
9use XS::APItest;
10
11BEGIN { *my_caller = \&XS::APItest::my_caller }
12
13{
14    package DB;
15    no strict "refs";
16    sub sub { &$DB::sub }
17}
18
19sub try_caller {
20    my @args = @_;
21    my $l   = shift @args;
22    my $n   = pop @args;
23    my $hhv = pop @args;
24
25    my @c  = my_caller $l;
26    my $hh = pop @c;
27
28    is_deeply \@c, [ @args, ($hhv) x 3 ], 
29                                "caller_cx for $n";
30    if (defined $hhv) {
31	local $TODO; # these two work ok under the bebugger
32        ok defined $hh,         "...with defined hinthash";
33        is reftype $hh, "HASH", "...which is a HASH";
34    }
35    is $hh->{foo},  $hhv,       "...with correct hinthash value";
36}
37
38try_caller 0, qw/main try_caller/ x 2, undef, "current sub";
39{
40    BEGIN { $^H{foo} = "bar" }
41    try_caller 0, qw/main try_caller/ x 2, "bar", "current sub w/hinthash";
42}
43
44sub one {
45    my ($hh, $n) = @_;
46    try_caller 1, qw/main one/ x 2, $hh, $n;
47}
48
49one undef, "upper sub";
50{
51    BEGIN { $^H{foo} = "baz" }
52    one "baz", "upper sub w/hinthash";
53}
54
55BEGIN { $^P = 1 }
56# This is really bizarre. One stack frame has the correct CV but the
57# wrong stash, the other the other way round. At least pp_caller knows
58# what to do with them...
59try_caller 0, qw/main sub DB try_caller/, undef, "current sub w/DB::sub";
60{
61    BEGIN { $^H{foo} = "DB" }
62    try_caller 0, qw/main sub DB try_caller/, "DB",
63                                    "current sub w/hinthash, DB::sub";
64}
65
66sub dbone {
67    my ($hh, $n) = @_;
68    try_caller 1, qw/main sub DB dbone/, $hh, $n;
69}
70
71dbone undef, "upper sub w/DB::sub";
72TODO: {
73    local $TODO = "hinthash incorrect under debugger";
74    BEGIN { $^{foo} = "DBu" }
75    dbone "DBu", "upper sub w/hinthash, DB::sub";
76}
77BEGIN { $^P = 0 }
78
79done_testing;
80