XS-APItest/t/caller.t: mark two passing tests
[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         local $TODO; # these two work ok under the bebugger
31         ok defined $hh,         "...with defined hinthash";
32         is reftype $hh, "HASH", "...which is a HASH";
33     }
34     is $hh->{foo},  $hhv,       "...with correct hinthash value";
35 }
36
37 try_caller 0, qw/main try_caller/ x 2, undef, "current sub";
38 {
39     BEGIN { $^H{foo} = "bar" }
40     try_caller 0, qw/main try_caller/ x 2, "bar", "current sub w/hinthash";
41 }
42
43 sub one {
44     my ($hh, $n) = @_;
45     try_caller 1, qw/main one/ x 2, $hh, $n;
46 }
47
48 one undef, "upper sub";
49 {
50     BEGIN { $^H{foo} = "baz" }
51     one "baz", "upper sub w/hinthash";
52 }
53
54 BEGIN { $^P = 1 }
55 # This is really bizarre. One stack frame has the correct CV but the
56 # wrong stash, the other the other way round. At least pp_caller knows
57 # what to do with them...
58 try_caller 0, qw/main sub DB try_caller/, undef, "current sub w/DB::sub";
59 {
60     BEGIN { $^H{foo} = "DB" }
61     try_caller 0, qw/main sub DB try_caller/, "DB",
62                                     "current sub w/hinthash, DB::sub";
63 }
64
65 sub dbone {
66     my ($hh, $n) = @_;
67     try_caller 1, qw/main sub DB dbone/, $hh, $n;
68 }
69
70 dbone undef, "upper sub w/DB::sub";
71 TODO: {
72     local $TODO = "hinthash incorrect under debugger";
73     BEGIN { $^{foo} = "DBu" }
74     dbone "DBu", "upper sub w/hinthash, DB::sub";
75 }
76 BEGIN { $^P = 0 }
77
78 done_testing;