t/op/exists_sub.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 sub t1;
  10 sub t2 : lvalue;
  11 sub t3 ();
  12 sub t4 ($);
  13 sub t5 {1;}
  14 {
  15     package P1;
  16     sub tmc {1;}
  17     package P2;
  18     @ISA = 'P1';
  19 }
  20
  21 my $has_t1 = ok( exists &t1, 't1 sub declared' );
  22 SKIP: {
  23     skip 't1 sub was not declared', 1 if ! $has_t1;
  24     ok( ! defined &t1, 't1 not defined' );
  25 }
  26
  27 my $has_t2 = ok( exists &t2, 't2 sub declared' );
  28 SKIP: {
  29     skip 't2 sub was not declared', 1 if ! $has_t2;
  30     ok( ! defined &t2, 't2 not defined' );
  31 }
  32
  33 my $has_t3 = ok( exists &t3, 't3 sub declared' );
  34 SKIP: {
  35     skip 't3 sub was not declared', 1 if ! $has_t3;
  36     ok( ! defined &t3, 't3 not defined' );
  37 }
  38
  39 my $has_t4 = ok( exists &t4, 't4 sub declared' );
  40 SKIP: {
  41     skip 't4 sub was not declared', 1 if ! $has_t4;
  42     ok( ! defined &t4, 't4 not defined' );
  43 }
  44
  45 my $has_t5 = ok( exists &t5, 't5 sub declared' );
  46 SKIP: {
  47     skip 't5 sub was not declared', 1 if ! $has_t5;
  48     ok( defined &t5, , 't5 defined' );
  49 }
  50
  51 my $has_p2_tmc = ok(! exists &P2::tmc, 'P2::tmc not declared, it was inherited');
  52 SKIP: {
  53     skip 'P2::tmc sub was not declared', 1 if ! $has_t5;
  54     ok( ! defined &P2::tmc, 'P2::tmc not defined' );
  55 }
  56
  57 my $ref;
  58 $ref->{A}[0] = \&t4;
  59 my $ref_exists = ok( exists &{$ref->{A}[0]}, 'references to subroutines exist');
  60 SKIP: {
  61     skip 1, 'Reference sub is not considered declared', 1 if ! $ref_exists;
  62     ok( ! defined &{$ref->{A}[0]}, 'Reference to a sub is not defined' );
  63 }
  64
  65 my $p1_tmc_exists = ok( exists &P1::tmc, 'test setup check');
  66 SKIP: {
  67     skip 'Setup P1::tmc sub is not considered declared', 1 if ! $p1_tmc_exists;
  68     ok( defined P1::tmc, 'Setup sub is defined' );
  69 }
  70
  71 undef &P1::tmc;
  72 $p1_tmc_exists = ok( exists &P1::tmc, 'P1::tmc was once defined, and continues to be after being undeffed');
  73 SKIP: {
  74     skip( 'Sub P1::tmc still exists after having undef called on it', 1) if ! $p1_tmc_exists;
  75     ok( ! defined &P1::tmc, 'P1::tmc is not longer defined after undef was called on it' );
  76 }
  77
  78 eval 'exists &t5()';
  79 like( $@, qr/not a subroutine name/, 'exists takes subroutine names with no argument list');
  80
  81 done_testing();
  82
  83 exit 0;