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