This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Treat a consecutive semicolons in a prototype as 1
[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 # We need this, as in places we're testing the interaction of prototypes with
18 # strict
19 use strict;
20
21 print "1..186\n";
22
23 my $i = 1;
24
25 sub testing (&$) {
26     my $p = prototype(shift);
27     my $c = shift;
28     my $what = defined $c ? '(' . $p . ')' : 'no prototype';   
29     print '#' x 25,"\n";
30     print '# Testing ',$what,"\n";
31     print '#' x 25,"\n";
32     print "not "
33         if((defined($p) && defined($c) && $p ne $c)
34            || (defined($p) != defined($c)));
35     printf "ok %d\n",$i++;
36 }
37
38 @_ = qw(a b c d);
39 my @array;
40 my %hash;
41
42 ##
43 ##
44 ##
45
46 testing \&no_proto, undef;
47
48 sub no_proto {
49     print "# \@_ = (",join(",",@_),")\n";
50     scalar(@_)
51 }
52
53 print "not " unless 0 == no_proto();
54 printf "ok %d\n",$i++;
55
56 print "not " unless 1 == no_proto(5);
57 printf "ok %d\n",$i++;
58
59 print "not " unless 4 == &no_proto;
60 printf "ok %d\n",$i++;
61
62 print "not " unless 1 == no_proto +6;
63 printf "ok %d\n",$i++;
64
65 print "not " unless 4 == no_proto(@_);
66 printf "ok %d\n",$i++;
67
68 ##
69 ##
70 ##
71
72
73 testing \&no_args, '';
74
75 sub no_args () {
76     print "# \@_ = (",join(",",@_),")\n";
77     scalar(@_)
78 }
79
80 print "not " unless 0 == no_args();
81 printf "ok %d\n",$i++;
82
83 print "not " unless 0 == no_args;
84 printf "ok %d\n",$i++;
85
86 print "not " unless 5 == no_args +5;
87 printf "ok %d\n",$i++;
88
89 print "not " unless 4 == &no_args;
90 printf "ok %d\n",$i++;
91
92 print "not " unless 2 == &no_args(1,2);
93 printf "ok %d\n",$i++;
94
95 eval "no_args(1)";
96 print "not " unless $@;
97 printf "ok %d\n",$i++;
98
99 ##
100 ##
101 ##
102
103 testing \&one_args, '$';
104
105 sub one_args ($) {
106     print "# \@_ = (",join(",",@_),")\n";
107     scalar(@_)
108 }
109
110 print "not " unless 1 == one_args(1);
111 printf "ok %d\n",$i++;
112
113 print "not " unless 1 == one_args +5;
114 printf "ok %d\n",$i++;
115
116 print "not " unless 4 == &one_args;
117 printf "ok %d\n",$i++;
118
119 print "not " unless 2 == &one_args(1,2);
120 printf "ok %d\n",$i++;
121
122 eval "one_args(1,2)";
123 print "not " unless $@;
124 printf "ok %d\n",$i++;
125
126 eval "one_args()";
127 print "not " unless $@;
128 printf "ok %d\n",$i++;
129
130 sub one_a_args ($) {
131     print "# \@_ = (",join(",",@_),")\n";
132     print "not " unless @_ == 1 && $_[0] == 4;
133     printf "ok %d\n",$i++;
134 }
135
136 one_a_args(@_);
137
138 ##
139 ##
140 ##
141
142 testing \&over_one_args, '$@';
143
144 sub over_one_args ($@) {
145     print "# \@_ = (",join(",",@_),")\n";
146     scalar(@_)
147 }
148
149 print "not " unless 1 == over_one_args(1);
150 printf "ok %d\n",$i++;
151
152 print "not " unless 2 == over_one_args(1,2);
153 printf "ok %d\n",$i++;
154
155 print "not " unless 1 == over_one_args +5;
156 printf "ok %d\n",$i++;
157
158 print "not " unless 4 == &over_one_args;
159 printf "ok %d\n",$i++;
160
161 print "not " unless 2 == &over_one_args(1,2);
162 printf "ok %d\n",$i++;
163
164 print "not " unless 5 == &over_one_args(1,@_);
165 printf "ok %d\n",$i++;
166
167 eval "over_one_args()";
168 print "not " unless $@;
169 printf "ok %d\n",$i++;
170
171 sub over_one_a_args ($@) {
172     print "# \@_ = (",join(",",@_),")\n";
173     print "not " unless @_ >= 1 && $_[0] == 4;
174     printf "ok %d\n",$i++;
175 }
176
177 over_one_a_args(@_);
178 over_one_a_args(@_,1);
179 over_one_a_args(@_,1,2);
180 over_one_a_args(@_,@_);
181
182 ##
183 ##
184 ##
185
186 testing \&scalar_and_hash, '$%';
187
188 sub scalar_and_hash ($%) {
189     print "# \@_ = (",join(",",@_),")\n";
190     scalar(@_)
191 }
192
193 print "not " unless 1 == scalar_and_hash(1);
194 printf "ok %d\n",$i++;
195
196 print "not " unless 3 == scalar_and_hash(1,2,3);
197 printf "ok %d\n",$i++;
198
199 print "not " unless 1 == scalar_and_hash +5;
200 printf "ok %d\n",$i++;
201
202 print "not " unless 4 == &scalar_and_hash;
203 printf "ok %d\n",$i++;
204
205 print "not " unless 2 == &scalar_and_hash(1,2);
206 printf "ok %d\n",$i++;
207
208 print "not " unless 5 == &scalar_and_hash(1,@_);
209 printf "ok %d\n",$i++;
210
211 eval "scalar_and_hash()";
212 print "not " unless $@;
213 printf "ok %d\n",$i++;
214
215 sub scalar_and_hash_a ($@) {
216     print "# \@_ = (",join(",",@_),")\n";
217     print "not " unless @_ >= 1 && $_[0] == 4;
218     printf "ok %d\n",$i++;
219 }
220
221 scalar_and_hash_a(@_);
222 scalar_and_hash_a(@_,1);
223 scalar_and_hash_a(@_,1,2);
224 scalar_and_hash_a(@_,@_);
225
226 ##
227 ##
228 ##
229
230 testing \&one_or_two, '$;$';
231
232 sub one_or_two ($;$) {
233     print "# \@_ = (",join(",",@_),")\n";
234     scalar(@_)
235 }
236
237 print "not " unless 1 == one_or_two(1);
238 printf "ok %d\n",$i++;
239
240 print "not " unless 2 == one_or_two(1,3);
241 printf "ok %d\n",$i++;
242
243 print "not " unless 1 == one_or_two +5;
244 printf "ok %d\n",$i++;
245
246 print "not " unless 4 == &one_or_two;
247 printf "ok %d\n",$i++;
248
249 print "not " unless 3 == &one_or_two(1,2,3);
250 printf "ok %d\n",$i++;
251
252 print "not " unless 5 == &one_or_two(1,@_);
253 printf "ok %d\n",$i++;
254
255 eval "one_or_two()";
256 print "not " unless $@;
257 printf "ok %d\n",$i++;
258
259 eval "one_or_two(1,2,3)";
260 print "not " unless $@;
261 printf "ok %d\n",$i++;
262
263 sub one_or_two_a ($;$) {
264     print "# \@_ = (",join(",",@_),")\n";
265     print "not " unless @_ >= 1 && $_[0] == 4;
266     printf "ok %d\n",$i++;
267 }
268
269 one_or_two_a(@_);
270 one_or_two_a(@_,1);
271 one_or_two_a(@_,@_);
272
273 ##
274 ##
275 ##
276
277 testing \&a_sub, '&';
278
279 sub a_sub (&) {
280     print "# \@_ = (",join(",",@_),")\n";
281     &{$_[0]};
282 }
283
284 sub tmp_sub_1 { printf "ok %d\n",$i++ }
285
286 a_sub { printf "ok %d\n",$i++ };
287 a_sub \&tmp_sub_1;
288
289 @array = ( \&tmp_sub_1 );
290 eval 'a_sub @array';
291 print "not " unless $@;
292 printf "ok %d\n",$i++;
293
294 ##
295 ##
296 ##
297
298 testing \&a_subx, '\&';
299
300 sub a_subx (\&) {
301     print "# \@_ = (",join(",",@_),")\n";
302     &{$_[0]};
303 }
304
305 sub tmp_sub_2 { printf "ok %d\n",$i++ }
306 a_subx &tmp_sub_2;
307
308 @array = ( \&tmp_sub_2 );
309 eval 'a_subx @array';
310 print "not " unless $@;
311 printf "ok %d\n",$i++;
312
313 ##
314 ##
315 ##
316
317 testing \&sub_aref, '&\@';
318
319 sub sub_aref (&\@) {
320     print "# \@_ = (",join(",",@_),")\n";
321     my($sub,$array) = @_;
322     print "not " unless @_ == 2 && @{$array} == 4;
323     print map { &{$sub}($_) } @{$array}
324 }
325
326 @array = (qw(O K)," ", $i++);
327 sub_aref { lc shift } @array;
328 print "\n";
329
330 ##
331 ##
332 ##
333
334 testing \&sub_array, '&@';
335
336 sub sub_array (&@) {
337     print "# \@_ = (",join(",",@_),")\n";
338     print "not " unless @_ == 5;
339     my $sub = shift;
340     print map { &{$sub}($_) } @_
341 }
342
343 @array = (qw(O K)," ", $i++);
344 sub_array { lc shift } @array;
345 sub_array { lc shift } ('O', 'K', ' ', $i++);
346 print "\n";
347
348 ##
349 ##
350 ##
351
352 testing \&a_hash, '%';
353
354 sub a_hash (%) {
355     print "# \@_ = (",join(",",@_),")\n";
356     scalar(@_);
357 }
358
359 print "not " unless 1 == a_hash 'a';
360 printf "ok %d\n",$i++;
361
362 print "not " unless 2 == a_hash 'a','b';
363 printf "ok %d\n",$i++;
364
365 ##
366 ##
367 ##
368
369 testing \&a_hash_ref, '\%';
370
371 sub a_hash_ref (\%) {
372     print "# \@_ = (",join(",",@_),")\n";
373     print "not " unless ref($_[0]) && $_[0]->{'a'};
374     printf "ok %d\n",$i++;
375     $_[0]->{'b'} = 2;
376 }
377
378 %hash = ( a => 1);
379 a_hash_ref %hash;
380 print "not " unless $hash{'b'} == 2;
381 printf "ok %d\n",$i++;
382
383 ##
384 ##
385 ##
386
387 testing \&array_ref_plus, '\@@';
388
389 sub array_ref_plus (\@@) {
390     print "# \@_ = (",join(",",@_),")\n";
391     print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
392     printf "ok %d\n",$i++;
393     @{$_[0]} = (qw(ok)," ",$i++,"\n");
394 }
395
396 @array = ('a');
397 { my @more = ('x');
398   array_ref_plus @array, @more; }
399 print "not " unless @array == 4;
400 print @array;
401
402 my $p;
403 print "not " if defined prototype('CORE::print');
404 print "ok ", $i++, "\n";
405
406 print "not " if defined prototype('CORE::system');
407 print "ok ", $i++, "\n";
408
409 print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@';
410 print "ok ", $i++, "\n";
411
412 print "# CORE::Foo => ($p), \$@ => '$@'\nnot " 
413     if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/;
414 print "ok ", $i++, "\n";
415
416 eval { prototype("CORE::a\0b") };
417 print "# CORE::a\\0b: \$@ => '$@'\nnot " 
418     if $@ !~ /^Can't find an opnumber for "a\0b"/;
419 print "ok ", $i++, "\n";
420
421 eval { prototype("CORE::\x{100}") };
422 print "# CORE::\\x{100}: => ($p), \$@ => '$@'\nnot " 
423     if $@ !~ /^Can't find an opnumber for "\x{100}"/;
424 print "ok ", $i++, "\n";
425
426 "CORE::Foo" =~ /(.*)/;
427 print "# \$1 containing CORE::Foo => ($p), \$@ => '$@'\nnot " 
428     if defined ($p = eval { prototype($1) or 1 })
429     or $@ !~ /^Can't find an opnumber/;
430 print "ok ", $i++, " - \$1 containing CORE::Foo\n";
431
432 # correctly note too-short parameter lists that don't end with '$',
433 #  a possible regression.
434
435 sub foo1 ($\@);
436 eval q{ foo1 "s" };
437 print "not " unless $@ =~ /^Not enough/;
438 print "ok ", $i++, "\n";
439
440 sub foo2 ($\%);
441 eval q{ foo2 "s" };
442 print "not " unless $@ =~ /^Not enough/;
443 print "ok ", $i++, "\n";
444
445 sub X::foo3;
446 *X::foo3 = sub {'ok'};
447 print "# $@not " unless eval {X->foo3} eq 'ok';
448 print "ok ", $i++, "\n";
449
450 sub X::foo4 ($);
451 *X::foo4 = sub ($) {'ok'};
452 print "not " unless X->foo4 eq 'ok';
453 print "ok ", $i++, "\n";
454
455 # test if the (*) prototype allows barewords, constants, scalar expressions,
456 # globs and globrefs (just as CORE::open() does), all under stricture
457 sub star (*&) { &{$_[1]} }
458 sub star2 (**&) { &{$_[2]} }
459 sub BAR { "quux" }
460 sub Bar::BAZ { "quuz" }
461 my $star = 'FOO';
462 star FOO, sub {
463     print "not " unless $_[0] eq 'FOO';
464     print "ok $i - star FOO\n";
465 }; $i++;
466 star(FOO, sub {
467         print "not " unless $_[0] eq 'FOO';
468         print "ok $i - star(FOO)\n";
469     }); $i++;
470 star "FOO", sub {
471     print "not " unless $_[0] eq 'FOO';
472     print qq/ok $i - star "FOO"\n/;
473 }; $i++;
474 star("FOO", sub {
475         print "not " unless $_[0] eq 'FOO';
476         print qq/ok $i - star("FOO")\n/;
477     }); $i++;
478 star $star, sub {
479     print "not " unless $_[0] eq 'FOO';
480     print "ok $i - star \$star\n";
481 }; $i++;
482 star($star, sub {
483         print "not " unless $_[0] eq 'FOO';
484         print "ok $i - star(\$star)\n";
485     }); $i++;
486 star *FOO, sub {
487     print "not " unless $_[0] eq \*FOO;
488     print "ok $i - star *FOO\n";
489 }; $i++;
490 star(*FOO, sub {
491         print "not " unless $_[0] eq \*FOO;
492         print "ok $i - star(*FOO)\n";
493     }); $i++;
494 star \*FOO, sub {
495     print "not " unless $_[0] eq \*FOO;
496     print "ok $i - star \\*FOO\n";
497 }; $i++;
498 star(\*FOO, sub {
499         print "not " unless $_[0] eq \*FOO;
500         print "ok $i - star(\\*FOO)\n";
501     }); $i++;
502 star2 FOO, BAR, sub {
503     print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
504     print "ok $i - star2 FOO, BAR\n";
505 }; $i++;
506 star2(Bar::BAZ, FOO, sub {
507         print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO';
508         print "ok $i - star2(Bar::BAZ, FOO)\n"
509     }); $i++;
510 star2 BAR(), FOO, sub {
511     print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO';
512     print "ok $i - star2 BAR(), FOO\n"
513 }; $i++;
514 star2(FOO, BAR(), sub {
515         print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux';
516         print "ok $i - star2(FOO, BAR())\n";
517     }); $i++;
518 star2 "FOO", "BAR", sub {
519     print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
520     print qq/ok $i - star2 "FOO", "BAR"\n/;
521 }; $i++;
522 star2("FOO", "BAR", sub {
523         print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
524         print qq/ok $i - star2("FOO", "BAR")\n/;
525     }); $i++;
526 star2 $star, $star, sub {
527     print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO';
528     print "ok $i - star2 \$star, \$star\n";
529 }; $i++;
530 star2($star, $star, sub {
531         print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO';
532         print "ok $i - star2(\$star, \$star)\n";
533     }); $i++;
534 star2 *FOO, *BAR, sub {
535     print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR;
536     print "ok $i - star2 *FOO, *BAR\n";
537 }; $i++;
538 star2(*FOO, *BAR, sub {
539         print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR;
540         print "ok $i - star2(*FOO, *BAR)\n";
541     }); $i++;
542 star2 \*FOO, \*BAR, sub {
543     no strict 'refs';
544     print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'};
545     print "ok $i - star2 \*FOO, \*BAR\n";
546 }; $i++;
547 star2(\*FOO, \*BAR, sub {
548         no strict 'refs';
549         print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'};
550         print "ok $i - star2(\*FOO, \*BAR)\n";
551     }); $i++;
552
553 # [perl #118585]
554 # Test that multiple semicolons are treated as one with *
555 sub star3(;;;*){}
556 sub star4( ; ; ; ; *){}
557 print "not " unless eval 'star3 STDERR; 1';
558 print "ok ", $i++, " star3 STDERR\n";
559 print "not " unless eval 'star4 STDERR; 1';
560 print "ok ", $i++, " star4 STDERR\n";
561
562 # test scalarref prototype
563 sub sreftest (\$$) {
564     print "not " unless ref $_[0];
565     print "ok $_[1] - sreftest\n";
566 }
567 {
568     no strict 'vars';
569     sreftest my $sref, $i++;
570     sreftest($helem{$i}, $i++);
571     sreftest $aelem[0], $i++;
572     sreftest sub { [0] }->()[0], $i++;
573     sreftest my $a = 'quidgley', $i++;
574     print "not " if eval 'return 1; sreftest(3+4)';
575     print "ok ", $i++, ' - \$ with invalid argument', "\n";
576 }
577
578 # test single term
579 sub lazy (+$$) {
580     print "not " unless @_ == 3 && ref $_[0] eq $_[1];
581     print "ok $_[2] - non container test\n";
582 }
583 sub quietlazy (+) { return shift(@_) }
584 sub give_aref { [] }
585 sub list_or_scalar { wantarray ? (1..10) : [] }
586 {
587     my @multiarray = ("a".."z");
588     my %bighash = @multiarray;
589     lazy(\@multiarray, 'ARRAY', $i++);
590     lazy(\%bighash, 'HASH', $i++);
591     lazy({}, 'HASH', $i++);
592     lazy(give_aref, 'ARRAY', $i++);
593     lazy(3, '', $i++); # allowed by prototype, even if runtime error
594     lazy(list_or_scalar, 'ARRAY', $i++); # propagate scalar context
595 }
596
597 # test prototypes when they are evaled and there is a syntax error
598 # Byacc generates the string "syntax error".  Bison gives the
599 # string "parse error".
600 #
601 for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
602   my $warn = "";
603   local $SIG{__WARN__} = sub {
604     my $thiswarn = join("",@_);
605     return if $thiswarn =~ /^Prototype mismatch: sub main::evaled_subroutine/;
606     $warn .= $thiswarn;
607   };
608   my $eval = "sub evaled_subroutine $p { &void *; }";
609   eval $eval;
610   print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i;
611   print "ok ", $i++, "\n";
612   if ($warn eq '') {
613      print "ok ", $i++, "\n";
614   } else {
615     print "not ok ", $i++, "# $warn \n";
616   }
617 }
618
619 {
620     my $myvar;
621     my @myarray;
622     my %myhash;
623     sub mysub { print "not calling mysub I hope\n" }
624     local *myglob;
625
626     sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" }
627
628     print "not " unless myref($myvar)   =~ /^SCALAR\(/;
629     print "ok ", $i++, "\n";
630     print "not " unless myref($myvar=7) =~ /^SCALAR\(/;
631     print "ok ", $i++, "\n";
632     print "not " unless myref(@myarray) =~ /^ARRAY\(/;
633     print "ok ", $i++, "\n";
634     print "not " unless myref(%myhash)  =~ /^HASH\(/;
635     print "ok ", $i++, "\n";
636     print "not " unless myref(&mysub)   =~ /^CODE\(/;
637     print "ok ", $i++, "\n";
638     print "not " unless myref(*myglob)  =~ /^GLOB\(/;
639     print "ok ", $i++, "\n";
640
641     eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/;
642     print "not "
643         unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /;
644     print "ok ", $i++, "\n";
645     eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/;
646     print "not "
647         unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /;
648     print "ok ", $i++, "\n";
649     eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/;
650     print "not "
651         unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /;
652     print "ok ", $i++, "\n";
653     eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/;
654     print "not "
655         unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /;
656     print "ok ", $i++, "\n";
657     eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/;
658     print "not "
659         unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] /
660             && $@ =~ /Not enough arguments/;
661     print "ok ", $i++, "\n";
662 }
663
664 # check that obviously bad prototypes are getting warnings
665 {
666   local $^W = 1;
667   my $warn = "";
668   local $SIG{__WARN__} = sub { $warn .= join("",@_) };
669   
670   eval 'sub badproto (@bar) { 1; }';
671   print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/;
672   print "ok ", $i++, "\n";
673
674   eval 'sub badproto2 (bar) { 1; }';
675   print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/;
676   print "ok ", $i++, "\n";
677   
678   eval 'sub badproto3 (&$bar$@) { 1; }';
679   print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/;
680   print "ok ", $i++, "\n";
681   
682   eval 'sub badproto4 (@ $b ar) { 1; }';
683   print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/;
684   print "ok ", $i++, "\n";
685 }
686
687 # make sure whitespace in prototypes works
688 eval "sub good (\$\t\$\n\$) { 1; }";
689 print "not " if $@;
690 print "ok ", $i++, "\n";
691
692 # Ought to fail, doesn't in 5.8.1.
693 eval 'sub bug (\[%@]) {  } my $array = [0 .. 1]; bug %$array;';
694 print "not " unless $@ =~ /Not a HASH reference/;
695 print "ok ", $i++, "\n";
696
697 # [perl #75904]
698 # Test that the following prototypes make subs parse as unary functions:
699 #  * \sigil \[...] ;$ ;* ;\sigil ;\[...]
700 # [perl #118585]
701 # As a special case, make sure that ;;* is treated the same as ;*
702 print "not "
703  unless eval 'sub uniproto1 (*) {} uniproto1 $_, 1' or warn $@;
704 print "ok ", $i++, "\n";
705 print "not "
706  unless eval 'sub uniproto2 (\$) {} uniproto2 $_, 1' or warn $@;
707 print "ok ", $i++, "\n";
708 print "not "
709  unless eval 'sub uniproto3 (\[$%]) {} uniproto3 %_, 1' or warn $@;
710 print "ok ", $i++, "\n";
711 print "not "
712  unless eval 'sub uniproto4 (;$) {} uniproto4 $_, 1' or warn $@;
713 print "ok ", $i++, "\n";
714 print "not "
715  unless eval 'sub uniproto5 (;*) {} uniproto5 $_, 1' or warn $@;
716 print "ok ", $i++, "\n";
717 print "not "
718  unless eval 'sub uniproto6 (;\@) {} uniproto6 @_, 1' or warn $@;
719 print "ok ", $i++, "\n";
720 print "not "
721  unless eval 'sub uniproto7 (;\[$%@]) {} uniproto7 @_, 1' or warn $@;
722 print "ok ", $i++, "\n";
723 print "not "
724  unless eval 'sub uniproto8 (+) {} uniproto8 $_, 1' or warn $@;
725 print "ok ", $i++, "\n";
726 print "not "
727  unless eval 'sub uniproto9 (;+) {} uniproto9 $_, 1' or warn $@;
728 print "ok ", $i++, "\n";
729 print "not "
730  unless eval 'sub uniproto10 (;;;*) {} uniproto10 $_, 1' or warn $@;
731 print "ok ", $i++, " - uniproto10 (;;;*)\n";
732 print "not "
733  unless eval 'sub uniproto11 ( ; ; ; * ) {} uniproto10 $_, 1' or warn $@;
734 print "ok ", $i++, " - uniproto11 ( ; ; ;  *)\n";
735 print "not "
736  unless eval 'sub uniproto12 (;;;+) {} uniproto12 $_, 1' or warn $@;
737 print "ok ", $i++, " - uniproto12 (;;;*)\n";
738 print "not "
739  unless eval 'sub uniproto12 ( ; ; ; + ) {} uniproto12 $_, 1' or warn $@;
740 print "ok ", $i++, " - uniproto12 ( ; ; ; * )\n";
741
742 # Test that a trailing semicolon makes a sub have listop precedence
743 sub unilist ($;)  { $_[0]+1 }
744 sub unilist2(_;)  { $_[0]+1 }
745 sub unilist3(;$;) { $_[0]+1 }
746 print "not " unless (unilist 0 || 5) == 6;
747 print "ok ", $i++, "\n";
748 print "not " unless (unilist2 0 || 5) == 6;
749 print "ok ", $i++, "\n";
750 print "not " unless (unilist3 0 || 5) == 6;
751 print "ok ", $i++, "\n";
752
753 {
754   # Lack of prototype on a subroutine definition should override any prototype
755   # on the declaration.
756   sub z_zwap (&);
757
758   local $SIG{__WARN__} = sub {
759     my $thiswarn = join "",@_;
760     if ($thiswarn =~ /^Prototype mismatch: sub main::z_zwap/) {
761       print 'ok ', $i++, "\n";
762     } else {
763       print 'not ok ', $i++, "\n";
764       print STDERR $thiswarn;
765     }
766   };
767
768   eval q{sub z_zwap {return @_}};
769
770   if ($@) {
771     print "not ok ", $i++, "# $@";
772   } else {
773     print "ok ", $i++, "\n";
774   }
775
776
777   my @a = (6,4,2);
778   my @got  = eval q{z_zwap(@a)};
779
780   if ($@) {
781     print "not ok ", $i++, " # $@";
782   } else {
783     print "ok ", $i++, "\n";
784   }
785
786   if ("@got" eq "@a") {
787     print "ok ", $i++, "\n";
788   } else {
789     print "not ok ", $i++, " # >@got<\n";
790   }
791 }