t/uni/caller.t

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