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'; | |
93430cb4 | 14 | unshift @INC, '../lib'; |
44a8e56a | 15 | } |
28757baa | 16 | |
17 | use strict; | |
18 | ||
2ba6ecf4 | 19 | print "1..87\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 | ||
296 | testing \&sub_aref, '&\@'; | |
297 | ||
298 | sub sub_aref (&\@) { | |
299 | print "# \@_ = (",join(",",@_),")\n"; | |
300 | my($sub,$array) = @_; | |
301 | print "not " unless @_ == 2 && @{$array} == 4; | |
302 | print map { &{$sub}($_) } @{$array} | |
303 | } | |
304 | ||
305 | @array = (qw(O K)," ", $i++); | |
306 | sub_aref { lc shift } @array; | |
307 | print "\n"; | |
308 | ||
309 | ## | |
310 | ## | |
311 | ## | |
312 | ||
313 | testing \&sub_array, '&@'; | |
314 | ||
315 | sub sub_array (&@) { | |
316 | print "# \@_ = (",join(",",@_),")\n"; | |
317 | print "not " unless @_ == 5; | |
318 | my $sub = shift; | |
319 | print map { &{$sub}($_) } @_ | |
320 | } | |
321 | ||
322 | @array = (qw(O K)," ", $i++); | |
323 | sub_array { lc shift } @array; | |
324 | print "\n"; | |
325 | ||
326 | ## | |
327 | ## | |
328 | ## | |
329 | ||
330 | testing \&a_hash, '%'; | |
331 | ||
332 | sub a_hash (%) { | |
333 | print "# \@_ = (",join(",",@_),")\n"; | |
334 | scalar(@_); | |
335 | } | |
336 | ||
337 | print "not " unless 1 == a_hash 'a'; | |
338 | printf "ok %d\n",$i++; | |
339 | ||
340 | print "not " unless 2 == a_hash 'a','b'; | |
341 | printf "ok %d\n",$i++; | |
342 | ||
343 | ## | |
344 | ## | |
345 | ## | |
346 | ||
347 | testing \&a_hash_ref, '\%'; | |
348 | ||
349 | sub a_hash_ref (\%) { | |
350 | print "# \@_ = (",join(",",@_),")\n"; | |
351 | print "not " unless ref($_[0]) && $_[0]->{'a'}; | |
352 | printf "ok %d\n",$i++; | |
353 | $_[0]->{'b'} = 2; | |
354 | } | |
355 | ||
356 | %hash = ( a => 1); | |
357 | a_hash_ref %hash; | |
358 | print "not " unless $hash{'b'} == 2; | |
359 | printf "ok %d\n",$i++; | |
360 | ||
361 | ## | |
362 | ## | |
363 | ## | |
364 | ||
69dcf70c | 365 | testing \&array_ref_plus, '\@@'; |
28757baa | 366 | |
69dcf70c | 367 | sub array_ref_plus (\@@) { |
28757baa | 368 | print "# \@_ = (",join(",",@_),")\n"; |
69dcf70c | 369 | print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x'; |
28757baa | 370 | printf "ok %d\n",$i++; |
371 | @{$_[0]} = (qw(ok)," ",$i++,"\n"); | |
372 | } | |
373 | ||
374 | @array = ('a'); | |
69dcf70c MB |
375 | { my @more = ('x'); |
376 | array_ref_plus @array, @more; } | |
28757baa | 377 | print "not " unless @array == 4; |
378 | print @array; | |
fb73857a | 379 | |
b6c543e3 IZ |
380 | my $p; |
381 | print "not " if defined prototype('CORE::print'); | |
382 | print "ok ", $i++, "\n"; | |
383 | ||
384 | print "not " if defined prototype('CORE::system'); | |
385 | print "ok ", $i++, "\n"; | |
386 | ||
387 | print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$'; | |
388 | print "ok ", $i++, "\n"; | |
389 | ||
390 | print "# CORE:Foo => ($p), \$@ => `$@'\nnot " | |
391 | if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Cannot find an opnumber/; | |
392 | print "ok ", $i++, "\n"; | |
393 | ||
fb73857a | 394 | # correctly note too-short parameter lists that don't end with '$', |
395 | # a possible regression. | |
396 | ||
397 | sub foo1 ($\@); | |
398 | eval q{ foo1 "s" }; | |
399 | print "not " unless $@ =~ /^Not enough/; | |
400 | print "ok ", $i++, "\n"; | |
401 | ||
402 | sub foo2 ($\%); | |
403 | eval q{ foo2 "s" }; | |
404 | print "not " unless $@ =~ /^Not enough/; | |
405 | print "ok ", $i++, "\n"; | |
57ff9a15 IZ |
406 | |
407 | sub X::foo3; | |
408 | *X::foo3 = sub {'ok'}; | |
409 | print "# $@not " unless eval {X->foo3} eq 'ok'; | |
410 | print "ok ", $i++, "\n"; | |
411 | ||
412 | sub X::foo4 ($); | |
413 | *X::foo4 = sub ($) {'ok'}; | |
414 | print "not " unless X->foo4 eq 'ok'; | |
415 | print "ok ", $i++, "\n"; | |
2ba6ecf4 GS |
416 | |
417 | # test if the (*) prototype allows barewords, constants, scalar expressions, | |
418 | # globs and globrefs (just as CORE::open() does), all under stricture | |
419 | sub star (*&) { &{$_[1]} } | |
420 | my $star = 'FOO'; | |
421 | star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; | |
422 | star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; | |
423 | star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; | |
424 | star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; | |
425 | star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; |