]> git.vpit.fr Git - perl/modules/indirect.git/blob - t/30-scope.t
Don't actually create an entry when storing NULL in the ptable
[perl/modules/indirect.git] / t / 30-scope.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 my $tests;
7 BEGIN { $tests = 18 }
8
9 use Test::More tests => 1 + $tests + 1 + 2 + 3 + 5;
10
11 use lib 't/lib';
12
13 my %wrong = map { $_ => 1 } 2, 3, 5, 7, 9, 10, 14, 15, 17, 18;
14
15 sub expect {
16  my ($pkg, $file) = @_;
17  $file = $file ? quotemeta $file : '\(eval\s+\d+\)';
18  return qr/^warn:Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"\s+at\s+$file\s+line\s+\d+/;
19 }
20
21 {
22  my $code = do { local $/; <DATA> };
23  my (%res, $num, @left);
24  {
25   local $SIG{__WARN__} = sub {
26    ++$num;
27    my $w = join '', 'warn:', @_;
28    if ($w =~ /"P(\d+)"/ and not exists $res{$1}) {
29     $res{$1} = $w;
30    } else {
31     push @left, "[$num] $w";
32    }
33   };
34   eval "die qq{ok\\n}; $code";
35   is($@, "ok\n", 'DATA compiled fine');
36  }
37  for (1 .. $tests) {
38   my $w = $res{$_};
39   if ($wrong{$_}) {
40    like($w, expect("P$_"), "$_ should warn");
41   } else {
42    is($w, undef, "$_ shouldn't warn");
43   }
44  }
45  is(@left, 0, 'nothing left');
46  diag "Extraneous warnings:\n", @left if @left;
47 }
48
49 {
50  my $w = '';
51  local $SIG{__WARN__} = sub {
52   $w = 'more than 2 warnings' if $w;
53   $w = join '', 'warn:', @_
54  };
55  {
56   eval 'no indirect; my $x = new Foo';
57   like($w, expect('Foo'), "eval 'no indirect; my \$x = new Foo'");
58  }
59  $w = '';
60  {
61   {
62    no indirect;
63    eval 'my $x = new Bar';
64   }
65   if ($] < 5.009005) {
66    is($w, '', "eval 'no indirect; my \$x = new Bar'");
67   } else {
68    like($w, expect('Bar'), "no indirect; eval 'my \$x = new Bar'");
69   }
70  }
71 }
72
73 {
74  my @w;
75  {
76   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
77   eval "die qq{ok\\n}; no indirect; use indirect::TestRequired1; my \$x = new Foo;";
78  }
79  is         $@, "ok\n",        'first require test doesn\'t croak prematurely';
80  my $w = shift @w;
81  like       $w, expect('Foo'), 'first require test catch errors in current scope';
82  is_deeply \@w, [ ],           'first require test doesn\'t propagate into the required file';
83 }
84
85 {
86  my @w;
87  {
88   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
89   eval "die qq{ok\\n}; no indirect; use indirect::TestRequired2; my \$x = new Bar;";
90  }
91  @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if $] <= 5.008003;
92  is   $@, "ok\n", 'second require test doesn\'t croak prematurely';
93  my $w = shift @w;
94  like $w, expect('Baz', 't/lib/indirect/TestRequired2.pm'),
95                                      'second require test caught error for Baz';
96  SKIP: {
97   skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 1
98                                                                if $] < 5.009005;
99   $w = shift @w;
100   like $w, expect('Blech'), 'second require test caught error for Blech';
101  }
102  $w = shift @w;
103  like       $w, expect('Bar'), 'second require test caught error for Bar';
104  is_deeply \@w, [ ],           'second require test doesn\'t have more errors';
105 }
106
107 __DATA__
108 my $a = new P1;
109
110 {
111  no indirect;
112  my $b = new P2;
113  {
114   my $c = new P3;
115  }
116  {
117   use indirect;
118   my $d = new P4;
119  }
120  my $e = new P5;
121 }
122
123 my $f = new P6;
124
125 no indirect;
126
127 my $g = new P7;
128
129 use indirect;
130
131 my $h = new P8;
132
133 {
134  no indirect;
135  eval { my $i = new P9 };
136 }
137
138 eval { no indirect; my $j = new P10 };
139
140 {
141  use indirect;
142  new P11 do { use indirect; new P12 };
143 }
144
145 {
146  use indirect;
147  new P13 do { no indirect; new P14 };
148 }
149
150 {
151  no indirect;
152  new P15 do { use indirect; new P16 };
153 }
154
155 {
156  no indirect;
157  new P17 do { no indirect; new P18 };
158 }