1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
#!/usr/bin/perl
use warnings;
use strict;
use builtin qw(reftype);
use Test::More;
use XS::APItest;
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) {
local $TODO; # these two work ok under the bebugger
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;
|
