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