t/comp/proto.t

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