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..177\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 # correctly note too-short parameter lists that don't end with '$',
 417 #  a possible regression.
 418
 419 sub foo1 ($\@);
 420 eval q{ foo1 "s" };
 421 print "not " unless $@ =~ /^Not enough/;
 422 print "ok ", $i++, "\n";
 423
 424 sub foo2 ($\%);
 425 eval q{ foo2 "s" };
 426 print "not " unless $@ =~ /^Not enough/;
 427 print "ok ", $i++, "\n";
 428
 429 sub X::foo3;
 430 *X::foo3 = sub {'ok'};
 431 print "# $@not " unless eval {X->foo3} eq 'ok';
 432 print "ok ", $i++, "\n";
 433
 434 sub X::foo4 ($);
 435 *X::foo4 = sub ($) {'ok'};
 436 print "not " unless X->foo4 eq 'ok';
 437 print "ok ", $i++, "\n";
 438
 439 # test if the (*) prototype allows barewords, constants, scalar expressions,
 440 # globs and globrefs (just as CORE::open() does), all under stricture
 441 sub star (*&) { &{$_[1]} }
 442 sub star2 (**&) { &{$_[2]} }
 443 sub BAR { "quux" }
 444 sub Bar::BAZ { "quuz" }
 445 my $star = 'FOO';
 446 star FOO, sub {
 447     print "not " unless $_[0] eq 'FOO';
 448     print "ok $i - star FOO\n";
 449 }; $i++;
 450 star(FOO, sub {
 451         print "not " unless $_[0] eq 'FOO';
 452         print "ok $i - star(FOO)\n";
 453     }); $i++;
 454 star "FOO", sub {
 455     print "not " unless $_[0] eq 'FOO';
 456     print qq/ok $i - star "FOO"\n/;
 457 }; $i++;
 458 star("FOO", sub {
 459         print "not " unless $_[0] eq 'FOO';
 460         print qq/ok $i - star("FOO")\n/;
 461     }); $i++;
 462 star $star, sub {
 463     print "not " unless $_[0] eq 'FOO';
 464     print "ok $i - star \$star\n";
 465 }; $i++;
 466 star($star, sub {
 467         print "not " unless $_[0] eq 'FOO';
 468         print "ok $i - star(\$star)\n";
 469     }); $i++;
 470 star *FOO, sub {
 471     print "not " unless $_[0] eq \*FOO;
 472     print "ok $i - star *FOO\n";
 473 }; $i++;
 474 star(*FOO, sub {
 475         print "not " unless $_[0] eq \*FOO;
 476         print "ok $i - star(*FOO)\n";
 477     }); $i++;
 478 star \*FOO, sub {
 479     print "not " unless $_[0] eq \*FOO;
 480     print "ok $i - star \\*FOO\n";
 481 }; $i++;
 482 star(\*FOO, sub {
 483         print "not " unless $_[0] eq \*FOO;
 484         print "ok $i - star(\\*FOO)\n";
 485     }); $i++;
 486 star2 FOO, BAR, sub {
 487     print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
 488     print "ok $i - star2 FOO, BAR\n";
 489 }; $i++;
 490 star2(Bar::BAZ, FOO, sub {
 491         print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO';
 492         print "ok $i - star2(Bar::BAZ, FOO)\n"
 493     }); $i++;
 494 star2 BAR(), FOO, sub {
 495     print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO';
 496     print "ok $i - star2 BAR(), FOO\n"
 497 }; $i++;
 498 star2(FOO, BAR(), sub {
 499         print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux';
 500         print "ok $i - star2(FOO, BAR())\n";
 501     }); $i++;
 502 star2 "FOO", "BAR", sub {
 503     print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
 504     print qq/ok $i - star2 "FOO", "BAR"\n/;
 505 }; $i++;
 506 star2("FOO", "BAR", sub {
 507         print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
 508         print qq/ok $i - star2("FOO", "BAR")\n/;
 509     }); $i++;
 510 star2 $star, $star, sub {
 511     print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO';
 512     print "ok $i - star2 \$star, \$star\n";
 513 }; $i++;
 514 star2($star, $star, sub {
 515         print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO';
 516         print "ok $i - star2(\$star, \$star)\n";
 517     }); $i++;
 518 star2 *FOO, *BAR, sub {
 519     print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR;
 520     print "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 "ok $i - star2(*FOO, *BAR)\n";
 525     }); $i++;
 526 star2 \*FOO, \*BAR, sub {
 527     no strict 'refs';
 528     print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'};
 529     print "ok $i - star2 \*FOO, \*BAR\n";
 530 }; $i++;
 531 star2(\*FOO, \*BAR, sub {
 532         no strict 'refs';
 533         print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'};
 534         print "ok $i - star2(\*FOO, \*BAR)\n";
 535     }); $i++;
 536
 537 # test scalarref prototype
 538 sub sreftest (\$$) {
 539     print "not " unless ref $_[0];
 540     print "ok $_[1] - sreftest\n";
 541 }
 542 {
 543     no strict 'vars';
 544     sreftest my $sref, $i++;
 545     sreftest($helem{$i}, $i++);
 546     sreftest $aelem[0], $i++;
 547     sreftest sub { [0] }->()[0], $i++;
 548     sreftest my $a = 'quidgley', $i++;
 549     print "not " if eval 'return 1; sreftest(3+4)';
 550     print "ok ", $i++, ' - \$ with invalid argument', "\n";
 551 }
 552
 553 # test single term
 554 sub lazy (+$$) {
 555     print "not " unless @_ == 3 && ref $_[0] eq $_[1];
 556     print "ok $_[2] - non container test\n";
 557 }
 558 sub quietlazy (+) { return shift(@_) }
 559 sub give_aref { [] }
 560 sub list_or_scalar { wantarray ? (1..10) : [] }
 561 {
 562     my @multiarray = ("a".."z");
 563     my %bighash = @multiarray;
 564     lazy(\@multiarray, 'ARRAY', $i++);
 565     lazy(\%bighash, 'HASH', $i++);
 566     lazy({}, 'HASH', $i++);
 567     lazy(give_aref, 'ARRAY', $i++);
 568     lazy(3, '', $i++); # allowed by prototype, even if runtime error
 569     lazy(list_or_scalar, 'ARRAY', $i++); # propagate scalar context
 570 }
 571
 572 # test prototypes when they are evaled and there is a syntax error
 573 # Byacc generates the string "syntax error".  Bison gives the
 574 # string "parse error".
 575 #
 576 for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
 577   my $warn = "";
 578   local $SIG{__WARN__} = sub {
 579     my $thiswarn = join("",@_);
 580     return if $thiswarn =~ /^Prototype mismatch: sub main::evaled_subroutine/;
 581     $warn .= $thiswarn;
 582   };
 583   my $eval = "sub evaled_subroutine $p { &void *; }";
 584   eval $eval;
 585   print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i;
 586   print "ok ", $i++, "\n";
 587   if ($warn eq '') {
 588      print "ok ", $i++, "\n";
 589   } else {
 590     print "not ok ", $i++, "# $warn \n";
 591   }
 592 }
 593
 594 {
 595     my $myvar;
 596     my @myarray;
 597     my %myhash;
 598     sub mysub { print "not calling mysub I hope\n" }
 599     local *myglob;
 600
 601     sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" }
 602
 603     print "not " unless myref($myvar)   =~ /^SCALAR\(/;
 604     print "ok ", $i++, "\n";
 605     print "not " unless myref($myvar=7) =~ /^SCALAR\(/;
 606     print "ok ", $i++, "\n";
 607     print "not " unless myref(@myarray) =~ /^ARRAY\(/;
 608     print "ok ", $i++, "\n";
 609     print "not " unless myref(%myhash)  =~ /^HASH\(/;
 610     print "ok ", $i++, "\n";
 611     print "not " unless myref(&mysub)   =~ /^CODE\(/;
 612     print "ok ", $i++, "\n";
 613     print "not " unless myref(*myglob)  =~ /^GLOB\(/;
 614     print "ok ", $i++, "\n";
 615
 616     eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/;
 617     print "not "
 618         unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /;
 619     print "ok ", $i++, "\n";
 620     eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/;
 621     print "not "
 622         unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /;
 623     print "ok ", $i++, "\n";
 624     eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/;
 625     print "not "
 626         unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /;
 627     print "ok ", $i++, "\n";
 628     eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/;
 629     print "not "
 630         unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /;
 631     print "ok ", $i++, "\n";
 632     eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/;
 633     print "not "
 634         unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] /
 635             && $@ =~ /Not enough arguments/;
 636     print "ok ", $i++, "\n";
 637 }
 638
 639 # check that obviously bad prototypes are getting warnings
 640 {
 641   local $^W = 1;
 642   my $warn = "";
 643   local $SIG{__WARN__} = sub { $warn .= join("",@_) };
 644
 645   eval 'sub badproto (@bar) { 1; }';
 646   print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/;
 647   print "ok ", $i++, "\n";
 648
 649   eval 'sub badproto2 (bar) { 1; }';
 650   print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/;
 651   print "ok ", $i++, "\n";
 652
 653   eval 'sub badproto3 (&$bar$@) { 1; }';
 654   print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/;
 655   print "ok ", $i++, "\n";
 656
 657   eval 'sub badproto4 (@ $b ar) { 1; }';
 658   print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/;
 659   print "ok ", $i++, "\n";
 660 }
 661
 662 # make sure whitespace in prototypes works
 663 eval "sub good (\$\t\$\n\$) { 1; }";
 664 print "not " if $@;
 665 print "ok ", $i++, "\n";
 666
 667 # Ought to fail, doesn't in 5.8.1.
 668 eval 'sub bug (\[%@]) {  } my $array = [0 .. 1]; bug %$array;';
 669 print "not " unless $@ =~ /Not a HASH reference/;
 670 print "ok ", $i++, "\n";
 671
 672 # [perl #75904]
 673 # Test that the following prototypes make subs parse as unary functions:
 674 #  * \sigil \[...] ;$ ;* ;\sigil ;\[...]
 675 print "not "
 676  unless eval 'sub uniproto1 (*) {} uniproto1 $_, 1' or warn $@;
 677 print "ok ", $i++, "\n";
 678 print "not "
 679  unless eval 'sub uniproto2 (\$) {} uniproto2 $_, 1' or warn $@;
 680 print "ok ", $i++, "\n";
 681 print "not "
 682  unless eval 'sub uniproto3 (\[$%]) {} uniproto3 %_, 1' or warn $@;
 683 print "ok ", $i++, "\n";
 684 print "not "
 685  unless eval 'sub uniproto4 (;$) {} uniproto4 $_, 1' or warn $@;
 686 print "ok ", $i++, "\n";
 687 print "not "
 688  unless eval 'sub uniproto5 (;*) {} uniproto5 $_, 1' or warn $@;
 689 print "ok ", $i++, "\n";
 690 print "not "
 691  unless eval 'sub uniproto6 (;\@) {} uniproto6 @_, 1' or warn $@;
 692 print "ok ", $i++, "\n";
 693 print "not "
 694  unless eval 'sub uniproto7 (;\[$%@]) {} uniproto7 @_, 1' or warn $@;
 695 print "ok ", $i++, "\n";
 696 print "not "
 697  unless eval 'sub uniproto8 (+) {} uniproto8 $_, 1' or warn $@;
 698 print "ok ", $i++, "\n";
 699 print "not "
 700  unless eval 'sub uniproto9 (;+) {} uniproto9 $_, 1' or warn $@;
 701 print "ok ", $i++, "\n";
 702
 703 # Test that a trailing semicolon makes a sub have listop precedence
 704 sub unilist ($;)  { $_[0]+1 }
 705 sub unilist2(_;)  { $_[0]+1 }
 706 sub unilist3(;$;) { $_[0]+1 }
 707 print "not " unless (unilist 0 || 5) == 6;
 708 print "ok ", $i++, "\n";
 709 print "not " unless (unilist2 0 || 5) == 6;
 710 print "ok ", $i++, "\n";
 711 print "not " unless (unilist3 0 || 5) == 6;
 712 print "ok ", $i++, "\n";
 713
 714 {
 715   # Lack of prototype on a subroutine definition should override any prototype
 716   # on the declaration.
 717   sub z_zwap (&);
 718
 719   local $SIG{__WARN__} = sub {
 720     my $thiswarn = join "",@_;
 721     if ($thiswarn =~ /^Prototype mismatch: sub main::z_zwap/) {
 722       print 'ok ', $i++, "\n";
 723     } else {
 724       print 'not ok ', $i++, "\n";
 725       print STDERR $thiswarn;
 726     }
 727   };
 728
 729   eval q{sub z_zwap {return @_}};
 730
 731   if ($@) {
 732     print "not ok ", $i++, "# $@";
 733   } else {
 734     print "ok ", $i++, "\n";
 735   }
 736
 737
 738   my @a = (6,4,2);
 739   my @got  = eval q{z_zwap(@a)};
 740
 741   if ($@) {
 742     print "not ok ", $i++, " # $@";
 743   } else {
 744     print "ok ", $i++, "\n";
 745   }
 746
 747   if ("@got" eq "@a") {
 748     print "ok ", $i++, "\n";
 749   } else {
 750     print "not ok ", $i++, " # >@got<\n";
 751   }
 752 }