Commit | Line | Data |
28757baa |
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. |
44a8e56a |
10 | # |
11 | |
12 | BEGIN { |
13 | chdir 't' if -d 't'; |
20822f61 |
14 | @INC = '../lib'; |
44a8e56a |
15 | } |
28757baa |
16 | |
17 | use strict; |
18 | |
5b794e05 |
19 | print "1..130\n"; |
28757baa |
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 | |
75fc29ea |
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 | |
28757baa |
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; |
36a5d4ba |
343 | sub_array { lc shift } ('O', 'K', ' ', $i++); |
28757baa |
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 | |
69dcf70c |
385 | testing \&array_ref_plus, '\@@'; |
28757baa |
386 | |
69dcf70c |
387 | sub array_ref_plus (\@@) { |
28757baa |
388 | print "# \@_ = (",join(",",@_),")\n"; |
69dcf70c |
389 | print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x'; |
28757baa |
390 | printf "ok %d\n",$i++; |
391 | @{$_[0]} = (qw(ok)," ",$i++,"\n"); |
392 | } |
393 | |
394 | @array = ('a'); |
69dcf70c |
395 | { my @more = ('x'); |
396 | array_ref_plus @array, @more; } |
28757baa |
397 | print "not " unless @array == 4; |
398 | print @array; |
fb73857a |
399 | |
b6c543e3 |
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 | |
1c1fc3ea |
407 | print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@'; |
b6c543e3 |
408 | print "ok ", $i++, "\n"; |
409 | |
410 | print "# CORE:Foo => ($p), \$@ => `$@'\nnot " |
ba5aeb3a |
411 | if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/; |
b6c543e3 |
412 | print "ok ", $i++, "\n"; |
413 | |
fb73857a |
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"; |
57ff9a15 |
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"; |
2ba6ecf4 |
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]} } |
18228614 |
440 | sub star2 (**&) { &{$_[2]} } |
441 | sub BAR { "quux" } |
2692f720 |
442 | sub Bar::BAZ { "quuz" } |
2ba6ecf4 |
443 | my $star = 'FOO'; |
444 | star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; |
18228614 |
445 | star(FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++; |
2ba6ecf4 |
446 | star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; |
18228614 |
447 | star("FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++; |
2ba6ecf4 |
448 | star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; |
18228614 |
449 | star($star, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++; |
2ba6ecf4 |
450 | star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; |
18228614 |
451 | star(*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++; |
2ba6ecf4 |
452 | star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; |
18228614 |
453 | star(\*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++; |
454 | star2 FOO, BAR, sub { print "ok $i\n" |
455 | if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++; |
2692f720 |
456 | star2(Bar::BAZ, FOO, sub { print "ok $i\n" |
457 | if $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO' }); $i++; |
18228614 |
458 | star2 BAR(), FOO, sub { print "ok $i\n" |
459 | if $_[0] eq 'quux' and $_[1] eq 'FOO' }; $i++; |
460 | star2(FOO, BAR(), sub { print "ok $i\n" |
461 | if $_[0] eq 'FOO' and $_[1] eq 'quux' }); $i++; |
462 | star2 "FOO", "BAR", sub { print "ok $i\n" |
463 | if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++; |
464 | star2("FOO", "BAR", sub { print "ok $i\n" |
465 | if $_[0] eq 'FOO' and $_[1] eq 'BAR' }); $i++; |
466 | star2 $star, $star, sub { print "ok $i\n" |
467 | if $_[0] eq 'FOO' and $_[1] eq 'FOO' }; $i++; |
468 | star2($star, $star, sub { print "ok $i\n" |
469 | if $_[0] eq 'FOO' and $_[1] eq 'FOO' }); $i++; |
470 | star2 *FOO, *BAR, sub { print "ok $i\n" |
1c01eb51 |
471 | if $_[0] eq \*FOO and $_[1] eq \*BAR }; $i++; |
18228614 |
472 | star2(*FOO, *BAR, sub { print "ok $i\n" |
1c01eb51 |
473 | if $_[0] eq \*FOO and $_[1] eq \*BAR }); $i++; |
18228614 |
474 | star2 \*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n" |
1c01eb51 |
475 | if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }; $i++; |
18228614 |
476 | star2(\*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n" |
1c01eb51 |
477 | if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }); $i++; |
18228614 |
478 | |
1c01eb51 |
479 | # test scalarref prototype |
480 | sub sreftest (\$$) { |
481 | print "ok $_[1]\n" if ref $_[0]; |
482 | } |
483 | { |
484 | no strict 'vars'; |
485 | sreftest my $sref, $i++; |
486 | sreftest($helem{$i}, $i++); |
487 | sreftest $aelem[0], $i++; |
488 | } |
c2b35b10 |
489 | |
490 | # test prototypes when they are evaled and there is a syntax error |
24cc8ef6 |
491 | # Byacc generates the string "syntax error". Bison gives the |
492 | # string "parse error". |
5279fd7b |
493 | # |
c2b35b10 |
494 | for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { |
4f945781 |
495 | no warnings 'prototype'; |
c2b35b10 |
496 | my $eval = "sub evaled_subroutine $p { &void *; }"; |
497 | eval $eval; |
24cc8ef6 |
498 | print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i; |
c2b35b10 |
499 | print "ok ", $i++, "\n"; |
500 | } |
337449a8 |
501 | |
502 | # Not $$;$;$ |
503 | print "not " unless prototype "CORE::substr" eq '$$;$$'; |
504 | print "ok ", $i++, "\n"; |
6e97e420 |
505 | |
506 | # recv takes a scalar reference for its second argument |
507 | print "not " unless prototype "CORE::recv" eq '*\\$$$'; |
508 | print "ok ", $i++, "\n"; |
5b794e05 |
509 | |
510 | { |
511 | my $myvar; |
512 | my @myarray; |
513 | my %myhash; |
514 | sub mysub { print "not calling mysub I hope\n" } |
515 | local *myglob; |
516 | |
517 | sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" } |
518 | |
519 | print "not " unless myref($myvar) =~ /^SCALAR\(/; |
520 | print "ok ", $i++, "\n"; |
521 | print "not " unless myref(@myarray) =~ /^ARRAY\(/; |
522 | print "ok ", $i++, "\n"; |
523 | print "not " unless myref(%myhash) =~ /^HASH\(/; |
524 | print "ok ", $i++, "\n"; |
525 | print "not " unless myref(&mysub) =~ /^CODE\(/; |
526 | print "ok ", $i++, "\n"; |
527 | print "not " unless myref(*myglob) =~ /^GLOB\(/; |
528 | print "ok ", $i++, "\n"; |
529 | } |