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 | ||
6954f42f | 21 | print "1..180\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; | |
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 | ||
75fc29ea GS |
298 | testing \&a_subx, '\&'; |
299 | ||
300 | sub a_subx (\&) { | |
301 | print "# \@_ = (",join(",",@_),")\n"; | |
302 | &{$_[0]}; | |
303 | } | |
304 | ||
305 | sub tmp_sub_2 { printf "ok %d\n",$i++ } | |
306 | a_subx &tmp_sub_2; | |
307 | ||
308 | @array = ( \&tmp_sub_2 ); | |
309 | eval 'a_subx @array'; | |
310 | print "not " unless $@; | |
311 | printf "ok %d\n",$i++; | |
312 | ||
313 | ## | |
314 | ## | |
315 | ## | |
316 | ||
28757baa | 317 | testing \&sub_aref, '&\@'; |
318 | ||
319 | sub sub_aref (&\@) { | |
320 | print "# \@_ = (",join(",",@_),")\n"; | |
321 | my($sub,$array) = @_; | |
322 | print "not " unless @_ == 2 && @{$array} == 4; | |
323 | print map { &{$sub}($_) } @{$array} | |
324 | } | |
325 | ||
326 | @array = (qw(O K)," ", $i++); | |
327 | sub_aref { lc shift } @array; | |
328 | print "\n"; | |
329 | ||
330 | ## | |
331 | ## | |
332 | ## | |
333 | ||
334 | testing \&sub_array, '&@'; | |
335 | ||
336 | sub sub_array (&@) { | |
337 | print "# \@_ = (",join(",",@_),")\n"; | |
338 | print "not " unless @_ == 5; | |
339 | my $sub = shift; | |
340 | print map { &{$sub}($_) } @_ | |
341 | } | |
342 | ||
343 | @array = (qw(O K)," ", $i++); | |
344 | sub_array { lc shift } @array; | |
36a5d4ba | 345 | sub_array { lc shift } ('O', 'K', ' ', $i++); |
28757baa | 346 | print "\n"; |
347 | ||
348 | ## | |
349 | ## | |
350 | ## | |
351 | ||
352 | testing \&a_hash, '%'; | |
353 | ||
354 | sub a_hash (%) { | |
355 | print "# \@_ = (",join(",",@_),")\n"; | |
356 | scalar(@_); | |
357 | } | |
358 | ||
359 | print "not " unless 1 == a_hash 'a'; | |
360 | printf "ok %d\n",$i++; | |
361 | ||
362 | print "not " unless 2 == a_hash 'a','b'; | |
363 | printf "ok %d\n",$i++; | |
364 | ||
365 | ## | |
366 | ## | |
367 | ## | |
368 | ||
369 | testing \&a_hash_ref, '\%'; | |
370 | ||
371 | sub a_hash_ref (\%) { | |
372 | print "# \@_ = (",join(",",@_),")\n"; | |
373 | print "not " unless ref($_[0]) && $_[0]->{'a'}; | |
374 | printf "ok %d\n",$i++; | |
375 | $_[0]->{'b'} = 2; | |
376 | } | |
377 | ||
378 | %hash = ( a => 1); | |
379 | a_hash_ref %hash; | |
380 | print "not " unless $hash{'b'} == 2; | |
381 | printf "ok %d\n",$i++; | |
382 | ||
383 | ## | |
384 | ## | |
385 | ## | |
386 | ||
69dcf70c | 387 | testing \&array_ref_plus, '\@@'; |
28757baa | 388 | |
69dcf70c | 389 | sub array_ref_plus (\@@) { |
28757baa | 390 | print "# \@_ = (",join(",",@_),")\n"; |
69dcf70c | 391 | print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x'; |
28757baa | 392 | printf "ok %d\n",$i++; |
393 | @{$_[0]} = (qw(ok)," ",$i++,"\n"); | |
394 | } | |
395 | ||
396 | @array = ('a'); | |
69dcf70c MB |
397 | { my @more = ('x'); |
398 | array_ref_plus @array, @more; } | |
28757baa | 399 | print "not " unless @array == 4; |
400 | print @array; | |
fb73857a | 401 | |
b6c543e3 IZ |
402 | my $p; |
403 | print "not " if defined prototype('CORE::print'); | |
404 | print "ok ", $i++, "\n"; | |
405 | ||
406 | print "not " if defined prototype('CORE::system'); | |
407 | print "ok ", $i++, "\n"; | |
408 | ||
1c1fc3ea | 409 | print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@'; |
b6c543e3 IZ |
410 | print "ok ", $i++, "\n"; |
411 | ||
6954f42f | 412 | print "# CORE::Foo => ($p), \$@ => '$@'\nnot " |
ba5aeb3a | 413 | if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/; |
b6c543e3 IZ |
414 | print "ok ", $i++, "\n"; |
415 | ||
1b08e051 FC |
416 | eval { prototype("CORE::a\0b") }; |
417 | print "# CORE::a\\0b: \$@ => '$@'\nnot " | |
418 | if $@ !~ /^Can't find an opnumber for "a\0b"/; | |
419 | print "ok ", $i++, "\n"; | |
420 | ||
421 | eval { prototype("CORE::\x{100}") }; | |
422 | print "# CORE::\\x{100}: => ($p), \$@ => '$@'\nnot " | |
423 | if $@ !~ /^Can't find an opnumber for "\x{100}"/; | |
424 | print "ok ", $i++, "\n"; | |
425 | ||
6954f42f FC |
426 | "CORE::Foo" =~ /(.*)/; |
427 | print "# \$1 containing CORE::Foo => ($p), \$@ => '$@'\nnot " | |
428 | if defined ($p = eval { prototype($1) or 1 }) | |
429 | or $@ !~ /^Can't find an opnumber/; | |
430 | print "ok ", $i++, " - \$1 containing CORE::Foo\n"; | |
431 | ||
fb73857a | 432 | # correctly note too-short parameter lists that don't end with '$', |
433 | # a possible regression. | |
434 | ||
435 | sub foo1 ($\@); | |
436 | eval q{ foo1 "s" }; | |
437 | print "not " unless $@ =~ /^Not enough/; | |
438 | print "ok ", $i++, "\n"; | |
439 | ||
440 | sub foo2 ($\%); | |
441 | eval q{ foo2 "s" }; | |
442 | print "not " unless $@ =~ /^Not enough/; | |
443 | print "ok ", $i++, "\n"; | |
57ff9a15 IZ |
444 | |
445 | sub X::foo3; | |
446 | *X::foo3 = sub {'ok'}; | |
447 | print "# $@not " unless eval {X->foo3} eq 'ok'; | |
448 | print "ok ", $i++, "\n"; | |
449 | ||
450 | sub X::foo4 ($); | |
451 | *X::foo4 = sub ($) {'ok'}; | |
452 | print "not " unless X->foo4 eq 'ok'; | |
453 | print "ok ", $i++, "\n"; | |
2ba6ecf4 GS |
454 | |
455 | # test if the (*) prototype allows barewords, constants, scalar expressions, | |
456 | # globs and globrefs (just as CORE::open() does), all under stricture | |
457 | sub star (*&) { &{$_[1]} } | |
18228614 GS |
458 | sub star2 (**&) { &{$_[2]} } |
459 | sub BAR { "quux" } | |
2692f720 | 460 | sub Bar::BAZ { "quuz" } |
2ba6ecf4 | 461 | my $star = 'FOO'; |
13fc5c14 RGS |
462 | star FOO, sub { |
463 | print "not " unless $_[0] eq 'FOO'; | |
464 | print "ok $i - star FOO\n"; | |
465 | }; $i++; | |
466 | star(FOO, sub { | |
467 | print "not " unless $_[0] eq 'FOO'; | |
468 | print "ok $i - star(FOO)\n"; | |
469 | }); $i++; | |
470 | star "FOO", sub { | |
471 | print "not " unless $_[0] eq 'FOO'; | |
472 | print qq/ok $i - star "FOO"\n/; | |
473 | }; $i++; | |
474 | star("FOO", sub { | |
475 | print "not " unless $_[0] eq 'FOO'; | |
476 | print qq/ok $i - star("FOO")\n/; | |
477 | }); $i++; | |
478 | star $star, sub { | |
479 | print "not " unless $_[0] eq 'FOO'; | |
480 | print "ok $i - star \$star\n"; | |
481 | }; $i++; | |
482 | star($star, sub { | |
483 | print "not " unless $_[0] eq 'FOO'; | |
484 | print "ok $i - star(\$star)\n"; | |
485 | }); $i++; | |
486 | star *FOO, sub { | |
487 | print "not " unless $_[0] eq \*FOO; | |
488 | print "ok $i - star *FOO\n"; | |
489 | }; $i++; | |
490 | star(*FOO, sub { | |
491 | print "not " unless $_[0] eq \*FOO; | |
492 | print "ok $i - star(*FOO)\n"; | |
493 | }); $i++; | |
494 | star \*FOO, sub { | |
495 | print "not " unless $_[0] eq \*FOO; | |
496 | print "ok $i - star \\*FOO\n"; | |
497 | }; $i++; | |
498 | star(\*FOO, sub { | |
499 | print "not " unless $_[0] eq \*FOO; | |
500 | print "ok $i - star(\\*FOO)\n"; | |
501 | }); $i++; | |
502 | star2 FOO, BAR, sub { | |
503 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; | |
504 | print "ok $i - star2 FOO, BAR\n"; | |
505 | }; $i++; | |
506 | star2(Bar::BAZ, FOO, sub { | |
507 | print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO'; | |
508 | print "ok $i - star2(Bar::BAZ, FOO)\n" | |
509 | }); $i++; | |
510 | star2 BAR(), FOO, sub { | |
511 | print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO'; | |
512 | print "ok $i - star2 BAR(), FOO\n" | |
513 | }; $i++; | |
514 | star2(FOO, BAR(), sub { | |
515 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux'; | |
516 | print "ok $i - star2(FOO, BAR())\n"; | |
517 | }); $i++; | |
518 | star2 "FOO", "BAR", sub { | |
519 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; | |
520 | print qq/ok $i - star2 "FOO", "BAR"\n/; | |
521 | }; $i++; | |
522 | star2("FOO", "BAR", sub { | |
523 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; | |
524 | print qq/ok $i - star2("FOO", "BAR")\n/; | |
525 | }); $i++; | |
526 | star2 $star, $star, sub { | |
527 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; | |
528 | print "ok $i - star2 \$star, \$star\n"; | |
529 | }; $i++; | |
530 | star2($star, $star, sub { | |
531 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; | |
532 | print "ok $i - star2(\$star, \$star)\n"; | |
533 | }); $i++; | |
534 | star2 *FOO, *BAR, sub { | |
535 | print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; | |
536 | print "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 "ok $i - star2(*FOO, *BAR)\n"; | |
541 | }); $i++; | |
542 | star2 \*FOO, \*BAR, sub { | |
543 | no strict 'refs'; | |
544 | print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; | |
545 | print "ok $i - star2 \*FOO, \*BAR\n"; | |
546 | }; $i++; | |
547 | star2(\*FOO, \*BAR, sub { | |
548 | no strict 'refs'; | |
549 | print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; | |
550 | print "ok $i - star2(\*FOO, \*BAR)\n"; | |
551 | }); $i++; | |
18228614 | 552 | |
1c01eb51 GS |
553 | # test scalarref prototype |
554 | sub sreftest (\$$) { | |
13fc5c14 RGS |
555 | print "not " unless ref $_[0]; |
556 | print "ok $_[1] - sreftest\n"; | |
1c01eb51 GS |
557 | } |
558 | { | |
559 | no strict 'vars'; | |
560 | sreftest my $sref, $i++; | |
561 | sreftest($helem{$i}, $i++); | |
562 | sreftest $aelem[0], $i++; | |
63983e4c | 563 | sreftest sub { [0] }->()[0], $i++; |
062678b2 FC |
564 | sreftest my $a = 'quidgley', $i++; |
565 | print "not " if eval 'return 1; sreftest(3+4)'; | |
566 | print "ok ", $i++, ' - \$ with invalid argument', "\n"; | |
1c01eb51 | 567 | } |
c2b35b10 | 568 | |
c035a075 DG |
569 | # test single term |
570 | sub lazy (+$$) { | |
571 | print "not " unless @_ == 3 && ref $_[0] eq $_[1]; | |
572 | print "ok $_[2] - non container test\n"; | |
573 | } | |
574 | sub quietlazy (+) { return shift(@_) } | |
575 | sub give_aref { [] } | |
576 | sub list_or_scalar { wantarray ? (1..10) : [] } | |
577 | { | |
578 | my @multiarray = ("a".."z"); | |
579 | my %bighash = @multiarray; | |
580 | lazy(\@multiarray, 'ARRAY', $i++); | |
581 | lazy(\%bighash, 'HASH', $i++); | |
582 | lazy({}, 'HASH', $i++); | |
583 | lazy(give_aref, 'ARRAY', $i++); | |
584 | lazy(3, '', $i++); # allowed by prototype, even if runtime error | |
585 | lazy(list_or_scalar, 'ARRAY', $i++); # propagate scalar context | |
586 | } | |
587 | ||
c2b35b10 | 588 | # test prototypes when they are evaled and there is a syntax error |
24cc8ef6 AD |
589 | # Byacc generates the string "syntax error". Bison gives the |
590 | # string "parse error". | |
5279fd7b | 591 | # |
c2b35b10 | 592 | for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { |
f3ca7bab NC |
593 | my $warn = ""; |
594 | local $SIG{__WARN__} = sub { | |
595 | my $thiswarn = join("",@_); | |
596 | return if $thiswarn =~ /^Prototype mismatch: sub main::evaled_subroutine/; | |
597 | $warn .= $thiswarn; | |
598 | }; | |
c2b35b10 A |
599 | my $eval = "sub evaled_subroutine $p { &void *; }"; |
600 | eval $eval; | |
24cc8ef6 | 601 | print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i; |
c2b35b10 | 602 | print "ok ", $i++, "\n"; |
f3ca7bab NC |
603 | if ($warn eq '') { |
604 | print "ok ", $i++, "\n"; | |
605 | } else { | |
606 | print "not ok ", $i++, "# $warn \n"; | |
607 | } | |
c2b35b10 | 608 | } |
337449a8 | 609 | |
5b794e05 JH |
610 | { |
611 | my $myvar; | |
612 | my @myarray; | |
613 | my %myhash; | |
614 | sub mysub { print "not calling mysub I hope\n" } | |
615 | local *myglob; | |
616 | ||
617 | sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" } | |
618 | ||
619 | print "not " unless myref($myvar) =~ /^SCALAR\(/; | |
620 | print "ok ", $i++, "\n"; | |
062678b2 FC |
621 | print "not " unless myref($myvar=7) =~ /^SCALAR\(/; |
622 | print "ok ", $i++, "\n"; | |
5b794e05 JH |
623 | print "not " unless myref(@myarray) =~ /^ARRAY\(/; |
624 | print "ok ", $i++, "\n"; | |
625 | print "not " unless myref(%myhash) =~ /^HASH\(/; | |
626 | print "ok ", $i++, "\n"; | |
627 | print "not " unless myref(&mysub) =~ /^CODE\(/; | |
628 | print "ok ", $i++, "\n"; | |
629 | print "not " unless myref(*myglob) =~ /^GLOB\(/; | |
630 | print "ok ", $i++, "\n"; | |
4eba7d22 RGS |
631 | |
632 | eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/; | |
a0751766 NC |
633 | print "not " |
634 | unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /; | |
4eba7d22 RGS |
635 | print "ok ", $i++, "\n"; |
636 | eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/; | |
a0751766 NC |
637 | print "not " |
638 | unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /; | |
4eba7d22 RGS |
639 | print "ok ", $i++, "\n"; |
640 | eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/; | |
a0751766 NC |
641 | print "not " |
642 | unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /; | |
4eba7d22 RGS |
643 | print "ok ", $i++, "\n"; |
644 | eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/; | |
a0751766 NC |
645 | print "not " |
646 | unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /; | |
4eba7d22 RGS |
647 | print "ok ", $i++, "\n"; |
648 | eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/; | |
a0751766 NC |
649 | print "not " |
650 | unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] / | |
651 | && $@ =~ /Not enough arguments/; | |
4eba7d22 | 652 | print "ok ", $i++, "\n"; |
5b794e05 | 653 | } |
2f758a16 | 654 | |
d37a9538 ST |
655 | # check that obviously bad prototypes are getting warnings |
656 | { | |
f3ca7bab | 657 | local $^W = 1; |
d37a9538 ST |
658 | my $warn = ""; |
659 | local $SIG{__WARN__} = sub { $warn .= join("",@_) }; | |
660 | ||
661 | eval 'sub badproto (@bar) { 1; }'; | |
662 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/; | |
663 | print "ok ", $i++, "\n"; | |
2f758a16 | 664 | |
d37a9538 ST |
665 | eval 'sub badproto2 (bar) { 1; }'; |
666 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/; | |
667 | print "ok ", $i++, "\n"; | |
668 | ||
669 | eval 'sub badproto3 (&$bar$@) { 1; }'; | |
670 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/; | |
671 | print "ok ", $i++, "\n"; | |
672 | ||
673 | eval 'sub badproto4 (@ $b ar) { 1; }'; | |
674 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/; | |
675 | print "ok ", $i++, "\n"; | |
676 | } | |
2f758a16 | 677 | |
d37a9538 ST |
678 | # make sure whitespace in prototypes works |
679 | eval "sub good (\$\t\$\n\$) { 1; }"; | |
680 | print "not " if $@; | |
d731386a | 681 | print "ok ", $i++, "\n"; |
b8ec4db0 A |
682 | |
683 | # Ought to fail, doesn't in 5.8.1. | |
684 | eval 'sub bug (\[%@]) { } my $array = [0 .. 1]; bug %$array;'; | |
685 | print "not " unless $@ =~ /Not a HASH reference/; | |
686 | print "ok ", $i++, "\n"; | |
649d02de FC |
687 | |
688 | # [perl #75904] | |
689 | # Test that the following prototypes make subs parse as unary functions: | |
690 | # * \sigil \[...] ;$ ;* ;\sigil ;\[...] | |
691 | print "not " | |
692 | unless eval 'sub uniproto1 (*) {} uniproto1 $_, 1' or warn $@; | |
693 | print "ok ", $i++, "\n"; | |
694 | print "not " | |
695 | unless eval 'sub uniproto2 (\$) {} uniproto2 $_, 1' or warn $@; | |
696 | print "ok ", $i++, "\n"; | |
697 | print "not " | |
698 | unless eval 'sub uniproto3 (\[$%]) {} uniproto3 %_, 1' or warn $@; | |
699 | print "ok ", $i++, "\n"; | |
700 | print "not " | |
701 | unless eval 'sub uniproto4 (;$) {} uniproto4 $_, 1' or warn $@; | |
702 | print "ok ", $i++, "\n"; | |
703 | print "not " | |
704 | unless eval 'sub uniproto5 (;*) {} uniproto5 $_, 1' or warn $@; | |
705 | print "ok ", $i++, "\n"; | |
706 | print "not " | |
707 | unless eval 'sub uniproto6 (;\@) {} uniproto6 @_, 1' or warn $@; | |
708 | print "ok ", $i++, "\n"; | |
709 | print "not " | |
710 | unless eval 'sub uniproto7 (;\[$%@]) {} uniproto7 @_, 1' or warn $@; | |
711 | print "ok ", $i++, "\n"; | |
c035a075 DG |
712 | print "not " |
713 | unless eval 'sub uniproto8 (+) {} uniproto8 $_, 1' or warn $@; | |
714 | print "ok ", $i++, "\n"; | |
715 | print "not " | |
716 | unless eval 'sub uniproto9 (;+) {} uniproto9 $_, 1' or warn $@; | |
717 | print "ok ", $i++, "\n"; | |
3fa17e3f | 718 | |
3a8944db FC |
719 | # Test that a trailing semicolon makes a sub have listop precedence |
720 | sub unilist ($;) { $_[0]+1 } | |
721 | sub unilist2(_;) { $_[0]+1 } | |
722 | sub unilist3(;$;) { $_[0]+1 } | |
723 | print "not " unless (unilist 0 || 5) == 6; | |
724 | print "ok ", $i++, "\n"; | |
725 | print "not " unless (unilist2 0 || 5) == 6; | |
726 | print "ok ", $i++, "\n"; | |
727 | print "not " unless (unilist3 0 || 5) == 6; | |
728 | print "ok ", $i++, "\n"; | |
729 | ||
3fa17e3f NC |
730 | { |
731 | # Lack of prototype on a subroutine definition should override any prototype | |
732 | # on the declaration. | |
733 | sub z_zwap (&); | |
734 | ||
735 | local $SIG{__WARN__} = sub { | |
736 | my $thiswarn = join "",@_; | |
737 | if ($thiswarn =~ /^Prototype mismatch: sub main::z_zwap/) { | |
738 | print 'ok ', $i++, "\n"; | |
739 | } else { | |
740 | print 'not ok ', $i++, "\n"; | |
741 | print STDERR $thiswarn; | |
742 | } | |
743 | }; | |
744 | ||
745 | eval q{sub z_zwap {return @_}}; | |
746 | ||
747 | if ($@) { | |
748 | print "not ok ", $i++, "# $@"; | |
749 | } else { | |
750 | print "ok ", $i++, "\n"; | |
751 | } | |
752 | ||
753 | ||
754 | my @a = (6,4,2); | |
755 | my @got = eval q{z_zwap(@a)}; | |
756 | ||
757 | if ($@) { | |
758 | print "not ok ", $i++, " # $@"; | |
759 | } else { | |
760 | print "ok ", $i++, "\n"; | |
761 | } | |
762 | ||
763 | if ("@got" eq "@a") { | |
764 | print "ok ", $i++, "\n"; | |
765 | } else { | |
766 | print "not ok ", $i++, " # >@got<\n"; | |
767 | } | |
768 | } |