contrib/perl5/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..87\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 \&sub_aref, '&\@';
 297
 298 sub sub_aref (&\@) {
 299     print "# \@_ = (",join(",",@_),")\n";
 300     my($sub,$array) = @_;
 301     print "not " unless @_ == 2 && @{$array} == 4;
 302     print map { &{$sub}($_) } @{$array}
 303 }
 304
 305 @array = (qw(O K)," ", $i++);
 306 sub_aref { lc shift } @array;
 307 print "\n";
 308
 309 ##
 310 ##
 311 ##
 312
 313 testing \&sub_array, '&@';
 314
 315 sub sub_array (&@) {
 316     print "# \@_ = (",join(",",@_),")\n";
 317     print "not " unless @_ == 5;
 318     my $sub = shift;
 319     print map { &{$sub}($_) } @_
 320 }
 321
 322 @array = (qw(O K)," ", $i++);
 323 sub_array { lc shift } @array;
 324 print "\n";
 325
 326 ##
 327 ##
 328 ##
 329
 330 testing \&a_hash, '%';
 331
 332 sub a_hash (%) {
 333     print "# \@_ = (",join(",",@_),")\n";
 334     scalar(@_);
 335 }
 336
 337 print "not " unless 1 == a_hash 'a';
 338 printf "ok %d\n",$i++;
 339
 340 print "not " unless 2 == a_hash 'a','b';
 341 printf "ok %d\n",$i++;
 342
 343 ##
 344 ##
 345 ##
 346
 347 testing \&a_hash_ref, '\%';
 348
 349 sub a_hash_ref (\%) {
 350     print "# \@_ = (",join(",",@_),")\n";
 351     print "not " unless ref($_[0]) && $_[0]->{'a'};
 352     printf "ok %d\n",$i++;
 353     $_[0]->{'b'} = 2;
 354 }
 355
 356 %hash = ( a => 1);
 357 a_hash_ref %hash;
 358 print "not " unless $hash{'b'} == 2;
 359 printf "ok %d\n",$i++;
 360
 361 ##
 362 ##
 363 ##
 364
 365 testing \&array_ref_plus, '\@@';
 366
 367 sub array_ref_plus (\@@) {
 368     print "# \@_ = (",join(",",@_),")\n";
 369     print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
 370     printf "ok %d\n",$i++;
 371     @{$_[0]} = (qw(ok)," ",$i++,"\n");
 372 }
 373
 374 @array = ('a');
 375 { my @more = ('x');
 376   array_ref_plus @array, @more; }
 377 print "not " unless @array == 4;
 378 print @array;
 379
 380 my $p;
 381 print "not " if defined prototype('CORE::print');
 382 print "ok ", $i++, "\n";
 383
 384 print "not " if defined prototype('CORE::system');
 385 print "ok ", $i++, "\n";
 386
 387 print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$';
 388 print "ok ", $i++, "\n";
 389
 390 print "# CORE:Foo => ($p), \$@ => `$@'\nnot "
 391     if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Cannot find an opnumber/;
 392 print "ok ", $i++, "\n";
 393
 394 # correctly note too-short parameter lists that don't end with '$',
 395 #  a possible regression.
 396
 397 sub foo1 ($\@);
 398 eval q{ foo1 "s" };
 399 print "not " unless $@ =~ /^Not enough/;
 400 print "ok ", $i++, "\n";
 401
 402 sub foo2 ($\%);
 403 eval q{ foo2 "s" };
 404 print "not " unless $@ =~ /^Not enough/;
 405 print "ok ", $i++, "\n";
 406
 407 sub X::foo3;
 408 *X::foo3 = sub {'ok'};
 409 print "# $@not " unless eval {X->foo3} eq 'ok';
 410 print "ok ", $i++, "\n";
 411
 412 sub X::foo4 ($);
 413 *X::foo4 = sub ($) {'ok'};
 414 print "not " unless X->foo4 eq 'ok';
 415 print "ok ", $i++, "\n";
 416
 417 # test if the (*) prototype allows barewords, constants, scalar expressions,
 418 # globs and globrefs (just as CORE::open() does), all under stricture
 419 sub star (*&) { &{$_[1]} }
 420 my $star = 'FOO';
 421 star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
 422 star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
 423 star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
 424 star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
 425 star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;