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 |
17 | # We need this, as in places we're testing the interaction of prototypes with |
18 | # strict |
28757baa |
19 | use strict; |
20 | |
f3ca7bab |
21 | print "1..153\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 |
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 |
397 | { my @more = ('x'); |
398 | array_ref_plus @array, @more; } |
28757baa |
399 | print "not " unless @array == 4; |
400 | print @array; |
fb73857a |
401 | |
b6c543e3 |
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 |
410 | print "ok ", $i++, "\n"; |
411 | |
412 | print "# CORE:Foo => ($p), \$@ => `$@'\nnot " |
ba5aeb3a |
413 | if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/; |
b6c543e3 |
414 | print "ok ", $i++, "\n"; |
415 | |
fb73857a |
416 | # correctly note too-short parameter lists that don't end with '$', |
417 | # a possible regression. |
418 | |
419 | sub foo1 ($\@); |
420 | eval q{ foo1 "s" }; |
421 | print "not " unless $@ =~ /^Not enough/; |
422 | print "ok ", $i++, "\n"; |
423 | |
424 | sub foo2 ($\%); |
425 | eval q{ foo2 "s" }; |
426 | print "not " unless $@ =~ /^Not enough/; |
427 | print "ok ", $i++, "\n"; |
57ff9a15 |
428 | |
429 | sub X::foo3; |
430 | *X::foo3 = sub {'ok'}; |
431 | print "# $@not " unless eval {X->foo3} eq 'ok'; |
432 | print "ok ", $i++, "\n"; |
433 | |
434 | sub X::foo4 ($); |
435 | *X::foo4 = sub ($) {'ok'}; |
436 | print "not " unless X->foo4 eq 'ok'; |
437 | print "ok ", $i++, "\n"; |
2ba6ecf4 |
438 | |
439 | # test if the (*) prototype allows barewords, constants, scalar expressions, |
440 | # globs and globrefs (just as CORE::open() does), all under stricture |
441 | sub star (*&) { &{$_[1]} } |
18228614 |
442 | sub star2 (**&) { &{$_[2]} } |
443 | sub BAR { "quux" } |
2692f720 |
444 | sub Bar::BAZ { "quuz" } |
2ba6ecf4 |
445 | my $star = 'FOO'; |
13fc5c14 |
446 | star FOO, sub { |
447 | print "not " unless $_[0] eq 'FOO'; |
448 | print "ok $i - star FOO\n"; |
449 | }; $i++; |
450 | star(FOO, sub { |
451 | print "not " unless $_[0] eq 'FOO'; |
452 | print "ok $i - star(FOO)\n"; |
453 | }); $i++; |
454 | star "FOO", sub { |
455 | print "not " unless $_[0] eq 'FOO'; |
456 | print qq/ok $i - star "FOO"\n/; |
457 | }; $i++; |
458 | star("FOO", sub { |
459 | print "not " unless $_[0] eq 'FOO'; |
460 | print qq/ok $i - star("FOO")\n/; |
461 | }); $i++; |
462 | star $star, sub { |
463 | print "not " unless $_[0] eq 'FOO'; |
464 | print "ok $i - star \$star\n"; |
465 | }; $i++; |
466 | star($star, sub { |
467 | print "not " unless $_[0] eq 'FOO'; |
468 | print "ok $i - star(\$star)\n"; |
469 | }); $i++; |
470 | star *FOO, sub { |
471 | print "not " unless $_[0] eq \*FOO; |
472 | print "ok $i - star *FOO\n"; |
473 | }; $i++; |
474 | star(*FOO, sub { |
475 | print "not " unless $_[0] eq \*FOO; |
476 | print "ok $i - star(*FOO)\n"; |
477 | }); $i++; |
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 | star2 FOO, BAR, sub { |
487 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; |
488 | print "ok $i - star2 FOO, BAR\n"; |
489 | }; $i++; |
490 | star2(Bar::BAZ, FOO, sub { |
491 | print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO'; |
492 | print "ok $i - star2(Bar::BAZ, FOO)\n" |
493 | }); $i++; |
494 | star2 BAR(), FOO, sub { |
495 | print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO'; |
496 | print "ok $i - star2 BAR(), FOO\n" |
497 | }; $i++; |
498 | star2(FOO, BAR(), sub { |
499 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux'; |
500 | print "ok $i - star2(FOO, BAR())\n"; |
501 | }); $i++; |
502 | star2 "FOO", "BAR", sub { |
503 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; |
504 | print qq/ok $i - star2 "FOO", "BAR"\n/; |
505 | }; $i++; |
506 | star2("FOO", "BAR", sub { |
507 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; |
508 | print qq/ok $i - star2("FOO", "BAR")\n/; |
509 | }); $i++; |
510 | star2 $star, $star, sub { |
511 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; |
512 | print "ok $i - star2 \$star, \$star\n"; |
513 | }; $i++; |
514 | star2($star, $star, sub { |
515 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; |
516 | print "ok $i - star2(\$star, \$star)\n"; |
517 | }); $i++; |
518 | star2 *FOO, *BAR, sub { |
519 | print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; |
520 | print "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 "ok $i - star2(*FOO, *BAR)\n"; |
525 | }); $i++; |
526 | star2 \*FOO, \*BAR, sub { |
527 | no strict 'refs'; |
528 | print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; |
529 | print "ok $i - star2 \*FOO, \*BAR\n"; |
530 | }; $i++; |
531 | star2(\*FOO, \*BAR, sub { |
532 | no strict 'refs'; |
533 | print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; |
534 | print "ok $i - star2(\*FOO, \*BAR)\n"; |
535 | }); $i++; |
18228614 |
536 | |
1c01eb51 |
537 | # test scalarref prototype |
538 | sub sreftest (\$$) { |
13fc5c14 |
539 | print "not " unless ref $_[0]; |
540 | print "ok $_[1] - sreftest\n"; |
1c01eb51 |
541 | } |
542 | { |
543 | no strict 'vars'; |
544 | sreftest my $sref, $i++; |
545 | sreftest($helem{$i}, $i++); |
546 | sreftest $aelem[0], $i++; |
547 | } |
c2b35b10 |
548 | |
549 | # test prototypes when they are evaled and there is a syntax error |
24cc8ef6 |
550 | # Byacc generates the string "syntax error". Bison gives the |
551 | # string "parse error". |
5279fd7b |
552 | # |
c2b35b10 |
553 | for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { |
f3ca7bab |
554 | my $warn = ""; |
555 | local $SIG{__WARN__} = sub { |
556 | my $thiswarn = join("",@_); |
557 | return if $thiswarn =~ /^Prototype mismatch: sub main::evaled_subroutine/; |
558 | $warn .= $thiswarn; |
559 | }; |
c2b35b10 |
560 | my $eval = "sub evaled_subroutine $p { &void *; }"; |
561 | eval $eval; |
24cc8ef6 |
562 | print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i; |
c2b35b10 |
563 | print "ok ", $i++, "\n"; |
f3ca7bab |
564 | if ($warn eq '') { |
565 | print "ok ", $i++, "\n"; |
566 | } else { |
567 | print "not ok ", $i++, "# $warn \n"; |
568 | } |
c2b35b10 |
569 | } |
337449a8 |
570 | |
571 | # Not $$;$;$ |
572 | print "not " unless prototype "CORE::substr" eq '$$;$$'; |
573 | print "ok ", $i++, "\n"; |
6e97e420 |
574 | |
575 | # recv takes a scalar reference for its second argument |
576 | print "not " unless prototype "CORE::recv" eq '*\\$$$'; |
577 | print "ok ", $i++, "\n"; |
5b794e05 |
578 | |
579 | { |
580 | my $myvar; |
581 | my @myarray; |
582 | my %myhash; |
583 | sub mysub { print "not calling mysub I hope\n" } |
584 | local *myglob; |
585 | |
586 | sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" } |
587 | |
588 | print "not " unless myref($myvar) =~ /^SCALAR\(/; |
589 | print "ok ", $i++, "\n"; |
590 | print "not " unless myref(@myarray) =~ /^ARRAY\(/; |
591 | print "ok ", $i++, "\n"; |
592 | print "not " unless myref(%myhash) =~ /^HASH\(/; |
593 | print "ok ", $i++, "\n"; |
594 | print "not " unless myref(&mysub) =~ /^CODE\(/; |
595 | print "ok ", $i++, "\n"; |
596 | print "not " unless myref(*myglob) =~ /^GLOB\(/; |
597 | print "ok ", $i++, "\n"; |
4eba7d22 |
598 | |
599 | eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/; |
a0751766 |
600 | print "not " |
601 | unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /; |
4eba7d22 |
602 | print "ok ", $i++, "\n"; |
603 | eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/; |
a0751766 |
604 | print "not " |
605 | unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /; |
4eba7d22 |
606 | print "ok ", $i++, "\n"; |
607 | eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/; |
a0751766 |
608 | print "not " |
609 | unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /; |
4eba7d22 |
610 | print "ok ", $i++, "\n"; |
611 | eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/; |
a0751766 |
612 | print "not " |
613 | unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /; |
4eba7d22 |
614 | print "ok ", $i++, "\n"; |
615 | eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/; |
a0751766 |
616 | print "not " |
617 | unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] / |
618 | && $@ =~ /Not enough arguments/; |
4eba7d22 |
619 | print "ok ", $i++, "\n"; |
5b794e05 |
620 | } |
2f758a16 |
621 | |
d37a9538 |
622 | # check that obviously bad prototypes are getting warnings |
623 | { |
f3ca7bab |
624 | local $^W = 1; |
d37a9538 |
625 | my $warn = ""; |
626 | local $SIG{__WARN__} = sub { $warn .= join("",@_) }; |
627 | |
628 | eval 'sub badproto (@bar) { 1; }'; |
629 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/; |
630 | print "ok ", $i++, "\n"; |
2f758a16 |
631 | |
d37a9538 |
632 | eval 'sub badproto2 (bar) { 1; }'; |
633 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/; |
634 | print "ok ", $i++, "\n"; |
635 | |
636 | eval 'sub badproto3 (&$bar$@) { 1; }'; |
637 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/; |
638 | print "ok ", $i++, "\n"; |
639 | |
640 | eval 'sub badproto4 (@ $b ar) { 1; }'; |
641 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/; |
642 | print "ok ", $i++, "\n"; |
643 | } |
2f758a16 |
644 | |
d37a9538 |
645 | # make sure whitespace in prototypes works |
646 | eval "sub good (\$\t\$\n\$) { 1; }"; |
647 | print "not " if $@; |
d731386a |
648 | print "ok ", $i++, "\n"; |
b8ec4db0 |
649 | |
650 | # Ought to fail, doesn't in 5.8.1. |
651 | eval 'sub bug (\[%@]) { } my $array = [0 .. 1]; bug %$array;'; |
652 | print "not " unless $@ =~ /Not a HASH reference/; |
653 | print "ok ", $i++, "\n"; |