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.
8 # Other tests for CORE subs are in coresubs.t
12 require "./test.pl"; require './charset_tools.pl';
14 set_up_inc( qw(. ../lib ../dist/if) );
17 no warnings 'experimental::smartmatch';
20 &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
24 use overload '%{}' => sub { +{} }
27 use overload '@{}' => sub { [] }
30 use overload '${}' => sub { \my $x }
34 evalbytes=> 'eval "string"',
35 join => 'join or string',
36 pos => 'match position',
37 prototype=> 'subroutine prototype',
38 readline => '<HANDLE>',
39 readpipe => 'quoted execution (``, qx)',
40 reset => 'symbol reset',
41 ref => 'reference-type operator',
42 undef => 'undef operator',
45 return $op_desc{$_[0]} || $_[0];
49 # This tests that the &{} syntax respects the number of arguments implied
50 # by the prototype, plus some extra tests for the (_) prototype.
54 # Create an alias, for the caller’s convenience.
55 *{"my$o"} = \&{"CORE::$o"};
57 my $p = prototype "CORE::$o";
58 $p = '$;$' if $p eq '$_';
63 eval " &CORE::$o(1) ";
64 like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
67 elsif ($p =~ /^_;?\z/) {
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";
79 my($in,$out) = @_; # for testing implied $_
81 # Since we have $in and $out values, we might as well test basic amper-
84 is &{"CORE::$o"}($in), $out, "&$o";
85 lis [&{"CORE::$o"}($in)], [$out], "&$o in list context";
88 is &{"CORE::$o"}(), $out, "&$o with no args";
90 elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc.
91 my $maxargs = length $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";
98 elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or ***
101 my $desc = quotemeta op_desc($o);
102 eval " &CORE::$o((1)x($args-1)) ";
103 like $@, qr/^Not enough arguments for $desc at /, "&$o w/too few args";
104 eval " &CORE::$o((1)x($args+1)) ";
105 like $@, qr/^Too many arguments for $desc at /, "&$o w/too many args";
107 elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or ***
108 my $minargs = length $1;
109 my $maxargs = $minargs + length $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";
116 elsif ($p eq '_;$') {
119 eval " &CORE::$o(1,2,3) ";
120 like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
123 # Do nothing, as we cannot test for too few or too many arguments.
125 elsif ($p =~ '^[$*;]+@\z') {
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";
134 elsif ($p =~ /^\*\\\$\$(;?)\$\z/) { # *\$$$ and *\$$;$
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)";
153 elsif ($p =~ /^\\%\$*\z/) { # \% and \%$$
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)";
173 elsif ($p =~ /^(;)?\\\[(\$\@%&?\*)](\$\@)?\z/) {
178 eval " &CORE::$o(1,2) ";
179 like $@, qr/^Too many arguments for ${\op_desc($o)} at /,
180 "&$o with too many args";
184 eval { &{"CORE::$o"}($3 ? 1 : ()) };
185 like $@, qr/^Not enough arguments for $o at /,
186 "&$o with too few args";
188 my $more_args = $3 ? ',1' : '';
189 eval " &CORE::$o(2$more_args) ";
190 like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
192 "&$o with non-ref arg";
193 eval " &CORE::$o(*STDOUT{IO}$more_args) ";
194 like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
196 "&$o with ioref arg";
197 my $class = ref *DATA{IO};
198 eval " &CORE::$o(bless(*DATA{IO}, 'hov')$more_args) ";
199 like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
201 "&$o with ioref arg with hash overload (which does not count)";
202 bless *DATA{IO}, $class;
203 if (do {$2 !~ /&/}) {
205 eval " &CORE::$o(\\&scriggle$more_args) ";
206 like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one (?x:
208 "&$o with coderef arg";
211 elsif ($p =~ /^;?\\\@([\@;])?/) { # ;\@ \@@ \@;$$@
215 eval { &{"CORE::$o"}() };
216 like $@, qr/^Not enough arguments for $o at /,
217 "&$o with too few args";
220 eval " &CORE::$o(\\\@1,2) ";
221 like $@, qr/^Too many arguments for $o at /,
222 "&$o with too many args";
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";
245 elsif ($p eq '\[%@]') {
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:
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:
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:
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:
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:
275 "&$o with scalarref arg";
277 elsif ($p eq ';\[$*]') {
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)";
296 die "Please add tests for the $p prototype";
300 # Test that &CORE::foo calls without parentheses (no new @_) can handle the
301 # total absence of any @_ without crashing.
305 pass('no crash with &CORE::foo when *_{ARRAY} is undef');
307 test_proto '__FILE__';
308 test_proto '__LINE__';
309 test_proto '__PACKAGE__';
310 test_proto '__SUB__';
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;
315 sub __SUB__test { &my__SUB__ }
316 is __SUB__test, \&__SUB__test, '&__SUB__'; ++ $tests;
318 test_proto 'abs', -5, 5;
322 if ($^O eq "MSWin32" && is_miniperl) {
324 skip "accept() not available in Win32 miniperl", 8
329 is &CORE::accept(qw{foo bar}), undef, "&accept";
330 lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context";
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';
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';
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';
360 test_proto 'binmode';
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';
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';
382 is $tmp, undef, '&break';
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';
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';
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';
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';
419 test_proto 'chr', 5, "\5";
427 open my $fh, ">", \my $buffalo;
428 print $fh 'an address in the outskirts of Jersey';
429 ok &CORE::close($fh), '&CORE::close retval';
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";
442 is $buffalo, "Nasusiro Tokasoni", '&CORE::close with no args';
445 lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests;
447 test_proto 'closedir';
449 is &CORE::closedir(foo), undef, '&CORE::closedir';
450 lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context';
452 test_proto 'connect';
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';
462 test_proto 'continue';
474 test_proto 'dbmclose';
475 test_proto 'dbmopen';
477 last unless eval { require AnyDBM_File };
479 my $filename = tempfile();
480 &mydbmopen(\my %db, $filename, 0666);
481 $db{1} = 2; $db{3} = 4;
483 is scalar keys %db, 0, '&dbmopen and &dbmclose';
484 my $Dfile = "$filename.pag";
486 ($Dfile) = <$filename*>;
489 unlink "$filename.sdbm_dir", $Dfile;
491 unlink "$filename.dir", $Dfile;
496 eval { dier('quinquangle') };
497 is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++;
499 test_proto $_ for qw(
500 endgrent endhostent endnetent endprotoent endpwent endservent
503 test_proto 'evalbytes';
506 my $U_100_bytes = byte_utf8a_to_utf8n("\xc4\x80");
507 chop(my $upgraded = "use utf8; $U_100_bytes" . chr 256);
508 is &myevalbytes($upgraded), chr 256, '&evalbytes';
513 is someone, "someone", "run-time hint bits do not leak into &evalbytes"
516 BEGIN { $^H{coreamp} = 42 }
520 is $^H{coreamp}, 42, "compile-time hh propagates into &evalbytes";
524 like $@, qr/strict/, 'compile-time hint bits propagate into &evalbytes';
529 is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n",
530 '&exit with no args';
534 test_proto 'formline';
536 is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval';
537 is $^A, ' 1 2', 'effect of &myformline';
538 lis [&myformline('@')], [1], '&myformline in list context';
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';
552 my $sharp_s = uni_to_native("\xdf");
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';
562 is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno';
563 lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx';
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';
580 test_proto "get$_" for qw '
581 grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname
585 test_proto 'getpgrp';
587 pass '&getpgrp with no args does not crash'; $tests++;
589 test_proto "get$_" for qw '
590 ppid priority protobyname protobynumber protoent
591 pwent pwnam pwuid servbyname servbyport servent sockname sockopt
594 # Make sure the following tests test what we think they are testing.
595 ok ! $CORE::{glob}, '*CORE::glob not autovivified yet'; $tests ++;
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 {};
604 is join($", &myglob()), "@_", '&glob without arguments';
605 is join($", &myglob("t/*.t")), "@_", '&glob with an arg';
610 pass '&gmtime without args does not crash'; ++$tests;
612 test_proto 'hex', ff=>255;
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';
620 test_proto 'int', 1.5=>1;
625 is &myjoin('a','b','c'), 'bac', '&join';
626 lis [&myjoin('a','b','c')], ['bac'], '&join in list context';
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';
636 skip "no Hash::Util on miniperl", 2, if is_miniperl;
638 sub Hash::Util::bucket_ratio (\%);
642 like Hash::Util::bucket_ratio(%h), qr!/(?:1024|2048)\z!, '&mykeys = changed number of buckets allocated';
643 eval { (&mykeys(\%h)) = 1025; };
644 like $@, qr/^Can't modify keys in list assignment at /;
647 test_proto 'kill'; # set up mykill alias
648 if ($^O ne 'riscos') {
650 ok( &mykill(0, $$), '&kill' );
653 test_proto 'lc', 'A', 'a';
654 test_proto 'lcfirst', 'AA', 'aA';
655 test_proto 'length', 'aaa', 3;
659 test_proto 'localtime';
661 pass '&localtime without args does not crash'; ++$tests;
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';
675 # mkdir is tested with implicit $_ at the end, to make the test easier
677 test_proto "msg$_" for qw( ctl get rcv snd );
681 is &mynot(1), !1, '¬';
682 lis [&mynot(0)], [!0], '¬ in list context';
684 test_proto 'oct', '666', 438;
689 ok &myopen('file'), '&open with 1 arg' or warn "1-arg open: $!";
690 like <file>, qr|^#|, 'result of &open with 1 arg';
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';
698 ok &myopen(my $fh2, "<", \"sharummbles"), 'retval of 3-arg &open';
699 is <$fh2>, 'sharummbles', 'result of three-arg &open';
702 test_proto 'opendir';
703 test_proto 'ord', chr(utf8::unicode_to_native(64)), utf8::unicode_to_native(64);
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';
718 is &mypop(), 'c', 'retval of &pop with no args (@ARGV)';
719 is "@ARGV", "a b", 'effect of &pop on @ARGV';
721 is &mypop(), 'k', 'retval of &pop with no args (@_)';
722 is "@_", "q j", 'effect of &pop on @_';
726 is &mypop(\@a), 4, 'retval of &pop';
727 lis [@a], [1..3], 'effect of &pop';
734 is &mypos, 3, 'reading &pos without args';
736 is pos, 4, 'writing to &pos without args';
740 is &mypos(\$x), 3, 'reading &pos without args';
742 is pos $x, 4, 'writing to &pos without args';
745 test_proto 'prototype';
747 is &myprototype(\&myprototype), prototype("CORE::prototype"), '&prototype';
753 is &mypush(\@a, "d", "e"), 5, 'retval of &push';
754 is "@a", "a b c d e", 'effect of &push';
757 test_proto 'quotemeta', '$', '\$';
763 use warnings FATAL => qw{numeric uninitialized};
765 }, '&rand returns a valid number';
766 unlike join(" ", &CORE::rand), qr/ /, '&rand in list context';
767 &cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 1 arg');
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';
781 test_proto 'readdir';
783 test_proto 'readline';
787 is scalar &myreadline,
788 "I wandered lonely as a cloud\n", '&readline w/no args';
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.
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';
808 test_proto 'readlink';
809 test_proto 'readpipe';
812 use if !is_miniperl, File::Spec::Functions, qw "catfile";
813 use if !is_miniperl, File::Temp, 'tempdir';
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';
827 test_proto 'ref', [], 'ARRAY';
831 my $oncer = sub { "a" =~ m?a? };
834 ok &$oncer, '&reset with no args';
839 ::lis [$b,$banana],[(undef)x2], '1-arg &reset';
842 test_proto 'reverse';
844 is &myreverse('reward'), 'drawer', '&reverse';
845 lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'],
846 '&reverse in list context';
848 test_proto 'rewinddir';
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';
860 is &myscalar(3), 3, '&scalar';
861 lis [&myscalar(3)], [3], '&scalar in list cx';
867 open my $fh, "<", \"misled" or die $!;
869 is <$fh>, 'sled', '&seek in action';
872 test_proto 'seekdir';
874 # Can’t test_proto, as it has none
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';
882 is &myselect(my $fh), $prev, '&select($arg) retval';
883 is lc ref $fh, 'glob', '&select autovivifies';
884 is select, $fh, '&select selects';
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)';
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
900 # select() is unimplemented in Win32 miniperl
903 test_proto "sem$_" for qw "ctl get op";
907 test_proto "set$_" for qw '
911 test_proto 'setpgrp';
913 eval { &mysetpgrp( 0) };
914 pass "&setpgrp with one argument";
916 pass "&setpgrp with no arguments";
918 test_proto "set$_" for qw '
919 priority protoent pwent servent sockopt
925 is &myshift(), 'a', 'retval of &shift with no args (@ARGV)';
926 is "@ARGV", "b c", 'effect of &shift on @ARGV';
928 is &myshift(), 'q', 'retval of &shift with no args (@_)';
929 is "@_", "j k", 'effect of &shift on @_';
933 is &myshift(\@a), 1, 'retval of &shift';
934 lis [@a], [2..4], 'effect of &shift';
937 test_proto "shm$_" for qw "ctl get read write";
938 test_proto 'shutdown';
941 test_proto "socket$_" for "", "pair";
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';
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';
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';
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';
960 test_proto 'sprintf';
962 is &mysprintf("%x", 65), '41', '&sprintf';
963 lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context';
965 test_proto 'sqrt', 4, 2;
971 pass '&srand with no args does not crash';
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';
985 test_proto 'symlink';
986 test_proto 'syscall';
988 test_proto 'sysopen';
991 &mysysopen(my $fh, 'test.pl', 0);
992 pass '&sysopen does not crash with 3 args';
993 ok $fh, 'sysopen autovivifies';
996 test_proto 'sysread';
997 test_proto 'sysseek';
998 test_proto 'syswrite';
1003 open my $fh, "test.pl" or die "Cannot open test.pl";
1005 is &mytell(), tell($fh), '&tell with no args';
1006 is &mytell($fh), tell($fh), '&tell with an arg';
1009 test_proto 'telldir';
1017 sub TIESCALAR { bless[] }
1018 sub FETCH { ++$fetches }
1021 my $obj = &mytie(\$tied, 'tier');
1022 is &mytied(\$tied), $obj, '&tie and &tied retvals';
1024 is $fetches, 1, '&tie actually ties';
1025 &CORE::untie(\$tied);
1027 is $fetches, 1, '&untie unties';
1032 like &mytime, qr/^\d+\z/, '&time in scalar context';
1033 like join('-', &mytime), qr/^\d+\z/, '&time in list context';
1037 like &mytimes, qr/^[\d.]+\z/, '× in scalar context';
1038 like join('-',&mytimes), qr/^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z/,
1039 '× in list context';
1041 test_proto 'uc', 'aa', 'AA';
1042 test_proto 'ucfirst', 'aa', "Aa";
1046 is &myumask, umask, '&umask with no args';
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';
1056 is $_, undef, '&undef(\$_) undefines $_';
1059 is @_, 0, '&undef(\@_) undefines @_';
1062 ok !%_, '&undef(\%_) undefines %_';
1063 &myundef(\&utf8::valid); # nobody should be using this :-)
1064 ok !defined &utf8::valid, '&undef(\&foo) undefines &foo';
1067 is *_{ARRAY}, undef, '@_=\*_, &undef undefines *_';
1070 is *_{ARRAY}, undef, '&undef(\*_) undefines *_';
1071 (&myundef(), @_) = 1..10;
1072 lis \@_, [2..10], 'list assignment to &undef()';
1073 ok !defined undef, 'list assignment to &undef() does not affect undef';
1076 test_proto 'unpack';
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;
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';
1089 test_proto 'unshift';
1093 is &myunshift(\@a, "d", "e"), 5, 'retval of &unshift';
1094 is "@a", "d e a b c", 'effect of &unshift';
1097 test_proto 'untie'; # behaviour already tested along with tie(d)
1101 is &myutime(undef,undef), 0, '&utime';
1102 lis [&myutime(undef,undef)], [0], '&utime in list context';
1104 test_proto 'values';
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';
1109 lis [&myvalues([ 1..4 ])], [1..4], '&myvalues(\@array) in list cx';
1113 is &myvec("foo", 0, 4), 6, '&vec';
1114 lis [&myvec("foo", 0, 4)], [6], '&vec in list context';
1117 is $tmp, "goo", 'lvalue &vec';
1120 test_proto 'waitpid';
1122 test_proto 'wantarray';
1126 $context = qw[void scalar list][&mywantarray + defined mywantarray()]
1129 is $context, 'list', '&wantarray with caller in list context';
1131 is($context, 'scalar', '&wantarray with caller in scalar context');
1133 is($context, 'void', '&wantarray with caller in void context');
1134 lis [&mywantarray],[wantarray], '&wantarray itself in list context';
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';
1148 like $@, qr'^Undefined format "STDOUT" called',
1149 "&write without arguments can handle the null";
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
1155 last if is_miniperl;
1156 require File::Spec::Functions;
1158 File::Spec::Functions::catfile(
1159 File::Spec::Functions::updir,'regen','keywords.pl'
1161 open my $kh, $keywords_file
1162 or die "$0 cannot open $keywords_file: $!";
1164 if (m?__END__?..${\0} and /^[-+](.*)/) {
1167 $word =~ /^(?:s(?:tate|ort|ay|ub)?|d(?:ef
1168 ault|ump|o)|p(?:rintf?|ackag
1169 e)|e(?:ls(?:if|e)|val|q)|g(?:[et]|iven|oto
1170 |rep)|u(?:n(?:less|til)|se)|l(?:(?:as)?t|ocal|e)|re
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;
1176 ok exists &{"my$word"}
1177 || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/),
1178 "$word either has been tested or is not ampable";
1183 # Add new tests above this line.
1185 # This test must come last (before the test count test):
1188 last if is_miniperl;
1192 require File::Temp ;
1193 my $dir = File::Temp::tempdir(uc cleanup => 1);
1197 # Make sure that implicit $_ is not applied to mkdir’s second argument.
1200 local $SIG{__WARN__} = sub { ++$warnings };
1203 ok &mymkdir(), '&mkdir';
1204 like <*>, qr/^phoo(.DIR)?\z/i, 'mkdir works with implicit $_';
1206 is $warnings, undef, 'no implicit $_ for second argument to mkdir';
1208 chdir($cwd); # so auto-cleanup can remove $dir
1211 # ------------ END TESTING ----------- #
1213 done_testing $tests;
1217 sub file { &CORE::__FILE__ }
1218 sub line { &CORE::__LINE__ } # 5
1219 sub dier { &CORE::die(@_) } # 6
1221 sub main::pakg { &CORE::__PACKAGE__ }
1223 # Please do not add new tests here.
1226 I wandered lonely as a cloud
1227 That floats on high o'er vales and hills,
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.