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