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 use strict;
  12
  13 my $i = 1;
  14
  15 ##
  16 ## Something really weird is happening here. Try changing the order
  17 ## of the next three lines, and try moving them to after the definition
  18 ## of testing, some combinations cause the script to fail while
  19 ## running tests on (&\@)
  20 ##
  21
  22 my %hash;
  23 my @array;
  24 @_ = qw(a b c d);
  25
  26 print "1..74\n";
  27
  28 sub testing (&$) {
  29     my $p = prototype(shift);
  30     my $c = shift;
  31     my $what = defined $c ? '(' . $p . ')' : 'no prototype';
  32     print '#' x 25,"\n";
  33     print '# Testing ',$what,"\n";
  34     print '#' x 25,"\n";
  35     print "not "
  36         if((defined($p) && defined($c) && $p ne $c)
  37            || (defined($p) != defined($c)));
  38     printf "ok %d\n",$i++;
  39 }
  40
  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     &{$_[0]};
 282 }
 283
 284 sub tmp_sub_1 { printf "ok %d\n",$i++ }
 285
 286 a_sub { printf "ok %d\n",$i++ };
 287 a_sub \&tmp_sub_1;
 288
 289 @array = ( \&tmp_sub_1 );
 290 eval 'a_sub @array';
 291 print "not " unless $@;
 292 printf "ok %d\n",$i++;
 293
 294 ##
 295 ##
 296 ##
 297
 298 testing \&sub_aref, '&\@';
 299
 300 sub sub_aref (&\@) {
 301     print "# \@_ = (",join(",",@_),")\n";
 302     my($sub,$array) = @_;
 303     print "not " unless @_ == 2 && @{$array} == 4;
 304     print map { &{$sub}($_) } @{$array}
 305 }
 306
 307 @array = (qw(O K)," ", $i++);
 308 sub_aref { lc shift } @array;
 309 print "\n";
 310
 311 ##
 312 ##
 313 ##
 314
 315 testing \&sub_array, '&@';
 316
 317 sub sub_array (&@) {
 318     print "# \@_ = (",join(",",@_),")\n";
 319     print "not " unless @_ == 5;
 320     my $sub = shift;
 321     print map { &{$sub}($_) } @_
 322 }
 323
 324 @array = (qw(O K)," ", $i++);
 325 sub_array { lc shift } @array;
 326 print "\n";
 327
 328 ##
 329 ##
 330 ##
 331
 332 testing \&a_hash, '%';
 333
 334 sub a_hash (%) {
 335     print "# \@_ = (",join(",",@_),")\n";
 336     scalar(@_);
 337 }
 338
 339 print "not " unless 1 == a_hash 'a';
 340 printf "ok %d\n",$i++;
 341
 342 print "not " unless 2 == a_hash 'a','b';
 343 printf "ok %d\n",$i++;
 344
 345 ##
 346 ##
 347 ##
 348
 349 testing \&a_hash_ref, '\%';
 350
 351 sub a_hash_ref (\%) {
 352     print "# \@_ = (",join(",",@_),")\n";
 353     print "not " unless ref($_[0]) && $_[0]->{'a'};
 354     printf "ok %d\n",$i++;
 355     $_[0]->{'b'} = 2;
 356 }
 357
 358 %hash = ( a => 1);
 359 a_hash_ref %hash;
 360 print "not " unless $hash{'b'} == 2;
 361 printf "ok %d\n",$i++;
 362
 363 ##
 364 ##
 365 ##
 366
 367 testing \&an_array_ref, '\@';
 368
 369 sub an_array_ref (\@) {
 370     print "# \@_ = (",join(",",@_),")\n";
 371     print "not " unless ref($_[0]) && 1 == @{$_[0]};
 372     printf "ok %d\n",$i++;
 373     @{$_[0]} = (qw(ok)," ",$i++,"\n");
 374 }
 375
 376 @array = ('a');
 377 an_array_ref @array;
 378 print "not " unless @array == 4;
 379 print @array;