t/32-global.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 my $tests;
   7 BEGIN { $tests = 9 }
   8
   9 use Test::More tests => (1 + $tests + 1) + 3 + 5 + 2 + 4;
  10
  11 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
  12
  13 use lib 't/lib';
  14
  15 my %wrong = map { $_ => 1 } 2, 3, 5, 6, 7, 9;
  16
  17 sub expect {
  18  my ($pkg, $file, $prefix) = @_;
  19  $file   = defined $file   ? quotemeta $file   : '\(eval \d+\)';
  20  $prefix = defined $prefix ? quotemeta $prefix : 'warn:';
  21  qr/^${prefix}Indirect call of method "new" on object "$pkg" at $file line \d+/;
  22 }
  23
  24 {
  25  my $code = do { local $/; <DATA> };
  26  my (%res, $num, @left);
  27
  28  {
  29   local $SIG{__WARN__} = sub {
  30    ++$num;
  31    my $w = join '', 'warn:', @_;
  32    if ($w =~ /"P(\d+)"/ and not exists $res{$1}) {
  33     $res{$1} = $w;
  34    } else {
  35     push @left, "[$num] $w";
  36    }
  37   };
  38   eval "return; $code";
  39  }
  40  is $@, '', 'DATA compiled fine';
  41
  42  for (1 .. $tests) {
  43   my $w = $res{$_};
  44   if ($wrong{$_}) {
  45    like $w, expect("P$_"), "$_ should warn";
  46   } else {
  47    is   $w, undef,         "$_ shouldn't warn";
  48   }
  49  }
  50
  51  is @left, 0, 'nothing left';
  52  diag "Extraneous warnings:\n", @left if @left;
  53 }
  54
  55 {
  56  my @w;
  57  {
  58   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  59   eval 'return; { no indirect "global" }; BEGIN { eval q[return; new XYZ] }';
  60  }
  61  is   $@, '', 'eval test did not croak prematurely';
  62  is   @w, 1,  'eval test threw one warning';
  63  diag join "\n", 'All warnings:', @w if @w > 1;
  64  like $w[0], expect('XYZ'), 'eval test threw the correct warning';
  65 }
  66
  67 {
  68  my @w;
  69  {
  70   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  71   eval 'return; { no indirect "global" }; use indirect::TestRequiredGlobal';
  72  }
  73  is   $@, '', 'require test did not croak prematurely';
  74  is   @w, 3,  'require test threw three warnings';
  75  diag join "\n", 'All warnings:', @w if @w > 3;
  76  like $w[0], expect('ABC', 't/lib/indirect/TestRequiredGlobal.pm'),
  77                             'require test first warning is correct';
  78  like $w[1], expect('DEF'), 'require test second warning is correct';
  79  like $w[2], expect('GHI'), 'require test third warning is correct';
  80 }
  81
  82 {
  83  my @w;
  84  {
  85   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  86   eval 'return; { no indirect qw<global fatal> }; new MNO';
  87  }
  88  like $@, expect('MNO', undef, ''), 'fatal test throw the correct exception';
  89  is   @w, 0,                        'fatal test did not throw any warning';
  90  diag join "\n", 'All warnings:', @w if @w;
  91 }
  92
  93 {
  94  my @w;
  95  my @h;
  96  my $hook = sub { push @h, join '', 'hook:', indirect::msg(@_) };
  97  {
  98   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  99   eval 'return; { no indirect hook => $hook, "global" }; new PQR';
 100  }
 101  is   $@, '', 'hook test did not croak prematurely';
 102  is   @w, 0,  'hook test did not throw any warning';
 103  diag join "\n", 'All warnings:', @w if @w;
 104  is   @h, 1,  'hook test hooked up three violations';
 105  diag join "\n", 'All captured violations:', @h if @h > 1;
 106  like $h[0], expect('PQR', undef, 'hook:'),
 107               'hook test captured the correct error';
 108 }
 109
 110 __DATA__
 111 my $a = new P1;
 112
 113 {
 114  no indirect 'global';
 115  my $b = new P2;
 116  {
 117   my $c = new P3;
 118  }
 119  {
 120   use indirect;
 121   my $d = new P4;
 122  }
 123  my $e = new P5;
 124 }
 125
 126 my $f = new P6;
 127
 128 no indirect;
 129
 130 my $g = new P7;
 131
 132 use indirect;
 133
 134 my $h = new P8;
 135
 136 {
 137  no indirect;
 138  eval { my $i = new P9 };
 139 }