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..215\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     return unless defined $_[0];
 282     &{$_[0]};
 283 }
 284
 285 sub tmp_sub_1 { printf "ok %d\n",$i++ }
 286
 287 a_sub { printf "ok %d\n",$i++ };
 288 a_sub \&tmp_sub_1;
 289 a_sub \(&tmp_sub_1);
 290
 291 @array = ( \&tmp_sub_1 );
 292 eval 'a_sub @array';
 293 print "not " unless $@;
 294 printf "ok %d\n",$i++;
 295 eval 'a_sub \@array';
 296 print "not " unless $@ =~ /Type of arg/;
 297 printf "ok %d\n",$i++;
 298 eval 'a_sub \%hash';
 299 print "not " unless $@ =~ /Type of arg/;
 300 printf "ok %d\n",$i++;
 301 eval 'a_sub \$scalar';
 302 print "not " unless $@ =~ /Type of arg/;
 303 printf "ok %d\n",$i++;
 304 eval 'a_sub \($list, %of, @refs)';
 305 print "not " unless $@ =~ /Type of arg/;
 306 printf "ok %d\n",$i++;
 307 eval 'a_sub undef';
 308 print "not " if $@;
 309 printf "ok %d\n",$i++;
 310
 311 ##
 312 ##
 313 ##
 314
 315 testing \&a_subx, '\&';
 316
 317 sub a_subx (\&) {
 318     print "# \@_ = (",join(",",@_),")\n";
 319     &{$_[0]};
 320 }
 321
 322 sub tmp_sub_2 { printf "ok %d\n",$i++ }
 323 a_subx &tmp_sub_2;
 324
 325 @array = ( \&tmp_sub_2 );
 326 eval 'a_subx @array';
 327 print "not " unless $@;
 328 printf "ok %d\n",$i++;
 329 my $bad =
 330     qr/Type of arg 1 to .* must be subroutine \(not subroutine entry\)/;
 331 eval 'a_subx &tmp_sub_2()';
 332 print "not " unless $@ =~ $bad;
 333 printf "ok %d - \\& prohibits &foo()\n",$i++;
 334 eval 'a_subx tmp_sub_2()';
 335 print "not " unless $@ =~ $bad;
 336 printf "ok %d - \\& prohibits foo()\n",$i++;
 337 eval 'a_subx tmp_sub_2';
 338 print "not " unless $@ =~ $bad;
 339 printf "ok %d - \\& prohibits foo where foo is an existing sub\n",$i++;
 340
 341 ##
 342 ##
 343 ##
 344
 345 testing \&sub_aref, '&\@';
 346
 347 sub sub_aref (&\@) {
 348     print "# \@_ = (",join(",",@_),")\n";
 349     my($sub,$array) = @_;
 350     print "not " unless @_ == 2 && @{$array} == 4;
 351     print map { &{$sub}($_) } @{$array}
 352 }
 353
 354 @array = (qw(O K)," ", $i++);
 355 sub_aref { lc shift } @array;
 356 print "\n";
 357
 358 ##
 359 ##
 360 ##
 361
 362 testing \&sub_array, '&@';
 363
 364 sub sub_array (&@) {
 365     print "# \@_ = (",join(",",@_),")\n";
 366     print "not " unless @_ == 5;
 367     my $sub = shift;
 368     print map { &{$sub}($_) } @_
 369 }
 370
 371 @array = (qw(O K)," ", $i++);
 372 sub_array { lc shift } @array;
 373 sub_array { lc shift } ('O', 'K', ' ', $i++);
 374 print "\n";
 375
 376 ##
 377 ##
 378 ##
 379
 380 testing \&a_hash, '%';
 381
 382 sub a_hash (%) {
 383     print "# \@_ = (",join(",",@_),")\n";
 384     scalar(@_);
 385 }
 386
 387 print "not " unless 1 == a_hash 'a';
 388 printf "ok %d\n",$i++;
 389
 390 print "not " unless 2 == a_hash 'a','b';
 391 printf "ok %d\n",$i++;
 392
 393 ##
 394 ##
 395 ##
 396
 397 testing \&a_hash_ref, '\%';
 398
 399 sub a_hash_ref (\%) {
 400     print "# \@_ = (",join(",",@_),")\n";
 401     print "not " unless ref($_[0]) && $_[0]->{'a'};
 402     printf "ok %d\n",$i++;
 403     $_[0]->{'b'} = 2;
 404 }
 405
 406 %hash = ( a => 1);
 407 a_hash_ref %hash;
 408 print "not " unless $hash{'b'} == 2;
 409 printf "ok %d\n",$i++;
 410
 411 %hash = ( a => 1);
 412 a_hash_ref +(%hash);
 413 print "not " unless $hash{'b'} == 2;
 414 printf "ok %d\n",$i++;
 415
 416 ##
 417 ##
 418 ##
 419
 420 testing \&array_ref_plus, '\@@';
 421
 422 sub array_ref_plus (\@@) {
 423     print "# \@_ = (",join(",",@_),")\n";
 424     print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
 425     printf "ok %d\n",$i++;
 426     @{$_[0]} = (qw(ok)," ",$i++,"\n");
 427 }
 428
 429 @array = ('a');
 430 { my @more = ('x');
 431   array_ref_plus @array, @more; }
 432 print "not " unless @array == 4;
 433 print @array;
 434
 435 @array = ('a');
 436 { my @more = ('x');
 437   array_ref_plus +(@array), @more; }
 438 print "not " unless @array == 4;
 439 print @array;
 440
 441 ##
 442 ##
 443 ##
 444
 445 my $p;
 446 print "not " if defined prototype('CORE::print');
 447 print "ok ", $i++, "\n";
 448
 449 print "not " if defined prototype('CORE::system');
 450 print "ok ", $i++, "\n";
 451
 452 print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@';
 453 print "ok ", $i++, "\n";
 454
 455 print "# CORE::Foo => ($p), \$@ => '$@'\nnot "
 456     if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/;
 457 print "ok ", $i++, "\n";
 458
 459 eval { prototype("CORE::a\0b") };
 460 print "# CORE::a\\0b: \$@ => '$@'\nnot "
 461     if $@ !~ /^Can't find an opnumber for "a\0b"/;
 462 print "ok ", $i++, "\n";
 463
 464 eval { prototype("CORE::\x{100}") };
 465 print "# CORE::\\x{100}: => ($p), \$@ => '$@'\nnot "
 466     if $@ !~ /^Can't find an opnumber for "\x{100}"/;
 467 print "ok ", $i++, "\n";
 468
 469 "CORE::Foo" =~ /(.*)/;
 470 print "# \$1 containing CORE::Foo => ($p), \$@ => '$@'\nnot "
 471     if defined ($p = eval { prototype($1) or 1 })
 472     or $@ !~ /^Can't find an opnumber/;
 473 print "ok ", $i++, " - \$1 containing CORE::Foo\n";
 474
 475 # correctly note too-short parameter lists that don't end with '$',
 476 #  a possible regression.
 477
 478 sub foo1 ($\@);
 479 eval q{ foo1 "s" };
 480 print "not " unless $@ =~ /^Not enough/;
 481 print "ok ", $i++, "\n";
 482
 483 sub foo2 ($\%);
 484 eval q{ foo2 "s" };
 485 print "not " unless $@ =~ /^Not enough/;
 486 print "ok ", $i++, "\n";
 487
 488 sub X::foo3;
 489 *X::foo3 = sub {'ok'};
 490 print "# $@not " unless eval {X->foo3} eq 'ok';
 491 print "ok ", $i++, "\n";
 492
 493 sub X::foo4 ($);
 494 *X::foo4 = sub ($) {'ok'};
 495 print "not " unless X->foo4 eq 'ok';
 496 print "ok ", $i++, "\n";
 497
 498 # test if the (*) prototype allows barewords, constants, scalar expressions,
 499 # globs and globrefs (just as CORE::open() does), all under stricture
 500 sub star (*&) { &{$_[1]} }
 501 sub star2 (**&) { &{$_[2]} }
 502 sub BAR { "quux" }
 503 sub Bar::BAZ { "quuz" }
 504 my $star = 'FOO';
 505 star FOO, sub {
 506     print "not " unless $_[0] eq 'FOO';
 507     print "ok $i - star FOO\n";
 508 }; $i++;
 509 star(FOO, sub {
 510         print "not " unless $_[0] eq 'FOO';
 511         print "ok $i - star(FOO)\n";
 512     }); $i++;
 513 star "FOO", sub {
 514     print "not " unless $_[0] eq 'FOO';
 515     print qq/ok $i - star "FOO"\n/;
 516 }; $i++;
 517 star("FOO", sub {
 518         print "not " unless $_[0] eq 'FOO';
 519         print qq/ok $i - star("FOO")\n/;
 520     }); $i++;
 521 star $star, sub {
 522     print "not " unless $_[0] eq 'FOO';
 523     print "ok $i - star \$star\n";
 524 }; $i++;
 525 star($star, sub {
 526         print "not " unless $_[0] eq 'FOO';
 527         print "ok $i - star(\$star)\n";
 528     }); $i++;
 529 star *FOO, sub {
 530     print "not " unless $_[0] eq \*FOO;
 531     print "ok $i - star *FOO\n";
 532 }; $i++;
 533 star(*FOO, sub {
 534         print "not " unless $_[0] eq \*FOO;
 535         print "ok $i - star(*FOO)\n";
 536     }); $i++;
 537 star \*FOO, sub {
 538     print "not " unless $_[0] eq \*FOO;
 539     print "ok $i - star \\*FOO\n";
 540 }; $i++;
 541 star(\*FOO, sub {
 542         print "not " unless $_[0] eq \*FOO;
 543         print "ok $i - star(\\*FOO)\n";
 544     }); $i++;
 545 star2 FOO, BAR, sub {
 546     print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux';
 547     print "ok $i - star2 FOO, BAR\n";
 548 }; $i++;
 549 star2(Bar::BAZ, FOO, sub {
 550         print "not " unless $_[0] eq 'quuz' and $_[1] eq 'FOO';
 551         print "ok $i - star2(Bar::BAZ, FOO)\n"
 552     }); $i++;
 553 star2 BAR(), FOO, sub {
 554     print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO';
 555     print "ok $i - star2 BAR(), FOO\n"
 556 }; $i++;
 557 star2(FOO, BAR(), sub {
 558         print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux';
 559         print "ok $i - star2(FOO, BAR())\n";
 560     }); $i++;
 561 star2 "FOO", "BAR", sub {
 562     print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
 563     print qq/ok $i - star2 "FOO", "BAR"\n/;
 564 }; $i++;
 565 star2("FOO", "BAR", sub {
 566         print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
 567         print qq/ok $i - star2("FOO", "BAR")\n/;
 568     }); $i++;
 569 star2 $star, $star, sub {
 570     print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO';
 571     print "ok $i - star2 \$star, \$star\n";
 572 }; $i++;
 573 star2($star, $star, sub {
 574         print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO';
 575         print "ok $i - star2(\$star, \$star)\n";
 576     }); $i++;
 577 star2 *FOO, *BAR, sub {
 578     print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR;
 579     print "ok $i - star2 *FOO, *BAR\n";
 580 }; $i++;
 581 star2(*FOO, *BAR, sub {
 582         print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR;
 583         print "ok $i - star2(*FOO, *BAR)\n";
 584     }); $i++;
 585 star2 \*FOO, \*BAR, sub {
 586     no strict 'refs';
 587     print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'};
 588     print "ok $i - star2 \*FOO, \*BAR\n";
 589 }; $i++;
 590 star2(\*FOO, \*BAR, sub {
 591         no strict 'refs';
 592         print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'};
 593         print "ok $i - star2(\*FOO, \*BAR)\n";
 594     }); $i++;
 595
 596 # [perl #118585]
 597 # Test that multiple semicolons are treated as one with *
 598 sub star3(;;;*){}
 599 sub star4( ; ; ; ; *){}
 600 print "not " unless eval 'star3 STDERR; 1';
 601 print "ok ", $i++, " star3 STDERR\n";
 602 print "not " unless eval 'star4 STDERR; 1';
 603 print "ok ", $i++, " star4 STDERR\n";
 604
 605 # [perl #2726]
 606 # Test that prototype binding is late
 607 print "not " unless eval 'sub l564($){ l564(); } 1';
 608 print "ok ", $i++, " prototype checking not done within initial definition\n";
 609 print "not " if eval 'sub l566($); sub l566($){ l566(); } 1';
 610 print "ok ", $i++, " prototype checking done if sub pre-declared\n";
 611
 612 # test scalarref prototype
 613 sub sreftest (\$$) {
 614     print "not " unless ref $_[0];
 615     print "ok $_[1] - sreftest\n";
 616 }
 617 {
 618     no strict 'vars';
 619     sreftest my $sref, $i++;
 620     sreftest($helem{$i}, $i++);
 621     sreftest $aelem[0], $i++;
 622     sreftest sub { [0] }->()[0], $i++;
 623     sreftest my $a = 'quidgley', $i++;
 624     print "not " if eval 'return 1; sreftest(3+4)';
 625     print "ok ", $i++, ' - \$ with invalid argument', "\n";
 626 }
 627
 628 # test single term
 629 sub lazy (+$$) {
 630     print "not " unless @_ == 3 && ref $_[0] eq $_[1];
 631     print "ok $_[2] - non container test\n";
 632 }
 633 sub quietlazy (+) { return shift(@_) }
 634 sub give_aref { [] }
 635 sub list_or_scalar { wantarray ? (1..10) : [] }
 636 {
 637     my @multiarray = ("a".."z");
 638     my %bighash = @multiarray;
 639     lazy(\@multiarray, 'ARRAY', $i++);
 640     lazy(\%bighash, 'HASH', $i++);
 641     lazy({}, 'HASH', $i++);
 642     lazy(give_aref, 'ARRAY', $i++);
 643     lazy(3, '', $i++); # allowed by prototype, even if runtime error
 644     lazy(list_or_scalar, 'ARRAY', $i++); # propagate scalar context
 645 }
 646
 647 # test prototypes when they are evaled and there is a syntax error
 648 # Byacc generates the string "syntax error".  Bison gives the
 649 # string "parse error".
 650 #
 651 for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
 652   my $warn = "";
 653   local $SIG{__WARN__} = sub {
 654     my $thiswarn = join("",@_);
 655     return if $thiswarn =~ /^Prototype mismatch: sub main::evaled_subroutine/;
 656     $warn .= $thiswarn;
 657   };
 658   my $eval = "sub evaled_subroutine $p { &void *; }";
 659   eval $eval;
 660   print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i;
 661   print "ok ", $i++, "\n";
 662   if ($warn eq '') {
 663      print "ok ", $i++, "\n";
 664   } else {
 665     print "not ok ", $i++, "# $warn \n";
 666   }
 667 }
 668
 669 {
 670     my $myvar;
 671     my @myarray;
 672     my %myhash;
 673     sub mysub { print "not calling mysub I hope\n" }
 674     local *myglob;
 675
 676     sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" }
 677
 678     print "not " unless myref($myvar)   =~ /^SCALAR\(/;
 679     print "ok ", $i++, "\n";
 680     print "not " unless myref($myvar=7) =~ /^SCALAR\(/;
 681     print "ok ", $i++, "\n";
 682     print "not " unless myref(@myarray) =~ /^ARRAY\(/;
 683     print "ok ", $i++, "\n";
 684     print "not " unless myref(%myhash)  =~ /^HASH\(/;
 685     print "ok ", $i++, "\n";
 686     print "not " unless myref(&mysub)   =~ /^CODE\(/;
 687     print "ok ", $i++, "\n";
 688     print "not " unless myref(*myglob)  =~ /^GLOB\(/;
 689     print "ok ", $i++, "\n";
 690
 691     eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/;
 692     print "not "
 693         unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /;
 694     print "ok ", $i++, "\n";
 695     eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/;
 696     print "not "
 697         unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /;
 698     print "ok ", $i++, "\n";
 699     eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/;
 700     print "not "
 701         unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /;
 702     print "ok ", $i++, "\n";
 703     eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/;
 704     print "not "
 705         unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /;
 706     print "ok ", $i++, "\n";
 707     eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/;
 708     print "not "
 709         unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] /
 710             && $@ =~ /Not enough arguments/;
 711     print "ok ", $i++, "\n";
 712 }
 713
 714 # check that obviously bad prototypes are getting warnings
 715 {
 716   local $^W = 1;
 717   my $warn = "";
 718   local $SIG{__WARN__} = sub { $warn .= join("",@_) };
 719
 720   eval 'sub badproto (@bar) { 1; }';
 721   print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/;
 722   print "ok ", $i++, " checking badproto - (\@bar)\n";
 723
 724   eval 'sub badproto2 (bar) { 1; }';
 725   print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/;
 726   print "ok ", $i++, " checking badproto2 - (bar)\n";
 727
 728   eval 'sub badproto3 (&$bar$@) { 1; }';
 729   print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/;
 730   print "ok ", $i++, " checking badproto3 - (&\$bar\$\@)\n";
 731
 732   eval 'sub badproto4 (@ $b ar) { 1; }';
 733   # This one emits two warnings
 734   print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@ \$b ar/;
 735   print "ok ", $i++, " checking badproto4 - (\@ \$b ar) - illegal character\n";
 736   print "not " unless $warn =~ /Prototype after '\@' for main::badproto4 : \@ \$b ar/;
 737   print "ok ", $i++, " checking badproto4 - (\@ \$b ar) - prototype after '\@'\n";
 738
 739   eval 'sub badproto5 ($_$) { 1; }';
 740   print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto5 : \$_\$/;
 741   print "ok ", $i++, " checking badproto5 - (\$_\$) - illegal character after '_'\n";
 742   print "not " if $warn =~ /Illegal character in prototype for main::badproto5 : \$_\$/;
 743   print "ok ", $i++, " checking badproto5 - (\$_\$) - but not just illegal character\n";
 744
 745   eval 'sub badproto6 (bar_) { 1; }';
 746   print "not " unless $warn =~ /Illegal character in prototype for main::badproto6 : bar_/;
 747   print "ok ", $i++, " checking badproto6 - (bar_) - illegal character\n";
 748   print "not " if $warn =~ /Illegal character after '_' in prototype for main::badproto6 : bar_/;
 749   print "ok ", $i++, " checking badproto6 - (bar_) - shouldn't add \"after '_'\"\n";
 750
 751   eval 'sub badproto7 (_;bar) { 1; }';
 752   print "not " unless $warn =~ /Illegal character in prototype for main::badproto7 : _;bar/;
 753   print "ok ", $i++, " checking badproto7 - (_;bar) - illegal character\n";
 754   print "not " if $warn =~ /Illegal character after '_' in prototype for main::badproto7 : _;bar/;
 755   print "ok ", $i++, " checking badproto7 - (_;bar) - shouldn't add \"after '_'\"\n";
 756
 757   eval 'sub badproto8 (_b) { 1; }';
 758   print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto8 : _b/;
 759   print "ok ", $i++, " checking badproto8 - (_b) - illegal character after '_'\n";
 760   print "not " unless $warn =~ /Illegal character in prototype for main::badproto8 : _b/;
 761   print "ok ", $i++, " checking badproto8 - (_b) - just illegal character\n";
 762
 763   eval 'sub badproto9 ([) { 1; }';
 764   print "not " unless $warn =~ /Missing '\]' in prototype for main::badproto9 : \[/;
 765   print "ok ", $i++, " checking for matching bracket\n";
 766
 767   eval 'sub badproto10 ([_]) { 1; }';
 768   print "not " if $warn =~ /Missing '\]' in prototype for main::badproto10 : \[/;
 769   print "ok ", $i++, " checking badproto10 - ([_]) - shouldn't trigger matching bracket\n";
 770   print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto10 : \[_\]/;
 771   print "ok ", $i++, " checking badproto10 - ([_]) - should trigger after '_' warnings\n";
 772 }
 773
 774 # make sure whitespace in prototypes works
 775 eval "sub good (\$\t\$\n\$) { 1; }";
 776 print "not " if $@;
 777 print "ok ", $i++, "\n";
 778 # [perl #118629]
 779 {
 780   my $warnings = 0;
 781   local $SIG{__WARN__} = sub { $warnings++;};
 782   $::{ckproto_test} = ' $ $ ';
 783         eval 'sub ckproto_test($$){1;}';
 784   print "not " if $warnings;
 785   print "ok ", $i++, " Check that ckproto ignores spaces in comparisons\n";
 786 }
 787
 788 # Ought to fail, doesn't in 5.8.1.
 789 eval 'sub bug (\[%@]) {  } my $array = [0 .. 1]; bug %$array;';
 790 print "not " unless $@ =~ /Not a HASH reference/;
 791 print "ok ", $i++, "\n";
 792
 793 # [perl #75904]
 794 # Test that the following prototypes make subs parse as unary functions:
 795 #  * \sigil \[...] ;$ ;* ;\sigil ;\[...]
 796 # [perl #118585]
 797 # As a special case, make sure that ;;* is treated the same as ;*
 798 print "not "
 799  unless eval 'sub uniproto1 (*) {} uniproto1 $_, 1' or warn $@;
 800 print "ok ", $i++, "\n";
 801 print "not "
 802  unless eval 'sub uniproto2 (\$) {} uniproto2 $_, 1' or warn $@;
 803 print "ok ", $i++, "\n";
 804 print "not "
 805  unless eval 'sub uniproto3 (\[$%]) {} uniproto3 %_, 1' or warn $@;
 806 print "ok ", $i++, "\n";
 807 print "not "
 808  unless eval 'sub uniproto4 (;$) {} uniproto4 $_, 1' or warn $@;
 809 print "ok ", $i++, "\n";
 810 print "not "
 811  unless eval 'sub uniproto5 (;*) {} uniproto5 $_, 1' or warn $@;
 812 print "ok ", $i++, "\n";
 813 print "not "
 814  unless eval 'sub uniproto6 (;\@) {} uniproto6 @_, 1' or warn $@;
 815 print "ok ", $i++, "\n";
 816 print "not "
 817  unless eval 'sub uniproto7 (;\[$%@]) {} uniproto7 @_, 1' or warn $@;
 818 print "ok ", $i++, "\n";
 819 print "not "
 820  unless eval 'sub uniproto8 (+) {} uniproto8 $_, 1' or warn $@;
 821 print "ok ", $i++, "\n";
 822 print "not "
 823  unless eval 'sub uniproto9 (;+) {} uniproto9 $_, 1' or warn $@;
 824 print "ok ", $i++, "\n";
 825 print "not "
 826  unless eval 'sub uniproto10 (;;;*) {} uniproto10 $_, 1' or warn $@;
 827 print "ok ", $i++, " - uniproto10 (;;;*)\n";
 828 print "not "
 829  unless eval 'sub uniproto11 ( ; ; ; * ) {} uniproto10 $_, 1' or warn $@;
 830 print "ok ", $i++, " - uniproto11 ( ; ; ;  *)\n";
 831 print "not "
 832  unless eval 'sub uniproto12 (;;;+) {} uniproto12 $_, 1' or warn $@;
 833 print "ok ", $i++, " - uniproto12 (;;;*)\n";
 834 print "not "
 835  unless eval 'sub uniproto13 ( ; ; ; + ) {} uniproto13 $_, 1' or warn $@;
 836 print "ok ", $i++, " - uniproto13 ( ; ; ; * )\n";
 837
 838
 839 # Test that a trailing semicolon makes a sub have listop precedence
 840 sub unilist ($;)  { $_[0]+1 }
 841 sub unilist2(_;)  { $_[0]+1 }
 842 sub unilist3(;$;) { $_[0]+1 }
 843 print "not " unless (unilist 0 || 5) == 6;
 844 print "ok ", $i++, "\n";
 845 print "not " unless (unilist2 0 || 5) == 6;
 846 print "ok ", $i++, "\n";
 847 print "not " unless (unilist3 0 || 5) == 6;
 848 print "ok ", $i++, "\n";
 849
 850 {
 851   # Lack of prototype on a subroutine definition should override any prototype
 852   # on the declaration.
 853   sub z_zwap (&);
 854
 855   local $SIG{__WARN__} = sub {
 856     my $thiswarn = join "",@_;
 857     if ($thiswarn =~ /^Prototype mismatch: sub main::z_zwap/) {
 858       print 'ok ', $i++, "\n";
 859     } else {
 860       print 'not ok ', $i++, "\n";
 861       print STDERR $thiswarn;
 862     }
 863   };
 864
 865   eval q{sub z_zwap {return @_}};
 866
 867   if ($@) {
 868     print "not ok ", $i++, "# $@";
 869   } else {
 870     print "ok ", $i++, "\n";
 871   }
 872
 873
 874   my @a = (6,4,2);
 875   my @got  = eval q{z_zwap(@a)};
 876
 877   if ($@) {
 878     print "not ok ", $i++, " # $@";
 879   } else {
 880     print "ok ", $i++, "\n";
 881   }
 882
 883   if ("@got" eq "@a") {
 884     print "ok ", $i++, "\n";
 885   } else {
 886     print "not ok ", $i++, " # >@got<\n";
 887   }
 888 }
 889
 890 # [perl #123514] prototype with no arguments
 891 $_ = sub ($$$$$$$) {};
 892 @_ = (1, 2, 3, prototype(), 4, 5, 6);
 893 print "not " unless "@_" eq '1 2 3 $$$$$$$ 4 5 6';
 894 print "ok ", $i++, " - [perl #123514] (got @_)\n";