Commit | Line | Data |
---|---|---|
47ac839d FC |
1 | #!./perl |
2 | ||
3 | # This file tests the results of calling subroutines in the CORE:: | |
4 | # namespace with ampersand syntax. In other words, it tests the bodies of | |
5 | # the subroutines themselves, not the ops that they might inline themselves | |
6 | # as when called as barewords. | |
7 | ||
bfce6a3e | 8 | # Other tests for CORE subs are in coresubs.t |
47ac839d FC |
9 | |
10 | BEGIN { | |
7d997a14 PE |
11 | chdir 't' if -d 't'; |
12 | require "./test.pl"; | |
13 | set_up_inc( qw(. ../lib ../dist/if) ); | |
14 | require './charset_tools.pl'; | |
15 | $^P |= 0x100; # Provide informative "file" names for evals | |
47ac839d | 16 | } |
47ac839d FC |
17 | |
18 | sub lis($$;$) { | |
19 | &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]); | |
20 | } | |
21 | ||
17008668 FC |
22 | package hov { |
23 | use overload '%{}' => sub { +{} } | |
24 | } | |
bea284c8 FC |
25 | package aov { |
26 | use overload '@{}' => sub { [] } | |
27 | } | |
17008668 FC |
28 | package sov { |
29 | use overload '${}' => sub { \my $x } | |
30 | } | |
31 | ||
47ac839d | 32 | my %op_desc = ( |
7d997a14 PE |
33 | evalbytes => 'eval "string"', |
34 | join => 'join or string', | |
35 | pos => 'match position', | |
36 | prototype => 'subroutine prototype', | |
37 | readline => '<HANDLE>', | |
38 | readpipe => 'quoted execution (``, qx)', | |
39 | reset => 'symbol reset', | |
40 | ref => 'reference-type operator', | |
41 | undef => 'undef operator', | |
47ac839d FC |
42 | ); |
43 | sub op_desc($) { | |
44 | return $op_desc{$_[0]} || $_[0]; | |
45 | } | |
46 | ||
47 | ||
48 | # This tests that the &{} syntax respects the number of arguments implied | |
49 | # by the prototype, plus some extra tests for the (_) prototype. | |
50 | sub test_proto { | |
51 | my($o) = shift; | |
52 | ||
53 | # Create an alias, for the caller’s convenience. | |
54 | *{"my$o"} = \&{"CORE::$o"}; | |
55 | ||
56 | my $p = prototype "CORE::$o"; | |
d6d78e19 | 57 | $p = '$;$' if $p eq '$_'; |
47ac839d FC |
58 | |
59 | if ($p eq '') { | |
60 | $tests ++; | |
61 | ||
62 | eval " &CORE::$o(1) "; | |
63 | like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; | |
64 | ||
65 | } | |
498a02d8 | 66 | elsif ($p =~ /^_;?\z/) { |
47ac839d FC |
67 | $tests ++; |
68 | ||
69 | eval " &CORE::$o(1,2) "; | |
70 | my $desc = quotemeta op_desc($o); | |
71 | like $@, qr/^Too many arguments for $desc at /, | |
72 | "&$o with too many args"; | |
73 | ||
74 | if (!@_) { return } | |
75 | ||
7fba2966 | 76 | $tests += 3; |
47ac839d FC |
77 | |
78 | my($in,$out) = @_; # for testing implied $_ | |
79 | ||
80 | # Since we have $in and $out values, we might as well test basic amper- | |
81 | # sand calls, too. | |
82 | ||
83 | is &{"CORE::$o"}($in), $out, "&$o"; | |
84 | lis [&{"CORE::$o"}($in)], [$out], "&$o in list context"; | |
85 | ||
86 | $_ = $in; | |
87 | is &{"CORE::$o"}(), $out, "&$o with no args"; | |
47ac839d FC |
88 | } |
89 | elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc. | |
90 | my $maxargs = length $1; | |
91 | $tests += 1; | |
92 | eval " &CORE::$o((1)x($maxargs+1)) "; | |
93 | my $desc = quotemeta op_desc($o); | |
94 | like $@, qr/^Too many arguments for $desc at /, | |
7d997a14 | 95 | "&$o with too many args"; |
47ac839d FC |
96 | } |
97 | elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or *** | |
98 | my $args = length $1; | |
99 | $tests += 2; | |
7d789282 | 100 | my $desc = quotemeta op_desc($o); |
47ac839d | 101 | eval " &CORE::$o((1)x($args-1)) "; |
7d789282 | 102 | like $@, qr/^Not enough arguments for $desc at /, "&$o w/too few args"; |
47ac839d | 103 | eval " &CORE::$o((1)x($args+1)) "; |
7d789282 | 104 | like $@, qr/^Too many arguments for $desc at /, "&$o w/too many args"; |
47ac839d FC |
105 | } |
106 | elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or *** | |
107 | my $minargs = length $1; | |
108 | my $maxargs = $minargs + length $2; | |
109 | $tests += 2; | |
110 | eval " &CORE::$o((1)x($minargs-1)) "; | |
111 | like $@, qr/^Not enough arguments for $o at /, "&$o with too few args"; | |
112 | eval " &CORE::$o((1)x($maxargs+1)) "; | |
113 | like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; | |
114 | } | |
115 | elsif ($p eq '_;$') { | |
116 | $tests += 1; | |
117 | ||
118 | eval " &CORE::$o(1,2,3) "; | |
119 | like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; | |
120 | } | |
121 | elsif ($p eq '@') { | |
122 | # Do nothing, as we cannot test for too few or too many arguments. | |
123 | } | |
124 | elsif ($p =~ '^[$*;]+@\z') { | |
125 | $tests ++; | |
126 | $p =~ ';@'; | |
127 | my $minargs = $-[0]; | |
128 | eval " &CORE::$o((1)x($minargs-1)) "; | |
129 | my $desc = quotemeta op_desc($o); | |
130 | like $@, qr/^Not enough arguments for $desc at /, | |
7d997a14 | 131 | "&$o with too few args"; |
47ac839d | 132 | } |
17008668 FC |
133 | elsif ($p =~ /^\*\\\$\$(;?)\$\z/) { # *\$$$ and *\$$;$ |
134 | $tests += 5; | |
135 | ||
136 | eval "&CORE::$o(1,1,1,1,1)"; | |
137 | like $@, qr/^Too many arguments for $o at /, | |
7d997a14 | 138 | "&$o with too many args"; |
17008668 FC |
139 | eval " &CORE::$o((1)x(\$1?2:3)) "; |
140 | like $@, qr/^Not enough arguments for $o at /, | |
7d997a14 | 141 | "&$o with too few args"; |
17008668 FC |
142 | eval " &CORE::$o(1,[],1,1) "; |
143 | like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /, | |
7d997a14 | 144 | "&$o with array ref arg"; |
17008668 FC |
145 | eval " &CORE::$o(1,1,1,1) "; |
146 | like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /, | |
7d997a14 | 147 | "&$o with scalar arg"; |
17008668 FC |
148 | eval " &CORE::$o(1,bless([], 'sov'),1,1) "; |
149 | like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /, | |
7d997a14 | 150 | "&$o with non-scalar arg w/scalar overload (which does not count)"; |
17008668 | 151 | } |
47ac839d FC |
152 | elsif ($p =~ /^\\%\$*\z/) { # \% and \%$$ |
153 | $tests += 5; | |
154 | ||
155 | eval "&CORE::$o(" . join(",", (1) x length $p) . ")"; | |
156 | like $@, qr/^Too many arguments for $o at /, | |
7d997a14 | 157 | "&$o with too many args"; |
47ac839d FC |
158 | eval " &CORE::$o(" . join(",", (1) x (length($p)-2)) . ") "; |
159 | like $@, qr/^Not enough arguments for $o at /, | |
7d997a14 | 160 | "&$o with too few args"; |
47ac839d FC |
161 | my $moreargs = ",1" x (length($p) - 2); |
162 | eval " &CORE::$o([]$moreargs) "; | |
163 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, | |
7d997a14 | 164 | "&$o with array ref arg"; |
47ac839d FC |
165 | eval " &CORE::$o(*foo$moreargs) "; |
166 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, | |
7d997a14 | 167 | "&$o with typeglob arg"; |
47ac839d FC |
168 | eval " &CORE::$o(bless([], 'hov')$moreargs) "; |
169 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, | |
7d997a14 | 170 | "&$o with non-hash arg with hash overload (which does not count)"; |
47ac839d | 171 | } |
46bef06f FC |
172 | elsif ($p =~ /^(;)?\\\[(\$\@%&?\*)](\$\@)?\z/) { |
173 | $tests += 3; | |
47ac839d | 174 | |
46bef06f | 175 | unless ($3) { |
efe889ae FC |
176 | $tests ++; |
177 | eval " &CORE::$o(1,2) "; | |
46bef06f | 178 | like $@, qr/^Too many arguments for ${\op_desc($o)} at /, |
efe889ae FC |
179 | "&$o with too many args"; |
180 | } | |
46bef06f FC |
181 | unless ($1) { |
182 | $tests ++; | |
183 | eval { &{"CORE::$o"}($3 ? 1 : ()) }; | |
184 | like $@, qr/^Not enough arguments for $o at /, | |
47ac839d | 185 | "&$o with too few args"; |
46bef06f FC |
186 | } |
187 | my $more_args = $3 ? ',1' : ''; | |
efe889ae | 188 | eval " &CORE::$o(2$more_args) "; |
47ac839d | 189 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: |
92e8e650 | 190 | ) \[\Q$2\E\] at /, |
7d997a14 | 191 | "&$o with non-ref arg"; |
efe889ae | 192 | eval " &CORE::$o(*STDOUT{IO}$more_args) "; |
47ac839d | 193 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: |
92e8e650 | 194 | ) \[\Q$2\E\] at /, |
7d997a14 | 195 | "&$o with ioref arg"; |
47ac839d | 196 | my $class = ref *DATA{IO}; |
efe889ae | 197 | eval " &CORE::$o(bless(*DATA{IO}, 'hov')$more_args) "; |
47ac839d | 198 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: |
92e8e650 | 199 | ) \[\Q$2\E\] at /, |
7d997a14 | 200 | "&$o with ioref arg with hash overload (which does not count)"; |
47ac839d | 201 | bless *DATA{IO}, $class; |
46bef06f | 202 | if (do {$2 !~ /&/}) { |
efe889ae FC |
203 | $tests++; |
204 | eval " &CORE::$o(\\&scriggle$more_args) "; | |
205 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one (?x: | |
92e8e650 | 206 | )of \[\Q$2\E\] at /, |
efe889ae | 207 | "&$o with coderef arg"; |
7d997a14 | 208 | } |
47ac839d | 209 | } |
bea284c8 FC |
210 | elsif ($p =~ /^;?\\\@([\@;])?/) { # ;\@ \@@ \@;$$@ |
211 | $tests += 7; | |
212 | ||
213 | if ($1) { | |
214 | eval { &{"CORE::$o"}() }; | |
215 | like $@, qr/^Not enough arguments for $o at /, | |
7d997a14 | 216 | "&$o with too few args"; |
bea284c8 FC |
217 | } |
218 | else { | |
219 | eval " &CORE::$o(\\\@1,2) "; | |
220 | like $@, qr/^Too many arguments for $o at /, | |
221 | "&$o with too many args"; | |
222 | } | |
223 | eval " &CORE::$o(2) "; | |
224 | like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, | |
7d997a14 | 225 | "&$o with non-ref arg"; |
bea284c8 FC |
226 | eval " &CORE::$o(*STDOUT{IO}) "; |
227 | like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, | |
7d997a14 | 228 | "&$o with ioref arg"; |
bea284c8 FC |
229 | my $class = ref *DATA{IO}; |
230 | eval " &CORE::$o(bless(*DATA{IO}, 'aov')) "; | |
231 | like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, | |
7d997a14 | 232 | "&$o with ioref arg with array overload (which does not count)"; |
bea284c8 FC |
233 | bless *DATA{IO}, $class; |
234 | eval " &CORE::$o(\\&scriggle) "; | |
235 | like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, | |
7d997a14 | 236 | "&$o with coderef arg"; |
bea284c8 FC |
237 | eval " &CORE::$o(\\\$_) "; |
238 | like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, | |
7d997a14 | 239 | "&$o with scalarref arg"; |
bea284c8 FC |
240 | eval " &CORE::$o({}) "; |
241 | like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, | |
7d997a14 | 242 | "&$o with hashref arg"; |
bea284c8 | 243 | } |
73665bc4 FC |
244 | elsif ($p eq '\[%@]') { |
245 | $tests += 7; | |
246 | ||
247 | eval " &CORE::$o(\\%1,2) "; | |
248 | like $@, qr/^Too many arguments for ${\op_desc($o)} at /, | |
7d997a14 | 249 | "&$o with too many args"; |
73665bc4 FC |
250 | eval { &{"CORE::$o"}() }; |
251 | like $@, qr/^Not enough arguments for $o at /, | |
7d997a14 | 252 | "&$o with too few args"; |
73665bc4 FC |
253 | eval " &CORE::$o(2) "; |
254 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: | |
255 | )reference at /, | |
7d997a14 | 256 | "&$o with non-ref arg"; |
73665bc4 FC |
257 | eval " &CORE::$o(*STDOUT{IO}) "; |
258 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: | |
259 | )reference at /, | |
7d997a14 | 260 | "&$o with ioref arg"; |
73665bc4 FC |
261 | my $class = ref *DATA{IO}; |
262 | eval " &CORE::$o(bless(*DATA{IO}, 'hov')) "; | |
263 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: | |
264 | )reference at /, | |
7d997a14 | 265 | "&$o with ioref arg with hash overload (which does not count)"; |
73665bc4 FC |
266 | bless *DATA{IO}, $class; |
267 | eval " &CORE::$o(\\&scriggle) "; | |
268 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: | |
269 | )reference at /, | |
7d997a14 | 270 | "&$o with coderef arg"; |
73665bc4 FC |
271 | eval " &CORE::$o(\\\$_) "; |
272 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: | |
273 | )reference at /, | |
7d997a14 | 274 | "&$o with scalarref arg"; |
73665bc4 | 275 | } |
1efec5ed FC |
276 | elsif ($p eq ';\[$*]') { |
277 | $tests += 4; | |
278 | ||
279 | my $desc = quotemeta op_desc($o); | |
280 | eval " &CORE::$o(1,2) "; | |
281 | like $@, qr/^Too many arguments for $desc at /, | |
7d997a14 | 282 | "&$o with too many args"; |
1efec5ed FC |
283 | eval " &CORE::$o([]) "; |
284 | like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /, | |
7d997a14 | 285 | "&$o with array ref arg"; |
1efec5ed FC |
286 | eval " &CORE::$o(1) "; |
287 | like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /, | |
7d997a14 | 288 | "&$o with scalar arg"; |
1efec5ed FC |
289 | eval " &CORE::$o(bless([], 'sov')) "; |
290 | like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /, | |
7d997a14 | 291 | "&$o with non-scalar arg w/scalar overload (which does not count)"; |
1efec5ed | 292 | } |
47ac839d FC |
293 | |
294 | else { | |
295 | die "Please add tests for the $p prototype"; | |
296 | } | |
297 | } | |
298 | ||
0e80230d FC |
299 | # Test that &CORE::foo calls without parentheses (no new @_) can handle the |
300 | # total absence of any @_ without crashing. | |
301 | undef *_; | |
302 | &CORE::wantarray; | |
303 | $tests++; | |
304 | pass('no crash with &CORE::foo when *_{ARRAY} is undef'); | |
305 | ||
63119cca | 306 | test_proto '__CLASS__'; |
47ac839d FC |
307 | test_proto '__FILE__'; |
308 | test_proto '__LINE__'; | |
309 | test_proto '__PACKAGE__'; | |
84ed0108 | 310 | test_proto '__SUB__'; |
47ac839d FC |
311 | |
312 | is file(), 'frob' , '__FILE__ does check its caller' ; ++ $tests; | |
313 | is line(), 5 , '__LINE__ does check its caller' ; ++ $tests; | |
314 | is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests; | |
84ed0108 FC |
315 | sub __SUB__test { &my__SUB__ } |
316 | is __SUB__test, \&__SUB__test, '&__SUB__'; ++ $tests; | |
47ac839d FC |
317 | |
318 | test_proto 'abs', -5, 5; | |
319 | ||
74416803 TC |
320 | SKIP: |
321 | { | |
7d997a14 PE |
322 | if ($^O eq "MSWin32" && is_miniperl) { |
323 | $tests += 8; | |
324 | skip "accept() not available in Win32 miniperl", 8 | |
325 | } | |
326 | $tests += 6; | |
327 | test_proto 'accept'; | |
328 | eval q{ | |
329 | is &CORE::accept(qw{foo bar}), undef, "&accept"; | |
330 | lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context"; | |
331 | ||
332 | &myaccept(my $foo, my $bar); | |
333 | is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument'; | |
334 | is $bar, undef, 'CORE::accept does not autovivify its second argument'; | |
335 | use strict; | |
336 | undef $foo; | |
337 | eval { 'myaccept'->($foo, $bar) }; | |
338 | like $@, qr/^Can't use an undefined value as a symbol reference at/, | |
339 | 'CORE::accept will not accept undef 2nd arg under strict'; | |
340 | is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict'; | |
341 | }; | |
74416803 | 342 | } |
47ac839d FC |
343 | |
344 | test_proto 'alarm'; | |
345 | test_proto 'atan2'; | |
346 | ||
347 | test_proto 'bind'; | |
348 | $tests += 3; | |
74416803 TC |
349 | SKIP: |
350 | { | |
7d997a14 PE |
351 | skip "bind() not available in Win32 miniperl", 3 |
352 | if $^O eq "MSWin32" && is_miniperl(); | |
353 | is &CORE::bind('foo', 'bear'), undef, "&bind"; | |
354 | lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context"; | |
355 | eval { &mybind(my $foo, "bear") }; | |
356 | like $@, qr/^Bad symbol for filehandle at/, | |
357 | 'CORE::bind dies with undef first arg'; | |
74416803 | 358 | } |
47ac839d FC |
359 | |
360 | test_proto 'binmode'; | |
361 | $tests += 3; | |
362 | is &CORE::binmode(qw[foo bar]), undef, "&binmode"; | |
363 | lis [&CORE::binmode(qw[foo bar])], [undef], "&binmode in list context"; | |
364 | is &mybinmode(foo), undef, '&binmode with one arg'; | |
365 | ||
366 | test_proto 'bless'; | |
367 | $tests += 3; | |
368 | like &CORE::bless([],'parcel'), qr/^parcel=ARRAY/, "&bless"; | |
7d997a14 PE |
369 | like join(" ", &CORE::bless([],'parcel')), qr/^parcel=ARRAY(?!.* )/, |
370 | "&bless in list context"; | |
47ac839d FC |
371 | like &mybless([]), qr/^main=ARRAY/, '&bless with one arg'; |
372 | ||
7896dde7 | 373 | test_proto 'break'; |
7d997a14 PE |
374 | { |
375 | $tests ++; | |
7896dde7 | 376 | my $tmp; |
8a487d3f | 377 | no warnings 'deprecated'; |
7896dde7 Z |
378 | CORE::given(1) { |
379 | CORE::when(1) { | |
380 | &mybreak; | |
381 | $tmp = 'bad'; | |
382 | } | |
383 | } | |
384 | is $tmp, undef, '&break'; | |
385 | } | |
386 | ||
47ac839d FC |
387 | test_proto 'caller'; |
388 | $tests += 4; | |
389 | sub caller_test { | |
7d997a14 PE |
390 | is scalar &CORE::caller, 'hadhad', '&caller'; |
391 | is scalar &CORE::caller(1), 'main', '&caller(1)'; | |
392 | lis [&CORE::caller], [caller], '&caller in list context'; | |
393 | # The last element of caller in list context is a hint hash, which | |
394 | # may be a different hash for caller vs &CORE::caller, so an eq com- | |
395 | # parison (which lis() uses for convenience) won’t work. So just | |
396 | # pop the last element, since the rest are sufficient to prove that | |
397 | # &CORE::caller works. | |
398 | my @ampcaller = &CORE::caller(1); | |
399 | my @caller = caller(1); | |
400 | pop @ampcaller; pop @caller; | |
401 | lis \@ampcaller, \@caller, '&caller(1) in list context'; | |
47ac839d FC |
402 | } |
403 | sub { | |
7d997a14 PE |
404 | package hadhad; |
405 | ::caller_test(); | |
47ac839d FC |
406 | }->(); |
407 | ||
408 | test_proto 'chmod'; | |
409 | $tests += 3; | |
410 | is &CORE::chmod(), 0, '&chmod with no args'; | |
411 | is &CORE::chmod(0666), 0, '&chmod'; | |
412 | lis [&CORE::chmod(0666)], [0], '&chmod in list context'; | |
413 | ||
414 | test_proto 'chown'; | |
415 | $tests += 4; | |
416 | is &CORE::chown(), 0, '&chown with no args'; | |
417 | is &CORE::chown(1), 0, '&chown with 1 arg'; | |
418 | is &CORE::chown(1,2), 0, '&chown'; | |
419 | lis [&CORE::chown(1,2)], [0], '&chown in list context'; | |
420 | ||
421 | test_proto 'chr', 5, "\5"; | |
422 | test_proto 'chroot'; | |
423 | ||
424 | test_proto 'close'; | |
425 | { | |
426 | last if is_miniperl; | |
427 | $tests += 3; | |
7d997a14 | 428 | |
47ac839d FC |
429 | open my $fh, ">", \my $buffalo; |
430 | print $fh 'an address in the outskirts of Jersey'; | |
431 | ok &CORE::close($fh), '&CORE::close retval'; | |
432 | print $fh 'lalala'; | |
433 | is $buffalo, 'an address in the outskirts of Jersey', | |
7d997a14 | 434 | 'effect of &CORE::close'; |
47ac839d FC |
435 | # This has to be a separate variable from $fh, as re-using the same |
436 | # variable can cause the tests to pass by accident. That actually hap- | |
437 | # pened during developement, because the second close() was reading | |
438 | # beyond the end of the stack and finding a $fh left over from before. | |
439 | open my $fh2, ">", \($buffalo = ''); | |
440 | select+(select($fh2), do { | |
7d997a14 PE |
441 | print "Nasusiro Tokasoni"; |
442 | &CORE::close(); | |
443 | print "jfd"; | |
444 | is $buffalo, "Nasusiro Tokasoni", '&CORE::close with no args'; | |
47ac839d FC |
445 | })[0]; |
446 | } | |
447 | lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests; | |
448 | ||
449 | test_proto 'closedir'; | |
450 | $tests += 2; | |
451 | is &CORE::closedir(foo), undef, '&CORE::closedir'; | |
452 | lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context'; | |
453 | ||
454 | test_proto 'connect'; | |
455 | $tests += 2; | |
74416803 TC |
456 | SKIP: |
457 | { | |
7d997a14 PE |
458 | skip "connect() not available in Win32 miniperl", 2 |
459 | if $^O eq "MSWin32" && is_miniperl(); | |
460 | is &CORE::connect('foo','bar'), undef, '&connect'; | |
461 | lis [&myconnect('foo','bar')], [undef], '&connect in list context'; | |
74416803 | 462 | } |
47ac839d FC |
463 | |
464 | test_proto 'continue'; | |
465 | $tests ++; | |
8a487d3f | 466 | no warnings 'deprecated'; |
47ac839d | 467 | CORE::given(1) { |
7896dde7 | 468 | CORE::when(1) { |
47ac839d FC |
469 | &mycontinue(); |
470 | } | |
471 | pass "&continue"; | |
472 | } | |
473 | ||
474 | test_proto 'cos'; | |
475 | test_proto 'crypt'; | |
476 | ||
477 | test_proto 'dbmclose'; | |
478 | test_proto 'dbmopen'; | |
479 | { | |
480 | last unless eval { require AnyDBM_File }; | |
481 | $tests ++; | |
482 | my $filename = tempfile(); | |
483 | &mydbmopen(\my %db, $filename, 0666); | |
484 | $db{1} = 2; $db{3} = 4; | |
485 | &mydbmclose(\%db); | |
486 | is scalar keys %db, 0, '&dbmopen and &dbmclose'; | |
d7f2696d SH |
487 | my $Dfile = "$filename.pag"; |
488 | if (! -e $Dfile) { | |
489 | ($Dfile) = <$filename*>; | |
490 | } | |
491 | if ($^O eq 'VMS') { | |
492 | unlink "$filename.sdbm_dir", $Dfile; | |
493 | } else { | |
494 | unlink "$filename.dir", $Dfile; | |
495 | } | |
47ac839d FC |
496 | } |
497 | ||
498 | test_proto 'die'; | |
499 | eval { dier('quinquangle') }; | |
500 | is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++; | |
501 | ||
502 | test_proto $_ for qw( | |
7d997a14 | 503 | endgrent endhostent endnetent endprotoent endpwent endservent |
47ac839d FC |
504 | ); |
505 | ||
7d789282 FC |
506 | test_proto 'evalbytes'; |
507 | $tests += 4; | |
508 | { | |
33eaa0ec KW |
509 | my $U_100_bytes = byte_utf8a_to_utf8n("\xc4\x80"); |
510 | chop(my $upgraded = "use utf8; $U_100_bytes" . chr 256); | |
7d789282 FC |
511 | is &myevalbytes($upgraded), chr 256, '&evalbytes'; |
512 | # Test hints | |
513 | require strict; | |
514 | strict->import; | |
515 | &myevalbytes(' | |
516 | is someone, "someone", "run-time hint bits do not leak into &evalbytes" | |
517 | '); | |
518 | use strict; | |
519 | BEGIN { $^H{coreamp} = 42 } | |
520 | $^H{coreamp} = 75; | |
521 | &myevalbytes(' | |
522 | BEGIN { | |
523 | is $^H{coreamp}, 42, "compile-time hh propagates into &evalbytes"; | |
524 | } | |
525 | ${"frobnicate"} | |
526 | '); | |
527 | like $@, qr/strict/, 'compile-time hint bits propagate into &evalbytes'; | |
528 | } | |
529 | ||
47ac839d FC |
530 | test_proto 'exit'; |
531 | $tests ++; | |
d3288251 | 532 | is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n", |
47ac839d FC |
533 | '&exit with no args'; |
534 | ||
535 | test_proto 'fork'; | |
536 | ||
537 | test_proto 'formline'; | |
538 | $tests += 3; | |
539 | is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval'; | |
540 | is $^A, ' 1 2', 'effect of &myformline'; | |
541 | lis [&myformline('@')], [1], '&myformline in list context'; | |
542 | ||
73665bc4 FC |
543 | test_proto 'each'; |
544 | $tests += 4; | |
545 | is &myeach({ "a","b" }), "a", '&myeach(\%hash) in scalar cx'; | |
546 | lis [&myeach({qw<a b>})], [qw<a b>], '&myeach(\%hash) in list cx'; | |
547 | is &myeach([ "a","b" ]), 0, '&myeach(\@array) in scalar cx'; | |
548 | lis [&myeach([qw<a b>])], [qw<0 a>], '&myeach(\@array) in list cx'; | |
549 | ||
47ac839d | 550 | test_proto 'exp'; |
838f2281 BF |
551 | |
552 | test_proto 'fc'; | |
553 | $tests += 2; | |
554 | { | |
33eaa0ec | 555 | my $sharp_s = uni_to_native("\xdf"); |
838f2281 BF |
556 | is &myfc($sharp_s), $sharp_s, '&fc, no unicode_strings'; |
557 | use feature 'unicode_strings'; | |
558 | is &myfc($sharp_s), "ss", '&fc, unicode_strings'; | |
559 | } | |
560 | ||
47ac839d FC |
561 | test_proto 'fcntl'; |
562 | ||
563 | test_proto 'fileno'; | |
564 | $tests += 2; | |
565 | is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno'; | |
566 | lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx'; | |
567 | ||
568 | test_proto 'flock'; | |
569 | test_proto 'fork'; | |
570 | ||
571 | test_proto 'getc'; | |
572 | { | |
573 | last if is_miniperl; | |
574 | $tests += 3; | |
575 | local *STDIN; | |
576 | open my $fh, "<", \(my $buf='falo'); | |
577 | open STDIN, "<", \(my $buf2 = 'bison'); | |
578 | is &mygetc($fh), 'f', '&mygetc'; | |
579 | is &mygetc(), 'b', '&mygetc with no args'; | |
580 | lis [&mygetc($fh)], ['a'], '&mygetc in list context'; | |
581 | } | |
582 | ||
583 | test_proto "get$_" for qw ' | |
584 | grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname | |
585 | netent peername | |
586 | '; | |
587 | ||
588 | test_proto 'getpgrp'; | |
589 | eval {&mygetpgrp()}; | |
590 | pass '&getpgrp with no args does not crash'; $tests++; | |
591 | ||
592 | test_proto "get$_" for qw ' | |
593 | ppid priority protobyname protobynumber protoent | |
594 | pwent pwnam pwuid servbyname servbyport servent sockname sockopt | |
595 | '; | |
596 | ||
498a02d8 FC |
597 | # Make sure the following tests test what we think they are testing. |
598 | ok ! $CORE::{glob}, '*CORE::glob not autovivified yet'; $tests ++; | |
599 | { | |
600 | # Make sure ck_glob does not respect the override when &CORE::glob is | |
601 | # autovivified (by test_proto). | |
602 | local *CORE::GLOBAL::glob = sub {}; | |
603 | test_proto 'glob'; | |
604 | } | |
605 | $_ = "t/*.t"; | |
606 | @_ = &myglob($_); | |
607 | is join($", &myglob()), "@_", '&glob without arguments'; | |
608 | is join($", &myglob("t/*.t")), "@_", '&glob with an arg'; | |
609 | $tests += 2; | |
610 | ||
47ac839d FC |
611 | test_proto 'gmtime'; |
612 | &CORE::gmtime; | |
613 | pass '&gmtime without args does not crash'; ++$tests; | |
614 | ||
615 | test_proto 'hex', ff=>255; | |
616 | ||
617 | test_proto 'index'; | |
618 | $tests += 3; | |
619 | is &myindex("foffooo","o",2),4,'&index'; | |
620 | lis [&myindex("foffooo","o",2)],[4],'&index in list context'; | |
621 | is &myindex("foffooo","o"),1,'&index with 2 args'; | |
622 | ||
623 | test_proto 'int', 1.5=>1; | |
624 | test_proto 'ioctl'; | |
625 | ||
626 | test_proto 'join'; | |
627 | $tests += 2; | |
628 | is &myjoin('a','b','c'), 'bac', '&join'; | |
629 | lis [&myjoin('a','b','c')], ['bac'], '&join in list context'; | |
630 | ||
73665bc4 | 631 | test_proto 'keys'; |
cd642408 | 632 | $tests += 6; |
73665bc4 FC |
633 | is &mykeys({ 1..4 }), 2, '&mykeys(\%hash) in scalar cx'; |
634 | lis [sort &mykeys({1..4})], [1,3], '&mykeys(\%hash) in list cx'; | |
635 | is &mykeys([ 1..4 ]), 4, '&mykeys(\@array) in scalar cx'; | |
636 | lis [&mykeys([ 1..4 ])], [0..3], '&mykeys(\@array) in list cx'; | |
cf8db57b JH |
637 | |
638 | SKIP: { | |
639 | skip "no Hash::Util on miniperl", 2, if is_miniperl; | |
640 | require Hash::Util; | |
641 | sub Hash::Util::bucket_ratio (\%); | |
642 | ||
cd642408 FC |
643 | my %h = 1..2; |
644 | &mykeys(\%h) = 1024; | |
6f019ba7 | 645 | like Hash::Util::bucket_ratio(%h), qr!/(?:1024|2048)\z!, '&mykeys = changed number of buckets allocated'; |
cd642408 FC |
646 | eval { (&mykeys(\%h)) = 1025; }; |
647 | like $@, qr/^Can't modify keys in list assignment at /; | |
648 | } | |
73665bc4 | 649 | |
47ac839d FC |
650 | test_proto 'kill'; # set up mykill alias |
651 | if ($^O ne 'riscos') { | |
7d997a14 PE |
652 | $tests ++; |
653 | ok( &mykill(0, $$), '&kill' ); | |
47ac839d FC |
654 | } |
655 | ||
656 | test_proto 'lc', 'A', 'a'; | |
657 | test_proto 'lcfirst', 'AA', 'aA'; | |
658 | test_proto 'length', 'aaa', 3; | |
659 | test_proto 'link'; | |
660 | test_proto 'listen'; | |
661 | ||
662 | test_proto 'localtime'; | |
663 | &CORE::localtime; | |
664 | pass '&localtime without args does not crash'; ++$tests; | |
665 | ||
666 | test_proto 'lock'; | |
667 | $tests += 6; | |
668 | is \&mylock(\$foo), \$foo, '&lock retval when passed a scalar ref'; | |
669 | lis [\&mylock(\$foo)], [\$foo], '&lock in list context'; | |
670 | is &mylock(\@foo), \@foo, '&lock retval when passed an array ref'; | |
671 | is &mylock(\%foo), \%foo, '&lock retval when passed a ash ref'; | |
672 | is &mylock(\&foo), \&foo, '&lock retval when passed a code ref'; | |
673 | is \&mylock(\*foo), \*foo, '&lock retval when passed a glob ref'; | |
674 | ||
675 | test_proto 'log'; | |
676 | ||
677 | test_proto 'mkdir'; | |
678 | # mkdir is tested with implicit $_ at the end, to make the test easier | |
679 | ||
680 | test_proto "msg$_" for qw( ctl get rcv snd ); | |
681 | ||
682 | test_proto 'not'; | |
683 | $tests += 2; | |
684 | is &mynot(1), !1, '¬'; | |
685 | lis [&mynot(0)], [!0], '¬ in list context'; | |
686 | ||
687 | test_proto 'oct', '666', 438; | |
688 | ||
689 | test_proto 'open'; | |
690 | $tests += 5; | |
691 | $file = 'test.pl'; | |
692 | ok &myopen('file'), '&open with 1 arg' or warn "1-arg open: $!"; | |
693 | like <file>, qr|^#|, 'result of &open with 1 arg'; | |
694 | close file; | |
695 | { | |
696 | ok &myopen(my $fh, "test.pl"), 'two-arg &open'; | |
697 | ok $fh, '&open autovivifies'; | |
698 | like <$fh>, qr '^#', 'result of &open with 2 args'; | |
699 | last if is_miniperl; | |
700 | $tests +=2; | |
701 | ok &myopen(my $fh2, "<", \"sharummbles"), 'retval of 3-arg &open'; | |
702 | is <$fh2>, 'sharummbles', 'result of three-arg &open'; | |
703 | } | |
704 | ||
705 | test_proto 'opendir'; | |
33eaa0ec | 706 | test_proto 'ord', chr(utf8::unicode_to_native(64)), utf8::unicode_to_native(64); |
47ac839d FC |
707 | |
708 | test_proto 'pack'; | |
709 | $tests += 2; | |
7d997a14 PE |
710 | my $Perl_as_a_hex_string = |
711 | join "", map { sprintf("%2X", utf8::unicode_to_native($_)) } 0x50, 0x65, 0x72, 0x6c; | |
33eaa0ec KW |
712 | is &mypack("H*", $Perl_as_a_hex_string), 'Perl', '&pack'; |
713 | lis [&mypack("H*", $Perl_as_a_hex_string)], ['Perl'], '&pack in list context'; | |
47ac839d FC |
714 | |
715 | test_proto 'pipe'; | |
1efec5ed | 716 | |
bea284c8 FC |
717 | test_proto 'pop'; |
718 | $tests += 6; | |
719 | @ARGV = qw<a b c>; | |
720 | is &mypop(), 'c', 'retval of &pop with no args (@ARGV)'; | |
721 | is "@ARGV", "a b", 'effect of &pop on @ARGV'; | |
722 | sub { | |
723 | is &mypop(), 'k', 'retval of &pop with no args (@_)'; | |
724 | is "@_", "q j", 'effect of &pop on @_'; | |
725 | }->(qw(q j k)); | |
726 | { | |
727 | my @a = 1..4; | |
728 | is &mypop(\@a), 4, 'retval of &pop'; | |
729 | lis [@a], [1..3], 'effect of &pop'; | |
730 | } | |
731 | ||
1efec5ed FC |
732 | test_proto 'pos'; |
733 | $tests += 4; | |
734 | $_ = "hello"; | |
735 | pos = 3; | |
736 | is &mypos, 3, 'reading &pos without args'; | |
737 | &mypos = 4; | |
738 | is pos, 4, 'writing to &pos without args'; | |
739 | { | |
740 | my $x = "gubai"; | |
741 | pos $x = 3; | |
742 | is &mypos(\$x), 3, 'reading &pos without args'; | |
743 | &mypos(\$x) = 4; | |
744 | is pos $x, 4, 'writing to &pos without args'; | |
745 | } | |
746 | ||
919ad5f7 FC |
747 | test_proto 'prototype'; |
748 | $tests++; | |
749 | is &myprototype(\&myprototype), prototype("CORE::prototype"), '&prototype'; | |
1efec5ed | 750 | |
bea284c8 FC |
751 | test_proto 'push'; |
752 | $tests += 2; | |
753 | { | |
754 | my @a = qw<a b c>; | |
755 | is &mypush(\@a, "d", "e"), 5, 'retval of &push'; | |
756 | is "@a", "a b c d e", 'effect of &push'; | |
757 | } | |
758 | ||
47ac839d FC |
759 | test_proto 'quotemeta', '$', '\$'; |
760 | ||
761 | test_proto 'rand'; | |
762 | $tests += 3; | |
d62c8fd1 DDM |
763 | my $r = &CORE::rand; |
764 | ok eval { | |
7d997a14 PE |
765 | use warnings FATAL => qw{numeric uninitialized}; |
766 | $r >= 0 && $r < 1; | |
d62c8fd1 | 767 | }, '&rand returns a valid number'; |
47ac839d | 768 | unlike join(" ", &CORE::rand), qr/ /, '&rand in list context'; |
16f6be75 | 769 | &cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 1 arg'); |
47ac839d | 770 | |
17008668 FC |
771 | test_proto 'read'; |
772 | { | |
773 | last if is_miniperl; | |
774 | $tests += 5; | |
775 | open my $fh, "<", \(my $buff = 'morays have their mores'); | |
776 | ok &myread($fh, \my $input, 6), '&read with 3 args'; | |
777 | is $input, 'morays', 'value read by 3-arg &read'; | |
778 | ok &myread($fh, \$input, 6, 6), '&read with 4 args'; | |
779 | is $input, 'morays have ', 'value read by 4-arg &read'; | |
780 | is +()=&myread($fh, \$input, 6), 1, '&read in list context'; | |
781 | } | |
782 | ||
47ac839d FC |
783 | test_proto 'readdir'; |
784 | ||
785 | test_proto 'readline'; | |
786 | { | |
787 | local *ARGV = *DATA; | |
788 | $tests ++; | |
789 | is scalar &myreadline, | |
790 | "I wandered lonely as a cloud\n", '&readline w/no args'; | |
791 | } | |
792 | { | |
793 | last if is_miniperl; | |
794 | $tests += 2; | |
795 | open my $fh, "<", \(my $buff = <<END); | |
796 | The Recursive Problem | |
797 | --------------------- | |
798 | I have a problem I cannot solve. | |
799 | The problem is that I cannot solve it. | |
800 | END | |
801 | is &myreadline($fh), "The Recursive Problem\n", | |
802 | '&readline with 1 arg'; | |
803 | lis [&myreadline($fh)], [ | |
804 | "---------------------\n", | |
805 | "I have a problem I cannot solve.\n", | |
806 | "The problem is that I cannot solve it.\n", | |
807 | ], '&readline in list context'; | |
808 | } | |
809 | ||
810 | test_proto 'readlink'; | |
811 | test_proto 'readpipe'; | |
17008668 | 812 | test_proto 'recv'; |
47ac839d FC |
813 | |
814 | use if !is_miniperl, File::Spec::Functions, qw "catfile"; | |
815 | use if !is_miniperl, File::Temp, 'tempdir'; | |
816 | ||
817 | test_proto 'rename'; | |
818 | { | |
7d997a14 PE |
819 | last if is_miniperl; |
820 | $tests ++; | |
821 | my $dir = tempdir(uc cleanup => 1); | |
822 | my $tmpfilenam = catfile $dir, 'aaa'; | |
823 | open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!"; | |
824 | close $fh or die "cannot close $tmpfilenam: $!"; | |
825 | &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb'); | |
826 | ok open(my $fh, '>', $tmpfilenam), '&rename'; | |
47ac839d FC |
827 | } |
828 | ||
829 | test_proto 'ref', [], 'ARRAY'; | |
830 | ||
f650fa72 FC |
831 | test_proto 'reset'; |
832 | $tests += 2; | |
833 | my $oncer = sub { "a" =~ m?a? }; | |
834 | &$oncer; | |
835 | &myreset; | |
1eaae977 | 836 | ok &$oncer, '&reset with no args'; |
f650fa72 FC |
837 | package resettest { |
838 | $b = "c"; | |
839 | $banana = "cream"; | |
840 | &::myreset('b'); | |
1eaae977 | 841 | ::lis [$b,$banana],[(undef)x2], '1-arg &reset'; |
f650fa72 FC |
842 | } |
843 | ||
47ac839d FC |
844 | test_proto 'reverse'; |
845 | $tests += 2; | |
846 | is &myreverse('reward'), 'drawer', '&reverse'; | |
847 | lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'], | |
848 | '&reverse in list context'; | |
849 | ||
850 | test_proto 'rewinddir'; | |
851 | ||
852 | test_proto 'rindex'; | |
853 | $tests += 3; | |
854 | is &myrindex("foffooo","o",2),1,'&rindex'; | |
855 | lis [&myrindex("foffooo","o",2)],[1],'&rindex in list context'; | |
856 | is &myrindex("foffooo","o"),6,'&rindex with 2 args'; | |
857 | ||
858 | test_proto 'rmdir'; | |
859 | ||
d33bb3da FC |
860 | test_proto 'scalar'; |
861 | $tests += 2; | |
862 | is &myscalar(3), 3, '&scalar'; | |
863 | lis [&myscalar(3)], [3], '&scalar in list cx'; | |
864 | ||
47ac839d FC |
865 | test_proto 'seek'; |
866 | { | |
7d997a14 PE |
867 | last if is_miniperl; |
868 | $tests += 1; | |
869 | open my $fh, "<", \"misled" or die $!; | |
870 | &myseek($fh, 2, 0); | |
871 | is <$fh>, 'sled', '&seek in action'; | |
47ac839d FC |
872 | } |
873 | ||
874 | test_proto 'seekdir'; | |
720d5b2f FC |
875 | |
876 | # Can’t test_proto, as it has none | |
877 | $tests += 8; | |
878 | *myselect = \&CORE::select; | |
879 | is defined prototype &myselect, defined prototype "CORE::select", | |
7d997a14 | 880 | 'prototype of &select (or lack thereof)'; |
720d5b2f FC |
881 | is &myselect, select, '&select with no args'; |
882 | { | |
883 | my $prev = select; | |
884 | is &myselect(my $fh), $prev, '&select($arg) retval'; | |
885 | is lc ref $fh, 'glob', '&select autovivifies'; | |
db9848c8 | 886 | is select, $fh, '&select selects'; |
720d5b2f FC |
887 | select $prev; |
888 | } | |
889 | eval { &myselect(1,2) }; | |
890 | like $@, qr/^Not enough arguments for select system call at /, | |
7d997a14 | 891 | '&myselect($two,$args)'; |
720d5b2f FC |
892 | eval { &myselect(1,2,3) }; |
893 | like $@, qr/^Not enough arguments for select system call at /, | |
7d997a14 | 894 | '&myselect($with,$three,$args)'; |
720d5b2f FC |
895 | eval { &myselect(1,2,3,4,5) }; |
896 | like $@, qr/^Too many arguments for select system call at /, | |
7d997a14 | 897 | '&myselect($a,$total,$of,$five,$args)'; |
74416803 | 898 | unless ($^O eq "MSWin32" && is_miniperl) { |
7d997a14 PE |
899 | &myselect((undef)x3,.25); |
900 | # Just have to assume that worked. :-) If we get here, at least it didn’t | |
901 | # crash or anything. | |
902 | # select() is unimplemented in Win32 miniperl | |
74416803 | 903 | } |
720d5b2f | 904 | |
47ac839d FC |
905 | test_proto "sem$_" for qw "ctl get op"; |
906 | ||
1ed240b7 FC |
907 | test_proto 'send'; |
908 | ||
47ac839d | 909 | test_proto "set$_" for qw ' |
92f2ac5f FC |
910 | grent hostent netent |
911 | '; | |
912 | ||
913 | test_proto 'setpgrp'; | |
914 | $tests +=2; | |
915 | eval { &mysetpgrp( 0) }; | |
916 | pass "&setpgrp with one argument"; | |
917 | eval { &mysetpgrp }; | |
918 | pass "&setpgrp with no arguments"; | |
919 | ||
920 | test_proto "set$_" for qw ' | |
921 | priority protoent pwent servent sockopt | |
47ac839d FC |
922 | '; |
923 | ||
bea284c8 FC |
924 | test_proto 'shift'; |
925 | $tests += 6; | |
926 | @ARGV = qw<a b c>; | |
927 | is &myshift(), 'a', 'retval of &shift with no args (@ARGV)'; | |
928 | is "@ARGV", "b c", 'effect of &shift on @ARGV'; | |
929 | sub { | |
930 | is &myshift(), 'q', 'retval of &shift with no args (@_)'; | |
931 | is "@_", "j k", 'effect of &shift on @_'; | |
932 | }->(qw(q j k)); | |
933 | { | |
934 | my @a = 1..4; | |
935 | is &myshift(\@a), 1, 'retval of &shift'; | |
936 | lis [@a], [2..4], 'effect of &shift'; | |
937 | } | |
938 | ||
47ac839d FC |
939 | test_proto "shm$_" for qw "ctl get read write"; |
940 | test_proto 'shutdown'; | |
941 | test_proto 'sin'; | |
0da4a804 | 942 | test_proto 'sleep'; |
47ac839d FC |
943 | test_proto "socket$_" for "", "pair"; |
944 | ||
bea284c8 FC |
945 | test_proto 'splice'; |
946 | $tests += 8; | |
947 | { | |
948 | my @a = qw<a b c>; | |
949 | is &mysplice(\@a, 1), 'c', 'retval of 2-arg &splice in scalar context'; | |
950 | lis \@a, ['a'], 'effect of 2-arg &splice in scalar context'; | |
951 | @a = qw<a b c>; | |
952 | lis [&mysplice(\@a, 1)], ['b','c'], 'retval of 2-arg &splice in list cx'; | |
953 | lis \@a, ['a'], 'effect of 2-arg &splice in list context'; | |
954 | @a = qw<a b c d>; | |
955 | lis [&mysplice(\@a,1,2)],['b','c'], 'retval of 3-arg &splice in list cx'; | |
956 | lis \@a, ['a','d'], 'effect of 3-arg &splice in list context'; | |
957 | @a = qw<a b c d>; | |
958 | lis [&mysplice(\@a,1,1,'e')],['b'], 'retval of 4-arg &splice in list cx'; | |
959 | lis \@a, [qw<a e c d>], 'effect of 4-arg &splice in list context'; | |
960 | } | |
961 | ||
47ac839d FC |
962 | test_proto 'sprintf'; |
963 | $tests += 2; | |
964 | is &mysprintf("%x", 65), '41', '&sprintf'; | |
965 | lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context'; | |
966 | ||
967 | test_proto 'sqrt', 4, 2; | |
d22667bf FC |
968 | |
969 | test_proto 'srand'; | |
970 | $tests ++; | |
971 | &CORE::srand; | |
0a5f3363 | 972 | () = &CORE::srand; |
d22667bf FC |
973 | pass '&srand with no args does not crash'; |
974 | ||
d80ed303 FC |
975 | test_proto 'study'; |
976 | ||
7bc95ae1 FC |
977 | test_proto 'substr'; |
978 | $tests += 5; | |
979 | $_ = "abc"; | |
980 | is &mysubstr($_, 1, 1, "d"), 'b', '4-arg &substr'; | |
981 | is $_, 'adc', 'what 4-arg &substr does'; | |
982 | is &mysubstr("abc", 1, 1), 'b', '3-arg &substr'; | |
983 | is &mysubstr("abc", 1), 'bc', '2-arg &substr'; | |
984 | &mysubstr($_, 1) = 'long'; | |
985 | is $_, 'along', 'lvalue &substr'; | |
986 | ||
47ac839d FC |
987 | test_proto 'symlink'; |
988 | test_proto 'syscall'; | |
de5e49e1 FC |
989 | |
990 | test_proto 'sysopen'; | |
991 | $tests +=2; | |
992 | { | |
993 | &mysysopen(my $fh, 'test.pl', 0); | |
994 | pass '&sysopen does not crash with 3 args'; | |
995 | ok $fh, 'sysopen autovivifies'; | |
996 | } | |
997 | ||
17008668 | 998 | test_proto 'sysread'; |
47ac839d | 999 | test_proto 'sysseek'; |
1ed240b7 | 1000 | test_proto 'syswrite'; |
b64a1294 FC |
1001 | |
1002 | test_proto 'tell'; | |
1003 | { | |
1004 | $tests += 2; | |
1005 | open my $fh, "test.pl" or die "Cannot open test.pl"; | |
1006 | <$fh>; | |
1007 | is &mytell(), tell($fh), '&tell with no args'; | |
1008 | is &mytell($fh), tell($fh), '&tell with an arg'; | |
1009 | } | |
1010 | ||
47ac839d FC |
1011 | test_proto 'telldir'; |
1012 | ||
efe889ae FC |
1013 | test_proto 'tie'; |
1014 | test_proto 'tied'; | |
1015 | $tests += 3; | |
1016 | { | |
1017 | my $fetches; | |
1018 | package tier { | |
1019 | sub TIESCALAR { bless[] } | |
1020 | sub FETCH { ++$fetches } | |
1021 | } | |
1022 | my $tied; | |
1023 | my $obj = &mytie(\$tied, 'tier'); | |
1024 | is &mytied(\$tied), $obj, '&tie and &tied retvals'; | |
1025 | () = "$tied"; | |
1026 | is $fetches, 1, '&tie actually ties'; | |
1027 | &CORE::untie(\$tied); | |
1028 | () = "$tied"; | |
1029 | is $fetches, 1, '&untie unties'; | |
1030 | } | |
1031 | ||
47ac839d FC |
1032 | test_proto 'time'; |
1033 | $tests += 2; | |
aaa63dae AB |
1034 | like &mytime, qr/^\d+\z/, '&time in scalar context'; |
1035 | like join('-', &mytime), qr/^\d+\z/, '&time in list context'; | |
47ac839d FC |
1036 | |
1037 | test_proto 'times'; | |
1038 | $tests += 2; | |
aaa63dae AB |
1039 | like &mytimes, qr/^[\d.]+\z/, '× in scalar context'; |
1040 | like join('-',&mytimes), qr/^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z/, | |
7d997a14 | 1041 | '× in list context'; |
47ac839d FC |
1042 | |
1043 | test_proto 'uc', 'aa', 'AA'; | |
1044 | test_proto 'ucfirst', 'aa', "Aa"; | |
58536d15 FC |
1045 | |
1046 | test_proto 'umask'; | |
1047 | $tests ++; | |
1048 | is &myumask, umask, '&umask with no args'; | |
1049 | ||
46bef06f | 1050 | test_proto 'undef'; |
88bb468b | 1051 | $tests += 12; |
46bef06f FC |
1052 | is &myundef(), undef, '&undef returns undef'; |
1053 | lis [&myundef()], [undef], '&undef returns undef in list cx'; | |
1054 | lis [&myundef(\$_)], [undef], '&undef(...) returns undef in list cx'; | |
1055 | is \&myundef(), \undef, '&undef returns the right undef'; | |
1056 | $_ = 'anserine questions'; | |
1057 | &myundef(\$_); | |
1058 | is $_, undef, '&undef(\$_) undefines $_'; | |
1059 | @_ = 1..3; | |
1060 | &myundef(\@_); | |
1061 | is @_, 0, '&undef(\@_) undefines @_'; | |
1062 | %_ = 1..4; | |
1063 | &myundef(\%_); | |
1064 | ok !%_, '&undef(\%_) undefines %_'; | |
1065 | &myundef(\&utf8::valid); # nobody should be using this :-) | |
1066 | ok !defined &utf8::valid, '&undef(\&foo) undefines &foo'; | |
1067 | @_ = \*_; | |
1068 | &myundef; | |
88bb468b FC |
1069 | is *_{ARRAY}, undef, '@_=\*_, &undef undefines *_'; |
1070 | @_ = \*_; | |
1071 | &myundef(\*_); | |
46bef06f | 1072 | is *_{ARRAY}, undef, '&undef(\*_) undefines *_'; |
c4ec50f1 FC |
1073 | (&myundef(), @_) = 1..10; |
1074 | lis \@_, [2..10], 'list assignment to &undef()'; | |
1075 | ok !defined undef, 'list assignment to &undef() does not affect undef'; | |
46bef06f FC |
1076 | undef @_; |
1077 | ||
d6d78e19 FC |
1078 | test_proto 'unpack'; |
1079 | $tests += 2; | |
7d997a14 PE |
1080 | my $abcd_as_a_hex_string = |
1081 | join "", map { sprintf("%2X", utf8::unicode_to_native($_)) } 0x61, 0x62, 0x63, 0x64; | |
1082 | my $bcde_as_a_hex_string = | |
1083 | join "", map { sprintf("%2X", utf8::unicode_to_native($_)) } 0x62, 0x63, 0x64, 0x65; | |
d6d78e19 | 1084 | $_ = 'abcd'; |
33eaa0ec KW |
1085 | is &myunpack("H*"), $abcd_as_a_hex_string, '&unpack with one arg'; |
1086 | is &myunpack("H*", "bcde"), $bcde_as_a_hex_string, '&unpack with two arg'; | |
d6d78e19 FC |
1087 | |
1088 | ||
bea284c8 FC |
1089 | test_proto 'unshift'; |
1090 | $tests += 2; | |
1091 | { | |
1092 | my @a = qw<a b c>; | |
1093 | is &myunshift(\@a, "d", "e"), 5, 'retval of &unshift'; | |
1094 | is "@a", "d e a b c", 'effect of &unshift'; | |
1095 | } | |
1096 | ||
efe889ae | 1097 | test_proto 'untie'; # behaviour already tested along with tie(d) |
47ac839d FC |
1098 | |
1099 | test_proto 'utime'; | |
1100 | $tests += 2; | |
1101 | is &myutime(undef,undef), 0, '&utime'; | |
1102 | lis [&myutime(undef,undef)], [0], '&utime in list context'; | |
1103 | ||
73665bc4 FC |
1104 | test_proto 'values'; |
1105 | $tests += 4; | |
1106 | is &myvalues({ 1..4 }), 2, '&myvalues(\%hash) in scalar cx'; | |
1107 | lis [sort &myvalues({1..4})], [2,4], '&myvalues(\%hash) in list cx'; | |
1108 | is &myvalues([ 1..4 ]), 4, '&myvalues(\@array) in scalar cx'; | |
f7ce57d8 | 1109 | lis [&myvalues([ 1..4 ])], [1..4], '&myvalues(\@array) in list cx'; |
73665bc4 | 1110 | |
47ac839d FC |
1111 | test_proto 'vec'; |
1112 | $tests += 3; | |
1113 | is &myvec("foo", 0, 4), 6, '&vec'; | |
1114 | lis [&myvec("foo", 0, 4)], [6], '&vec in list context'; | |
1115 | $tmp = "foo"; | |
1116 | ++&myvec($tmp,0,4); | |
1117 | is $tmp, "goo", 'lvalue &vec'; | |
1118 | ||
1119 | test_proto 'wait'; | |
1120 | test_proto 'waitpid'; | |
1121 | ||
1122 | test_proto 'wantarray'; | |
1123 | $tests += 4; | |
1124 | my $context; | |
1125 | my $cx_sub = sub { | |
1126 | $context = qw[void scalar list][&mywantarray + defined mywantarray()] | |
1127 | }; | |
1128 | () = &$cx_sub; | |
1129 | is $context, 'list', '&wantarray with caller in list context'; | |
1130 | scalar &$cx_sub; | |
1131 | is($context, 'scalar', '&wantarray with caller in scalar context'); | |
1132 | &$cx_sub; | |
1133 | is($context, 'void', '&wantarray with caller in void context'); | |
1134 | lis [&mywantarray],[wantarray], '&wantarray itself in list context'; | |
1135 | ||
1136 | test_proto 'warn'; | |
1137 | { $tests += 3; | |
1138 | my $w; | |
1139 | local $SIG{__WARN__} = sub { $w = shift }; | |
1140 | is &mywarn('a'), 1, '&warn retval'; | |
1141 | is $w, "a at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'warning'; | |
1142 | lis [&mywarn()], [1], '&warn retval in list context'; | |
1143 | } | |
1144 | ||
96db40ac FC |
1145 | test_proto 'write'; |
1146 | $tests ++; | |
1147 | eval {&mywrite}; | |
1148 | like $@, qr'^Undefined format "STDOUT" called', | |
7d997a14 | 1149 | "&write without arguments can handle the null"; |
96db40ac | 1150 | |
47ac839d FC |
1151 | # This is just a check to make sure we have tested everything. If we |
1152 | # haven’t, then either the sub needs to be tested or the list in | |
1153 | # gv.c is wrong. | |
1154 | { | |
1155 | last if is_miniperl; | |
1156 | require File::Spec::Functions; | |
1157 | my $keywords_file = | |
7d997a14 | 1158 | File::Spec::Functions::catfile( |
47ac839d | 1159 | File::Spec::Functions::updir,'regen','keywords.pl' |
7d997a14 | 1160 | ); |
b0df1b47 | 1161 | my %nottest_words = map { $_ => 1 } qw( |
99b497aa | 1162 | ADJUST AUTOLOAD BEGIN CHECK CORE DESTROY END INIT UNITCHECK |
b0df1b47 | 1163 | __DATA__ __END__ |
99b497aa PE |
1164 | and catch class cmp default defer do dump else elsif eq eval field finally |
1165 | for foreach format ge given goto grep gt if isa last le local lt m map | |
1166 | method my ne next no or our package print printf q qq qr qw qx redo require | |
1167 | return s say sort state sub tr try unless until use when while x xor y | |
b0df1b47 | 1168 | ); |
47ac839d FC |
1169 | open my $kh, $keywords_file |
1170 | or die "$0 cannot open $keywords_file: $!"; | |
1171 | while(<$kh>) { | |
94c7f5d8 | 1172 | if (m?__END__?..${\0} and /^[-+](.*)/) { |
47ac839d | 1173 | my $word = $1; |
b0df1b47 | 1174 | next if $nottest_words{$word}; |
47ac839d FC |
1175 | $tests ++; |
1176 | ok exists &{"my$word"} | |
1177 | || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/), | |
7d997a14 | 1178 | "$word either has been tested or is not ampable"; |
47ac839d FC |
1179 | } |
1180 | } | |
1181 | } | |
1182 | ||
1183 | # Add new tests above this line. | |
1184 | ||
1185 | # This test must come last (before the test count test): | |
1186 | ||
1187 | { | |
1188 | last if is_miniperl; | |
d3288251 CB |
1189 | require Cwd; |
1190 | import Cwd; | |
d6d78e19 | 1191 | $tests += 3; |
47ac839d FC |
1192 | require File::Temp ; |
1193 | my $dir = File::Temp::tempdir(uc cleanup => 1); | |
d3288251 | 1194 | my $cwd = cwd(); |
47ac839d | 1195 | chdir($dir); |
d6d78e19 FC |
1196 | |
1197 | # Make sure that implicit $_ is not applied to mkdir’s second argument. | |
1198 | local $^W = 1; | |
1199 | my $warnings; | |
1200 | local $SIG{__WARN__} = sub { ++$warnings }; | |
1201 | ||
7fba2966 | 1202 | local $_ = 'Phoo'; |
47ac839d | 1203 | ok &mymkdir(), '&mkdir'; |
d3288251 | 1204 | like <*>, qr/^phoo(.DIR)?\z/i, 'mkdir works with implicit $_'; |
d6d78e19 FC |
1205 | |
1206 | is $warnings, undef, 'no implicit $_ for second argument to mkdir'; | |
1207 | ||
d3288251 | 1208 | chdir($cwd); # so auto-cleanup can remove $dir |
47ac839d FC |
1209 | } |
1210 | ||
1211 | # ------------ END TESTING ----------- # | |
1212 | ||
cbfc5cbc | 1213 | done_testing $tests; |
47ac839d FC |
1214 | |
1215 | #line 3 frob | |
1216 | ||
1217 | sub file { &CORE::__FILE__ } | |
1218 | sub line { &CORE::__LINE__ } # 5 | |
1219 | sub dier { &CORE::die(@_) } # 6 | |
1220 | package stribble; | |
1221 | sub main::pakg { &CORE::__PACKAGE__ } | |
1222 | ||
1223 | # Please do not add new tests here. | |
1224 | package main; | |
1225 | CORE::__DATA__ | |
1226 | I wandered lonely as a cloud | |
f298f061 | 1227 | That floats on high o'er vales and hills, |
47ac839d FC |
1228 | And all at once I saw a crowd, |
1229 | A host of golden daffodils! | |
1230 | Beside the lake, beneath the trees, | |
1231 | Fluttering, dancing, in the breeze. | |
1232 | -- Wordsworth |