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 # XXX known to leak scalars
  13 $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
  14
  15 BEGIN {
  16     chdir 't' if -d 't';
  17     @INC = '../lib';
  18 }
  19
  20 use strict;
  21
  22 print "1..124\n";
  23
  24 my $i = 1;
  25
  26 sub testing (&$) {
  27     my $p = prototype(shift);
  28     my $c = shift;
  29     my $what = defined $c ? '(' . $p . ')' : 'no prototype';
  30     print '#' x 25,"\n";
  31     print '# Testing ',$what,"\n";
  32     print '#' x 25,"\n";
  33     print "not "
  34         if((defined($p) && defined($c) && $p ne $c)
  35            || (defined($p) != defined($c)));
  36     printf "ok %d\n",$i++;
  37 }
  38
  39 @_ = qw(a b c d);
  40 my @array;
  41 my %hash;
  42
  43 ##
  44 ##
  45 ##
  46
  47 testing \&no_proto, undef;
  48
  49 sub no_proto {
  50     print "# \@_ = (",join(",",@_),")\n";
  51     scalar(@_)
  52 }
  53
  54 print "not " unless 0 == no_proto();
  55 printf "ok %d\n",$i++;
  56
  57 print "not " unless 1 == no_proto(5);
  58 printf "ok %d\n",$i++;
  59
  60 print "not " unless 4 == &no_proto;
  61 printf "ok %d\n",$i++;
  62
  63 print "not " unless 1 == no_proto +6;
  64 printf "ok %d\n",$i++;
  65
  66 print "not " unless 4 == no_proto(@_);
  67 printf "ok %d\n",$i++;
  68
  69 ##
  70 ##
  71 ##
  72
  73
  74 testing \&no_args, '';
  75
  76 sub no_args () {
  77     print "# \@_ = (",join(",",@_),")\n";
  78     scalar(@_)
  79 }
  80
  81 print "not " unless 0 == no_args();
  82 printf "ok %d\n",$i++;
  83
  84 print "not " unless 0 == no_args;
  85 printf "ok %d\n",$i++;
  86
  87 print "not " unless 5 == no_args +5;
  88 printf "ok %d\n",$i++;
  89
  90 print "not " unless 4 == &no_args;
  91 printf "ok %d\n",$i++;
  92
  93 print "not " unless 2 == &no_args(1,2);
  94 printf "ok %d\n",$i++;
  95
  96 eval "no_args(1)";
  97 print "not " unless $@;
  98 printf "ok %d\n",$i++;
  99
 100 ##
 101 ##
 102 ##
 103
 104 testing \&one_args, '$';
 105
 106 sub one_args ($) {
 107     print "# \@_ = (",join(",",@_),")\n";
 108     scalar(@_)
 109 }
 110
 111 print "not " unless 1 == one_args(1);
 112 printf "ok %d\n",$i++;
 113
 114 print "not " unless 1 == one_args +5;
 115 printf "ok %d\n",$i++;
 116
 117 print "not " unless 4 == &one_args;
 118 printf "ok %d\n",$i++;
 119
 120 print "not " unless 2 == &one_args(1,2);
 121 printf "ok %d\n",$i++;
 122
 123 eval "one_args(1,2)";
 124 print "not " unless $@;
 125 printf "ok %d\n",$i++;
 126
 127 eval "one_args()";
 128 print "not " unless $@;
 129 printf "ok %d\n",$i++;
 130
 131 sub one_a_args ($) {
 132     print "# \@_ = (",join(",",@_),")\n";
 133     print "not " unless @_ == 1 && $_[0] == 4;
 134     printf "ok %d\n",$i++;
 135 }
 136
 137 one_a_args(@_);
 138
 139 ##
 140 ##
 141 ##
 142
 143 testing \&over_one_args, '$@';
 144
 145 sub over_one_args ($@) {
 146     print "# \@_ = (",join(",",@_),")\n";
 147     scalar(@_)
 148 }
 149
 150 print "not " unless 1 == over_one_args(1);
 151 printf "ok %d\n",$i++;
 152
 153 print "not " unless 2 == over_one_args(1,2);
 154 printf "ok %d\n",$i++;
 155
 156 print "not " unless 1 == over_one_args +5;
 157 printf "ok %d\n",$i++;
 158
 159 print "not " unless 4 == &over_one_args;
 160 printf "ok %d\n",$i++;
 161
 162 print "not " unless 2 == &over_one_args(1,2);
 163 printf "ok %d\n",$i++;
 164
 165 print "not " unless 5 == &over_one_args(1,@_);
 166 printf "ok %d\n",$i++;
 167
 168 eval "over_one_args()";
 169 print "not " unless $@;
 170 printf "ok %d\n",$i++;
 171
 172 sub over_one_a_args ($@) {
 173     print "# \@_ = (",join(",",@_),")\n";
 174     print "not " unless @_ >= 1 && $_[0] == 4;
 175     printf "ok %d\n",$i++;
 176 }
 177
 178 over_one_a_args(@_);
 179 over_one_a_args(@_,1);
 180 over_one_a_args(@_,1,2);
 181 over_one_a_args(@_,@_);
 182
 183 ##
 184 ##
 185 ##
 186
 187 testing \&scalar_and_hash, '$%';
 188
 189 sub scalar_and_hash ($%) {
 190     print "# \@_ = (",join(",",@_),")\n";
 191     scalar(@_)
 192 }
 193
 194 print "not " unless 1 == scalar_and_hash(1);
 195 printf "ok %d\n",$i++;
 196
 197 print "not " unless 3 == scalar_and_hash(1,2,3);
 198 printf "ok %d\n",$i++;
 199
 200 print "not " unless 1 == scalar_and_hash +5;
 201 printf "ok %d\n",$i++;
 202
 203 print "not " unless 4 == &scalar_and_hash;
 204 printf "ok %d\n",$i++;
 205
 206 print "not " unless 2 == &scalar_and_hash(1,2);
 207 printf "ok %d\n",$i++;
 208
 209 print "not " unless 5 == &scalar_and_hash(1,@_);
 210 printf "ok %d\n",$i++;
 211
 212 eval "scalar_and_hash()";
 213 print "not " unless $@;
 214 printf "ok %d\n",$i++;
 215
 216 sub scalar_and_hash_a ($@) {
 217     print "# \@_ = (",join(",",@_),")\n";
 218     print "not " unless @_ >= 1 && $_[0] == 4;
 219     printf "ok %d\n",$i++;
 220 }
 221
 222 scalar_and_hash_a(@_);
 223 scalar_and_hash_a(@_,1);
 224 scalar_and_hash_a(@_,1,2);
 225 scalar_and_hash_a(@_,@_);
 226
 227 ##
 228 ##
 229 ##
 230
 231 testing \&one_or_two, '$;$';
 232
 233 sub one_or_two ($;$) {
 234     print "# \@_ = (",join(",",@_),")\n";
 235     scalar(@_)
 236 }
 237
 238 print "not " unless 1 == one_or_two(1);
 239 printf "ok %d\n",$i++;
 240
 241 print "not " unless 2 == one_or_two(1,3);
 242 printf "ok %d\n",$i++;
 243
 244 print "not " unless 1 == one_or_two +5;
 245 printf "ok %d\n",$i++;
 246
 247 print "not " unless 4 == &one_or_two;
 248 printf "ok %d\n",$i++;
 249
 250 print "not " unless 3 == &one_or_two(1,2,3);
 251 printf "ok %d\n",$i++;
 252
 253 print "not " unless 5 == &one_or_two(1,@_);
 254 printf "ok %d\n",$i++;
 255
 256 eval "one_or_two()";
 257 print "not " unless $@;
 258 printf "ok %d\n",$i++;
 259
 260 eval "one_or_two(1,2,3)";
 261 print "not " unless $@;
 262 printf "ok %d\n",$i++;
 263
 264 sub one_or_two_a ($;$) {
 265     print "# \@_ = (",join(",",@_),")\n";
 266     print "not " unless @_ >= 1 && $_[0] == 4;
 267     printf "ok %d\n",$i++;
 268 }
 269
 270 one_or_two_a(@_);
 271 one_or_two_a(@_,1);
 272 one_or_two_a(@_,@_);
 273
 274 ##
 275 ##
 276 ##
 277
 278 testing \&a_sub, '&';
 279
 280 sub a_sub (&) {
 281     print "# \@_ = (",join(",",@_),")\n";
 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
 290 @array = ( \&tmp_sub_1 );
 291 eval 'a_sub @array';
 292 print "not " unless $@;
 293 printf "ok %d\n",$i++;
 294
 295 ##
 296 ##
 297 ##
 298
 299 testing \&a_subx, '\&';
 300
 301 sub a_subx (\&) {
 302     print "# \@_ = (",join(",",@_),")\n";
 303     &{$_[0]};
 304 }
 305
 306 sub tmp_sub_2 { printf "ok %d\n",$i++ }
 307 a_subx &tmp_sub_2;
 308
 309 @array = ( \&tmp_sub_2 );
 310 eval 'a_subx @array';
 311 print "not " unless $@;
 312 printf "ok %d\n",$i++;
 313
 314 ##
 315 ##
 316 ##
 317
 318 testing \&sub_aref, '&\@';
 319
 320 sub sub_aref (&\@) {
 321     print "# \@_ = (",join(",",@_),")\n";
 322     my($sub,$array) = @_;
 323     print "not " unless @_ == 2 && @{$array} == 4;
 324     print map { &{$sub}($_) } @{$array}
 325 }
 326
 327 @array = (qw(O K)," ", $i++);
 328 sub_aref { lc shift } @array;
 329 print "\n";
 330
 331 ##
 332 ##
 333 ##
 334
 335 testing \&sub_array, '&@';
 336
 337 sub sub_array (&@) {
 338     print "# \@_ = (",join(",",@_),")\n";
 339     print "not " unless @_ == 5;
 340     my $sub = shift;
 341     print map { &{$sub}($_) } @_
 342 }
 343
 344 @array = (qw(O K)," ", $i++);
 345 sub_array { lc shift } @array;
 346 sub_array { lc shift } ('O', 'K', ' ', $i++);
 347 print "\n";
 348
 349 ##
 350 ##
 351 ##
 352
 353 testing \&a_hash, '%';
 354
 355 sub a_hash (%) {
 356     print "# \@_ = (",join(",",@_),")\n";
 357     scalar(@_);
 358 }
 359
 360 print "not " unless 1 == a_hash 'a';
 361 printf "ok %d\n",$i++;
 362
 363 print "not " unless 2 == a_hash 'a','b';
 364 printf "ok %d\n",$i++;
 365
 366 ##
 367 ##
 368 ##
 369
 370 testing \&a_hash_ref, '\%';
 371
 372 sub a_hash_ref (\%) {
 373     print "# \@_ = (",join(",",@_),")\n";
 374     print "not " unless ref($_[0]) && $_[0]->{'a'};
 375     printf "ok %d\n",$i++;
 376     $_[0]->{'b'} = 2;
 377 }
 378
 379 %hash = ( a => 1);
 380 a_hash_ref %hash;
 381 print "not " unless $hash{'b'} == 2;
 382 printf "ok %d\n",$i++;
 383
 384 ##
 385 ##
 386 ##
 387
 388 testing \&array_ref_plus, '\@@';
 389
 390 sub array_ref_plus (\@@) {
 391     print "# \@_ = (",join(",",@_),")\n";
 392     print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
 393     printf "ok %d\n",$i++;
 394     @{$_[0]} = (qw(ok)," ",$i++,"\n");
 395 }
 396
 397 @array = ('a');
 398 { my @more = ('x');
 399   array_ref_plus @array, @more; }
 400 print "not " unless @array == 4;
 401 print @array;
 402
 403 my $p;
 404 print "not " if defined prototype('CORE::print');
 405 print "ok ", $i++, "\n";
 406
 407 print "not " if defined prototype('CORE::system');
 408 print "ok ", $i++, "\n";
 409
 410 print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@';
 411 print "ok ", $i++, "\n";
 412
 413 print "# CORE:Foo => ($p), \$@ => `$@'\nnot "
 414     if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/;
 415 print "ok ", $i++, "\n";
 416
 417 # correctly note too-short parameter lists that don't end with '$',
 418 #  a possible regression.
 419
 420 sub foo1 ($\@);
 421 eval q{ foo1 "s" };
 422 print "not " unless $@ =~ /^Not enough/;
 423 print "ok ", $i++, "\n";
 424
 425 sub foo2 ($\%);
 426 eval q{ foo2 "s" };
 427 print "not " unless $@ =~ /^Not enough/;
 428 print "ok ", $i++, "\n";
 429
 430 sub X::foo3;
 431 *X::foo3 = sub {'ok'};
 432 print "# $@not " unless eval {X->foo3} eq 'ok';
 433 print "ok ", $i++, "\n";
 434
 435 sub X::foo4 ($);
 436 *X::foo4 = sub ($) {'ok'};
 437 print "not " unless X->foo4 eq 'ok';
 438 print "ok ", $i++, "\n";
 439
 440 # test if the (*) prototype allows barewords, constants, scalar expressions,
 441 # globs and globrefs (just as CORE::open() does), all under stricture
 442 sub star (*&) { &{$_[1]} }
 443 sub star2 (**&) { &{$_[2]} }
 444 sub BAR { "quux" }
 445 sub Bar::BAZ { "quuz" }
 446 my $star = 'FOO';
 447 star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
 448 star(FOO, 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 $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
 452 star($star, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
 453 star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
 454 star(*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
 455 star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
 456 star(\*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
 457 star2 FOO, BAR, sub { print "ok $i\n"
 458                         if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
 459 star2(Bar::BAZ, FOO, sub { print "ok $i\n"
 460                         if $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO' }); $i++;
 461 star2 BAR(), FOO, sub { print "ok $i\n"
 462                         if $_[0] eq 'quux' and $_[1] eq 'FOO' }; $i++;
 463 star2(FOO, BAR(), sub { print "ok $i\n"
 464                         if $_[0] eq 'FOO' and $_[1] eq 'quux' }); $i++;
 465 star2 "FOO", "BAR", sub { print "ok $i\n"
 466                         if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
 467 star2("FOO", "BAR", sub { print "ok $i\n"
 468                         if $_[0] eq 'FOO' and $_[1] eq 'BAR' }); $i++;
 469 star2 $star, $star, sub { print "ok $i\n"
 470                         if $_[0] eq 'FOO' and $_[1] eq 'FOO' }; $i++;
 471 star2($star, $star, sub { print "ok $i\n"
 472                         if $_[0] eq 'FOO' and $_[1] eq 'FOO' }); $i++;
 473 star2 *FOO, *BAR, sub { print "ok $i\n"
 474                         if $_[0] eq \*FOO and $_[1] eq \*BAR }; $i++;
 475 star2(*FOO, *BAR, sub { print "ok $i\n"
 476                         if $_[0] eq \*FOO and $_[1] eq \*BAR }); $i++;
 477 star2 \*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
 478                         if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }; $i++;
 479 star2(\*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
 480                         if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }); $i++;
 481
 482 # test scalarref prototype
 483 sub sreftest (\$$) {
 484     print "ok $_[1]\n" if ref $_[0];
 485 }
 486 {
 487     no strict 'vars';
 488     sreftest my $sref, $i++;
 489     sreftest($helem{$i}, $i++);
 490     sreftest $aelem[0], $i++;
 491 }
 492
 493 # test prototypes when they are evaled and there is a syntax error
 494 #
 495 for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
 496   no warnings 'redefine';
 497   my $eval = "sub evaled_subroutine $p { &void *; }";
 498   eval $eval;
 499   print "# eval[$eval]\nnot " unless $@ && $@ =~ /syntax error/;
 500   print "ok ", $i++, "\n";
 501 }
 502
 503 # Not $$;$;$
 504 print "not " unless prototype "CORE::substr" eq '$$;$$';
 505 print "ok ", $i++, "\n";