]> git.vpit.fr Git - perl/modules/indirect.git/blob - t/21-bad.t
Typos
[perl/modules/indirect.git] / t / 21-bad.t
1 #!perl -T
2
3 package Dongs;
4
5 sub new;
6
7 package main;
8
9 use strict;
10 use warnings;
11
12 my ($tests, $reports);
13 BEGIN {
14  $tests   = 61;
15  $reports = 69;
16 }
17
18 use Test::More tests => 3 * (4 * $tests + $reports) + 4;
19
20 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
21
22 my ($obj, $x);
23 our ($y, $bloop);
24
25 sub expect {
26  my ($expected) = @_;
27
28  die unless $expected;
29
30  map {
31   my ($meth, $obj, $file, $line) = @$_;
32   $meth = quotemeta $meth;
33   $obj  = ($obj =~ /^\s*\{/) ? "a block" : "object \"\Q$obj\E\"";
34   $file = '\(eval \d+\)' unless defined $file;
35   $line = '\d+'          unless defined $line;
36   qr/^Indirect call of method "$meth" on $obj at $file line $line/
37  } eval $expected;
38 }
39
40 my @warns;
41
42 sub try {
43  my ($code) = @_;
44
45  @warns = ();
46  {
47   local $SIG{__WARN__} = sub { push @warns, @_ };
48   eval $code;
49  }
50 }
51
52 {
53  local $/ = "####";
54  while (<DATA>) {
55   chomp;
56   s/\s*$//;
57   s/(.*?)$//m;
58   my ($skip, $prefix) = split /#+/, $1;
59   $skip   = 0  unless defined $skip;
60   $prefix = '' unless defined $prefix;
61   s/\s*//;
62
63 SKIP:
64   {
65    my ($code, $expected) = split /^-{4,}$/m, $_, 2;
66    my @expected = expect($expected);
67
68    skip "$_: $skip" => 3 * (4 + @expected) if eval $skip;
69
70    {
71     try "return; $prefix; use indirect; $code";
72     is $@,     '', "use indirect: $code";
73     is @warns, 0,  'correct number of reports';
74
75     try "return; $prefix; no indirect; $code";
76     is $@,     '',        "no indirect: $code";
77     is @warns, @expected, 'correct number of reports';
78     for my $i (0 .. $#expected) {
79      like $warns[$i], $expected[$i], "report $i is correct";
80     }
81    }
82
83    {
84     local $_ = $_;
85     s/Hlagh/Dongs/g;
86     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
87     my @expected = expect($expected);
88
89     try "return; $prefix; use indirect; $code";
90     is $@,     '', "use indirect, defined: $code";
91     is @warns, 0,  'correct number of reports';
92
93     try "return; $prefix; no indirect; $code";
94     is $@,     '',        "no indirect, defined: $code";
95     is @warns, @expected, 'correct number of reports';
96     for my $i (0 .. $#expected) {
97      like $warns[$i], $expected[$i], "report $i is correct";
98     }
99    }
100
101    {
102     my $code = $code;
103     $code =~ s/\$/\$ \n\t /g;
104
105     try "return; $prefix; use indirect; $code";
106     is $@,     '', "use indirect, spaces: $code";
107     is @warns, 0,  'correct number of reports';
108
109     try "return; $prefix; no indirect; $code";
110     is $@,     '',        "no indirect, spaces: $code";
111     is @warns, @expected, 'correct number of reports';
112     for my $i (0 .. $#expected) {
113      like $warns[$i], $expected[$i], "report $i is correct";
114     }
115    }
116   }
117  }
118 }
119
120 eval {
121  my @warns;
122  {
123   local $SIG{__WARN__} = sub { push @warns, @_ };
124   eval "return; no indirect 'hlagh'; \$obj = new Hlagh1;";
125  }
126  is        $@,      '',  'no indirect "hlagh" didn\'t croak';
127  is        @warns,  1,   'only one warning';
128  my $warn = shift @warns;
129  like      $warn,   qr/^Indirect call of method "new" on object "Hlagh1"/,
130                          'no indirect "hlagh" enables the pragma';
131  is_deeply \@warns, [ ], 'nothing more';
132 }
133
134 __DATA__
135
136 $obj = new Hlagh;
137 ----
138 [ 'new', 'Hlagh' ]
139 ####
140 $obj = new Hlagh if 0;
141 ----
142 [ 'new', 'Hlagh' ]
143 ####
144 $obj = new Hlagh();
145 ----
146 [ 'new', 'Hlagh' ]
147 ####
148 $obj = new Hlagh(1);
149 ----
150 [ 'new', 'Hlagh' ]
151 ####
152 $obj = new Hlagh(1, 2);
153 ----
154 [ 'new', 'Hlagh' ]
155 ####
156 $obj = new        Hlagh            ;
157 ----
158 [ 'new', 'Hlagh' ]
159 ####
160 $obj = new        Hlagh     (      )      ;
161 ----
162 [ 'new', 'Hlagh' ]
163 ####
164 $obj = new        Hlagh     (      1        )     ;
165 ----
166 [ 'new', 'Hlagh' ]
167 ####
168 $obj = new        Hlagh     (      1        ,       2        )     ;
169 ----
170 [ 'new', 'Hlagh' ]
171 ####
172 $obj = new    
173                       Hlagh             
174         ;
175 ----
176 [ 'new', 'Hlagh' ]
177 ####
178 $obj = new   
179                                        Hlagh     (    
180                   )      ;
181 ----
182 [ 'new', 'Hlagh' ]
183 ####
184 $obj =
185               new    
186     Hlagh     (      1   
187             )     ;
188 ----
189 [ 'new', 'Hlagh' ]
190 ####
191 $obj =
192 new      
193 Hlagh    
194                    (      1        ,  
195                 2        )     ;
196 ----
197 [ 'new', 'Hlagh' ]
198 ####
199 $obj = new $x;
200 ----
201 [ 'new', '$x' ]
202 ####
203 $obj = new $x();
204 ----
205 [ 'new', '$x' ]
206 ####
207 $obj = new $x('foo');
208 ----
209 [ 'new', '$x' ]
210 ####
211 $obj = new $x qq{foo}, 1;
212 ----
213 [ 'new', '$x' ]
214 ####
215 $obj = new $x qr{foo\s+bar}, 1 .. 1;
216 ----
217 [ 'new', '$x' ]
218 ####
219 $obj = new $x(qw/bar baz/);
220 ----
221 [ 'new', '$x' ]
222 ####
223 $obj = new
224           $_;
225 ----
226 [ 'new', '$_' ]
227 ####
228 $obj = new
229              $_     (        );
230 ----
231 [ 'new', '$_' ]
232 ####
233 $obj = new $_      qr/foo/  ;
234 ----
235 [ 'new', '$_' ]
236 ####
237 $obj = new $_     qq(bar baz);
238 ----
239 [ 'new', '$_' ]
240 ####
241 meh $_;
242 ----
243 [ 'meh', '$_' ]
244 ####
245 meh $_ 1, 2;
246 ----
247 [ 'meh', '$_' ]
248 ####
249 meh $$;
250 ----
251 [ 'meh', '$$' ]
252 ####
253 meh $$ 1, 2;
254 ----
255 [ 'meh', '$$' ]
256 ####
257 meh $x;
258 ----
259 [ 'meh', '$x' ]
260 ####
261 meh $x 1, 2;
262 ----
263 [ 'meh', '$x' ]
264 ####
265 meh $x, 1, 2;
266 ----
267 [ 'meh', '$x' ]
268 ####
269 meh $y;
270 ----
271 [ 'meh', '$y' ]
272 ####
273 meh $y 1, 2;
274 ----
275 [ 'meh', '$y' ]
276 ####
277 meh $y, 1, 2;
278 ----
279 [ 'meh', '$y' ]
280 #### $] < 5.010 # use feature 'state'; state $z
281 meh $z;
282 ----
283 [ 'meh', '$z' ]
284 #### $] < 5.010 # use feature 'state'; state $z
285 meh $z 1, 2;
286 ----
287 [ 'meh', '$z' ]
288 #### $] < 5.010 # use feature 'state'; state $z
289 meh $z, 1, 2;
290 ----
291 [ 'meh', '$z' ]
292 ####
293 package sploosh;
294 our $sploosh;
295 meh $sploosh::sploosh;
296 ----
297 [ 'meh', '$sploosh::sploosh' ]
298 ####
299 package sploosh;
300 our $sploosh;
301 meh $sploosh;
302 ----
303 [ 'meh', '$sploosh' ]
304 ####
305 package sploosh;
306 meh $main::bloop;
307 ----
308 [ 'meh', '$main::bloop' ]
309 ####
310 package sploosh;
311 meh $bloop;
312 ----
313 [ 'meh', '$bloop' ]
314 ####
315 package ma;
316 meh $bloop;
317 ----
318 [ 'meh', '$bloop' ]
319 ####
320 package sploosh;
321 our $sploosh;
322 package main;
323 meh $sploosh::sploosh;
324 ----
325 [ 'meh', '$sploosh::sploosh' ]
326 ####
327 new Hlagh->wut;
328 ----
329 [ 'new', 'Hlagh' ]
330 ####
331 new Hlagh->wut();
332 ----
333 [ 'new', 'Hlagh' ]
334 ####
335 new Hlagh->wut, "Wut";
336 ----
337 [ 'new', 'Hlagh' ]
338 ####
339 $obj = HlaghHlagh Hlagh;
340 ----
341 [ 'HlaghHlagh', 'Hlagh' ]
342 ####
343 $obj = HlaghHlagh Hlagh; # HlaghHlagh Hlagh
344 ----
345 [ 'HlaghHlagh', 'Hlagh' ]
346 ####
347 $obj = new newnew;
348 ----
349 [ 'new', 'newnew' ]
350 ####
351 $obj = new newnew; # new newnew
352 ----
353 [ 'new', 'newnew' ]
354 ####
355 $obj = feh feh;
356 ----
357 [ 'feh', 'feh' ]
358 ####
359 $obj = feh feh; # feh feh
360 ----
361 [ 'feh', 'feh' ]
362 ####
363 new Hlagh (meh $x)
364 ----
365 [ 'meh', '$x' ], [ 'new', 'Hlagh' ]
366 ####
367 Hlagh->new(meh $x)
368 ----
369 [ 'meh', '$x' ]
370 ####
371 meh { };
372 ----
373 [ 'meh', '{' ]
374 ####
375 meh {
376  1;
377 };
378 ----
379 [ 'meh', '{' ]
380 ####
381 meh {
382  1;
383  1;
384 };
385 ----
386 [ 'meh', '{' ]
387 ####
388 meh { new Hlagh; 1; };
389 ----
390 [ 'new', 'Hlagh' ], [ 'meh', '{' ]
391 ####
392 meh { feh $x; 1; };
393 ----
394 [ 'feh', '$x' ], [ 'meh', '{' ]
395 ####
396 meh { feh $x; use indirect; new Hlagh; 1; };
397 ----
398 [ 'feh', '$x' ], [ 'meh', '{' ]
399 ####
400 meh { feh $y; 1; };
401 ----
402 [ 'feh', '$y' ], [ 'meh', '{' ]
403 ####
404 meh { feh $x; 1; } new Hlagh, feh $y;
405 ----
406 [ 'feh', '$x' ], [ 'new', 'Hlagh' ], [ 'feh', '$y' ], [ 'meh', '{' ]