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..180\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 # test scalarref prototype
 554 sub sreftest (\$$) {
 555     print "not " unless ref $_[0];
 556     print "ok $_[1] - sreftest\n";
 557 }
 558 {
 559     no strict 'vars';
 560     sreftest my $sref, $i++;
 561     sreftest($helem{$i}, $i++);
 562     sreftest $aelem[0], $i++;
 563     sreftest sub { [0] }->()[0], $i++;
 564     sreftest my $a = 'quidgley', $i++;
 565     print "not " if eval 'return 1; sreftest(3+4)';
 566     print "ok ", $i++, ' - \$ with invalid argument', "\n";
 567 }
 568
 569 # test single term
 570 sub lazy (+$$) {
 571     print "not " unless @_ == 3 && ref $_[0] eq $_[1];
 572     print "ok $_[2] - non container test\n";
 573 }
 574 sub quietlazy (+) { return shift(@_) }
 575 sub give_aref { [] }
 576 sub list_or_scalar { wantarray ? (1..10) : [] }
 577 {
 578     my @multiarray = ("a".."z");
 579     my %bighash = @multiarray;
 580     lazy(\@multiarray, 'ARRAY', $i++);
 581     lazy(\%bighash, 'HASH', $i++);
 582     lazy({}, 'HASH', $i++);
 583     lazy(give_aref, 'ARRAY', $i++);
 584     lazy(3, '', $i++); # allowed by prototype, even if runtime error
 585     lazy(list_or_scalar, 'ARRAY', $i++); # propagate scalar context
 586 }
 587
 588 # test prototypes when they are evaled and there is a syntax error
 589 # Byacc generates the string "syntax error".  Bison gives the
 590 # string "parse error".
 591 #
 592 for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
 593   my $warn = "";
 594   local $SIG{__WARN__} = sub {
 595     my $thiswarn = join("",@_);
 596     return if $thiswarn =~ /^Prototype mismatch: sub main::evaled_subroutine/;
 597     $warn .= $thiswarn;
 598   };
 599   my $eval = "sub evaled_subroutine $p { &void *; }";
 600   eval $eval;
 601   print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i;
 602   print "ok ", $i++, "\n";
 603   if ($warn eq '') {
 604      print "ok ", $i++, "\n";
 605   } else {
 606     print "not ok ", $i++, "# $warn \n";
 607   }
 608 }
 609
 610 {
 611     my $myvar;
 612     my @myarray;
 613     my %myhash;
 614     sub mysub { print "not calling mysub I hope\n" }
 615     local *myglob;
 616
 617     sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" }
 618
 619     print "not " unless myref($myvar)   =~ /^SCALAR\(/;
 620     print "ok ", $i++, "\n";
 621     print "not " unless myref($myvar=7) =~ /^SCALAR\(/;
 622     print "ok ", $i++, "\n";
 623     print "not " unless myref(@myarray) =~ /^ARRAY\(/;
 624     print "ok ", $i++, "\n";
 625     print "not " unless myref(%myhash)  =~ /^HASH\(/;
 626     print "ok ", $i++, "\n";
 627     print "not " unless myref(&mysub)   =~ /^CODE\(/;
 628     print "ok ", $i++, "\n";
 629     print "not " unless myref(*myglob)  =~ /^GLOB\(/;
 630     print "ok ", $i++, "\n";
 631
 632     eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/;
 633     print "not "
 634         unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /;
 635     print "ok ", $i++, "\n";
 636     eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/;
 637     print "not "
 638         unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /;
 639     print "ok ", $i++, "\n";
 640     eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/;
 641     print "not "
 642         unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /;
 643     print "ok ", $i++, "\n";
 644     eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/;
 645     print "not "
 646         unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /;
 647     print "ok ", $i++, "\n";
 648     eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/;
 649     print "not "
 650         unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] /
 651             && $@ =~ /Not enough arguments/;
 652     print "ok ", $i++, "\n";
 653 }
 654
 655 # check that obviously bad prototypes are getting warnings
 656 {
 657   local $^W = 1;
 658   my $warn = "";
 659   local $SIG{__WARN__} = sub { $warn .= join("",@_) };
 660
 661   eval 'sub badproto (@bar) { 1; }';
 662   print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/;
 663   print "ok ", $i++, "\n";
 664
 665   eval 'sub badproto2 (bar) { 1; }';
 666   print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/;
 667   print "ok ", $i++, "\n";
 668
 669   eval 'sub badproto3 (&$bar$@) { 1; }';
 670   print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/;
 671   print "ok ", $i++, "\n";
 672
 673   eval 'sub badproto4 (@ $b ar) { 1; }';
 674   print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/;
 675   print "ok ", $i++, "\n";
 676 }
 677
 678 # make sure whitespace in prototypes works
 679 eval "sub good (\$\t\$\n\$) { 1; }";
 680 print "not " if $@;
 681 print "ok ", $i++, "\n";
 682
 683 # Ought to fail, doesn't in 5.8.1.
 684 eval 'sub bug (\[%@]) {  } my $array = [0 .. 1]; bug %$array;';
 685 print "not " unless $@ =~ /Not a HASH reference/;
 686 print "ok ", $i++, "\n";
 687
 688 # [perl #75904]
 689 # Test that the following prototypes make subs parse as unary functions:
 690 #  * \sigil \[...] ;$ ;* ;\sigil ;\[...]
 691 print "not "
 692  unless eval 'sub uniproto1 (*) {} uniproto1 $_, 1' or warn $@;
 693 print "ok ", $i++, "\n";
 694 print "not "
 695  unless eval 'sub uniproto2 (\$) {} uniproto2 $_, 1' or warn $@;
 696 print "ok ", $i++, "\n";
 697 print "not "
 698  unless eval 'sub uniproto3 (\[$%]) {} uniproto3 %_, 1' or warn $@;
 699 print "ok ", $i++, "\n";
 700 print "not "
 701  unless eval 'sub uniproto4 (;$) {} uniproto4 $_, 1' or warn $@;
 702 print "ok ", $i++, "\n";
 703 print "not "
 704  unless eval 'sub uniproto5 (;*) {} uniproto5 $_, 1' or warn $@;
 705 print "ok ", $i++, "\n";
 706 print "not "
 707  unless eval 'sub uniproto6 (;\@) {} uniproto6 @_, 1' or warn $@;
 708 print "ok ", $i++, "\n";
 709 print "not "
 710  unless eval 'sub uniproto7 (;\[$%@]) {} uniproto7 @_, 1' or warn $@;
 711 print "ok ", $i++, "\n";
 712 print "not "
 713  unless eval 'sub uniproto8 (+) {} uniproto8 $_, 1' or warn $@;
 714 print "ok ", $i++, "\n";
 715 print "not "
 716  unless eval 'sub uniproto9 (;+) {} uniproto9 $_, 1' or warn $@;
 717 print "ok ", $i++, "\n";
 718
 719 # Test that a trailing semicolon makes a sub have listop precedence
 720 sub unilist ($;)  { $_[0]+1 }
 721 sub unilist2(_;)  { $_[0]+1 }
 722 sub unilist3(;$;) { $_[0]+1 }
 723 print "not " unless (unilist 0 || 5) == 6;
 724 print "ok ", $i++, "\n";
 725 print "not " unless (unilist2 0 || 5) == 6;
 726 print "ok ", $i++, "\n";
 727 print "not " unless (unilist3 0 || 5) == 6;
 728 print "ok ", $i++, "\n";
 729
 730 {
 731   # Lack of prototype on a subroutine definition should override any prototype
 732   # on the declaration.
 733   sub z_zwap (&);
 734
 735   local $SIG{__WARN__} = sub {
 736     my $thiswarn = join "",@_;
 737     if ($thiswarn =~ /^Prototype mismatch: sub main::z_zwap/) {
 738       print 'ok ', $i++, "\n";
 739     } else {
 740       print 'not ok ', $i++, "\n";
 741       print STDERR $thiswarn;
 742     }
 743   };
 744
 745   eval q{sub z_zwap {return @_}};
 746
 747   if ($@) {
 748     print "not ok ", $i++, "# $@";
 749   } else {
 750     print "ok ", $i++, "\n";
 751   }
 752
 753
 754   my @a = (6,4,2);
 755   my @got  = eval q{z_zwap(@a)};
 756
 757   if ($@) {
 758     print "not ok ", $i++, " # $@";
 759   } else {
 760     print "ok ", $i++, "\n";
 761   }
 762
 763   if ("@got" eq "@a") {
 764     print "ok ", $i++, "\n";
 765   } else {
 766     print "not ok ", $i++, " # >@got<\n";
 767   }
 768 }