This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH op.c] Bad \[...] prototype checking
[perl5.git] / t / comp / proto.t
1 #!./perl
2 #
3 # Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
4 #
5 # So far there are tests for the following prototypes.
6 # none, () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@)
7 #
8 # It is impossible to test every prototype that can be specified, but
9 # we should test as many as we can.
10 #
11
12 BEGIN {
13     chdir 't' if -d 't';
14     @INC = '../lib';
15 }
16
17 use strict;
18
19 print "1..140\n";
20
21 my $i = 1;
22
23 sub testing (&$) {
24     my $p = prototype(shift);
25     my $c = shift;
26     my $what = defined $c ? '(' . $p . ')' : 'no prototype';   
27     print '#' x 25,"\n";
28     print '# Testing ',$what,"\n";
29     print '#' x 25,"\n";
30     print "not "
31         if((defined($p) && defined($c) && $p ne $c)
32            || (defined($p) != defined($c)));
33     printf "ok %d\n",$i++;
34 }
35
36 @_ = qw(a b c d);
37 my @array;
38 my %hash;
39
40 ##
41 ##
42 ##
43
44 testing \&no_proto, undef;
45
46 sub no_proto {
47     print "# \@_ = (",join(",",@_),")\n";
48     scalar(@_)
49 }
50
51 print "not " unless 0 == no_proto();
52 printf "ok %d\n",$i++;
53
54 print "not " unless 1 == no_proto(5);
55 printf "ok %d\n",$i++;
56
57 print "not " unless 4 == &no_proto;
58 printf "ok %d\n",$i++;
59
60 print "not " unless 1 == no_proto +6;
61 printf "ok %d\n",$i++;
62
63 print "not " unless 4 == no_proto(@_);
64 printf "ok %d\n",$i++;
65
66 ##
67 ##
68 ##
69
70
71 testing \&no_args, '';
72
73 sub no_args () {
74     print "# \@_ = (",join(",",@_),")\n";
75     scalar(@_)
76 }
77
78 print "not " unless 0 == no_args();
79 printf "ok %d\n",$i++;
80
81 print "not " unless 0 == no_args;
82 printf "ok %d\n",$i++;
83
84 print "not " unless 5 == no_args +5;
85 printf "ok %d\n",$i++;
86
87 print "not " unless 4 == &no_args;
88 printf "ok %d\n",$i++;
89
90 print "not " unless 2 == &no_args(1,2);
91 printf "ok %d\n",$i++;
92
93 eval "no_args(1)";
94 print "not " unless $@;
95 printf "ok %d\n",$i++;
96
97 ##
98 ##
99 ##
100
101 testing \&one_args, '$';
102
103 sub one_args ($) {
104     print "# \@_ = (",join(",",@_),")\n";
105     scalar(@_)
106 }
107
108 print "not " unless 1 == one_args(1);
109 printf "ok %d\n",$i++;
110
111 print "not " unless 1 == one_args +5;
112 printf "ok %d\n",$i++;
113
114 print "not " unless 4 == &one_args;
115 printf "ok %d\n",$i++;
116
117 print "not " unless 2 == &one_args(1,2);
118 printf "ok %d\n",$i++;
119
120 eval "one_args(1,2)";
121 print "not " unless $@;
122 printf "ok %d\n",$i++;
123
124 eval "one_args()";
125 print "not " unless $@;
126 printf "ok %d\n",$i++;
127
128 sub one_a_args ($) {
129     print "# \@_ = (",join(",",@_),")\n";
130     print "not " unless @_ == 1 && $_[0] == 4;
131     printf "ok %d\n",$i++;
132 }
133
134 one_a_args(@_);
135
136 ##
137 ##
138 ##
139
140 testing \&over_one_args, '$@';
141
142 sub over_one_args ($@) {
143     print "# \@_ = (",join(",",@_),")\n";
144     scalar(@_)
145 }
146
147 print "not " unless 1 == over_one_args(1);
148 printf "ok %d\n",$i++;
149
150 print "not " unless 2 == over_one_args(1,2);
151 printf "ok %d\n",$i++;
152
153 print "not " unless 1 == over_one_args +5;
154 printf "ok %d\n",$i++;
155
156 print "not " unless 4 == &over_one_args;
157 printf "ok %d\n",$i++;
158
159 print "not " unless 2 == &over_one_args(1,2);
160 printf "ok %d\n",$i++;
161
162 print "not " unless 5 == &over_one_args(1,@_);
163 printf "ok %d\n",$i++;
164
165 eval "over_one_args()";
166 print "not " unless $@;
167 printf "ok %d\n",$i++;
168
169 sub over_one_a_args ($@) {
170     print "# \@_ = (",join(",",@_),")\n";
171     print "not " unless @_ >= 1 && $_[0] == 4;
172     printf "ok %d\n",$i++;
173 }
174
175 over_one_a_args(@_);
176 over_one_a_args(@_,1);
177 over_one_a_args(@_,1,2);
178 over_one_a_args(@_,@_);
179
180 ##
181 ##
182 ##
183
184 testing \&scalar_and_hash, '$%';
185
186 sub scalar_and_hash ($%) {
187     print "# \@_ = (",join(",",@_),")\n";
188     scalar(@_)
189 }
190
191 print "not " unless 1 == scalar_and_hash(1);
192 printf "ok %d\n",$i++;
193
194 print "not " unless 3 == scalar_and_hash(1,2,3);
195 printf "ok %d\n",$i++;
196
197 print "not " unless 1 == scalar_and_hash +5;
198 printf "ok %d\n",$i++;
199
200 print "not " unless 4 == &scalar_and_hash;
201 printf "ok %d\n",$i++;
202
203 print "not " unless 2 == &scalar_and_hash(1,2);
204 printf "ok %d\n",$i++;
205
206 print "not " unless 5 == &scalar_and_hash(1,@_);
207 printf "ok %d\n",$i++;
208
209 eval "scalar_and_hash()";
210 print "not " unless $@;
211 printf "ok %d\n",$i++;
212
213 sub scalar_and_hash_a ($@) {
214     print "# \@_ = (",join(",",@_),")\n";
215     print "not " unless @_ >= 1 && $_[0] == 4;
216     printf "ok %d\n",$i++;
217 }
218
219 scalar_and_hash_a(@_);
220 scalar_and_hash_a(@_,1);
221 scalar_and_hash_a(@_,1,2);
222 scalar_and_hash_a(@_,@_);
223
224 ##
225 ##
226 ##
227
228 testing \&one_or_two, '$;$';
229
230 sub one_or_two ($;$) {
231     print "# \@_ = (",join(",",@_),")\n";
232     scalar(@_)
233 }
234
235 print "not " unless 1 == one_or_two(1);
236 printf "ok %d\n",$i++;
237
238 print "not " unless 2 == one_or_two(1,3);
239 printf "ok %d\n",$i++;
240
241 print "not " unless 1 == one_or_two +5;
242 printf "ok %d\n",$i++;
243
244 print "not " unless 4 == &one_or_two;
245 printf "ok %d\n",$i++;
246
247 print "not " unless 3 == &one_or_two(1,2,3);
248 printf "ok %d\n",$i++;
249
250 print "not " unless 5 == &one_or_two(1,@_);
251 printf "ok %d\n",$i++;
252
253 eval "one_or_two()";
254 print "not " unless $@;
255 printf "ok %d\n",$i++;
256
257 eval "one_or_two(1,2,3)";
258 print "not " unless $@;
259 printf "ok %d\n",$i++;
260
261 sub one_or_two_a ($;$) {
262     print "# \@_ = (",join(",",@_),")\n";
263     print "not " unless @_ >= 1 && $_[0] == 4;
264     printf "ok %d\n",$i++;
265 }
266
267 one_or_two_a(@_);
268 one_or_two_a(@_,1);
269 one_or_two_a(@_,@_);
270
271 ##
272 ##
273 ##
274
275 testing \&a_sub, '&';
276
277 sub a_sub (&) {
278     print "# \@_ = (",join(",",@_),")\n";
279     &{$_[0]};
280 }
281
282 sub tmp_sub_1 { printf "ok %d\n",$i++ }
283
284 a_sub { printf "ok %d\n",$i++ };
285 a_sub \&tmp_sub_1;
286
287 @array = ( \&tmp_sub_1 );
288 eval 'a_sub @array';
289 print "not " unless $@;
290 printf "ok %d\n",$i++;
291
292 ##
293 ##
294 ##
295
296 testing \&a_subx, '\&';
297
298 sub a_subx (\&) {
299     print "# \@_ = (",join(",",@_),")\n";
300     &{$_[0]};
301 }
302
303 sub tmp_sub_2 { printf "ok %d\n",$i++ }
304 a_subx &tmp_sub_2;
305
306 @array = ( \&tmp_sub_2 );
307 eval 'a_subx @array';
308 print "not " unless $@;
309 printf "ok %d\n",$i++;
310
311 ##
312 ##
313 ##
314
315 testing \&sub_aref, '&\@';
316
317 sub sub_aref (&\@) {
318     print "# \@_ = (",join(",",@_),")\n";
319     my($sub,$array) = @_;
320     print "not " unless @_ == 2 && @{$array} == 4;
321     print map { &{$sub}($_) } @{$array}
322 }
323
324 @array = (qw(O K)," ", $i++);
325 sub_aref { lc shift } @array;
326 print "\n";
327
328 ##
329 ##
330 ##
331
332 testing \&sub_array, '&@';
333
334 sub sub_array (&@) {
335     print "# \@_ = (",join(",",@_),")\n";
336     print "not " unless @_ == 5;
337     my $sub = shift;
338     print map { &{$sub}($_) } @_
339 }
340
341 @array = (qw(O K)," ", $i++);
342 sub_array { lc shift } @array;
343 sub_array { lc shift } ('O', 'K', ' ', $i++);
344 print "\n";
345
346 ##
347 ##
348 ##
349
350 testing \&a_hash, '%';
351
352 sub a_hash (%) {
353     print "# \@_ = (",join(",",@_),")\n";
354     scalar(@_);
355 }
356
357 print "not " unless 1 == a_hash 'a';
358 printf "ok %d\n",$i++;
359
360 print "not " unless 2 == a_hash 'a','b';
361 printf "ok %d\n",$i++;
362
363 ##
364 ##
365 ##
366
367 testing \&a_hash_ref, '\%';
368
369 sub a_hash_ref (\%) {
370     print "# \@_ = (",join(",",@_),")\n";
371     print "not " unless ref($_[0]) && $_[0]->{'a'};
372     printf "ok %d\n",$i++;
373     $_[0]->{'b'} = 2;
374 }
375
376 %hash = ( a => 1);
377 a_hash_ref %hash;
378 print "not " unless $hash{'b'} == 2;
379 printf "ok %d\n",$i++;
380
381 ##
382 ##
383 ##
384
385 testing \&array_ref_plus, '\@@';
386
387 sub array_ref_plus (\@@) {
388     print "# \@_ = (",join(",",@_),")\n";
389     print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
390     printf "ok %d\n",$i++;
391     @{$_[0]} = (qw(ok)," ",$i++,"\n");
392 }
393
394 @array = ('a');
395 { my @more = ('x');
396   array_ref_plus @array, @more; }
397 print "not " unless @array == 4;
398 print @array;
399
400 my $p;
401 print "not " if defined prototype('CORE::print');
402 print "ok ", $i++, "\n";
403
404 print "not " if defined prototype('CORE::system');
405 print "ok ", $i++, "\n";
406
407 print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@';
408 print "ok ", $i++, "\n";
409
410 print "# CORE:Foo => ($p), \$@ => `$@'\nnot " 
411     if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/;
412 print "ok ", $i++, "\n";
413
414 # correctly note too-short parameter lists that don't end with '$',
415 #  a possible regression.
416
417 sub foo1 ($\@);
418 eval q{ foo1 "s" };
419 print "not " unless $@ =~ /^Not enough/;
420 print "ok ", $i++, "\n";
421
422 sub foo2 ($\%);
423 eval q{ foo2 "s" };
424 print "not " unless $@ =~ /^Not enough/;
425 print "ok ", $i++, "\n";
426
427 sub X::foo3;
428 *X::foo3 = sub {'ok'};
429 print "# $@not " unless eval {X->foo3} eq 'ok';
430 print "ok ", $i++, "\n";
431
432 sub X::foo4 ($);
433 *X::foo4 = sub ($) {'ok'};
434 print "not " unless X->foo4 eq 'ok';
435 print "ok ", $i++, "\n";
436
437 # test if the (*) prototype allows barewords, constants, scalar expressions,
438 # globs and globrefs (just as CORE::open() does), all under stricture
439 sub star (*&) { &{$_[1]} }
440 sub star2 (**&) { &{$_[2]} }
441 sub BAR { "quux" }
442 sub Bar::BAZ { "quuz" }
443 my $star = 'FOO';
444 star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
445 star(FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
446 star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
447 star("FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
448 star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
449 star($star, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
450 star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
451 star(*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
452 star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
453 star(\*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
454 star2 FOO, BAR, sub { print "ok $i\n"
455                         if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
456 star2(Bar::BAZ, FOO, sub { print "ok $i\n"
457                         if $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO' }); $i++;
458 star2 BAR(), FOO, sub { print "ok $i\n"
459                         if $_[0] eq 'quux' and $_[1] eq 'FOO' }; $i++;
460 star2(FOO, BAR(), sub { print "ok $i\n"
461                         if $_[0] eq 'FOO' and $_[1] eq 'quux' }); $i++;
462 star2 "FOO", "BAR", sub { print "ok $i\n"
463                         if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
464 star2("FOO", "BAR", sub { print "ok $i\n"
465                         if $_[0] eq 'FOO' and $_[1] eq 'BAR' }); $i++;
466 star2 $star, $star, sub { print "ok $i\n"
467                         if $_[0] eq 'FOO' and $_[1] eq 'FOO' }; $i++;
468 star2($star, $star, sub { print "ok $i\n"
469                         if $_[0] eq 'FOO' and $_[1] eq 'FOO' }); $i++;
470 star2 *FOO, *BAR, sub { print "ok $i\n"
471                         if $_[0] eq \*FOO and $_[1] eq \*BAR }; $i++;
472 star2(*FOO, *BAR, sub { print "ok $i\n"
473                         if $_[0] eq \*FOO and $_[1] eq \*BAR }); $i++;
474 star2 \*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
475                         if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }; $i++;
476 star2(\*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
477                         if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }); $i++;
478
479 # test scalarref prototype
480 sub sreftest (\$$) {
481     print "ok $_[1]\n" if ref $_[0];
482 }
483 {
484     no strict 'vars';
485     sreftest my $sref, $i++;
486     sreftest($helem{$i}, $i++);
487     sreftest $aelem[0], $i++;
488 }
489
490 # test prototypes when they are evaled and there is a syntax error
491 # Byacc generates the string "syntax error".  Bison gives the
492 # string "parse error".
493 #
494 for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
495   no warnings 'prototype';
496   my $eval = "sub evaled_subroutine $p { &void *; }";
497   eval $eval;
498   print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i;
499   print "ok ", $i++, "\n";
500 }
501
502 # Not $$;$;$
503 print "not " unless prototype "CORE::substr" eq '$$;$$';
504 print "ok ", $i++, "\n";
505
506 # recv takes a scalar reference for its second argument
507 print "not " unless prototype "CORE::recv" eq '*\\$$$';
508 print "ok ", $i++, "\n";
509
510 {
511     my $myvar;
512     my @myarray;
513     my %myhash;
514     sub mysub { print "not calling mysub I hope\n" }
515     local *myglob;
516
517     sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" }
518
519     print "not " unless myref($myvar)   =~ /^SCALAR\(/;
520     print "ok ", $i++, "\n";
521     print "not " unless myref(@myarray) =~ /^ARRAY\(/;
522     print "ok ", $i++, "\n";
523     print "not " unless myref(%myhash)  =~ /^HASH\(/;
524     print "ok ", $i++, "\n";
525     print "not " unless myref(&mysub)   =~ /^CODE\(/;
526     print "ok ", $i++, "\n";
527     print "not " unless myref(*myglob)  =~ /^GLOB\(/;
528     print "ok ", $i++, "\n";
529
530     eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/;
531     print "not " unless $@ =~ /Type of arg 1 to main::multi1 must be one of/;
532     print "ok ", $i++, "\n";
533     eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/;
534     print "not " unless $@ =~ /Type of arg 1 to main::multi2 must be one of/;
535     print "ok ", $i++, "\n";
536     eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/;
537     print "not " unless $@ =~ /Type of arg 1 to main::multi3 must be one of/;
538     print "ok ", $i++, "\n";
539     eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/;
540     print "not " unless $@ =~ /Type of arg 2 to main::multi4 must be one of/;
541     print "ok ", $i++, "\n";
542     eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/;
543     print "not " unless $@ =~ /Type of arg 1 to main::multi5 must be one of/
544                      && $@ =~ /Not enough arguments/;
545     print "ok ", $i++, "\n";
546 }
547
548 # check that obviously bad prototypes are getting warnings
549 {
550   my $warn = "";
551   local $SIG{__WARN__} = sub { $warn .= join("",@_) };
552   
553   eval 'sub badproto (@bar) { 1; }';
554   print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/;
555   print "ok ", $i++, "\n";
556
557   eval 'sub badproto2 (bar) { 1; }';
558   print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/;
559   print "ok ", $i++, "\n";
560   
561   eval 'sub badproto3 (&$bar$@) { 1; }';
562   print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/;
563   print "ok ", $i++, "\n";
564   
565   eval 'sub badproto4 (@ $b ar) { 1; }';
566   print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/;
567   print "ok ", $i++, "\n";
568 }
569
570 # make sure whitespace in prototypes works
571 eval "sub good (\$\t\$\n\$) { 1; }";
572 print "not " if $@;
573 print "ok ", $i++, "\n";