14c7992724c955f754b04269e18790d2914d7d00
[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 use feature 'experimental::sub_signature';
102
103 {
104     no feature 'experimental::sub_signature';
105     eval 'sub a($foo){} a(5);';
106     like($@, "Not enough arguments", "no feature should force old style processing $@");
107     like($warnings[0], "Illegal character", "The warning should be on as well");
108     @warnings = ();
109     eval 'sub b($ foo $){}';
110     like($warnings[0], "\\\$foo\\\$", "It should still be removing spaces");
111     @warnings = ();
112 }
113
114 # Not yet implemented: Greedy
115 # Arrays (@array = ()) silences the used only once warning)
116 sub greedyarray(@array){return $#array; @array = ();}
117 BEGIN {
118     no_warnings("named arrays");
119     my @array = qw(1 2 3);
120     is(greedyarray(@array),2,"Named array using a literal array");
121     is(greedyarray(1,2,3),2,"Named array using a list of args");
122 }
123
124 # Hashes (%hash = ()) silences the used only once warning)
125 sub greedyhash(%hash){my @keys = sort keys %hash; return "@keys"; %hash = ();}
126 BEGIN {
127     no_warnings("named hashes");
128     my %hash = (c => 1, d => 2);
129     is(greedyhash(%hash),"c d","Named hash using a literal hash");
130     is(greedyhash("c",1,"d",2),"c d","Named hash using a list of args");
131 }
132
133 # Checking params
134 sub onep($one){ return "$one"; }
135 is(onep("A"), "A", "Checking one param");
136
137 sub twop($one,$two){ return "$one $two"; }
138 is(twop("A","B"), "A B", "Checking two param");
139
140 sub recc($a,$c){ return recc("$a $a",$c-1) if $c; return $a; }
141 is(recc("A", 2), "A A A A", "Checking recursive");
142 no_warnings("checking params");
143
144 # Make sure whitespace doesn't matter
145 sub whitespace (  $a  ,  $b   ) { return $b; }
146 BEGIN {
147     no_warnings("extra whitespace in the definition");
148 }
149 is(whitespace(4,5),5,"Prototype ignores whitespace");
150
151 # Checking old prototype behavior
152 sub oldproto(*){ my $name = shift; return $name;}
153 is(oldproto STDOUT,"STDOUT", "Traditional prototype behavior still works");
154
155 sub manualproto($name){ return $name; }
156 BEGIN { if (!is_miniperl) { Scalar::Util::set_prototype(\&manualproto,"*") } }
157 if (is_miniperl) {
158     skip("Scalar::Util may not be available in miniperl");
159 }
160 else {
161     eval "is(manualproto STDOUT, 'STDOUT', 'Forcing it with set_prototype works'); 1" || die $@;
162 }
163
164 sub prototag($name) : proto(*){ return $name; }
165 BEGIN { no_warnings("sub with proto attribute") }
166 if (is_miniperl) {
167     skip("Scalar::Util may not be available in miniperl");
168 }
169 else {
170     eval "is(prototag STDOUT, 'STDOUT', 'Forcing it with a proto attribute works'); 1" || die $@;
171 }
172
173 sub ignoredproto(*);
174 sub ignoredproto($name){ return $name;}
175 BEGIN {
176     if (is_miniperl) {
177         skip("warnings may not be available in miniperl");
178         skip("warnings may not be available in miniperl");
179     }
180     else {
181         is(scalar(@warnings), 1, "Should have exactly one warning");
182         like($warnings[0], "vs none", "ignoredproto should complain of a mismatch");
183     }
184     @warnings = ();
185 }
186
187
188
189 {
190     my $sub = sub ($x, $y) { $x * $y };
191
192     is($sub->(3, 4), 12, "anonymous subs work");
193 }
194
195 {
196     sub empty ($bar, $baz) { }
197     BEGIN { no_warnings("empty sub body") }
198
199     { local $TODO = "this doesn't work yet";
200     is(scalar(empty(1, 2)), undef, "empty sub returns undef in scalar context");
201     }
202     my $ret = [empty(1, 2)];
203     is(scalar(@$ret), 0, "empty sub returns nothing in list context");
204 }
205
206 {
207     sub arg_length ($foo, $bar) {
208         return ($foo // 'undef') . ($bar // 'undef');
209     }
210
211     is(arg_length, 'undefundef', "no args passed");
212     is(arg_length('FOO2'), 'FOO2undef', "one arg passed");
213     is(arg_length('FOO3', 'BAR3'), 'FOO3BAR3', "two args passed");
214     is(arg_length('FOO4', 'BAR4', 'BAZ4'), 'FOO4BAR4', "three args passed");
215
216     my @foo;
217     is(arg_length(@foo), 'undefundef', "no args passed");
218     @foo = ('2FOO');
219     is(arg_length(@foo), '2FOOundef', "one arg passed");
220     @foo = ('3FOO', '3BAR');
221     is(arg_length(@foo), '3FOO3BAR', "two args passed");
222     @foo = ('4FOO', '4BAR', '4BAZ');
223     is(arg_length(@foo), '4FOO4BAR', "three args passed");
224 }
225
226 {
227     my $x = 10;
228
229     sub closure1 ($y) {
230         return $x * $y;
231     }
232
233     is(closure1(3), 30, "closures work");
234 }
235
236 {
237     my $x = 10;
238
239     sub shadowing1 ($x) {
240         return $x + 5;
241     }
242     BEGIN { no_warnings("variable shadowing") } # XXX or do we want one?
243
244     is(shadowing1(3), 8, "variable shadowing works");
245 }
246
247 {
248     sub shadowing2 ($x) {
249         my $x = 10;
250         return $x + 5;
251     }
252     BEGIN { no_warnings("variable shadowing") } # XXX or do we want one?
253
254     is(shadowing2(3), 15, "variable shadowing works");
255 }
256
257 {
258     my $failed = !eval 'sub bad_slurpy_array (@foo, $bar) { }; 1';
259     my $err = $@;
260     ok($failed, "slurpies must come last");
261     like($err, qr/^Illegal signature/, "slurpies must come last");
262 }
263
264 {
265     my $failed = !eval 'sub bad_slurpy_hash (%foo, $bar) { }; 1';
266     my $err = $@;
267     ok($failed, "slurpies must come last");
268     like($err, qr/^Illegal signature/, "slurpies must come last");
269 }
270
271 {
272     my $failed = !eval 'sub bad_slurpy_dup (%foo, %bar) { }; 1';
273     my $err = $@;
274     ok($failed, "Can't use two slurpy args");
275     like($err, qr/^Illegal signature/, "Can't use two slurpy args");
276 }
277 no_warnings("invalid slurpy parameters");
278
279 # Ban @_ inside the sub if it has a named proto
280 {
281     my ($legal, $failed);
282     my $err = "Can't use \@_ in a sub with a signature";
283     $legal = eval 'sub not_banned1 { $#_ }; 1';
284     ok($legal, "No changes to \$#_ within traditional subs");
285     $legal = eval 'sub not_banned2 { @_; }; 1';
286     ok($legal, "No changes to \@_ within traditional subs");
287     $failed = !eval 'sub banned1 ($foo){ $#_ }; 1';
288     ok($failed, "Cannot use a literal \$#_ with subroutine signatures");
289     like($@,$err, "Died for the right reason");
290     $failed = !eval 'sub banned2 ($foo){ @_ }; 1';
291     ok($failed, "Cannot use a literal \@_ with subroutine signatures");
292     like($@,$err, "Died for the right reason");
293     $legal = eval 'sub banned3 ($foo){ sub not_banned3 { $#_ }; }; 1';
294     ok($legal, "\$#_ restriction doesn't apply to nested subs");
295     $legal = eval 'sub banned4 ($foo){ sub not_banned4 { @_ }; }; 1';
296     ok($legal, "\@_ restriction doesn't apply to nested subs");
297     $legal = eval 'sub not_banned5 ($foo){ return eval q{"@_"; 1}; } 1';
298     ok($legal, "\@_ restriction not visible in string eval at compile time");
299     $failed = !not_banned5(12);
300     ok($failed, "\@_ restriction in effect for string eval at run time");
301
302     # Test aliases too
303     *globb = *main::_;
304     $legal = eval 'sub banned5 ($foo) { $#globb;}; 1';
305     ok($legal, "Using an alias compiles fine - count");
306     no_warnings("using a global alias - count");
307     $legal = eval 'sub banned6 ($foo) { my ($a) = @globb; }; 1';
308     ok($legal, "Using an alias compiles fine - assignment");
309     no_warnings("using a global alias - assignment");
310     $legal = eval 'sub banned7 ($foo) { $globb[0]; }; 1';
311     ok($legal, "Using an alias compiles fine - direct access");
312     no_warnings("using a global alias - direct access");
313     $failed = !eval 'banned5(); 1';
314     ok($failed, "An alias to \$#_ dies in execution - () syntax");
315     like($@,$err, "Died for the right reason");
316     $failed = !eval '&banned5(); 1';
317     ok($failed, "An alias to \$#_ dies in execution - & syntax");
318     like($@,$err, "Died for the right reason");
319     @normal = qw(1 2 3);
320     *globb = *normal;
321     $legal = eval 'banned5(); 1';
322     ok($legal, "globb is fine again - ()");
323     $legal = eval '&banned5(); 1';
324     ok($legal, "globb is fine again - &");
325 }
326
327 # Test UTF-8
328
329 BEGIN { no_warnings("end of compile time") }
330 no_warnings("end of runtime");
331
332 END { print "1..$test\n" }