Commit | Line | Data |
---|---|---|
90d1f214 BM |
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; |