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 | |
b8ec4db0 |
19 | print "1..141\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'; |
13fc5c14 |
444 | star FOO, sub { |
445 | print "not " unless $_[0] eq 'FOO'; |
446 | print "ok $i - star FOO\n"; |
447 | }; $i++; |
448 | star(FOO, sub { |
449 | print "not " unless $_[0] eq 'FOO'; |
450 | print "ok $i - star(FOO)\n"; |
451 | }); $i++; |
452 | star "FOO", sub { |
453 | print "not " unless $_[0] eq 'FOO'; |
454 | print qq/ok $i - star "FOO"\n/; |
455 | }; $i++; |
456 | star("FOO", sub { |
457 | print "not " unless $_[0] eq 'FOO'; |
458 | print qq/ok $i - star("FOO")\n/; |
459 | }); $i++; |
460 | star $star, sub { |
461 | print "not " unless $_[0] eq 'FOO'; |
462 | print "ok $i - star \$star\n"; |
463 | }; $i++; |
464 | star($star, sub { |
465 | print "not " unless $_[0] eq 'FOO'; |
466 | print "ok $i - star(\$star)\n"; |
467 | }); $i++; |
468 | star *FOO, sub { |
469 | print "not " unless $_[0] eq \*FOO; |
470 | print "ok $i - star *FOO\n"; |
471 | }; $i++; |
472 | star(*FOO, sub { |
473 | print "not " unless $_[0] eq \*FOO; |
474 | print "ok $i - star(*FOO)\n"; |
475 | }); $i++; |
476 | star \*FOO, sub { |
477 | print "not " unless $_[0] eq \*FOO; |
478 | print "ok $i - star \\*FOO\n"; |
479 | }; $i++; |
480 | star(\*FOO, sub { |
481 | print "not " unless $_[0] eq \*FOO; |
482 | print "ok $i - star(\\*FOO)\n"; |
483 | }); $i++; |
484 | star2 FOO, BAR, sub { |
485 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; |
486 | print "ok $i - star2 FOO, BAR\n"; |
487 | }; $i++; |
488 | star2(Bar::BAZ, FOO, sub { |
489 | print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO'; |
490 | print "ok $i - star2(Bar::BAZ, FOO)\n" |
491 | }); $i++; |
492 | star2 BAR(), FOO, sub { |
493 | print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO'; |
494 | print "ok $i - star2 BAR(), FOO\n" |
495 | }; $i++; |
496 | star2(FOO, BAR(), sub { |
497 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux'; |
498 | print "ok $i - star2(FOO, BAR())\n"; |
499 | }); $i++; |
500 | star2 "FOO", "BAR", sub { |
501 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; |
502 | print qq/ok $i - star2 "FOO", "BAR"\n/; |
503 | }; $i++; |
504 | star2("FOO", "BAR", sub { |
505 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; |
506 | print qq/ok $i - star2("FOO", "BAR")\n/; |
507 | }); $i++; |
508 | star2 $star, $star, sub { |
509 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; |
510 | print "ok $i - star2 \$star, \$star\n"; |
511 | }; $i++; |
512 | star2($star, $star, sub { |
513 | print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; |
514 | print "ok $i - star2(\$star, \$star)\n"; |
515 | }); $i++; |
516 | star2 *FOO, *BAR, sub { |
517 | print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; |
518 | print "ok $i - star2 *FOO, *BAR\n"; |
519 | }; $i++; |
520 | star2(*FOO, *BAR, sub { |
521 | print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; |
522 | print "ok $i - star2(*FOO, *BAR)\n"; |
523 | }); $i++; |
524 | star2 \*FOO, \*BAR, sub { |
525 | no strict 'refs'; |
526 | print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; |
527 | print "ok $i - star2 \*FOO, \*BAR\n"; |
528 | }; $i++; |
529 | star2(\*FOO, \*BAR, sub { |
530 | no strict 'refs'; |
531 | print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; |
532 | print "ok $i - star2(\*FOO, \*BAR)\n"; |
533 | }); $i++; |
18228614 |
534 | |
1c01eb51 |
535 | # test scalarref prototype |
536 | sub sreftest (\$$) { |
13fc5c14 |
537 | print "not " unless ref $_[0]; |
538 | print "ok $_[1] - sreftest\n"; |
1c01eb51 |
539 | } |
540 | { |
541 | no strict 'vars'; |
542 | sreftest my $sref, $i++; |
543 | sreftest($helem{$i}, $i++); |
544 | sreftest $aelem[0], $i++; |
545 | } |
c2b35b10 |
546 | |
547 | # test prototypes when they are evaled and there is a syntax error |
24cc8ef6 |
548 | # Byacc generates the string "syntax error". Bison gives the |
549 | # string "parse error". |
5279fd7b |
550 | # |
c2b35b10 |
551 | for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { |
4f945781 |
552 | no warnings 'prototype'; |
c2b35b10 |
553 | my $eval = "sub evaled_subroutine $p { &void *; }"; |
554 | eval $eval; |
24cc8ef6 |
555 | print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i; |
c2b35b10 |
556 | print "ok ", $i++, "\n"; |
557 | } |
337449a8 |
558 | |
559 | # Not $$;$;$ |
560 | print "not " unless prototype "CORE::substr" eq '$$;$$'; |
561 | print "ok ", $i++, "\n"; |
6e97e420 |
562 | |
563 | # recv takes a scalar reference for its second argument |
564 | print "not " unless prototype "CORE::recv" eq '*\\$$$'; |
565 | print "ok ", $i++, "\n"; |
5b794e05 |
566 | |
567 | { |
568 | my $myvar; |
569 | my @myarray; |
570 | my %myhash; |
571 | sub mysub { print "not calling mysub I hope\n" } |
572 | local *myglob; |
573 | |
574 | sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" } |
575 | |
576 | print "not " unless myref($myvar) =~ /^SCALAR\(/; |
577 | print "ok ", $i++, "\n"; |
578 | print "not " unless myref(@myarray) =~ /^ARRAY\(/; |
579 | print "ok ", $i++, "\n"; |
580 | print "not " unless myref(%myhash) =~ /^HASH\(/; |
581 | print "ok ", $i++, "\n"; |
582 | print "not " unless myref(&mysub) =~ /^CODE\(/; |
583 | print "ok ", $i++, "\n"; |
584 | print "not " unless myref(*myglob) =~ /^GLOB\(/; |
585 | print "ok ", $i++, "\n"; |
4eba7d22 |
586 | |
587 | eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/; |
a0751766 |
588 | print "not " |
589 | unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /; |
4eba7d22 |
590 | print "ok ", $i++, "\n"; |
591 | eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/; |
a0751766 |
592 | print "not " |
593 | unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /; |
4eba7d22 |
594 | print "ok ", $i++, "\n"; |
595 | eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/; |
a0751766 |
596 | print "not " |
597 | unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /; |
4eba7d22 |
598 | print "ok ", $i++, "\n"; |
599 | eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/; |
a0751766 |
600 | print "not " |
601 | unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /; |
4eba7d22 |
602 | print "ok ", $i++, "\n"; |
603 | eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/; |
a0751766 |
604 | print "not " |
605 | unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] / |
606 | && $@ =~ /Not enough arguments/; |
4eba7d22 |
607 | print "ok ", $i++, "\n"; |
5b794e05 |
608 | } |
2f758a16 |
609 | |
d37a9538 |
610 | # check that obviously bad prototypes are getting warnings |
611 | { |
420cdfc1 |
612 | use warnings 'syntax'; |
d37a9538 |
613 | my $warn = ""; |
614 | local $SIG{__WARN__} = sub { $warn .= join("",@_) }; |
615 | |
616 | eval 'sub badproto (@bar) { 1; }'; |
617 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/; |
618 | print "ok ", $i++, "\n"; |
2f758a16 |
619 | |
d37a9538 |
620 | eval 'sub badproto2 (bar) { 1; }'; |
621 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/; |
622 | print "ok ", $i++, "\n"; |
623 | |
624 | eval 'sub badproto3 (&$bar$@) { 1; }'; |
625 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/; |
626 | print "ok ", $i++, "\n"; |
627 | |
628 | eval 'sub badproto4 (@ $b ar) { 1; }'; |
629 | print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/; |
630 | print "ok ", $i++, "\n"; |
631 | } |
2f758a16 |
632 | |
d37a9538 |
633 | # make sure whitespace in prototypes works |
634 | eval "sub good (\$\t\$\n\$) { 1; }"; |
635 | print "not " if $@; |
d731386a |
636 | print "ok ", $i++, "\n"; |
b8ec4db0 |
637 | |
638 | # Ought to fail, doesn't in 5.8.1. |
639 | eval 'sub bug (\[%@]) { } my $array = [0 .. 1]; bug %$array;'; |
640 | print "not " unless $@ =~ /Not a HASH reference/; |
641 | print "ok ", $i++, "\n"; |