]> git.vpit.fr Git - perl/modules/subs-auto.git/blob - t/10-base.t
Update the bug tracker URL in META after the rt.perl.org upgrade
[perl/modules/subs-auto.git] / t / 10-base.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 92;
7
8 # ... Helpers .................................................................
9
10 my %_re = (
11  bareword => sub { qr/^Bareword\s+['"]?\s*$_[0]\s*['"]?\s+not\s+allowed\s+while\s+["']?\s*strict\s+subs\s*['"]?\s+in\s+use\s+at\s+$_[1]\s+line\s+$_[2]/ },
12  undefined => sub { qr/^Undefined\s+subroutine\s+\&$_[0]\s+called\s+at\s+$_[1]\s+line\s+$_[2]/ },
13 );
14
15 sub _got_test {
16  my $sub  = shift;
17  my $line = shift;
18  my %args = @_;
19  my $msg  = delete $args{msg};
20  $msg     = join ' ', $args{name}, $sub, 'line', $line unless $msg;
21  my $file = $args{eval} ? '\\(eval\\s+\\d+\\)' : quotemeta $0;
22  my $re   = $_re{$args{name}}->($sub, $file, $line);
23  if ($args{todo}) {
24   TODO: {
25    local $TODO = $args{todo};
26    like($@, $re, $msg);
27   }
28  } else {
29   like($@, $re, $msg);
30  }
31 }
32
33 sub _got_bareword { _got_test(@_, name => 'bareword'); }
34
35 sub _got_undefined {
36  my $sub = shift;
37  $sub = 'main::' . $sub if $sub !~ /::/;
38  _got_test($sub, @_, name => 'undefined');
39 }
40
41 sub _got_ok { is($@, '', $_[0]); }
42
43 my $warn;
44
45 # ... First test that the default behaviour apply to all the subs .............
46
47 my $bar;
48 sub bar { $bar = 1 }
49
50 eval "yay 11, 13"; # Defined on the other side of the scope
51 _got_ok('compiling to yay(11,13)');
52 our @yay;
53 is_deeply(\@yay, [ 11, 13 ], 'yay really was executed');
54
55 eval "flip"; # Not called in sub::auto zone, not declared, not defined
56 _got_bareword('flip', 1, eval => 1);
57
58 eval "flop"; # Not called in sub::auto zone, declared outside, not defined
59 _got_undefined('flop', 1, eval => 1);
60
61 my $qux;
62 eval "qux"; # Called in sub::auto zone, not declared, not defined
63 _got_bareword('qux', 1, eval => 1);
64
65 my $blech;
66 eval "blech"; # Called in sub::auto zone, declared outside, not defined
67 _got_undefined('blech', 1, eval => 1);
68
69 my $wut;
70 eval "wut"; # Called in sub::auto zone, declared and defined outside
71 _got_ok('compiling to wut()');
72
73 # === Starting from here ======================================================
74 use subs::auto;
75
76 # ... Called in sub::auto zone only, not declared, not defined ................
77
78 eval { onlycalledonce 1, 2 };
79 _got_undefined('onlycalledonce', __LINE__-1);
80
81 # ... Method calls, anyone? ...................................................
82
83 eval { Test::More->import() };
84 _got_ok('don\'t touch class names');
85
86 my $strict;
87 sub strict { $strict = 1; undef }
88 eval { strict->import };
89 is($strict, 1, 'the strict subroutine was called');
90
91 # ... Test hash keys ..........................................................
92
93 my $c = 0;
94 my %h = (
95  a => 5,
96  b => 7,
97 );
98 sub a { ++$c }
99 sub b { ++$c }
100 is($c, 0, "hash keys shouldn't be converted");
101
102 my $foo;
103 our @foo;
104
105 # ... Called in sub::auto zone, declared and defined inside ...................
106
107 eval { foo 1, 2, \%h };
108 _got_ok('compiling to foo(1,2,\\\%h)');
109 is($foo, 15, 'foo really was executed');
110
111 eval { foo(3, 4, \%h) };
112 _got_ok('compiling to foo(3,4,\\\%h)');
113 is($foo, 19, 'foo() really was executed');
114
115 eval { local @_ = (5, 6, \%h); &foo };
116 _got_ok('compiling to foo(5,6,\\\%h)');
117 is($foo, 23, '&foo really was executed');
118
119 eval { &foo(7, 8, \%h) };
120 _got_ok('compiling to foo(7,8,\\\%h)');
121 is($foo, 27, '&foo() really was executed');
122
123 # ... Called in sub::auto zone, declared and defined outside ..................
124
125 eval { wut 13, "what" };
126 _got_ok('compiling to wut(13,"what")');
127 is($wut, 17, 'wut really was executed');
128
129 eval { wut(17, "what") };
130 _got_ok('compiling to wut(17,"what")');
131 is($wut, 21, 'wut() really was executed');
132
133 eval { local @_ = (21, "what"); &wut };
134 _got_ok('compiling to wut(21,"what")');
135 is($wut, 25, '&wut really was executed');
136
137 eval { &wut(25, "what") };
138 _got_ok('compiling to wut(25,"what")');
139 is($wut, 29, '&wut() really was executed');
140
141 # ... Called in sub::auto zone, not declared, not defined .....................
142
143 eval { qux };
144 _got_undefined('qux', __LINE__-1);
145
146 eval { qux() };
147 _got_undefined('qux', __LINE__-1);
148
149 eval { &qux };
150 _got_undefined('qux', __LINE__-1);
151
152 eval { &qux() };
153 _got_undefined('qux', __LINE__-1);
154
155 # ... Are our subs visible in the symbol table entry or what? .................
156
157 {
158  no strict 'refs';
159  is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined');
160  is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined, really');
161  isnt(*{'::yay'}{CODE}, undef, 'yay is defined');
162  isnt(*{'::foo'}{CODE}, undef, 'foo is defined');
163  is(*{'::flip'}{CODE}, undef, 'flip isn\'t defined');
164  isnt(*{'::flop'}{CODE}, undef, 'flop is defined');
165  is(*{'::qux'}{CODE}, undef, 'qux isn\'t defined');
166  isnt(*{'::blech'}{CODE}, undef, 'blech is defined');
167  isnt(*{'::wut'}{CODE}, undef, 'wut is defined');
168 }
169
170 # ... Let's check that this didn't induce any quantic effect ..................
171
172 eval { no warnings; no strict; qux };
173 _got_undefined('qux', __LINE__-1);
174
175 eval { no warnings; no strict; blech };
176 _got_undefined('blech', __LINE__-1);
177
178 # ... Define foo ..............................................................
179
180 sub foo {
181  if ($_[2]) {
182   my %h = %{$_[2]};
183   $foo = $_[0] + $_[1] + (($h{a} || 0 == 5) ? 4 : 0)
184                        + (($h{b} || 0 == 7) ? 8 : 0);
185   undef;
186  } else {
187   $foo = '::foo'; # for symbol table tests later
188  }
189 }
190
191 eval { foo 3, 4, { } };
192 _got_ok('compiling to foo(3,4,{})');
193 is($foo, 7, 'foo really was executed');
194
195 # ... Locally define qux (declared outside, not defined) ......................
196
197 $warn = undef;
198 eval {
199  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ }; 
200  local *qux = sub { $qux = $_[0] };
201  qux 5;
202 };
203 _got_ok('compiling to qux(5)');
204 is($qux, 5, 'qux really was executed');
205 is($warn, undef, 'no redefine warning');
206
207 # ... Locally define blech (declared and defined outside) .....................
208
209 $warn = undef;
210 eval {
211  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
212  local *blech = sub { $blech = $_[0] };
213  blech 7;
214 };
215 _got_ok('compiling to blech(7)');
216 is($blech, 7, 'blech really was executed');
217 is($warn, undef, 'no redefine warning');
218
219 # ... But now they aren't anymore .............................................
220
221 eval { qux };
222 _got_undefined('qux', __LINE__-1);
223
224 eval { blech };
225 _got_undefined('blech', __LINE__-1);
226
227 # === Up to there =============================================================
228 no subs::auto;
229
230 # ... Barewords are strings when the pragma isn't in effect ...................
231
232 my $b;
233 my $cb = eval {
234  sub {
235   $b = do {
236    no strict;
237    no warnings 'reserved';
238    blech;
239   }  
240  }
241 };
242 _got_ok('compiling to bareword');
243 $cb->();
244 is($b, 'blech', 'bareword ok');
245
246 # ... Does foo's definition still valid outside of the pragma scope? ..........
247
248 eval { foo 13, 1, { } };
249 _got_ok('compiling to foo(13,1,{})');
250 is($foo, 14, 'foo really was executed');
251
252 # ... Locally define qux ......................................................
253
254 $warn = undef;
255 {
256  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/; diag $_[0] };
257  local *qux = sub { $qux = 2 * $_[0] };
258  qux(3);
259 }
260 _got_ok('compiling to qux(3)');
261 is($qux, 6, 'new qux really was executed');
262 is($warn, undef, 'no redefine warning');
263
264 # ... Locally define blech ....................................................
265
266 $warn = undef;
267 {
268  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
269  local *blech = sub { $blech = 2 * $_[0] };
270  blech(9);
271 }
272 _got_ok('compiling to blech(9)');
273 is($blech, 18, 'new blech really was executed');
274 is($warn, undef, 'no redefine warning');
275
276 # ... But now they aren't anymore .............................................
277
278 eval "qux";
279 _got_bareword('qux', 1, eval => 1);
280
281 eval "blech";
282 _got_undefined('blech', 1, eval => 1);
283
284 # ... How's my symbol table, Doug Hastings? ...................................
285
286 {
287  no strict qw<refs subs>;
288  is(*{::feh}{CODE}, undef, 'feh isn\'t defined');
289  is(*{::feh}{CODE}, undef, 'feh isn\'t defined, really');
290  isnt(*{::yay}{CODE}, undef, 'yay is defined');
291  isnt(*{::foo}{CODE}, undef, 'foo is defined'); # calls foo
292  is($foo, '::foo', 'foo was called');
293  is(*{::flip}{CODE}, undef, 'flip isn\'t defined');
294  isnt(*{::flop}{CODE}, undef, 'flop is defined');
295  is(*{::qux}{CODE}, undef, 'qux isn\'t defined');
296  isnt(*{::blech}{CODE}, undef, 'blech is defined');
297  isnt(*{::wut}{CODE}, undef, 'wut is defined');
298 }
299
300 # ... Declareth thy oneth thad shalt be .......................................
301
302 sub blech;
303 eval { blech };
304 _got_undefined('blech', __LINE__-1);
305
306 sub flop;
307
308 bar();
309 is($bar, 1, 'bar ok');
310
311 sub wut { $wut = ($_[0] || 0) + length($_[1] || ''); '::wut' }
312
313 sub yay { @yay = @_; '::yay' }
314
315 # === Restarting from there ===================================================
316 use subs::auto;
317
318 # ... How does the pragma propagates through eval STRING? .....................
319
320 eval "no subs::auto; meh";
321 _got_bareword("meh", 1, eval => 1);
322 # eval "use subs::auto; meh";
323 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
324 # eval "meh";
325 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
326
327 # ... Try filehandles .........................................................
328
329 my $buf = '';
330 {
331  no subs::auto;
332  open DONGS, '>', \$buf or die "open-in-memory: $!";
333 }
334 print DONGS "hlagh\n";
335 is($buf, "hlagh\n", 'filehandles should\'t be touched');
336 close DONGS;
337
338 # ... Try default filehandles .................................................
339
340 seek DATA, 0, 1;
341 my @fruits = <DATA>;
342 chomp @fruits;
343 is_deeply(\@fruits, [ qw<apple pear banana> ], 'DATA filehandle ok');
344
345 # ... Retest foo (declared and defined inside) ................................
346
347 eval { foo 7, 9, { } };
348 _got_ok('compiling to foo(7,9,{})');
349 is($foo, 16, 'foo really was executed');
350
351 eval { foo(8, 10, { }) };
352 _got_ok('compiling to foo(8,10,{})');
353 is($foo, 18, 'foo() really was executed');
354
355 eval { local @_ = (9, 11, { }); &foo };
356 _got_ok('compiling to foo(9,11,{})');
357 is($foo, 20, '&foo really was executed');
358
359 eval { &foo(10, 12, { }) };
360 _got_ok('compiling to foo(10,12,{})');
361 is($foo, 22, '&foo() really was executed');
362
363 # ... Retest blech (declared outside, not defined) ............................
364
365 eval { blech };
366 _got_undefined('blech', __LINE__-1);
367
368 eval { blech() };
369 _got_undefined('blech', __LINE__-1);
370
371 eval { &blech };
372 _got_undefined('blech', __LINE__-1);
373
374 eval { &blech() };
375 _got_undefined('blech', __LINE__-1);
376
377 # ... Try _ in a filetest .....................................................
378
379 ok(-f $0 && -r _, '-X _');
380
381 __DATA__
382 apple
383 pear
384 banana