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