1#!/usr/bin/perl 2 3use warnings; 4use strict; 5 6use Test::More; 7use XS::APItest; 8use Scalar::Util qw/reftype/; 9 10BEGIN { *my_caller = \&XS::APItest::my_caller } 11 12{ 13 package DB; 14 no strict "refs"; 15 sub sub { &$DB::sub } 16} 17 18sub 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 37try_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 43sub one { 44 my ($hh, $n) = @_; 45 try_caller 1, qw/main one/ x 2, $hh, $n; 46} 47 48one undef, "upper sub"; 49{ 50 BEGIN { $^H{foo} = "baz" } 51 one "baz", "upper sub w/hinthash"; 52} 53 54BEGIN { $^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... 58try_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 65sub dbone { 66 my ($hh, $n) = @_; 67 try_caller 1, qw/main sub DB dbone/, $hh, $n; 68} 69 70dbone undef, "upper sub w/DB::sub"; 71TODO: { 72 local $TODO = "hinthash incorrect under debugger"; 73 BEGIN { $^{foo} = "DBu" } 74 dbone "DBu", "upper sub w/hinthash, DB::sub"; 75} 76BEGIN { $^P = 0 } 77 78done_testing; 79