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 | |
f3ca7bab NC |
17 | # We need this, as in places we're testing the interaction of prototypes with |
18 | # strict | |
28757baa | 19 | use strict; |
20 | ||
60f71a82 | 21 | print "1..207\n"; |
28757baa | 22 | |
23 | my $i = 1; | |
24 | ||
25 | sub testing (&$) { | |
26 | my $p = prototype(shift); | |
27 | my $c = shift; | |
28 | my $what = defined $c ? '(' . $p . ')' : 'no prototype'; | |
29 | print '#' x 25,"\n"; | |
30 | print '# Testing ',$what,"\n"; | |
31 | print '#' x 25,"\n"; | |
32 | print "not " | |
33 | if((defined($p) && defined($c) && $p ne $c) | |
34 | || (defined($p) != defined($c))); | |
35 | printf "ok %d\n",$i++; | |
36 | } | |
37 | ||
38 | @_ = qw(a b c d); | |
39 | my @array; | |
40 | my %hash; | |
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; | |
60f71a82 | 288 | a_sub \(&tmp_sub_1); |
28757baa | 289 | |
290 | @array = ( \&tmp_sub_1 ); | |
291 | eval 'a_sub @array'; | |
292 | print "not " unless $@; | |
293 | printf "ok %d\n",$i++; | |
e41e9865 FC |
294 | eval 'a_sub \@array'; |
295 | print "not " unless $@ =~ /Type of arg/; | |
296 | printf "ok %d\n",$i++; | |
297 | eval 'a_sub \%hash'; | |
298 | print "not " unless $@ =~ /Type of arg/; | |
299 | printf "ok %d\n",$i++; | |
300 | eval 'a_sub \$scalar'; | |
301 | print "not " unless $@ =~ /Type of arg/; | |
302 | printf "ok %d\n",$i++; | |
303 | eval 'a_sub \($list, %of, @refs)'; | |
304 | print "not " unless $@ =~ /Type of arg/; | |
305 | printf "ok %d\n",$i++; | |
306 | eval 'a_sub undef'; | |
307 | print "not " unless $@ =~ /Type of arg/; | |
308 | printf "ok %d\n",$i++; | |
28757baa | 309 | |
310 | ## | |
311 | ## | |
312 | ## | |
313 | ||
75fc29ea GS |
314 | testing \&a_subx, '\&'; |
315 | ||
316 | sub a_subx (\&) { | |
317 | print "# \@_ = (",join(",",@_),")\n"; | |
318 | &{$_[0]}; | |
319 | } | |
320 | ||
321 | sub tmp_sub_2 { printf "ok %d\n",$i++ } | |
322 | a_subx &tmp_sub_2; | |
323 | ||
324 | @array = ( \&tmp_sub_2 ); | |
325 | eval 'a_subx @array'; | |
326 | print "not " unless $@; | |
327 | printf "ok %d\n",$i++; | |
328 | ||
329 | ## | |
330 | ## | |
331 | ## | |
332 | ||
28757baa | 333 | testing \&sub_aref, '&\@'; |
334 | ||
335 | sub sub_aref (&\@) { | |
336 | print "# \@_ = (",join(",",@_),")\n"; | |
337 | my($sub,$array) = @_; | |
338 | print "not " unless @_ == 2 && @{$array} == 4; | |
339 | print map { &{$sub}($_) } @{$array} | |
340 | } | |
341 | ||
342 | @array = (qw(O K)," ", $i++); | |
343 | sub_aref { lc shift } @array; | |
344 | print "\n"; | |
345 | ||
346 | ## | |
347 | ## | |
348 | ## | |
349 | ||
350 | testing \&sub_array, '&@'; | |
351 | ||
352 | sub sub_array (&@) { | |
353 | print "# \@_ = (",join(",",@_),")\n"; | |
354 | print "not " unless @_ == 5; | |
355 | my $sub = shift; | |
356 | print map { &{$sub}($_) } @_ | |
357 | } | |
358 | ||
359 | @array = (qw(O K)," ", $i++); | |
360 | sub_array { lc shift } @array; | |
36a5d4ba | 361 | sub_array { lc shift } ('O', 'K', ' ', $i++); |
28757baa | 362 | print "\n"; |
363 | ||
364 | ## | |
365 | ## | |
366 | ## | |
367 | ||
368 | testing \&a_hash, '%'; | |
369 | ||
370 | sub a_hash (%) { | |
371 | print "# \@_ = (",join(",",@_),")\n"; | |
372 | scalar(@_); | |
373 | } | |
374 | ||
375 | print "not " unless 1 == a_hash 'a'; | |
376 | printf "ok %d\n",$i++; | |
377 | ||
378 | print "not " unless 2 == a_hash 'a','b'; | |
379 | printf "ok %d\n",$i++; | |
380 | ||
381 | ## | |
382 | ## | |
383 | ## | |
384 | ||
385 | testing \&a_hash_ref, '\%'; | |
386 | ||
387 | sub a_hash_ref (\%) { | |
388 | print "# \@_ = (",join(",",@_),")\n"; | |
389 | print "not " unless ref($_[0]) && $_[0]->{'a'}; | |
390 | printf "ok %d\n",$i++; | |
391 | $_[0]->{'b'} = 2; | |
392 | } | |
393 | ||
394 | %hash = ( a => 1); | |
395 | a_hash_ref %hash; | |
396 | print "not " unless $hash{'b'} == 2; | |
397 | printf "ok %d\n",$i++; | |
398 | ||
399 | ## | |
400 | ## | |
401 | ## | |
402 | ||
69dcf70c | 403 | testing \&array_ref_plus, '\@@'; |
28757baa | 404 | |
69dcf70c | 405 | sub array_ref_plus (\@@) { |
28757baa | 406 | print "# \@_ = (",join(",",@_),")\n"; |
69dcf70c | 407 | print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x'; |
28757baa | 408 | printf "ok %d\n",$i++; |
409 | @{$_[0]} = (qw(ok)," ",$i++,"\n"); | |
410 | } | |
411 | ||
412 | @array = ('a'); | |
69dcf70c MB |
413 | { my @more = ('x'); |
414 | array_ref_plus @array, @more; } | |
28757baa | 415 | print "not " unless @array == 4; |
416 | print @array; | |
fb73857a | 417 | |
b6c543e3 IZ |
418 | my $p; |
419 | print "not " if defined prototype('CORE::print'); | |
420 | print "ok ", $i++, "\n"; | |
421 | ||
422 | print "not " if defined prototype('CORE::system'); | |
423 | print "ok ", $i++, "\n"; | |
424 | ||
1c1fc3ea | 425 | print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@'; |
b6c543e3 IZ |
426 | print "ok ", $i++, "\n"; |
427 | ||
6954f42f | 428 | print "# CORE::Foo => ($p), \$@ => '$@'\nnot " |
ba5aeb3a | 429 | if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/; |
b6c543e3 IZ |
430 | print "ok ", $i++, "\n"; |
431 | ||
1b08e051 FC |
432 | eval { prototype("CORE::a\0b") }; |
433 | print "# CORE::a\\0b: \$@ => '$@'\nnot " | |
434 | if $@ !~ /^Can't find an opnumber for "a\0b"/; | |
435 | print "ok ", $i++, "\n"; | |
436 | ||
437 | eval { prototype("CORE::\x{100}") }; | |
438 | print "# CORE::\\x{100}: => ($p), \$@ => '$@'\nnot " | |
439 | if $@ !~ /^Can't find an opnumber for "\x{100}"/; | |
440 | print "ok ", $i++, "\n"; | |
441 | ||
6954f42f FC |
442 | "CORE::Foo" =~ /(.*)/; |
443 | print "# \$1 containing CORE::Foo => ($p), \$@ => '$@'\nnot " | |
444 | if defined ($p = eval { prototype($1) or 1 }) | |
445 | or $@ !~ /^Can't find an opnumber/; | |
446 | print "ok ", $i++, " - \$1 containing CORE::Foo\n"; | |
447 | ||
fb73857a | 448 | # correctly note too-short parameter lists that don't end with '$', |
449 | # a possible regression. | |
450 | ||
451 | sub foo1 ($\@); | |
452 | eval q{ foo1 "s" }; | |
453 | print "not " unless $@ =~ /^Not enough/; | |
454 | print "ok ", $i++, "\n"; | |
455 | ||
456 | sub foo2 ($\%); | |
457 | eval q{ foo2 "s" }; | |
458 | print "not " unless $@ =~ /^Not enough/; | |
459 | print "ok ", $i++, "\n"; | |
57ff9a15 IZ |
460 | |
461 | sub X::foo3; | |
462 | *X::foo3 = sub {'ok'}; | |
463 | print "# $@not " unless eval {X->foo3} eq 'ok'; | |
464 | print "ok ", $i++, "\n"; | |
465 | ||
466 | sub X::foo4 ($); | |
467 | *X::foo4 = sub ($) {'ok'}; | |
468 | print "not " unless X->foo4 eq 'ok'; | |
469 | print "ok ", $i++, "\n"; | |
2ba6ecf4 GS |
470 | |
471 | # test if the (*) prototype allows barewords, constants, scalar expressions, | |
472 | # globs and globrefs (just as CORE::open() does), all under stricture | |
473 | sub star (*&) { &{$_[1]} } | |
18228614 GS |
474 | sub star2 (**&) { &{$_[2]} } |
475 | sub BAR { "quux" } | |
2692f720 | 476 | sub Bar::BAZ { "quuz" } |
2ba6ecf4 | 477 | my $star = 'FOO'; |
13fc5c14 RGS |
478 | star FOO, sub { |
479 | print "not " unless $_[0] eq 'FOO'; | |
480 | print "ok $i - star FOO\n"; | |
481 | }; $i++; | |
482 | star(FOO, sub { | |
483 | print "not " unless $_[0] eq 'FOO'; | |
484 | print "ok $i - star(FOO)\n"; | |
485 | }); $i++; | |
486 | star "FOO", sub { | |
487 | print "not " unless $_[0] eq 'FOO'; | |
488 | print qq/ok $i - star "FOO"\n/; | |
489 | }; $i++; | |
490 | star("FOO", sub { | |
491 | print "not " unless $_[0] eq 'FOO'; | |
492 | print qq/ok $i - star("FOO")\n/; | |
493 | }); $i++; | |
494 | star $star, sub { | |
495 | print "not " unless $_[0] eq 'FOO'; | |
496 | print "ok $i - star \$star\n"; | |
497 | }; $i++; | |
498 | star($star, sub { | |
499 | print "not " unless $_[0] eq 'FOO'; | |
500 | print "ok $i - star(\$star)\n"; | |
501 | }); $i++; | |
502 | star *FOO, sub { | |
503 | print "not " unless $_[0] eq \*FOO; | |
504 | print "ok $i - star *FOO\n"; | |
505 | }; $i++; | |
506 | star(*FOO, sub { | |
507 | print "not " unless $_[0] eq \*FOO; | |
508 | print "ok $i - star(*FOO)\n"; | |
509 | }); $i++; | |
510 | star \*FOO, sub { | |
511 | print "not " unless $_[0] eq \*FOO; | |
512 | print "ok $i - star \\*FOO\n"; | |
513 | }; $i++; | |
514 | star(\*FOO, sub { | |
515 | print "not " unless $_[0] eq \*FOO; | |
516 | print "ok $i - star(\\*FOO)\n"; | |
517 | }); $i++; | |
518 | star2 FOO, BAR, sub { | |
cfc7ef15 | 519 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux'; |
13fc5c14 RGS |
520 | print "ok $i - star2 FOO, BAR\n"; |
521 | }; $i++; | |
522 | star2(Bar::BAZ, FOO, sub { | |
cfc7ef15 | 523 | print "not " unless $_[0] eq 'quuz' and $_[1] eq 'FOO'; |
13fc5c14 RGS |
524 | print "ok $i - star2(Bar::BAZ, FOO)\n" |
525 | }); $i++; | |
526 | star2 BAR(), FOO, sub { | |
527 | print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO'; | |
528 | print "ok $i - star2 BAR(), FOO\n" | |
529 | }; $i++; | |
530 | star2(FOO, BAR(), sub { | |
531 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux'; | |
532 | print "ok $i - star2(FOO, BAR())\n"; | |
533 | }); $i++; | |
534 | star2 "FOO", "BAR", sub { | |
535 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; | |
536 | print qq/ok $i - star2 "FOO", "BAR"\n/; | |
537 | }; $i++; | |
538 | star2("FOO", "BAR", sub { | |
539 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; | |
540 | print qq/ok $i - star2("FOO", "BAR")\n/; | |
541 | }); $i++; | |
542 | star2 $star, $star, sub { | |
543 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; | |
544 | print "ok $i - star2 \$star, \$star\n"; | |
545 | }; $i++; | |
546 | star2($star, $star, sub { | |
547 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; | |
548 | print "ok $i - star2(\$star, \$star)\n"; | |
549 | }); $i++; | |
550 | star2 *FOO, *BAR, sub { | |
551 | print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; | |
552 | print "ok $i - star2 *FOO, *BAR\n"; | |
553 | }; $i++; | |
554 | star2(*FOO, *BAR, sub { | |
555 | print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; | |
556 | print "ok $i - star2(*FOO, *BAR)\n"; | |
557 | }); $i++; | |
558 | star2 \*FOO, \*BAR, sub { | |
559 | no strict 'refs'; | |
560 | print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; | |
561 | print "ok $i - star2 \*FOO, \*BAR\n"; | |
562 | }; $i++; | |
563 | star2(\*FOO, \*BAR, sub { | |
564 | no strict 'refs'; | |
565 | print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; | |
566 | print "ok $i - star2(\*FOO, \*BAR)\n"; | |
567 | }); $i++; | |
18228614 | 568 | |
80e09529 PM |
569 | # [perl #118585] |
570 | # Test that multiple semicolons are treated as one with * | |
571 | sub star3(;;;*){} | |
572 | sub star4( ; ; ; ; *){} | |
573 | print "not " unless eval 'star3 STDERR; 1'; | |
574 | print "ok ", $i++, " star3 STDERR\n"; | |
575 | print "not " unless eval 'star4 STDERR; 1'; | |
576 | print "ok ", $i++, " star4 STDERR\n"; | |
577 | ||
eb40d2ca PM |
578 | # [perl #2726] |
579 | # Test that prototype binding is late | |
580 | print "not " unless eval 'sub l564($){ l564(); } 1'; | |
581 | print "ok ", $i++, " prototype checking not done within initial definition\n"; | |
582 | print "not " if eval 'sub l566($); sub l566($){ l566(); } 1'; | |
583 | print "ok ", $i++, " prototype checking done if sub pre-declared\n"; | |
584 | ||
1c01eb51 GS |
585 | # test scalarref prototype |
586 | sub sreftest (\$$) { | |
13fc5c14 RGS |
587 | print "not " unless ref $_[0]; |
588 | print "ok $_[1] - sreftest\n"; | |
1c01eb51 GS |
589 | } |
590 | { | |
591 | no strict 'vars'; | |
592 | sreftest my $sref, $i++; | |
593 | sreftest($helem{$i}, $i++); | |
594 | sreftest $aelem[0], $i++; | |
63983e4c | 595 | sreftest sub { [0] }->()[0], $i++; |
062678b2 FC |
596 | sreftest my $a = 'quidgley', $i++; |
597 | print "not " if eval 'return 1; sreftest(3+4)'; | |
598 | print "ok ", $i++, ' - \$ with invalid argument', "\n"; | |
1c01eb51 | 599 | } |
c2b35b10 | 600 | |
c035a075 DG |
601 | # test single term |
602 | sub lazy (+$$) { | |
603 | print "not " unless @_ == 3 && ref $_[0] eq $_[1]; | |
604 | print "ok $_[2] - non container test\n"; | |
605 | } | |
606 | sub quietlazy (+) { return shift(@_) } | |
607 | sub give_aref { [] } | |
608 | sub list_or_scalar { wantarray ? (1..10) : [] } | |
609 | { | |
610 | my @multiarray = ("a".."z"); | |
611 | my %bighash = @multiarray; | |
612 | lazy(\@multiarray, 'ARRAY', $i++); | |
613 | lazy(\%bighash, 'HASH', $i++); | |
614 | lazy({}, 'HASH', $i++); | |
615 | lazy(give_aref, 'ARRAY', $i++); | |
616 | lazy(3, '', $i++); # allowed by prototype, even if runtime error | |
617 | lazy(list_or_scalar, 'ARRAY', $i++); # propagate scalar context | |
618 | } | |
619 | ||
c2b35b10 | 620 | # test prototypes when they are evaled and there is a syntax error |
24cc8ef6 AD |
621 | # Byacc generates the string "syntax error". Bison gives the |
622 | # string "parse error". | |
5279fd7b | 623 | # |
c2b35b10 | 624 | for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { |
f3ca7bab NC |
625 | my $warn = ""; |
626 | local $SIG{__WARN__} = sub { | |
627 | my $thiswarn = join("",@_); | |
628 | return if $thiswarn =~ /^Prototype mismatch: sub main::evaled_subroutine/; | |
629 | $warn .= $thiswarn; | |
630 | }; | |
c2b35b10 A |
631 | my $eval = "sub evaled_subroutine $p { &void *; }"; |
632 | eval $eval; | |
24cc8ef6 | 633 | print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i; |
c2b35b10 | 634 | print "ok ", $i++, "\n"; |
f3ca7bab NC |
635 | if ($warn eq '') { |
636 | print "ok ", $i++, "\n"; | |
637 | } else { | |
638 | print "not ok ", $i++, "# $warn \n"; | |
639 | } | |
c2b35b10 | 640 | } |
337449a8 | 641 | |
5b794e05 JH |
642 | { |
643 | my $myvar; | |
644 | my @myarray; | |
645 | my %myhash; | |
646 | sub mysub { print "not calling mysub I hope\n" } | |
647 | local *myglob; | |
648 | ||
649 | sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" } | |
650 | ||
651 | print "not " unless myref($myvar) =~ /^SCALAR\(/; | |
652 | print "ok ", $i++, "\n"; | |
062678b2 FC |
653 | print "not " unless myref($myvar=7) =~ /^SCALAR\(/; |
654 | print "ok ", $i++, "\n"; | |
5b794e05 JH |
655 | print "not " unless myref(@myarray) =~ /^ARRAY\(/; |
656 | print "ok ", $i++, "\n"; | |
657 | print "not " unless myref(%myhash) =~ /^HASH\(/; | |
658 | print "ok ", $i++, "\n"; | |
659 | print "not " unless myref(&mysub) =~ /^CODE\(/; | |
660 | print "ok ", $i++, "\n"; | |
661 | print "not " unless myref(*myglob) =~ /^GLOB\(/; | |
662 | print "ok ", $i++, "\n"; | |
4eba7d22 RGS |
663 | |
664 | eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/; | |
a0751766 NC |
665 | print "not " |
666 | unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /; | |
4eba7d22 RGS |
667 | print "ok ", $i++, "\n"; |
668 | eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/; | |
a0751766 NC |
669 | print "not " |
670 | unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /; | |
4eba7d22 RGS |
671 | print "ok ", $i++, "\n"; |
672 | eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/; | |
a0751766 NC |
673 | print "not " |
674 | unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /; | |
4eba7d22 RGS |
675 | print "ok ", $i++, "\n"; |
676 | eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/; | |
a0751766 NC |
677 | print "not " |
678 | unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /; | |
4eba7d22 RGS |
679 | print "ok ", $i++, "\n"; |
680 | eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/; | |
a0751766 NC |
681 | print "not " |
682 | unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] / | |
683 | && $@ =~ /Not enough arguments/; | |
4eba7d22 | 684 | print "ok ", $i++, "\n"; |
5b794e05 | 685 | } |
2f758a16 | 686 | |
d37a9538 ST |
687 | # check that obviously bad prototypes are getting warnings |
688 | { | |
f3ca7bab | 689 | local $^W = 1; |
d37a9538 ST |
690 | my $warn = ""; |
691 | local $SIG{__WARN__} = sub { $warn .= join("",@_) }; | |
692 | ||
693 | eval 'sub badproto (@bar) { 1; }'; | |
694 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/; | |
f791a21a | 695 | print "ok ", $i++, " checking badproto - (\@bar)\n"; |
2f758a16 | 696 | |
d37a9538 ST |
697 | eval 'sub badproto2 (bar) { 1; }'; |
698 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/; | |
f791a21a | 699 | print "ok ", $i++, " checking badproto2 - (bar)\n"; |
d37a9538 ST |
700 | |
701 | eval 'sub badproto3 (&$bar$@) { 1; }'; | |
702 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/; | |
f791a21a | 703 | print "ok ", $i++, " checking badproto3 - (&\$bar\$\@)\n"; |
d37a9538 ST |
704 | |
705 | eval 'sub badproto4 (@ $b ar) { 1; }'; | |
f791a21a | 706 | # This one emits two warnings |
fe788d6b | 707 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@ \$b ar/; |
f791a21a PM |
708 | print "ok ", $i++, " checking badproto4 - (\@ \$b ar) - illegal character\n"; |
709 | print "not " unless $warn =~ /Prototype after '\@' for main::badproto4 : \@ \$b ar/; | |
710 | print "ok ", $i++, " checking badproto4 - (\@ \$b ar) - prototype after '\@'\n"; | |
711 | ||
712 | eval 'sub badproto5 ($_$) { 1; }'; | |
713 | print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto5 : \$_\$/; | |
714 | print "ok ", $i++, " checking badproto5 - (\$_\$) - illegal character after '_'\n"; | |
715 | print "not " if $warn =~ /Illegal character in prototype for main::badproto5 : \$_\$/; | |
716 | print "ok ", $i++, " checking badproto5 - (\$_\$) - but not just illegal character\n"; | |
50278ed0 | 717 | |
f791a21a PM |
718 | eval 'sub badproto6 (bar_) { 1; }'; |
719 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto6 : bar_/; | |
720 | print "ok ", $i++, " checking badproto6 - (bar_) - illegal character\n"; | |
721 | print "not " if $warn =~ /Illegal character after '_' in prototype for main::badproto6 : bar_/; | |
722 | print "ok ", $i++, " checking badproto6 - (bar_) - shouldn't add \"after '_'\"\n"; | |
50278ed0 | 723 | |
f791a21a PM |
724 | eval 'sub badproto7 (_;bar) { 1; }'; |
725 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto7 : _;bar/; | |
726 | print "ok ", $i++, " checking badproto7 - (_;bar) - illegal character\n"; | |
727 | print "not " if $warn =~ /Illegal character after '_' in prototype for main::badproto7 : _;bar/; | |
728 | print "ok ", $i++, " checking badproto7 - (_;bar) - shouldn't add \"after '_'\"\n"; | |
50278ed0 | 729 | |
f791a21a PM |
730 | eval 'sub badproto8 (_b) { 1; }'; |
731 | print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto8 : _b/; | |
732 | print "ok ", $i++, " checking badproto8 - (_b) - illegal character after '_'\n"; | |
733 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto8 : _b/; | |
734 | print "ok ", $i++, " checking badproto8 - (_b) - just illegal character\n"; | |
50278ed0 PM |
735 | |
736 | eval 'sub badproto9 ([) { 1; }'; | |
737 | print "not " unless $warn =~ /Missing '\]' in prototype for main::badproto9 : \[/; | |
738 | print "ok ", $i++, " checking for matching bracket\n"; | |
739 | ||
740 | eval 'sub badproto10 ([_]) { 1; }'; | |
741 | print "not " if $warn =~ /Missing '\]' in prototype for main::badproto10 : \[/; | |
742 | print "ok ", $i++, " checking badproto10 - ([_]) - shouldn't trigger matching bracket\n"; | |
743 | print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto10 : \[_\]/; | |
744 | print "ok ", $i++, " checking badproto10 - ([_]) - should trigger after '_' warnings\n"; | |
d37a9538 | 745 | } |
2f758a16 | 746 | |
d37a9538 ST |
747 | # make sure whitespace in prototypes works |
748 | eval "sub good (\$\t\$\n\$) { 1; }"; | |
749 | print "not " if $@; | |
d731386a | 750 | print "ok ", $i++, "\n"; |
7a2f0b06 PM |
751 | # [perl #118629] |
752 | { | |
753 | my $warnings = 0; | |
754 | local $SIG{__WARN__} = sub { $warnings++;}; | |
755 | $::{ckproto_test} = ' $ $ '; | |
756 | eval 'sub ckproto_test($$){1;}'; | |
757 | print "not " if $warnings; | |
758 | print "ok ", $i++, " Check that ckproto ignores spaces in comparisons\n"; | |
759 | } | |
b8ec4db0 A |
760 | |
761 | # Ought to fail, doesn't in 5.8.1. | |
762 | eval 'sub bug (\[%@]) { } my $array = [0 .. 1]; bug %$array;'; | |
763 | print "not " unless $@ =~ /Not a HASH reference/; | |
764 | print "ok ", $i++, "\n"; | |
649d02de FC |
765 | |
766 | # [perl #75904] | |
767 | # Test that the following prototypes make subs parse as unary functions: | |
768 | # * \sigil \[...] ;$ ;* ;\sigil ;\[...] | |
80e09529 PM |
769 | # [perl #118585] |
770 | # As a special case, make sure that ;;* is treated the same as ;* | |
649d02de FC |
771 | print "not " |
772 | unless eval 'sub uniproto1 (*) {} uniproto1 $_, 1' or warn $@; | |
773 | print "ok ", $i++, "\n"; | |
774 | print "not " | |
775 | unless eval 'sub uniproto2 (\$) {} uniproto2 $_, 1' or warn $@; | |
776 | print "ok ", $i++, "\n"; | |
777 | print "not " | |
778 | unless eval 'sub uniproto3 (\[$%]) {} uniproto3 %_, 1' or warn $@; | |
779 | print "ok ", $i++, "\n"; | |
780 | print "not " | |
781 | unless eval 'sub uniproto4 (;$) {} uniproto4 $_, 1' or warn $@; | |
782 | print "ok ", $i++, "\n"; | |
783 | print "not " | |
784 | unless eval 'sub uniproto5 (;*) {} uniproto5 $_, 1' or warn $@; | |
785 | print "ok ", $i++, "\n"; | |
786 | print "not " | |
787 | unless eval 'sub uniproto6 (;\@) {} uniproto6 @_, 1' or warn $@; | |
788 | print "ok ", $i++, "\n"; | |
789 | print "not " | |
790 | unless eval 'sub uniproto7 (;\[$%@]) {} uniproto7 @_, 1' or warn $@; | |
791 | print "ok ", $i++, "\n"; | |
c035a075 DG |
792 | print "not " |
793 | unless eval 'sub uniproto8 (+) {} uniproto8 $_, 1' or warn $@; | |
794 | print "ok ", $i++, "\n"; | |
795 | print "not " | |
796 | unless eval 'sub uniproto9 (;+) {} uniproto9 $_, 1' or warn $@; | |
797 | print "ok ", $i++, "\n"; | |
80e09529 PM |
798 | print "not " |
799 | unless eval 'sub uniproto10 (;;;*) {} uniproto10 $_, 1' or warn $@; | |
800 | print "ok ", $i++, " - uniproto10 (;;;*)\n"; | |
801 | print "not " | |
802 | unless eval 'sub uniproto11 ( ; ; ; * ) {} uniproto10 $_, 1' or warn $@; | |
803 | print "ok ", $i++, " - uniproto11 ( ; ; ; *)\n"; | |
804 | print "not " | |
805 | unless eval 'sub uniproto12 (;;;+) {} uniproto12 $_, 1' or warn $@; | |
806 | print "ok ", $i++, " - uniproto12 (;;;*)\n"; | |
807 | print "not " | |
f791a21a PM |
808 | unless eval 'sub uniproto13 ( ; ; ; + ) {} uniproto13 $_, 1' or warn $@; |
809 | print "ok ", $i++, " - uniproto13 ( ; ; ; * )\n"; | |
810 | ||
3fa17e3f | 811 | |
3a8944db FC |
812 | # Test that a trailing semicolon makes a sub have listop precedence |
813 | sub unilist ($;) { $_[0]+1 } | |
814 | sub unilist2(_;) { $_[0]+1 } | |
815 | sub unilist3(;$;) { $_[0]+1 } | |
816 | print "not " unless (unilist 0 || 5) == 6; | |
817 | print "ok ", $i++, "\n"; | |
818 | print "not " unless (unilist2 0 || 5) == 6; | |
819 | print "ok ", $i++, "\n"; | |
820 | print "not " unless (unilist3 0 || 5) == 6; | |
821 | print "ok ", $i++, "\n"; | |
822 | ||
3fa17e3f NC |
823 | { |
824 | # Lack of prototype on a subroutine definition should override any prototype | |
825 | # on the declaration. | |
826 | sub z_zwap (&); | |
827 | ||
828 | local $SIG{__WARN__} = sub { | |
829 | my $thiswarn = join "",@_; | |
830 | if ($thiswarn =~ /^Prototype mismatch: sub main::z_zwap/) { | |
831 | print 'ok ', $i++, "\n"; | |
832 | } else { | |
833 | print 'not ok ', $i++, "\n"; | |
834 | print STDERR $thiswarn; | |
835 | } | |
836 | }; | |
837 | ||
838 | eval q{sub z_zwap {return @_}}; | |
839 | ||
840 | if ($@) { | |
841 | print "not ok ", $i++, "# $@"; | |
842 | } else { | |
843 | print "ok ", $i++, "\n"; | |
844 | } | |
845 | ||
846 | ||
847 | my @a = (6,4,2); | |
848 | my @got = eval q{z_zwap(@a)}; | |
849 | ||
850 | if ($@) { | |
851 | print "not ok ", $i++, " # $@"; | |
852 | } else { | |
853 | print "ok ", $i++, "\n"; | |
854 | } | |
855 | ||
856 | if ("@got" eq "@a") { | |
857 | print "ok ", $i++, "\n"; | |
858 | } else { | |
859 | print "not ok ", $i++, " # >@got<\n"; | |
860 | } | |
861 | } |