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'; | |
12 | @INC = qw(. ../lib); | |
13 | require "test.pl"; | |
14 | $^P |= 0x100; | |
15 | } | |
16 | # Since tests inside evals can too easily fail silently, we cannot rely | |
17 | # on done_testing. It’s much easier to count the tests as we go than to | |
18 | # declare the plan up front, so this script ends with a test that makes | |
19 | # sure the right number of tests have happened. | |
20 | ||
21 | sub lis($$;$) { | |
22 | &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]); | |
23 | } | |
24 | ||
17008668 FC |
25 | package hov { |
26 | use overload '%{}' => sub { +{} } | |
27 | } | |
28 | package sov { | |
29 | use overload '${}' => sub { \my $x } | |
30 | } | |
31 | ||
47ac839d | 32 | my %op_desc = ( |
7d789282 | 33 | evalbytes=> 'eval "string"', |
47ac839d FC |
34 | join => 'join or string', |
35 | readline => '<HANDLE>', | |
36 | readpipe => 'quoted execution (``, qx)', | |
f650fa72 | 37 | reset => 'symbol reset', |
47ac839d FC |
38 | ref => 'reference-type operator', |
39 | ); | |
40 | sub op_desc($) { | |
41 | return $op_desc{$_[0]} || $_[0]; | |
42 | } | |
43 | ||
44 | ||
45 | # This tests that the &{} syntax respects the number of arguments implied | |
46 | # by the prototype, plus some extra tests for the (_) prototype. | |
47 | sub test_proto { | |
48 | my($o) = shift; | |
49 | ||
50 | # Create an alias, for the caller’s convenience. | |
51 | *{"my$o"} = \&{"CORE::$o"}; | |
52 | ||
53 | my $p = prototype "CORE::$o"; | |
d6d78e19 | 54 | $p = '$;$' if $p eq '$_'; |
47ac839d FC |
55 | |
56 | if ($p eq '') { | |
57 | $tests ++; | |
58 | ||
59 | eval " &CORE::$o(1) "; | |
60 | like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; | |
61 | ||
62 | } | |
63 | elsif ($p eq '_') { | |
64 | $tests ++; | |
65 | ||
66 | eval " &CORE::$o(1,2) "; | |
67 | my $desc = quotemeta op_desc($o); | |
68 | like $@, qr/^Too many arguments for $desc at /, | |
69 | "&$o with too many args"; | |
70 | ||
71 | if (!@_) { return } | |
72 | ||
73 | $tests += 6; | |
74 | ||
75 | my($in,$out) = @_; # for testing implied $_ | |
76 | ||
77 | # Since we have $in and $out values, we might as well test basic amper- | |
78 | # sand calls, too. | |
79 | ||
80 | is &{"CORE::$o"}($in), $out, "&$o"; | |
81 | lis [&{"CORE::$o"}($in)], [$out], "&$o in list context"; | |
82 | ||
83 | $_ = $in; | |
84 | is &{"CORE::$o"}(), $out, "&$o with no args"; | |
85 | ||
86 | # Since there is special code to deal with lexical $_, make sure it | |
87 | # works in all cases. | |
88 | undef $_; | |
89 | { | |
90 | my $_ = $in; | |
91 | is &{"CORE::$o"}(), $out, "&$o with no args uses lexical \$_"; | |
92 | } | |
93 | # Make sure we get the right pad under recursion | |
94 | my $r; | |
95 | $r = sub { | |
96 | if($_[0]) { | |
97 | my $_ = $in; | |
98 | is &{"CORE::$o"}(), $out, | |
99 | "&$o with no args uses the right lexical \$_ under recursion"; | |
100 | } | |
101 | else { | |
102 | &$r(1) | |
103 | } | |
104 | }; | |
105 | &$r(0); | |
106 | my $_ = $in; | |
107 | eval { | |
108 | is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval" | |
109 | }; | |
110 | } | |
111 | elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc. | |
112 | my $maxargs = length $1; | |
113 | $tests += 1; | |
114 | eval " &CORE::$o((1)x($maxargs+1)) "; | |
115 | my $desc = quotemeta op_desc($o); | |
116 | like $@, qr/^Too many arguments for $desc at /, | |
117 | "&$o with too many args"; | |
118 | } | |
119 | elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or *** | |
120 | my $args = length $1; | |
121 | $tests += 2; | |
7d789282 | 122 | my $desc = quotemeta op_desc($o); |
47ac839d | 123 | eval " &CORE::$o((1)x($args-1)) "; |
7d789282 | 124 | like $@, qr/^Not enough arguments for $desc at /, "&$o w/too few args"; |
47ac839d | 125 | eval " &CORE::$o((1)x($args+1)) "; |
7d789282 | 126 | like $@, qr/^Too many arguments for $desc at /, "&$o w/too many args"; |
47ac839d FC |
127 | } |
128 | elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or *** | |
129 | my $minargs = length $1; | |
130 | my $maxargs = $minargs + length $2; | |
131 | $tests += 2; | |
132 | eval " &CORE::$o((1)x($minargs-1)) "; | |
133 | like $@, qr/^Not enough arguments for $o at /, "&$o with too few args"; | |
134 | eval " &CORE::$o((1)x($maxargs+1)) "; | |
135 | like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; | |
136 | } | |
137 | elsif ($p eq '_;$') { | |
138 | $tests += 1; | |
139 | ||
140 | eval " &CORE::$o(1,2,3) "; | |
141 | like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; | |
142 | } | |
143 | elsif ($p eq '@') { | |
144 | # Do nothing, as we cannot test for too few or too many arguments. | |
145 | } | |
146 | elsif ($p =~ '^[$*;]+@\z') { | |
147 | $tests ++; | |
148 | $p =~ ';@'; | |
149 | my $minargs = $-[0]; | |
150 | eval " &CORE::$o((1)x($minargs-1)) "; | |
151 | my $desc = quotemeta op_desc($o); | |
152 | like $@, qr/^Not enough arguments for $desc at /, | |
153 | "&$o with too few args"; | |
154 | } | |
17008668 FC |
155 | elsif ($p =~ /^\*\\\$\$(;?)\$\z/) { # *\$$$ and *\$$;$ |
156 | $tests += 5; | |
157 | ||
158 | eval "&CORE::$o(1,1,1,1,1)"; | |
159 | like $@, qr/^Too many arguments for $o at /, | |
160 | "&$o with too many args"; | |
161 | eval " &CORE::$o((1)x(\$1?2:3)) "; | |
162 | like $@, qr/^Not enough arguments for $o at /, | |
163 | "&$o with too few args"; | |
164 | eval " &CORE::$o(1,[],1,1) "; | |
165 | like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /, | |
166 | "&$o with array ref arg"; | |
167 | eval " &CORE::$o(1,1,1,1) "; | |
168 | like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /, | |
169 | "&$o with scalar arg"; | |
170 | eval " &CORE::$o(1,bless([], 'sov'),1,1) "; | |
171 | like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /, | |
172 | "&$o with non-scalar arg w/scalar overload (which does not count)"; | |
173 | } | |
47ac839d FC |
174 | elsif ($p =~ /^\\%\$*\z/) { # \% and \%$$ |
175 | $tests += 5; | |
176 | ||
177 | eval "&CORE::$o(" . join(",", (1) x length $p) . ")"; | |
178 | like $@, qr/^Too many arguments for $o at /, | |
179 | "&$o with too many args"; | |
180 | eval " &CORE::$o(" . join(",", (1) x (length($p)-2)) . ") "; | |
181 | like $@, qr/^Not enough arguments for $o at /, | |
182 | "&$o with too few args"; | |
183 | my $moreargs = ",1" x (length($p) - 2); | |
184 | eval " &CORE::$o([]$moreargs) "; | |
185 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, | |
186 | "&$o with array ref arg"; | |
187 | eval " &CORE::$o(*foo$moreargs) "; | |
188 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, | |
189 | "&$o with typeglob arg"; | |
190 | eval " &CORE::$o(bless([], 'hov')$moreargs) "; | |
191 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, | |
192 | "&$o with non-hash arg with hash overload (which does not count)"; | |
193 | } | |
efe889ae FC |
194 | elsif ($p =~ /^\\\[(\$\@%&?\*)](\$\@)?\z/) { |
195 | $tests += 4; | |
47ac839d | 196 | |
efe889ae FC |
197 | unless ($2) { |
198 | $tests ++; | |
199 | eval " &CORE::$o(1,2) "; | |
200 | like $@, qr/^Too many arguments for $o at /, | |
201 | "&$o with too many args"; | |
202 | } | |
203 | eval { &{"CORE::$o"}($2 ? 1 : ()) }; | |
47ac839d FC |
204 | like $@, qr/^Not enough arguments for $o at /, |
205 | "&$o with too few args"; | |
efe889ae FC |
206 | my $more_args = $2 ? ',1' : ''; |
207 | eval " &CORE::$o(2$more_args) "; | |
47ac839d | 208 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: |
efe889ae | 209 | ) \[\Q$1\E] at /, |
47ac839d | 210 | "&$o with non-ref arg"; |
efe889ae | 211 | eval " &CORE::$o(*STDOUT{IO}$more_args) "; |
47ac839d | 212 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: |
efe889ae | 213 | ) \[\Q$1\E] at /, |
47ac839d FC |
214 | "&$o with ioref arg"; |
215 | my $class = ref *DATA{IO}; | |
efe889ae | 216 | eval " &CORE::$o(bless(*DATA{IO}, 'hov')$more_args) "; |
47ac839d | 217 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: |
efe889ae | 218 | ) \[\Q$1\E] at /, |
47ac839d FC |
219 | "&$o with ioref arg with hash overload (which does not count)"; |
220 | bless *DATA{IO}, $class; | |
efe889ae FC |
221 | if (do {$1 !~ /&/}) { |
222 | $tests++; | |
223 | eval " &CORE::$o(\\&scriggle$more_args) "; | |
224 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one (?x: | |
225 | )of \[\Q$1\E] at /, | |
226 | "&$o with coderef arg"; | |
227 | } | |
47ac839d FC |
228 | } |
229 | ||
230 | else { | |
231 | die "Please add tests for the $p prototype"; | |
232 | } | |
233 | } | |
234 | ||
235 | test_proto '__FILE__'; | |
236 | test_proto '__LINE__'; | |
237 | test_proto '__PACKAGE__'; | |
84ed0108 | 238 | test_proto '__SUB__'; |
47ac839d FC |
239 | |
240 | is file(), 'frob' , '__FILE__ does check its caller' ; ++ $tests; | |
241 | is line(), 5 , '__LINE__ does check its caller' ; ++ $tests; | |
242 | is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests; | |
84ed0108 FC |
243 | sub __SUB__test { &my__SUB__ } |
244 | is __SUB__test, \&__SUB__test, '&__SUB__'; ++ $tests; | |
47ac839d FC |
245 | |
246 | test_proto 'abs', -5, 5; | |
247 | ||
248 | test_proto 'accept'; | |
249 | $tests += 6; eval q{ | |
250 | is &CORE::accept(qw{foo bar}), undef, "&accept"; | |
251 | lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context"; | |
252 | ||
253 | &myaccept(my $foo, my $bar); | |
254 | is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument'; | |
255 | is $bar, undef, 'CORE::accept does not autovivify its second argument'; | |
256 | use strict; | |
257 | undef $foo; | |
258 | eval { 'myaccept'->($foo, $bar) }; | |
259 | like $@, qr/^Can't use an undefined value as a symbol reference at/, | |
260 | 'CORE::accept will not accept undef 2nd arg under strict'; | |
261 | is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict'; | |
262 | }; | |
263 | ||
264 | test_proto 'alarm'; | |
265 | test_proto 'atan2'; | |
266 | ||
267 | test_proto 'bind'; | |
268 | $tests += 3; | |
269 | is &CORE::bind('foo', 'bear'), undef, "&bind"; | |
270 | lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context"; | |
271 | eval { &mybind(my $foo, "bear") }; | |
272 | like $@, qr/^Bad symbol for filehandle at/, | |
273 | 'CORE::bind dies with undef first arg'; | |
274 | ||
275 | test_proto 'binmode'; | |
276 | $tests += 3; | |
277 | is &CORE::binmode(qw[foo bar]), undef, "&binmode"; | |
278 | lis [&CORE::binmode(qw[foo bar])], [undef], "&binmode in list context"; | |
279 | is &mybinmode(foo), undef, '&binmode with one arg'; | |
280 | ||
281 | test_proto 'bless'; | |
282 | $tests += 3; | |
283 | like &CORE::bless([],'parcel'), qr/^parcel=ARRAY/, "&bless"; | |
284 | like join(" ", &CORE::bless([],'parcel')), | |
285 | qr/^parcel=ARRAY(?!.* )/, "&bless in list context"; | |
286 | like &mybless([]), qr/^main=ARRAY/, '&bless with one arg'; | |
287 | ||
288 | test_proto 'break'; | |
289 | { $tests ++; | |
290 | my $tmp; | |
291 | CORE::given(1) { | |
292 | CORE::when(1) { | |
293 | &mybreak; | |
294 | $tmp = 'bad'; | |
295 | } | |
296 | } | |
297 | is $tmp, undef, '&break'; | |
298 | } | |
299 | ||
300 | test_proto 'caller'; | |
301 | $tests += 4; | |
302 | sub caller_test { | |
303 | is scalar &CORE::caller, 'hadhad', '&caller'; | |
304 | is scalar &CORE::caller(1), 'main', '&caller(1)'; | |
305 | lis [&CORE::caller], [caller], '&caller in list context'; | |
d90b3686 FC |
306 | # The last element of caller in list context is a hint hash, which |
307 | # may be a different hash for caller vs &CORE::caller, so an eq com- | |
308 | # parison (which lis() uses for convenience) won’t work. So just | |
309 | # pop the last element, since the rest are sufficient to prove that | |
310 | # &CORE::caller works. | |
311 | my @ampcaller = &CORE::caller(1); | |
312 | my @caller = caller(1); | |
313 | pop @ampcaller; pop @caller; | |
314 | lis \@ampcaller, \@caller, '&caller(1) in list context'; | |
47ac839d FC |
315 | } |
316 | sub { | |
317 | package hadhad; | |
318 | ::caller_test(); | |
319 | }->(); | |
320 | ||
321 | test_proto 'chmod'; | |
322 | $tests += 3; | |
323 | is &CORE::chmod(), 0, '&chmod with no args'; | |
324 | is &CORE::chmod(0666), 0, '&chmod'; | |
325 | lis [&CORE::chmod(0666)], [0], '&chmod in list context'; | |
326 | ||
327 | test_proto 'chown'; | |
328 | $tests += 4; | |
329 | is &CORE::chown(), 0, '&chown with no args'; | |
330 | is &CORE::chown(1), 0, '&chown with 1 arg'; | |
331 | is &CORE::chown(1,2), 0, '&chown'; | |
332 | lis [&CORE::chown(1,2)], [0], '&chown in list context'; | |
333 | ||
334 | test_proto 'chr', 5, "\5"; | |
335 | test_proto 'chroot'; | |
336 | ||
337 | test_proto 'close'; | |
338 | { | |
339 | last if is_miniperl; | |
340 | $tests += 3; | |
341 | ||
342 | open my $fh, ">", \my $buffalo; | |
343 | print $fh 'an address in the outskirts of Jersey'; | |
344 | ok &CORE::close($fh), '&CORE::close retval'; | |
345 | print $fh 'lalala'; | |
346 | is $buffalo, 'an address in the outskirts of Jersey', | |
347 | 'effect of &CORE::close'; | |
348 | # This has to be a separate variable from $fh, as re-using the same | |
349 | # variable can cause the tests to pass by accident. That actually hap- | |
350 | # pened during developement, because the second close() was reading | |
351 | # beyond the end of the stack and finding a $fh left over from before. | |
352 | open my $fh2, ">", \($buffalo = ''); | |
353 | select+(select($fh2), do { | |
354 | print "Nasusiro Tokasoni"; | |
355 | &CORE::close(); | |
356 | print "jfd"; | |
357 | is $buffalo, "Nasusiro Tokasoni", '&CORE::close with no args'; | |
358 | })[0]; | |
359 | } | |
360 | lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests; | |
361 | ||
362 | test_proto 'closedir'; | |
363 | $tests += 2; | |
364 | is &CORE::closedir(foo), undef, '&CORE::closedir'; | |
365 | lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context'; | |
366 | ||
367 | test_proto 'connect'; | |
368 | $tests += 2; | |
369 | is &CORE::connect('foo','bar'), undef, '&connect'; | |
370 | lis [&myconnect('foo','bar')], [undef], '&connect in list context'; | |
371 | ||
372 | test_proto 'continue'; | |
373 | $tests ++; | |
374 | CORE::given(1) { | |
375 | CORE::when(1) { | |
376 | &mycontinue(); | |
377 | } | |
378 | pass "&continue"; | |
379 | } | |
380 | ||
381 | test_proto 'cos'; | |
382 | test_proto 'crypt'; | |
383 | ||
384 | test_proto 'dbmclose'; | |
385 | test_proto 'dbmopen'; | |
386 | { | |
387 | last unless eval { require AnyDBM_File }; | |
388 | $tests ++; | |
389 | my $filename = tempfile(); | |
390 | &mydbmopen(\my %db, $filename, 0666); | |
391 | $db{1} = 2; $db{3} = 4; | |
392 | &mydbmclose(\%db); | |
393 | is scalar keys %db, 0, '&dbmopen and &dbmclose'; | |
394 | } | |
395 | ||
396 | test_proto 'die'; | |
397 | eval { dier('quinquangle') }; | |
398 | is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++; | |
399 | ||
400 | test_proto $_ for qw( | |
401 | endgrent endhostent endnetent endprotoent endpwent endservent | |
402 | ); | |
403 | ||
7d789282 FC |
404 | test_proto 'evalbytes'; |
405 | $tests += 4; | |
406 | { | |
407 | chop(my $upgraded = "use utf8; '\xc4\x80'" . chr 256); | |
408 | is &myevalbytes($upgraded), chr 256, '&evalbytes'; | |
409 | # Test hints | |
410 | require strict; | |
411 | strict->import; | |
412 | &myevalbytes(' | |
413 | is someone, "someone", "run-time hint bits do not leak into &evalbytes" | |
414 | '); | |
415 | use strict; | |
416 | BEGIN { $^H{coreamp} = 42 } | |
417 | $^H{coreamp} = 75; | |
418 | &myevalbytes(' | |
419 | BEGIN { | |
420 | is $^H{coreamp}, 42, "compile-time hh propagates into &evalbytes"; | |
421 | } | |
422 | ${"frobnicate"} | |
423 | '); | |
424 | like $@, qr/strict/, 'compile-time hint bits propagate into &evalbytes'; | |
425 | } | |
426 | ||
47ac839d FC |
427 | test_proto 'exit'; |
428 | $tests ++; | |
d3288251 | 429 | is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n", |
47ac839d FC |
430 | '&exit with no args'; |
431 | ||
432 | test_proto 'fork'; | |
433 | ||
434 | test_proto 'formline'; | |
435 | $tests += 3; | |
436 | is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval'; | |
437 | is $^A, ' 1 2', 'effect of &myformline'; | |
438 | lis [&myformline('@')], [1], '&myformline in list context'; | |
439 | ||
440 | test_proto 'exp'; | |
441 | test_proto 'fcntl'; | |
442 | ||
443 | test_proto 'fileno'; | |
444 | $tests += 2; | |
445 | is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno'; | |
446 | lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx'; | |
447 | ||
448 | test_proto 'flock'; | |
449 | test_proto 'fork'; | |
450 | ||
451 | test_proto 'getc'; | |
452 | { | |
453 | last if is_miniperl; | |
454 | $tests += 3; | |
455 | local *STDIN; | |
456 | open my $fh, "<", \(my $buf='falo'); | |
457 | open STDIN, "<", \(my $buf2 = 'bison'); | |
458 | is &mygetc($fh), 'f', '&mygetc'; | |
459 | is &mygetc(), 'b', '&mygetc with no args'; | |
460 | lis [&mygetc($fh)], ['a'], '&mygetc in list context'; | |
461 | } | |
462 | ||
463 | test_proto "get$_" for qw ' | |
464 | grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname | |
465 | netent peername | |
466 | '; | |
467 | ||
468 | test_proto 'getpgrp'; | |
469 | eval {&mygetpgrp()}; | |
470 | pass '&getpgrp with no args does not crash'; $tests++; | |
471 | ||
472 | test_proto "get$_" for qw ' | |
473 | ppid priority protobyname protobynumber protoent | |
474 | pwent pwnam pwuid servbyname servbyport servent sockname sockopt | |
475 | '; | |
476 | ||
477 | test_proto 'gmtime'; | |
478 | &CORE::gmtime; | |
479 | pass '&gmtime without args does not crash'; ++$tests; | |
480 | ||
481 | test_proto 'hex', ff=>255; | |
482 | ||
483 | test_proto 'index'; | |
484 | $tests += 3; | |
485 | is &myindex("foffooo","o",2),4,'&index'; | |
486 | lis [&myindex("foffooo","o",2)],[4],'&index in list context'; | |
487 | is &myindex("foffooo","o"),1,'&index with 2 args'; | |
488 | ||
489 | test_proto 'int', 1.5=>1; | |
490 | test_proto 'ioctl'; | |
491 | ||
492 | test_proto 'join'; | |
493 | $tests += 2; | |
494 | is &myjoin('a','b','c'), 'bac', '&join'; | |
495 | lis [&myjoin('a','b','c')], ['bac'], '&join in list context'; | |
496 | ||
497 | test_proto 'kill'; # set up mykill alias | |
498 | if ($^O ne 'riscos') { | |
499 | $tests ++; | |
500 | ok( &mykill(0, $$), '&kill' ); | |
501 | } | |
502 | ||
503 | test_proto 'lc', 'A', 'a'; | |
504 | test_proto 'lcfirst', 'AA', 'aA'; | |
505 | test_proto 'length', 'aaa', 3; | |
506 | test_proto 'link'; | |
507 | test_proto 'listen'; | |
508 | ||
509 | test_proto 'localtime'; | |
510 | &CORE::localtime; | |
511 | pass '&localtime without args does not crash'; ++$tests; | |
512 | ||
513 | test_proto 'lock'; | |
514 | $tests += 6; | |
515 | is \&mylock(\$foo), \$foo, '&lock retval when passed a scalar ref'; | |
516 | lis [\&mylock(\$foo)], [\$foo], '&lock in list context'; | |
517 | is &mylock(\@foo), \@foo, '&lock retval when passed an array ref'; | |
518 | is &mylock(\%foo), \%foo, '&lock retval when passed a ash ref'; | |
519 | is &mylock(\&foo), \&foo, '&lock retval when passed a code ref'; | |
520 | is \&mylock(\*foo), \*foo, '&lock retval when passed a glob ref'; | |
521 | ||
522 | test_proto 'log'; | |
523 | ||
524 | test_proto 'mkdir'; | |
525 | # mkdir is tested with implicit $_ at the end, to make the test easier | |
526 | ||
527 | test_proto "msg$_" for qw( ctl get rcv snd ); | |
528 | ||
529 | test_proto 'not'; | |
530 | $tests += 2; | |
531 | is &mynot(1), !1, '¬'; | |
532 | lis [&mynot(0)], [!0], '¬ in list context'; | |
533 | ||
534 | test_proto 'oct', '666', 438; | |
535 | ||
536 | test_proto 'open'; | |
537 | $tests += 5; | |
538 | $file = 'test.pl'; | |
539 | ok &myopen('file'), '&open with 1 arg' or warn "1-arg open: $!"; | |
540 | like <file>, qr|^#|, 'result of &open with 1 arg'; | |
541 | close file; | |
542 | { | |
543 | ok &myopen(my $fh, "test.pl"), 'two-arg &open'; | |
544 | ok $fh, '&open autovivifies'; | |
545 | like <$fh>, qr '^#', 'result of &open with 2 args'; | |
546 | last if is_miniperl; | |
547 | $tests +=2; | |
548 | ok &myopen(my $fh2, "<", \"sharummbles"), 'retval of 3-arg &open'; | |
549 | is <$fh2>, 'sharummbles', 'result of three-arg &open'; | |
550 | } | |
551 | ||
552 | test_proto 'opendir'; | |
553 | test_proto 'ord', chr(64), 64; | |
554 | ||
555 | test_proto 'pack'; | |
556 | $tests += 2; | |
557 | is &mypack("H*", '5065726c'), 'Perl', '&pack'; | |
558 | lis [&mypack("H*", '5065726c')], ['Perl'], '&pack in list context'; | |
559 | ||
560 | test_proto 'pipe'; | |
561 | test_proto 'quotemeta', '$', '\$'; | |
562 | ||
563 | test_proto 'rand'; | |
564 | $tests += 3; | |
565 | like &CORE::rand, qr/^0[.\d]*\z/, '&rand'; | |
566 | unlike join(" ", &CORE::rand), qr/ /, '&rand in list context'; | |
567 | &cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 2 args'); | |
568 | ||
17008668 FC |
569 | test_proto 'read'; |
570 | { | |
571 | last if is_miniperl; | |
572 | $tests += 5; | |
573 | open my $fh, "<", \(my $buff = 'morays have their mores'); | |
574 | ok &myread($fh, \my $input, 6), '&read with 3 args'; | |
575 | is $input, 'morays', 'value read by 3-arg &read'; | |
576 | ok &myread($fh, \$input, 6, 6), '&read with 4 args'; | |
577 | is $input, 'morays have ', 'value read by 4-arg &read'; | |
578 | is +()=&myread($fh, \$input, 6), 1, '&read in list context'; | |
579 | } | |
580 | ||
47ac839d FC |
581 | test_proto 'readdir'; |
582 | ||
583 | test_proto 'readline'; | |
584 | { | |
585 | local *ARGV = *DATA; | |
586 | $tests ++; | |
587 | is scalar &myreadline, | |
588 | "I wandered lonely as a cloud\n", '&readline w/no args'; | |
589 | } | |
590 | { | |
591 | last if is_miniperl; | |
592 | $tests += 2; | |
593 | open my $fh, "<", \(my $buff = <<END); | |
594 | The Recursive Problem | |
595 | --------------------- | |
596 | I have a problem I cannot solve. | |
597 | The problem is that I cannot solve it. | |
598 | END | |
599 | is &myreadline($fh), "The Recursive Problem\n", | |
600 | '&readline with 1 arg'; | |
601 | lis [&myreadline($fh)], [ | |
602 | "---------------------\n", | |
603 | "I have a problem I cannot solve.\n", | |
604 | "The problem is that I cannot solve it.\n", | |
605 | ], '&readline in list context'; | |
606 | } | |
607 | ||
608 | test_proto 'readlink'; | |
609 | test_proto 'readpipe'; | |
17008668 | 610 | test_proto 'recv'; |
47ac839d FC |
611 | |
612 | use if !is_miniperl, File::Spec::Functions, qw "catfile"; | |
613 | use if !is_miniperl, File::Temp, 'tempdir'; | |
614 | ||
615 | test_proto 'rename'; | |
616 | { | |
617 | last if is_miniperl; | |
618 | $tests ++; | |
619 | my $dir = tempdir(uc cleanup => 1); | |
620 | my $tmpfilenam = catfile $dir, 'aaa'; | |
621 | open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!"; | |
622 | close $fh or die "cannot close $tmpfilenam: $!"; | |
623 | &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb'); | |
624 | ok open(my $fh, '>', $tmpfilenam), '&rename'; | |
625 | } | |
626 | ||
627 | test_proto 'ref', [], 'ARRAY'; | |
628 | ||
f650fa72 FC |
629 | test_proto 'reset'; |
630 | $tests += 2; | |
631 | my $oncer = sub { "a" =~ m?a? }; | |
632 | &$oncer; | |
633 | &myreset; | |
634 | ok &$oncer, '&reset with one arg'; | |
635 | package resettest { | |
636 | $b = "c"; | |
637 | $banana = "cream"; | |
638 | &::myreset('b'); | |
639 | ::lis [$b,$banana],[(undef)x2], '2-arg &reset'; | |
640 | } | |
641 | ||
47ac839d FC |
642 | test_proto 'reverse'; |
643 | $tests += 2; | |
644 | is &myreverse('reward'), 'drawer', '&reverse'; | |
645 | lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'], | |
646 | '&reverse in list context'; | |
647 | ||
648 | test_proto 'rewinddir'; | |
649 | ||
650 | test_proto 'rindex'; | |
651 | $tests += 3; | |
652 | is &myrindex("foffooo","o",2),1,'&rindex'; | |
653 | lis [&myrindex("foffooo","o",2)],[1],'&rindex in list context'; | |
654 | is &myrindex("foffooo","o"),6,'&rindex with 2 args'; | |
655 | ||
656 | test_proto 'rmdir'; | |
657 | ||
658 | test_proto 'seek'; | |
659 | { | |
660 | last if is_miniperl; | |
661 | $tests += 1; | |
662 | open my $fh, "<", \"misled" or die $!; | |
663 | &myseek($fh, 2, 0); | |
664 | is <$fh>, 'sled', '&seek in action'; | |
665 | } | |
666 | ||
667 | test_proto 'seekdir'; | |
720d5b2f FC |
668 | |
669 | # Can’t test_proto, as it has none | |
670 | $tests += 8; | |
671 | *myselect = \&CORE::select; | |
672 | is defined prototype &myselect, defined prototype "CORE::select", | |
673 | 'prototype of &select (or lack thereof)'; | |
674 | is &myselect, select, '&select with no args'; | |
675 | { | |
676 | my $prev = select; | |
677 | is &myselect(my $fh), $prev, '&select($arg) retval'; | |
678 | is lc ref $fh, 'glob', '&select autovivifies'; | |
679 | is select=~s/\*//rug, (*$fh."")=~s/\*//rug, '&select selects'; | |
680 | select $prev; | |
681 | } | |
682 | eval { &myselect(1,2) }; | |
683 | like $@, qr/^Not enough arguments for select system call at /, | |
684 | ,'&myselect($two,$args)'; | |
685 | eval { &myselect(1,2,3) }; | |
686 | like $@, qr/^Not enough arguments for select system call at /, | |
687 | ,'&myselect($with,$three,$args)'; | |
688 | eval { &myselect(1,2,3,4,5) }; | |
689 | like $@, qr/^Too many arguments for select system call at /, | |
690 | ,'&myselect($a,$total,$of,$five,$args)'; | |
691 | &myselect((undef)x3,.25); | |
692 | # Just have to assume that worked. :-) If we get here, at least it didn’t | |
693 | # crash or anything. | |
694 | ||
47ac839d FC |
695 | test_proto "sem$_" for qw "ctl get op"; |
696 | ||
1ed240b7 FC |
697 | test_proto 'send'; |
698 | ||
47ac839d | 699 | test_proto "set$_" for qw ' |
92f2ac5f FC |
700 | grent hostent netent |
701 | '; | |
702 | ||
703 | test_proto 'setpgrp'; | |
704 | $tests +=2; | |
705 | eval { &mysetpgrp( 0) }; | |
706 | pass "&setpgrp with one argument"; | |
707 | eval { &mysetpgrp }; | |
708 | pass "&setpgrp with no arguments"; | |
709 | ||
710 | test_proto "set$_" for qw ' | |
711 | priority protoent pwent servent sockopt | |
47ac839d FC |
712 | '; |
713 | ||
714 | test_proto "shm$_" for qw "ctl get read write"; | |
715 | test_proto 'shutdown'; | |
716 | test_proto 'sin'; | |
0da4a804 | 717 | test_proto 'sleep'; |
47ac839d FC |
718 | test_proto "socket$_" for "", "pair"; |
719 | ||
720 | test_proto 'sprintf'; | |
721 | $tests += 2; | |
722 | is &mysprintf("%x", 65), '41', '&sprintf'; | |
723 | lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context'; | |
724 | ||
725 | test_proto 'sqrt', 4, 2; | |
d22667bf FC |
726 | |
727 | test_proto 'srand'; | |
728 | $tests ++; | |
729 | &CORE::srand; | |
730 | pass '&srand with no args does not crash'; | |
731 | ||
7bc95ae1 FC |
732 | test_proto 'substr'; |
733 | $tests += 5; | |
734 | $_ = "abc"; | |
735 | is &mysubstr($_, 1, 1, "d"), 'b', '4-arg &substr'; | |
736 | is $_, 'adc', 'what 4-arg &substr does'; | |
737 | is &mysubstr("abc", 1, 1), 'b', '3-arg &substr'; | |
738 | is &mysubstr("abc", 1), 'bc', '2-arg &substr'; | |
739 | &mysubstr($_, 1) = 'long'; | |
740 | is $_, 'along', 'lvalue &substr'; | |
741 | ||
47ac839d FC |
742 | test_proto 'symlink'; |
743 | test_proto 'syscall'; | |
de5e49e1 FC |
744 | |
745 | test_proto 'sysopen'; | |
746 | $tests +=2; | |
747 | { | |
748 | &mysysopen(my $fh, 'test.pl', 0); | |
749 | pass '&sysopen does not crash with 3 args'; | |
750 | ok $fh, 'sysopen autovivifies'; | |
751 | } | |
752 | ||
17008668 | 753 | test_proto 'sysread'; |
47ac839d | 754 | test_proto 'sysseek'; |
1ed240b7 | 755 | test_proto 'syswrite'; |
b64a1294 FC |
756 | |
757 | test_proto 'tell'; | |
758 | { | |
759 | $tests += 2; | |
760 | open my $fh, "test.pl" or die "Cannot open test.pl"; | |
761 | <$fh>; | |
762 | is &mytell(), tell($fh), '&tell with no args'; | |
763 | is &mytell($fh), tell($fh), '&tell with an arg'; | |
764 | } | |
765 | ||
47ac839d FC |
766 | test_proto 'telldir'; |
767 | ||
efe889ae FC |
768 | test_proto 'tie'; |
769 | test_proto 'tied'; | |
770 | $tests += 3; | |
771 | { | |
772 | my $fetches; | |
773 | package tier { | |
774 | sub TIESCALAR { bless[] } | |
775 | sub FETCH { ++$fetches } | |
776 | } | |
777 | my $tied; | |
778 | my $obj = &mytie(\$tied, 'tier'); | |
779 | is &mytied(\$tied), $obj, '&tie and &tied retvals'; | |
780 | () = "$tied"; | |
781 | is $fetches, 1, '&tie actually ties'; | |
782 | &CORE::untie(\$tied); | |
783 | () = "$tied"; | |
784 | is $fetches, 1, '&untie unties'; | |
785 | } | |
786 | ||
47ac839d FC |
787 | test_proto 'time'; |
788 | $tests += 2; | |
789 | like &mytime, '^\d+\z', '&time in scalar context'; | |
790 | like join('-', &mytime), '^\d+\z', '&time in list context'; | |
791 | ||
792 | test_proto 'times'; | |
793 | $tests += 2; | |
794 | like &mytimes, '^[\d.]+\z', '× in scalar context'; | |
795 | like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z', | |
796 | '× in list context'; | |
797 | ||
798 | test_proto 'uc', 'aa', 'AA'; | |
799 | test_proto 'ucfirst', 'aa', "Aa"; | |
58536d15 FC |
800 | |
801 | test_proto 'umask'; | |
802 | $tests ++; | |
803 | is &myumask, umask, '&umask with no args'; | |
804 | ||
d6d78e19 FC |
805 | test_proto 'unpack'; |
806 | $tests += 2; | |
807 | $_ = 'abcd'; | |
808 | is &myunpack("H*"), '61626364', '&unpack with one arg'; | |
809 | is &myunpack("H*", "bcde"), '62636465', '&unpack with two arg'; | |
810 | ||
811 | ||
efe889ae | 812 | test_proto 'untie'; # behaviour already tested along with tie(d) |
47ac839d FC |
813 | |
814 | test_proto 'utime'; | |
815 | $tests += 2; | |
816 | is &myutime(undef,undef), 0, '&utime'; | |
817 | lis [&myutime(undef,undef)], [0], '&utime in list context'; | |
818 | ||
819 | test_proto 'vec'; | |
820 | $tests += 3; | |
821 | is &myvec("foo", 0, 4), 6, '&vec'; | |
822 | lis [&myvec("foo", 0, 4)], [6], '&vec in list context'; | |
823 | $tmp = "foo"; | |
824 | ++&myvec($tmp,0,4); | |
825 | is $tmp, "goo", 'lvalue &vec'; | |
826 | ||
827 | test_proto 'wait'; | |
828 | test_proto 'waitpid'; | |
829 | ||
830 | test_proto 'wantarray'; | |
831 | $tests += 4; | |
832 | my $context; | |
833 | my $cx_sub = sub { | |
834 | $context = qw[void scalar list][&mywantarray + defined mywantarray()] | |
835 | }; | |
836 | () = &$cx_sub; | |
837 | is $context, 'list', '&wantarray with caller in list context'; | |
838 | scalar &$cx_sub; | |
839 | is($context, 'scalar', '&wantarray with caller in scalar context'); | |
840 | &$cx_sub; | |
841 | is($context, 'void', '&wantarray with caller in void context'); | |
842 | lis [&mywantarray],[wantarray], '&wantarray itself in list context'; | |
843 | ||
844 | test_proto 'warn'; | |
845 | { $tests += 3; | |
846 | my $w; | |
847 | local $SIG{__WARN__} = sub { $w = shift }; | |
848 | is &mywarn('a'), 1, '&warn retval'; | |
849 | is $w, "a at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'warning'; | |
850 | lis [&mywarn()], [1], '&warn retval in list context'; | |
851 | } | |
852 | ||
96db40ac FC |
853 | test_proto 'write'; |
854 | $tests ++; | |
855 | eval {&mywrite}; | |
856 | like $@, qr'^Undefined format "STDOUT" called', | |
857 | "&write without arguments can handle the null"; | |
858 | ||
47ac839d FC |
859 | # This is just a check to make sure we have tested everything. If we |
860 | # haven’t, then either the sub needs to be tested or the list in | |
861 | # gv.c is wrong. | |
862 | { | |
863 | last if is_miniperl; | |
864 | require File::Spec::Functions; | |
865 | my $keywords_file = | |
866 | File::Spec::Functions::catfile( | |
867 | File::Spec::Functions::updir,'regen','keywords.pl' | |
868 | ); | |
869 | open my $kh, $keywords_file | |
870 | or die "$0 cannot open $keywords_file: $!"; | |
871 | while(<$kh>) { | |
872 | if (m?__END__?..${\0} and /^[-](.*)/) { | |
873 | my $word = $1; | |
874 | next if | |
875 | $word =~ /^(?:CORE|and|cmp|dump|eq|ge|gt|le|lt|ne|or|x|xor)\z/; | |
876 | $tests ++; | |
877 | ok exists &{"my$word"} | |
878 | || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/), | |
879 | "$word either has been tested or is not ampable"; | |
880 | } | |
881 | } | |
882 | } | |
883 | ||
884 | # Add new tests above this line. | |
885 | ||
886 | # This test must come last (before the test count test): | |
887 | ||
888 | { | |
889 | last if is_miniperl; | |
d3288251 CB |
890 | require Cwd; |
891 | import Cwd; | |
d6d78e19 | 892 | $tests += 3; |
47ac839d FC |
893 | require File::Temp ; |
894 | my $dir = File::Temp::tempdir(uc cleanup => 1); | |
d3288251 | 895 | my $cwd = cwd(); |
47ac839d | 896 | chdir($dir); |
d6d78e19 FC |
897 | |
898 | # Make sure that implicit $_ is not applied to mkdir’s second argument. | |
899 | local $^W = 1; | |
900 | my $warnings; | |
901 | local $SIG{__WARN__} = sub { ++$warnings }; | |
902 | ||
47ac839d FC |
903 | my $_ = 'Phoo'; |
904 | ok &mymkdir(), '&mkdir'; | |
d3288251 | 905 | like <*>, qr/^phoo(.DIR)?\z/i, 'mkdir works with implicit $_'; |
d6d78e19 FC |
906 | |
907 | is $warnings, undef, 'no implicit $_ for second argument to mkdir'; | |
908 | ||
d3288251 | 909 | chdir($cwd); # so auto-cleanup can remove $dir |
47ac839d FC |
910 | } |
911 | ||
912 | # ------------ END TESTING ----------- # | |
913 | ||
914 | is curr_test, $tests+1, 'right number of tests'; | |
915 | done_testing; | |
916 | ||
917 | #line 3 frob | |
918 | ||
919 | sub file { &CORE::__FILE__ } | |
920 | sub line { &CORE::__LINE__ } # 5 | |
921 | sub dier { &CORE::die(@_) } # 6 | |
922 | package stribble; | |
923 | sub main::pakg { &CORE::__PACKAGE__ } | |
924 | ||
925 | # Please do not add new tests here. | |
926 | package main; | |
927 | CORE::__DATA__ | |
928 | I wandered lonely as a cloud | |
929 | That floats on high o’er vales and hills, | |
930 | And all at once I saw a crowd, | |
931 | A host of golden daffodils! | |
932 | Beside the lake, beneath the trees, | |
933 | Fluttering, dancing, in the breeze. | |
934 | -- Wordsworth |