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..122\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 print "\n";
 344
 345 ##
 346 ##
 347 ##
 348
 349 testing \&a_hash, '%';
 350
 351 sub a_hash (%) {
 352     print "# \@_ = (",join(",",@_),")\n";
 353     scalar(@_);
 354 }
 355
 356 print "not " unless 1 == a_hash 'a';
 357 printf "ok %d\n",$i++;
 358
 359 print "not " unless 2 == a_hash 'a','b';
 360 printf "ok %d\n",$i++;
 361
 362 ##
 363 ##
 364 ##
 365
 366 testing \&a_hash_ref, '\%';
 367
 368 sub a_hash_ref (\%) {
 369     print "# \@_ = (",join(",",@_),")\n";
 370     print "not " unless ref($_[0]) && $_[0]->{'a'};
 371     printf "ok %d\n",$i++;
 372     $_[0]->{'b'} = 2;
 373 }
 374
 375 %hash = ( a => 1);
 376 a_hash_ref %hash;
 377 print "not " unless $hash{'b'} == 2;
 378 printf "ok %d\n",$i++;
 379
 380 ##
 381 ##
 382 ##
 383
 384 testing \&array_ref_plus, '\@@';
 385
 386 sub array_ref_plus (\@@) {
 387     print "# \@_ = (",join(",",@_),")\n";
 388     print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
 389     printf "ok %d\n",$i++;
 390     @{$_[0]} = (qw(ok)," ",$i++,"\n");
 391 }
 392
 393 @array = ('a');
 394 { my @more = ('x');
 395   array_ref_plus @array, @more; }
 396 print "not " unless @array == 4;
 397 print @array;
 398
 399 my $p;
 400 print "not " if defined prototype('CORE::print');
 401 print "ok ", $i++, "\n";
 402
 403 print "not " if defined prototype('CORE::system');
 404 print "ok ", $i++, "\n";
 405
 406 print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@';
 407 print "ok ", $i++, "\n";
 408
 409 print "# CORE:Foo => ($p), \$@ => `$@'\nnot "
 410     if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/;
 411 print "ok ", $i++, "\n";
 412
 413 # correctly note too-short parameter lists that don't end with '$',
 414 #  a possible regression.
 415
 416 sub foo1 ($\@);
 417 eval q{ foo1 "s" };
 418 print "not " unless $@ =~ /^Not enough/;
 419 print "ok ", $i++, "\n";
 420
 421 sub foo2 ($\%);
 422 eval q{ foo2 "s" };
 423 print "not " unless $@ =~ /^Not enough/;
 424 print "ok ", $i++, "\n";
 425
 426 sub X::foo3;
 427 *X::foo3 = sub {'ok'};
 428 print "# $@not " unless eval {X->foo3} eq 'ok';
 429 print "ok ", $i++, "\n";
 430
 431 sub X::foo4 ($);
 432 *X::foo4 = sub ($) {'ok'};
 433 print "not " unless X->foo4 eq 'ok';
 434 print "ok ", $i++, "\n";
 435
 436 # test if the (*) prototype allows barewords, constants, scalar expressions,
 437 # globs and globrefs (just as CORE::open() does), all under stricture
 438 sub star (*&) { &{$_[1]} }
 439 sub star2 (**&) { &{$_[2]} }
 440 sub BAR { "quux" }
 441 sub Bar::BAZ { "quuz" }
 442 my $star = 'FOO';
 443 star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
 444 star(FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
 445 star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
 446 star("FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
 447 star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
 448 star($star, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
 449 star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
 450 star(*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
 451 star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
 452 star(\*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
 453 star2 FOO, BAR, sub { print "ok $i\n"
 454                         if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
 455 star2(Bar::BAZ, FOO, sub { print "ok $i\n"
 456                         if $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO' }); $i++;
 457 star2 BAR(), FOO, sub { print "ok $i\n"
 458                         if $_[0] eq 'quux' and $_[1] eq 'FOO' }; $i++;
 459 star2(FOO, BAR(), sub { print "ok $i\n"
 460                         if $_[0] eq 'FOO' and $_[1] eq 'quux' }); $i++;
 461 star2 "FOO", "BAR", sub { print "ok $i\n"
 462                         if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
 463 star2("FOO", "BAR", sub { print "ok $i\n"
 464                         if $_[0] eq 'FOO' and $_[1] eq 'BAR' }); $i++;
 465 star2 $star, $star, sub { print "ok $i\n"
 466                         if $_[0] eq 'FOO' and $_[1] eq 'FOO' }; $i++;
 467 star2($star, $star, sub { print "ok $i\n"
 468                         if $_[0] eq 'FOO' and $_[1] eq 'FOO' }); $i++;
 469 star2 *FOO, *BAR, sub { print "ok $i\n"
 470                         if $_[0] eq \*FOO and $_[1] eq \*BAR }; $i++;
 471 star2(*FOO, *BAR, sub { print "ok $i\n"
 472                         if $_[0] eq \*FOO and $_[1] eq \*BAR }); $i++;
 473 star2 \*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
 474                         if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }; $i++;
 475 star2(\*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
 476                         if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }); $i++;
 477
 478 # test scalarref prototype
 479 sub sreftest (\$$) {
 480     print "ok $_[1]\n" if ref $_[0];
 481 }
 482 {
 483     no strict 'vars';
 484     sreftest my $sref, $i++;
 485     sreftest($helem{$i}, $i++);
 486     sreftest $aelem[0], $i++;
 487 }
 488
 489 # test prototypes when they are evaled and there is a syntax error
 490 #
 491 # NOTE: evaled syntax errors mean scalar leaks
 492 #
 493 for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
 494   no warnings 'redefine';
 495   my $eval = "sub evaled_subroutine $p { &void *; }";
 496   eval $eval;
 497   print "# eval[$eval]\nnot " unless $@ && $@ =~ /syntax error/;
 498   print "ok ", $i++, "\n";
 499 }