1#!./perl 2# Tests for caller() 3 4BEGIN { 5 chdir 't' if -d 't'; 6 @INC = '../lib'; 7 require './test.pl'; 8 plan( tests => 18 ); 9} 10 11use utf8; 12use open qw( :utf8 :std ); 13 14package ｍａｉｎ; 15 16{ 17 local $@; 18 eval 'ok(1);'; 19 ::like $@, qr/Undefined subroutine &ｍａｉｎ::ok called at/u; 20} 21my @c; 22 23sub { @c = caller(0) } -> (); 24::is( $c[3], "ｍａｉｎ::__ANON__", "anonymous subroutine name" ); 25::ok( $c[4], "hasargs true with anon sub" ); 26 27# Bug 20020517.003, used to dump core 28sub ｆｏｏ { @c = caller(0) } 29my $fooref = delete $ｍａｉｎ::{ｆｏｏ}; 30$fooref -> (); 31::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" ); 32::ok( $c[4], "hasargs true with deleted sub" ); 33 34print "# Tests with caller(1)\n"; 35 36sub ｆ { @c = caller(1) } 37 38sub ｃａｌｌｆ { ｆ(); } 39ｃａｌｌｆ(); 40::is( $c[3], "ｍａｉｎ::ｃａｌｌｆ", "subroutine name" ); 41::ok( $c[4], "hasargs true with ｃａｌｌｆ()" ); 42&ｃａｌｌｆ; 43::ok( !$c[4], "hasargs false with &ｃａｌｌｆ" ); 44 45eval { ｆ() }; 46::is( $c[3], "(eval)", "subroutine name in an eval {}" ); 47::ok( !$c[4], "hasargs false in an eval {}" ); 48 49eval q{ ｆ() }; 50::is( $c[3], "(eval)", "subroutine name in an eval ''" ); 51::ok( !$c[4], "hasargs false in an eval ''" ); 52 53sub { ｆ() } -> (); 54::is( $c[3], "ｍａｉｎ::__ANON__", "anonymous subroutine name" ); 55::ok( $c[4], "hasargs true with anon sub" ); 56 57sub ｆｏｏ2 { ｆ() } 58my $fooref2 = delete $ｍａｉｎ::{ｆｏｏ2}; 59$fooref2 -> (); 60::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" ); 61::ok( $c[4], "hasargs true with deleted sub" ); 62 63sub ｐｂ { return (caller(0))[3] } 64 65::is( eval 'ｐｂ()', 'ｍａｉｎ::ｐｂ', "actually return the right function name" ); 66 67my $saved_perldb = $^P; 68$^P = 16; 69$^P = $saved_perldb; 70 71::is( eval 'ｐｂ()', 'ｍａｉｎ::ｐｂ', 'actually return the right function name even if $^P had been on at some point' ); 72