f747cf97ecfa47d8ed6d4d1dfd094d0f0de6caf2
[perl.git] / t / comp / namedproto.t
1 #!./perl
2 #
3 # Tests for named prototypes
4
5
6 my @warnings;
7 my $test;
8
9 BEGIN {
10     chdir 't' if -d 't';
11     @INC = ('../lib','.');
12     $SIG{'__WARN__'} = sub { push @warnings, @_ };
13     $| = 1;
14 }
15
16 sub is_miniperl { !defined &DynaLoader::boot_DynaLoader }
17
18 sub failed {
19     my ($got, $expected, $name) = @_;
20     print "not ok $test - $name\n";
21     my @caller = caller(1);
22     print "# Failed test at $caller[1] line $caller[2]\n";
23     if (defined $got) {
24         print "# Got '$got'\n";
25     } else {
26         print "# Got undef\n";
27     }
28     print "# Expected $expected\n";
29     return;
30 }
31
32 sub like {
33     my ($got, $pattern, $name) = @_;
34     $test = $test + 1;
35     if ($::TODO) {
36         $name .= " # TODO: $::TODO";
37     }
38     if (defined $got && $got =~ $pattern) {
39         print "ok $test - $name\n";
40         # Principle of least surprise - maintain the expected interface, even
41         # though we aren't using it here (yet).
42         return 1;
43     }
44     failed($got, $pattern, $name);
45 }
46
47 sub is {
48     my ($got, $expect, $name) = @_;
49     $test = $test + 1;
50     if ($::TODO) {
51         $name .= " # TODO: $::TODO";
52     }
53     if (defined $got && $got eq $expect) {
54         print "ok $test - $name\n";
55         return 1;
56     }
57     failed($got, "'$expect'", $name);
58 }
59
60 sub ok {
61     my ($got, $name) = @_;
62     $test = $test + 1;
63     if ($::TODO) {
64         $name .= " # TODO: $::TODO";
65     }
66     if ($got) {
67         print "ok $test - $name\n";
68         return 1;
69     }
70     failed($got, "a true value", $name);
71 }
72
73 sub skip {
74     my ($desc) = @_;
75     $test = $test + 1;
76     print "ok $test # SKIP $desc\n";
77 }
78
79 sub no_warnings {
80     my ($desc) = @_;
81
82     if (is_miniperl) {
83         skip("warnings may not be available in miniperl");
84     }
85     else {
86         is(scalar(@warnings), 0, "No warnings with $desc");
87         print "# $warnings[0]" if $#warnings >= 0;
88     }
89     @warnings = ();
90 }
91
92 BEGIN {
93     $test = 0;
94     if (!is_miniperl) {
95         require Scalar::Util;
96         require warnings;
97         warnings->import;
98     }
99 }
100
101 # Not yet implemented: Greedy
102 # Arrays (@array = ()) silences the used only once warning)
103 sub greedyarray(@array){return $#array; @array = ();}
104 BEGIN {
105     local $TODO = "Named arrays not yet implemented";
106     no_warnings("named arrays");
107     my @array = qw(1 2 3);
108     is(greedyarray(@array),2);
109     is(greedyarray(1,2,3),2);
110 }
111
112 # Hashes (%hash = ()) silences the used only once warning)
113 sub greedyhash(%hash){my @keys = sort keys %hash; return "@keys"; %hash = ();}
114 BEGIN {
115     local $TODO = "Named hashes not yet implemented";
116     no_warnings("named hashes");
117     my %hash = (c => 1, d => 2);
118     is(greedyhash(%hash),"c d");
119     is(greedyhash("c",1,"d",2),"c d");
120 }
121
122 # Checking params
123 sub onep($one){ return "$one"; }
124 is(onep("A"), "A", "Checking one param");
125
126 sub twop($one,$two){ return "$one $two"; }
127 is(twop("A","B"), "A B", "Checking two param");
128
129 sub recc($a,$c){ return recc("$a $a",$c-1) if $c; return $a; }
130 is(recc("A", 2), "A A A A", "Checking recursive");
131 no_warnings("checking params");
132
133 # Make sure whitespace doesn't matter
134 sub whitespace (  $a  ,  $b   ) { return $b; }
135 BEGIN {
136     no_warnings("extra whitespace in the definition");
137 }
138 is(whitespace(4,5),5,"Prototype ignores whitespace");
139
140
141 # Testing readonly
142 my $a = 5;
143 sub testro($a){ $a = 5; }
144 eval { testro($a); };
145 like($@,"read-only","Args should be passed read-only");
146
147 # Checking old prototype behavior
148 sub oldproto(*){ my $name = shift; return $name;}
149 is(oldproto STDOUT,"STDOUT", "Traditional prototype behavior still works");
150
151 sub manualproto($name){ return $name; }
152 BEGIN { if (!is_miniperl) { Scalar::Util::set_prototype(\&manualproto,"*") } }
153 if (is_miniperl) {
154     skip("Scalar::Util may not be available in miniperl");
155 }
156 else {
157     eval "is(manualproto STDOUT, 'STDOUT', 'Forcing it with set_prototype works'); 1" || die $@;
158 }
159
160 sub manualrecproto($name){
161     BEGIN { if (!is_miniperl) { Scalar::Util::set_prototype(\&manualrecproto,"*") } }
162     return $name;
163 }
164 BEGIN {
165     local $TODO = "Not sure how to use set_prototype for a recursive";
166     no_warnings("set_prototype on recursive function");
167 }
168
169 sub ignoredproto(*);
170 sub ignoredproto($name){ return $name;}
171 BEGIN {
172     if (is_miniperl) {
173         skip("warnings may not be available in miniperl");
174         skip("warnings may not be available in miniperl");
175     }
176     else {
177         is(scalar(@warnings), 1, "Should have exactly one warning");
178         like($warnings[0], "vs none", "ignoredproto should complain of a mismatch");
179     }
180     @warnings = ();
181 }
182
183 {
184     my $sub = sub ($x, $y) { $x * $y };
185
186     is($sub->(3, 4), 12, "anonymous subs work");
187 }
188
189 {
190     sub empty ($bar, $baz) { }
191     BEGIN { no_warnings("empty sub body") }
192
193     { local $TODO = "this doesn't work yet";
194     is(scalar(empty(1, 2)), undef, "empty sub returns undef in scalar context");
195     }
196     my $ret = [empty(1, 2)];
197     is(scalar(@$ret), 0, "empty sub returns nothing in list context");
198 }
199
200 {
201     sub arg_length ($foo, $bar) {
202         return ($foo // 'undef') . ($bar // 'undef');
203     }
204
205     is(arg_length, 'undefundef', "no args passed");
206     is(arg_length('FOO2'), 'FOO2undef', "one arg passed");
207     is(arg_length('FOO3', 'BAR3'), 'FOO3BAR3', "two args passed");
208     is(arg_length('FOO4', 'BAR4', 'BAZ4'), 'FOO4BAR4', "three args passed");
209
210     my @foo;
211     { local $TODO = "args are persisting between calls";
212     is(arg_length(@foo), 'undefundef', "no args passed");
213     @foo = ('2FOO');
214     is(arg_length(@foo), '2FOOundef', "one arg passed");
215     }
216     @foo = ('3FOO', '3BAR');
217     is(arg_length(@foo), '3FOO3BAR', "two args passed");
218     @foo = ('4FOO', '4BAR', '4BAZ');
219     is(arg_length(@foo), '4FOO4BAR', "three args passed");
220 }
221
222 {
223     my $x = 10;
224
225     sub closure1 ($y) {
226         return $x * $y;
227     }
228
229     is(closure1(3), 30, "closures work");
230 }
231
232 {
233     my $x = 10;
234
235     sub shadowing1 ($x) {
236         return $x + 5;
237     }
238     BEGIN { no_warnings("variable shadowing") } # XXX or do we want one?
239
240     is(shadowing1(3), 8, "variable shadowing works");
241 }
242
243 {
244     sub shadowing2 ($x) {
245         my $x = 10;
246         return $x + 5;
247     }
248     BEGIN { no_warnings("variable shadowing") } # XXX or do we want one?
249
250     is(shadowing2(3), 15, "variable shadowing works");
251 }
252
253 { local $TODO = "slurpy parameters not supported yet";
254 {
255     my $failed = !eval 'sub bad_slurpy_array (@foo, $bar) { }; 1';
256     my $err = $@;
257     ok($failed, "slurpies must come last");
258     like($err, qr/slurpy/, "slurpies must come last"); # XXX better regex
259 }
260
261 {
262     my $failed = !eval 'sub bad_slurpy_hash (%foo, $bar) { }; 1';
263     my $err = $@;
264     ok($failed, "slurpies must come last");
265     like($err, qr/slurpy/, "slurpies must come last"); # XXX better regex
266 }
267 no_warnings("invalid slurpy parameters");
268 }
269
270 # Test UTF-8
271
272 BEGIN { no_warnings("end of compile time") }
273 no_warnings("end of runtime");
274
275 END { print "1..$test\n" }