t/uni/caller.t

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