This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from patch from perl5.003_19 to perl5.003_20]
[perl5.git] / t / comp / proto.t
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.
10
11 use strict;
12
13 print "1..74\n";
14
15 my $i = 1;
16
17 sub testing (&$) {
18     my $p = prototype(shift);
19     my $c = shift;
20     my $what = defined $c ? '(' . $p . ')' : 'no prototype';   
21     print '#' x 25,"\n";
22     print '# Testing ',$what,"\n";
23     print '#' x 25,"\n";
24     print "not "
25         if((defined($p) && defined($c) && $p ne $c)
26            || (defined($p) != defined($c)));
27     printf "ok %d\n",$i++;
28 }
29
30 @_ = qw(a b c d);
31 my @array;
32 my %hash;
33
34 ##
35 ##
36 ##
37
38 testing \&no_proto, undef;
39
40 sub no_proto {
41     print "# \@_ = (",join(",",@_),")\n";
42     scalar(@_)
43 }
44
45 print "not " unless 0 == no_proto();
46 printf "ok %d\n",$i++;
47
48 print "not " unless 1 == no_proto(5);
49 printf "ok %d\n",$i++;
50
51 print "not " unless 4 == &no_proto;
52 printf "ok %d\n",$i++;
53
54 print "not " unless 1 == no_proto +6;
55 printf "ok %d\n",$i++;
56
57 print "not " unless 4 == no_proto(@_);
58 printf "ok %d\n",$i++;
59
60 ##
61 ##
62 ##
63
64
65 testing \&no_args, '';
66
67 sub no_args () {
68     print "# \@_ = (",join(",",@_),")\n";
69     scalar(@_)
70 }
71
72 print "not " unless 0 == no_args();
73 printf "ok %d\n",$i++;
74
75 print "not " unless 0 == no_args;
76 printf "ok %d\n",$i++;
77
78 print "not " unless 5 == no_args +5;
79 printf "ok %d\n",$i++;
80
81 print "not " unless 4 == &no_args;
82 printf "ok %d\n",$i++;
83
84 print "not " unless 2 == &no_args(1,2);
85 printf "ok %d\n",$i++;
86
87 eval "no_args(1)";
88 print "not " unless $@;
89 printf "ok %d\n",$i++;
90
91 ##
92 ##
93 ##
94
95 testing \&one_args, '$';
96
97 sub one_args ($) {
98     print "# \@_ = (",join(",",@_),")\n";
99     scalar(@_)
100 }
101
102 print "not " unless 1 == one_args(1);
103 printf "ok %d\n",$i++;
104
105 print "not " unless 1 == one_args +5;
106 printf "ok %d\n",$i++;
107
108 print "not " unless 4 == &one_args;
109 printf "ok %d\n",$i++;
110
111 print "not " unless 2 == &one_args(1,2);
112 printf "ok %d\n",$i++;
113
114 eval "one_args(1,2)";
115 print "not " unless $@;
116 printf "ok %d\n",$i++;
117
118 eval "one_args()";
119 print "not " unless $@;
120 printf "ok %d\n",$i++;
121
122 sub one_a_args ($) {
123     print "# \@_ = (",join(",",@_),")\n";
124     print "not " unless @_ == 1 && $_[0] == 4;
125     printf "ok %d\n",$i++;
126 }
127
128 one_a_args(@_);
129
130 ##
131 ##
132 ##
133
134 testing \&over_one_args, '$@';
135
136 sub over_one_args ($@) {
137     print "# \@_ = (",join(",",@_),")\n";
138     scalar(@_)
139 }
140
141 print "not " unless 1 == over_one_args(1);
142 printf "ok %d\n",$i++;
143
144 print "not " unless 2 == over_one_args(1,2);
145 printf "ok %d\n",$i++;
146
147 print "not " unless 1 == over_one_args +5;
148 printf "ok %d\n",$i++;
149
150 print "not " unless 4 == &over_one_args;
151 printf "ok %d\n",$i++;
152
153 print "not " unless 2 == &over_one_args(1,2);
154 printf "ok %d\n",$i++;
155
156 print "not " unless 5 == &over_one_args(1,@_);
157 printf "ok %d\n",$i++;
158
159 eval "over_one_args()";
160 print "not " unless $@;
161 printf "ok %d\n",$i++;
162
163 sub over_one_a_args ($@) {
164     print "# \@_ = (",join(",",@_),")\n";
165     print "not " unless @_ >= 1 && $_[0] == 4;
166     printf "ok %d\n",$i++;
167 }
168
169 over_one_a_args(@_);
170 over_one_a_args(@_,1);
171 over_one_a_args(@_,1,2);
172 over_one_a_args(@_,@_);
173
174 ##
175 ##
176 ##
177
178 testing \&scalar_and_hash, '$%';
179
180 sub scalar_and_hash ($%) {
181     print "# \@_ = (",join(",",@_),")\n";
182     scalar(@_)
183 }
184
185 print "not " unless 1 == scalar_and_hash(1);
186 printf "ok %d\n",$i++;
187
188 print "not " unless 3 == scalar_and_hash(1,2,3);
189 printf "ok %d\n",$i++;
190
191 print "not " unless 1 == scalar_and_hash +5;
192 printf "ok %d\n",$i++;
193
194 print "not " unless 4 == &scalar_and_hash;
195 printf "ok %d\n",$i++;
196
197 print "not " unless 2 == &scalar_and_hash(1,2);
198 printf "ok %d\n",$i++;
199
200 print "not " unless 5 == &scalar_and_hash(1,@_);
201 printf "ok %d\n",$i++;
202
203 eval "scalar_and_hash()";
204 print "not " unless $@;
205 printf "ok %d\n",$i++;
206
207 sub scalar_and_hash_a ($@) {
208     print "# \@_ = (",join(",",@_),")\n";
209     print "not " unless @_ >= 1 && $_[0] == 4;
210     printf "ok %d\n",$i++;
211 }
212
213 scalar_and_hash_a(@_);
214 scalar_and_hash_a(@_,1);
215 scalar_and_hash_a(@_,1,2);
216 scalar_and_hash_a(@_,@_);
217
218 ##
219 ##
220 ##
221
222 testing \&one_or_two, '$;$';
223
224 sub one_or_two ($;$) {
225     print "# \@_ = (",join(",",@_),")\n";
226     scalar(@_)
227 }
228
229 print "not " unless 1 == one_or_two(1);
230 printf "ok %d\n",$i++;
231
232 print "not " unless 2 == one_or_two(1,3);
233 printf "ok %d\n",$i++;
234
235 print "not " unless 1 == one_or_two +5;
236 printf "ok %d\n",$i++;
237
238 print "not " unless 4 == &one_or_two;
239 printf "ok %d\n",$i++;
240
241 print "not " unless 3 == &one_or_two(1,2,3);
242 printf "ok %d\n",$i++;
243
244 print "not " unless 5 == &one_or_two(1,@_);
245 printf "ok %d\n",$i++;
246
247 eval "one_or_two()";
248 print "not " unless $@;
249 printf "ok %d\n",$i++;
250
251 eval "one_or_two(1,2,3)";
252 print "not " unless $@;
253 printf "ok %d\n",$i++;
254
255 sub one_or_two_a ($;$) {
256     print "# \@_ = (",join(",",@_),")\n";
257     print "not " unless @_ >= 1 && $_[0] == 4;
258     printf "ok %d\n",$i++;
259 }
260
261 one_or_two_a(@_);
262 one_or_two_a(@_,1);
263 one_or_two_a(@_,@_);
264
265 ##
266 ##
267 ##
268
269 testing \&a_sub, '&';
270
271 sub a_sub (&) {
272     print "# \@_ = (",join(",",@_),")\n";
273     &{$_[0]};
274 }
275
276 sub tmp_sub_1 { printf "ok %d\n",$i++ }
277
278 a_sub { printf "ok %d\n",$i++ };
279 a_sub \&tmp_sub_1;
280
281 @array = ( \&tmp_sub_1 );
282 eval 'a_sub @array';
283 print "not " unless $@;
284 printf "ok %d\n",$i++;
285
286 ##
287 ##
288 ##
289
290 testing \&sub_aref, '&\@';
291
292 sub sub_aref (&\@) {
293     print "# \@_ = (",join(",",@_),")\n";
294     my($sub,$array) = @_;
295     print "not " unless @_ == 2 && @{$array} == 4;
296     print map { &{$sub}($_) } @{$array}
297 }
298
299 @array = (qw(O K)," ", $i++);
300 sub_aref { lc shift } @array;
301 print "\n";
302
303 ##
304 ##
305 ##
306
307 testing \&sub_array, '&@';
308
309 sub sub_array (&@) {
310     print "# \@_ = (",join(",",@_),")\n";
311     print "not " unless @_ == 5;
312     my $sub = shift;
313     print map { &{$sub}($_) } @_
314 }
315
316 @array = (qw(O K)," ", $i++);
317 sub_array { lc shift } @array;
318 print "\n";
319
320 ##
321 ##
322 ##
323
324 testing \&a_hash, '%';
325
326 sub a_hash (%) {
327     print "# \@_ = (",join(",",@_),")\n";
328     scalar(@_);
329 }
330
331 print "not " unless 1 == a_hash 'a';
332 printf "ok %d\n",$i++;
333
334 print "not " unless 2 == a_hash 'a','b';
335 printf "ok %d\n",$i++;
336
337 ##
338 ##
339 ##
340
341 testing \&a_hash_ref, '\%';
342
343 sub a_hash_ref (\%) {
344     print "# \@_ = (",join(",",@_),")\n";
345     print "not " unless ref($_[0]) && $_[0]->{'a'};
346     printf "ok %d\n",$i++;
347     $_[0]->{'b'} = 2;
348 }
349
350 %hash = ( a => 1);
351 a_hash_ref %hash;
352 print "not " unless $hash{'b'} == 2;
353 printf "ok %d\n",$i++;
354
355 ##
356 ##
357 ##
358
359 testing \&an_array_ref, '\@';
360
361 sub an_array_ref (\@) {
362     print "# \@_ = (",join(",",@_),")\n";
363     print "not " unless ref($_[0]) && 1 == @{$_[0]};
364     printf "ok %d\n",$i++;
365     @{$_[0]} = (qw(ok)," ",$i++,"\n");
366 }
367
368 @array = ('a');
369 an_array_ref @array;
370 print "not " unless @array == 4;
371 print @array;