t/op/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 }
   9
  10 plan( tests => 20 );
  11
  12 my @c;
  13
  14 print "# Tests with caller(0)\n";
  15
  16 @c = caller(0);
  17 ok( (!@c), "caller(0) in main program" );
  18
  19 eval { @c = caller(0) };
  20 is( $c[3], "(eval)", "subroutine name in an eval {}" );
  21 ok( !$c[4], "hasargs false in an eval {}" );
  22
  23 eval q{ @c = (Caller(0))[3] };
  24 is( $c[3], "(eval)", "subroutine name in an eval ''" );
  25 ok( !$c[4], "hasargs false in an eval ''" );
  26
  27 sub { @c = caller(0) } -> ();
  28 is( $c[3], "main::__ANON__", "anonymous subroutine name" );
  29 ok( $c[4], "hasargs true with anon sub" );
  30
  31 # Bug 20020517.003, used to dump core
  32 sub foo { @c = caller(0) }
  33 my $fooref = delete $::{foo};
  34 $fooref -> ();
  35 is( $c[3], "(unknown)", "unknown subroutine name" );
  36 ok( $c[4], "hasargs true with unknown sub" );
  37
  38 print "# Tests with caller(1)\n";
  39
  40 sub f { @c = caller(1) }
  41
  42 sub callf { f(); }
  43 callf();
  44 is( $c[3], "main::callf", "subroutine name" );
  45 ok( $c[4], "hasargs true with callf()" );
  46 &callf;
  47 ok( !$c[4], "hasargs false with &callf" );
  48
  49 eval { f() };
  50 is( $c[3], "(eval)", "subroutine name in an eval {}" );
  51 ok( !$c[4], "hasargs false in an eval {}" );
  52
  53 eval q{ f() };
  54 is( $c[3], "(eval)", "subroutine name in an eval ''" );
  55 ok( !$c[4], "hasargs false in an eval ''" );
  56
  57 sub { f() } -> ();
  58 is( $c[3], "main::__ANON__", "anonymous subroutine name" );
  59 ok( $c[4], "hasargs true with anon sub" );
  60
  61 sub foo2 { f() }
  62 my $fooref2 = delete $::{foo2};
  63 $fooref2 -> ();
  64 is( $c[3], "(unknown)", "unknown subroutine name" );
  65 ok( $c[4], "hasargs true with unknown sub" );