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 @INC = qw(. ../lib ../dist/if);
13 require "./test.pl"; require './charset_tools.pl';
17 no warnings 'experimental::smartmatch';
20 &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
24 use overload '%{}' => sub { +{} }
27 use overload '${}' => sub { \my $x }
31 evalbytes=> 'eval "string"',
32 join => 'join or string',
33 pos => 'match position',
34 prototype=> 'subroutine prototype',
35 readline => '<HANDLE>',
36 readpipe => 'quoted execution (``, qx)',
37 reset => 'symbol reset',
38 ref => 'reference-type operator',
39 undef => 'undef operator',
42 return $op_desc{$_[0]} || $_[0];
46 # This tests that the &{} syntax respects the number of arguments implied
47 # by the prototype, plus some extra tests for the (_) prototype.
51 # Create an alias, for the caller’s convenience.
52 *{"my$o"} = \&{"CORE::$o"};
54 my $p = prototype "CORE::$o";
55 $p = '$;$' if $p eq '$_';
60 eval " &CORE::$o(1) ";
61 like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
64 elsif ($p =~ /^_;?\z/) {
67 eval " &CORE::$o(1,2) ";
68 my $desc = quotemeta op_desc($o);
69 like $@, qr/^Too many arguments for $desc at /,
70 "&$o with too many args";
76 my($in,$out) = @_; # for testing implied $_
78 # Since we have $in and $out values, we might as well test basic amper-
81 is &{"CORE::$o"}($in), $out, "&$o";
82 lis [&{"CORE::$o"}($in)], [$out], "&$o in list context";
85 is &{"CORE::$o"}(), $out, "&$o with no args";
87 # Since there is special code to deal with lexical $_, make sure it
91 no warnings 'experimental::lexical_topic';
93 is &{"CORE::$o"}(), $out, "&$o with no args uses lexical \$_";
95 # Make sure we get the right pad under recursion
99 no warnings 'experimental::lexical_topic';
101 is &{"CORE::$o"}(), $out,
102 "&$o with no args uses the right lexical \$_ under recursion";
109 no warnings 'experimental::lexical_topic';
112 is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval"
115 elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc.
116 my $maxargs = length $1;
118 eval " &CORE::$o((1)x($maxargs+1)) ";
119 my $desc = quotemeta op_desc($o);
120 like $@, qr/^Too many arguments for $desc at /,
121 "&$o with too many args";
123 elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or ***
124 my $args = length $1;
126 my $desc = quotemeta op_desc($o);
127 eval " &CORE::$o((1)x($args-1)) ";
128 like $@, qr/^Not enough arguments for $desc at /, "&$o w/too few args";
129 eval " &CORE::$o((1)x($args+1)) ";
130 like $@, qr/^Too many arguments for $desc at /, "&$o w/too many args";
132 elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or ***
133 my $minargs = length $1;
134 my $maxargs = $minargs + length $2;
136 eval " &CORE::$o((1)x($minargs-1)) ";
137 like $@, qr/^Not enough arguments for $o at /, "&$o with too few args";
138 eval " &CORE::$o((1)x($maxargs+1)) ";
139 like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
141 elsif ($p eq '_;$') {
144 eval " &CORE::$o(1,2,3) ";
145 like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
148 # Do nothing, as we cannot test for too few or too many arguments.
150 elsif ($p =~ '^[$*;]+@\z') {
154 eval " &CORE::$o((1)x($minargs-1)) ";
155 my $desc = quotemeta op_desc($o);
156 like $@, qr/^Not enough arguments for $desc at /,
157 "&$o with too few args";
159 elsif ($p =~ /^\*\\\$\$(;?)\$\z/) { # *\$$$ and *\$$;$
162 eval "&CORE::$o(1,1,1,1,1)";
163 like $@, qr/^Too many arguments for $o at /,
164 "&$o with too many args";
165 eval " &CORE::$o((1)x(\$1?2:3)) ";
166 like $@, qr/^Not enough arguments for $o at /,
167 "&$o with too few args";
168 eval " &CORE::$o(1,[],1,1) ";
169 like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /,
170 "&$o with array ref arg";
171 eval " &CORE::$o(1,1,1,1) ";
172 like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /,
173 "&$o with scalar arg";
174 eval " &CORE::$o(1,bless([], 'sov'),1,1) ";
175 like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /,
176 "&$o with non-scalar arg w/scalar overload (which does not count)";
178 elsif ($p =~ /^\\%\$*\z/) { # \% and \%$$
181 eval "&CORE::$o(" . join(",", (1) x length $p) . ")";
182 like $@, qr/^Too many arguments for $o at /,
183 "&$o with too many args";
184 eval " &CORE::$o(" . join(",", (1) x (length($p)-2)) . ") ";
185 like $@, qr/^Not enough arguments for $o at /,
186 "&$o with too few args";
187 my $moreargs = ",1" x (length($p) - 2);
188 eval " &CORE::$o([]$moreargs) ";
189 like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /,
190 "&$o with array ref arg";
191 eval " &CORE::$o(*foo$moreargs) ";
192 like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /,
193 "&$o with typeglob arg";
194 eval " &CORE::$o(bless([], 'hov')$moreargs) ";
195 like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /,
196 "&$o with non-hash arg with hash overload (which does not count)";
198 elsif ($p =~ /^(;)?\\\[(\$\@%&?\*)](\$\@)?\z/) {
203 eval " &CORE::$o(1,2) ";
204 like $@, qr/^Too many arguments for ${\op_desc($o)} at /,
205 "&$o with too many args";
209 eval { &{"CORE::$o"}($3 ? 1 : ()) };
210 like $@, qr/^Not enough arguments for $o at /,
211 "&$o with too few args";
213 my $more_args = $3 ? ',1' : '';
214 eval " &CORE::$o(2$more_args) ";
215 like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
217 "&$o with non-ref arg";
218 eval " &CORE::$o(*STDOUT{IO}$more_args) ";
219 like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
221 "&$o with ioref arg";
222 my $class = ref *DATA{IO};
223 eval " &CORE::$o(bless(*DATA{IO}, 'hov')$more_args) ";
224 like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
226 "&$o with ioref arg with hash overload (which does not count)";
227 bless *DATA{IO}, $class;
228 if (do {$2 !~ /&/}) {
230 eval " &CORE::$o(\\&scriggle$more_args) ";
231 like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one (?x:
233 "&$o with coderef arg";
236 elsif ($p eq ';\[$*]') {
239 my $desc = quotemeta op_desc($o);
240 eval " &CORE::$o(1,2) ";
241 like $@, qr/^Too many arguments for $desc at /,
242 "&$o with too many args";
243 eval " &CORE::$o([]) ";
244 like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
245 "&$o with array ref arg";
246 eval " &CORE::$o(1) ";
247 like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
248 "&$o with scalar arg";
249 eval " &CORE::$o(bless([], 'sov')) ";
250 like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
251 "&$o with non-scalar arg w/scalar overload (which does not count)";
255 die "Please add tests for the $p prototype";
259 # Test that &CORE::foo calls without parentheses (no new @_) can handle the
260 # total absence of any @_ without crashing.
264 pass('no crash with &CORE::foo when *_{ARRAY} is undef');
266 test_proto '__FILE__';
267 test_proto '__LINE__';
268 test_proto '__PACKAGE__';
269 test_proto '__SUB__';
271 is file(), 'frob' , '__FILE__ does check its caller' ; ++ $tests;
272 is line(), 5 , '__LINE__ does check its caller' ; ++ $tests;
273 is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests;
274 sub __SUB__test { &my__SUB__ }
275 is __SUB__test, \&__SUB__test, '&__SUB__'; ++ $tests;
277 test_proto 'abs', -5, 5;
281 if ($^O eq "MSWin32" && is_miniperl) {
283 skip "accept() not available in Win32 miniperl", 8
288 is &CORE::accept(qw{foo bar}), undef, "&accept";
289 lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context";
291 &myaccept(my $foo, my $bar);
292 is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument';
293 is $bar, undef, 'CORE::accept does not autovivify its second argument';
296 eval { 'myaccept'->($foo, $bar) };
297 like $@, qr/^Can't use an undefined value as a symbol reference at/,
298 'CORE::accept will not accept undef 2nd arg under strict';
299 is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict';
310 skip "bind() not available in Win32 miniperl", 3
311 if $^O eq "MSWin32" && is_miniperl();
312 is &CORE::bind('foo', 'bear'), undef, "&bind";
313 lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context";
314 eval { &mybind(my $foo, "bear") };
315 like $@, qr/^Bad symbol for filehandle at/,
316 'CORE::bind dies with undef first arg';
319 test_proto 'binmode';
321 is &CORE::binmode(qw[foo bar]), undef, "&binmode";
322 lis [&CORE::binmode(qw[foo bar])], [undef], "&binmode in list context";
323 is &mybinmode(foo), undef, '&binmode with one arg';
327 like &CORE::bless([],'parcel'), qr/^parcel=ARRAY/, "&bless";
328 like join(" ", &CORE::bless([],'parcel')),
329 qr/^parcel=ARRAY(?!.* )/, "&bless in list context";
330 like &mybless([]), qr/^main=ARRAY/, '&bless with one arg';
341 is $tmp, undef, '&break';
347 is scalar &CORE::caller, 'hadhad', '&caller';
348 is scalar &CORE::caller(1), 'main', '&caller(1)';
349 lis [&CORE::caller], [caller], '&caller in list context';
350 # The last element of caller in list context is a hint hash, which
351 # may be a different hash for caller vs &CORE::caller, so an eq com-
352 # parison (which lis() uses for convenience) won’t work. So just
353 # pop the last element, since the rest are sufficient to prove that
354 # &CORE::caller works.
355 my @ampcaller = &CORE::caller(1);
356 my @caller = caller(1);
357 pop @ampcaller; pop @caller;
358 lis \@ampcaller, \@caller, '&caller(1) in list context';
367 is &CORE::chmod(), 0, '&chmod with no args';
368 is &CORE::chmod(0666), 0, '&chmod';
369 lis [&CORE::chmod(0666)], [0], '&chmod in list context';
373 is &CORE::chown(), 0, '&chown with no args';
374 is &CORE::chown(1), 0, '&chown with 1 arg';
375 is &CORE::chown(1,2), 0, '&chown';
376 lis [&CORE::chown(1,2)], [0], '&chown in list context';
378 test_proto 'chr', 5, "\5";
386 open my $fh, ">", \my $buffalo;
387 print $fh 'an address in the outskirts of Jersey';
388 ok &CORE::close($fh), '&CORE::close retval';
390 is $buffalo, 'an address in the outskirts of Jersey',
391 'effect of &CORE::close';
392 # This has to be a separate variable from $fh, as re-using the same
393 # variable can cause the tests to pass by accident. That actually hap-
394 # pened during developement, because the second close() was reading
395 # beyond the end of the stack and finding a $fh left over from before.
396 open my $fh2, ">", \($buffalo = '');
397 select+(select($fh2), do {
398 print "Nasusiro Tokasoni";
401 is $buffalo, "Nasusiro Tokasoni", '&CORE::close with no args';
404 lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests;
406 test_proto 'closedir';
408 is &CORE::closedir(foo), undef, '&CORE::closedir';
409 lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context';
411 test_proto 'connect';
415 skip "connect() not available in Win32 miniperl", 2
416 if $^O eq "MSWin32" && is_miniperl();
417 is &CORE::connect('foo','bar'), undef, '&connect';
418 lis [&myconnect('foo','bar')], [undef], '&connect in list context';
421 test_proto 'continue';
433 test_proto 'dbmclose';
434 test_proto 'dbmopen';
436 last unless eval { require AnyDBM_File };
438 my $filename = tempfile();
439 &mydbmopen(\my %db, $filename, 0666);
440 $db{1} = 2; $db{3} = 4;
442 is scalar keys %db, 0, '&dbmopen and &dbmclose';
443 my $Dfile = "$filename.pag";
445 ($Dfile) = <$filename*>;
448 unlink "$filename.sdbm_dir", $Dfile;
450 unlink "$filename.dir", $Dfile;
455 eval { dier('quinquangle') };
456 is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++;
458 test_proto $_ for qw(
459 endgrent endhostent endnetent endprotoent endpwent endservent
462 test_proto 'evalbytes';
465 my $U_100_bytes = byte_utf8a_to_utf8n("\xc4\x80");
466 chop(my $upgraded = "use utf8; $U_100_bytes" . chr 256);
467 is &myevalbytes($upgraded), chr 256, '&evalbytes';
472 is someone, "someone", "run-time hint bits do not leak into &evalbytes"
475 BEGIN { $^H{coreamp} = 42 }
479 is $^H{coreamp}, 42, "compile-time hh propagates into &evalbytes";
483 like $@, qr/strict/, 'compile-time hint bits propagate into &evalbytes';
488 is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n",
489 '&exit with no args';
493 test_proto 'formline';
495 is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval';
496 is $^A, ' 1 2', 'effect of &myformline';
497 lis [&myformline('@')], [1], '&myformline in list context';
504 my $sharp_s = uni_to_native("\xdf");
505 is &myfc($sharp_s), $sharp_s, '&fc, no unicode_strings';
506 use feature 'unicode_strings';
507 is &myfc($sharp_s), "ss", '&fc, unicode_strings';
514 is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno';
515 lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx';
525 open my $fh, "<", \(my $buf='falo');
526 open STDIN, "<", \(my $buf2 = 'bison');
527 is &mygetc($fh), 'f', '&mygetc';
528 is &mygetc(), 'b', '&mygetc with no args';
529 lis [&mygetc($fh)], ['a'], '&mygetc in list context';
532 test_proto "get$_" for qw '
533 grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname
537 test_proto 'getpgrp';
539 pass '&getpgrp with no args does not crash'; $tests++;
541 test_proto "get$_" for qw '
542 ppid priority protobyname protobynumber protoent
543 pwent pwnam pwuid servbyname servbyport servent sockname sockopt
546 # Make sure the following tests test what we think they are testing.
547 ok ! $CORE::{glob}, '*CORE::glob not autovivified yet'; $tests ++;
549 # Make sure ck_glob does not respect the override when &CORE::glob is
550 # autovivified (by test_proto).
551 local *CORE::GLOBAL::glob = sub {};
556 is join($", &myglob()), "@_", '&glob without arguments';
557 is join($", &myglob("t/*.t")), "@_", '&glob with an arg';
562 pass '&gmtime without args does not crash'; ++$tests;
564 test_proto 'hex', ff=>255;
568 is &myindex("foffooo","o",2),4,'&index';
569 lis [&myindex("foffooo","o",2)],[4],'&index in list context';
570 is &myindex("foffooo","o"),1,'&index with 2 args';
572 test_proto 'int', 1.5=>1;
577 is &myjoin('a','b','c'), 'bac', '&join';
578 lis [&myjoin('a','b','c')], ['bac'], '&join in list context';
580 test_proto 'kill'; # set up mykill alias
581 if ($^O ne 'riscos') {
583 ok( &mykill(0, $$), '&kill' );
586 test_proto 'lc', 'A', 'a';
587 test_proto 'lcfirst', 'AA', 'aA';
588 test_proto 'length', 'aaa', 3;
592 test_proto 'localtime';
594 pass '&localtime without args does not crash'; ++$tests;
598 is \&mylock(\$foo), \$foo, '&lock retval when passed a scalar ref';
599 lis [\&mylock(\$foo)], [\$foo], '&lock in list context';
600 is &mylock(\@foo), \@foo, '&lock retval when passed an array ref';
601 is &mylock(\%foo), \%foo, '&lock retval when passed a ash ref';
602 is &mylock(\&foo), \&foo, '&lock retval when passed a code ref';
603 is \&mylock(\*foo), \*foo, '&lock retval when passed a glob ref';
608 # mkdir is tested with implicit $_ at the end, to make the test easier
610 test_proto "msg$_" for qw( ctl get rcv snd );
614 is &mynot(1), !1, '¬';
615 lis [&mynot(0)], [!0], '¬ in list context';
617 test_proto 'oct', '666', 438;
622 ok &myopen('file'), '&open with 1 arg' or warn "1-arg open: $!";
623 like <file>, qr|^#|, 'result of &open with 1 arg';
626 ok &myopen(my $fh, "test.pl"), 'two-arg &open';
627 ok $fh, '&open autovivifies';
628 like <$fh>, qr '^#', 'result of &open with 2 args';
631 ok &myopen(my $fh2, "<", \"sharummbles"), 'retval of 3-arg &open';
632 is <$fh2>, 'sharummbles', 'result of three-arg &open';
635 test_proto 'opendir';
636 test_proto 'ord', chr(utf8::unicode_to_native(64)), utf8::unicode_to_native(64);
640 my $Perl_as_a_hex_string = join "", map
641 { sprintf("%2X", utf8::unicode_to_native($_)) }
642 0x50, 0x65, 0x72, 0x6c;
643 is &mypack("H*", $Perl_as_a_hex_string), 'Perl', '&pack';
644 lis [&mypack("H*", $Perl_as_a_hex_string)], ['Perl'], '&pack in list context';
652 is &mypos, 3, 'reading &pos without args';
654 is pos, 4, 'writing to &pos without args';
658 is &mypos(\$x), 3, 'reading &pos without args';
660 is pos $x, 4, 'writing to &pos without args';
663 test_proto 'prototype';
665 is &myprototype(\&myprototype), prototype("CORE::prototype"), '&prototype';
667 test_proto 'quotemeta', '$', '\$';
673 use warnings FATAL => qw{numeric uninitialized};
675 }, '&rand returns a valid number';
676 unlike join(" ", &CORE::rand), qr/ /, '&rand in list context';
677 &cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 1 arg');
683 open my $fh, "<", \(my $buff = 'morays have their mores');
684 ok &myread($fh, \my $input, 6), '&read with 3 args';
685 is $input, 'morays', 'value read by 3-arg &read';
686 ok &myread($fh, \$input, 6, 6), '&read with 4 args';
687 is $input, 'morays have ', 'value read by 4-arg &read';
688 is +()=&myread($fh, \$input, 6), 1, '&read in list context';
691 test_proto 'readdir';
693 test_proto 'readline';
697 is scalar &myreadline,
698 "I wandered lonely as a cloud\n", '&readline w/no args';
703 open my $fh, "<", \(my $buff = <<END);
704 The Recursive Problem
705 ---------------------
706 I have a problem I cannot solve.
707 The problem is that I cannot solve it.
709 is &myreadline($fh), "The Recursive Problem\n",
710 '&readline with 1 arg';
711 lis [&myreadline($fh)], [
712 "---------------------\n",
713 "I have a problem I cannot solve.\n",
714 "The problem is that I cannot solve it.\n",
715 ], '&readline in list context';
718 test_proto 'readlink';
719 test_proto 'readpipe';
722 use if !is_miniperl, File::Spec::Functions, qw "catfile";
723 use if !is_miniperl, File::Temp, 'tempdir';
729 my $dir = tempdir(uc cleanup => 1);
730 my $tmpfilenam = catfile $dir, 'aaa';
731 open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!";
732 close $fh or die "cannot close $tmpfilenam: $!";
733 &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb');
734 ok open(my $fh, '>', $tmpfilenam), '&rename';
737 test_proto 'ref', [], 'ARRAY';
741 my $oncer = sub { "a" =~ m?a? };
744 ok &$oncer, '&reset with no args';
749 ::lis [$b,$banana],[(undef)x2], '1-arg &reset';
752 test_proto 'reverse';
754 is &myreverse('reward'), 'drawer', '&reverse';
755 lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'],
756 '&reverse in list context';
758 test_proto 'rewinddir';
762 is &myrindex("foffooo","o",2),1,'&rindex';
763 lis [&myrindex("foffooo","o",2)],[1],'&rindex in list context';
764 is &myrindex("foffooo","o"),6,'&rindex with 2 args';
770 is &myscalar(3), 3, '&scalar';
771 lis [&myscalar(3)], [3], '&scalar in list cx';
777 open my $fh, "<", \"misled" or die $!;
779 is <$fh>, 'sled', '&seek in action';
782 test_proto 'seekdir';
784 # Can’t test_proto, as it has none
786 *myselect = \&CORE::select;
787 is defined prototype &myselect, defined prototype "CORE::select",
788 'prototype of &select (or lack thereof)';
789 is &myselect, select, '&select with no args';
792 is &myselect(my $fh), $prev, '&select($arg) retval';
793 is lc ref $fh, 'glob', '&select autovivifies';
794 is select=~s/\*//rug, (*$fh."")=~s/\*//rug, '&select selects';
797 eval { &myselect(1,2) };
798 like $@, qr/^Not enough arguments for select system call at /,
799 ,'&myselect($two,$args)';
800 eval { &myselect(1,2,3) };
801 like $@, qr/^Not enough arguments for select system call at /,
802 ,'&myselect($with,$three,$args)';
803 eval { &myselect(1,2,3,4,5) };
804 like $@, qr/^Too many arguments for select system call at /,
805 ,'&myselect($a,$total,$of,$five,$args)';
806 unless ($^O eq "MSWin32" && is_miniperl) {
807 &myselect((undef)x3,.25);
808 # Just have to assume that worked. :-) If we get here, at least it didn’t
810 # select() is unimplemented in Win32 miniperl
813 test_proto "sem$_" for qw "ctl get op";
817 test_proto "set$_" for qw '
821 test_proto 'setpgrp';
823 eval { &mysetpgrp( 0) };
824 pass "&setpgrp with one argument";
826 pass "&setpgrp with no arguments";
828 test_proto "set$_" for qw '
829 priority protoent pwent servent sockopt
832 test_proto "shm$_" for qw "ctl get read write";
833 test_proto 'shutdown';
836 test_proto "socket$_" for "", "pair";
838 test_proto 'sprintf';
840 is &mysprintf("%x", 65), '41', '&sprintf';
841 lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context';
843 test_proto 'sqrt', 4, 2;
849 pass '&srand with no args does not crash';
856 is &mysubstr($_, 1, 1, "d"), 'b', '4-arg &substr';
857 is $_, 'adc', 'what 4-arg &substr does';
858 is &mysubstr("abc", 1, 1), 'b', '3-arg &substr';
859 is &mysubstr("abc", 1), 'bc', '2-arg &substr';
860 &mysubstr($_, 1) = 'long';
861 is $_, 'along', 'lvalue &substr';
863 test_proto 'symlink';
864 test_proto 'syscall';
866 test_proto 'sysopen';
869 &mysysopen(my $fh, 'test.pl', 0);
870 pass '&sysopen does not crash with 3 args';
871 ok $fh, 'sysopen autovivifies';
874 test_proto 'sysread';
875 test_proto 'sysseek';
876 test_proto 'syswrite';
881 open my $fh, "test.pl" or die "Cannot open test.pl";
883 is &mytell(), tell($fh), '&tell with no args';
884 is &mytell($fh), tell($fh), '&tell with an arg';
887 test_proto 'telldir';
895 sub TIESCALAR { bless[] }
896 sub FETCH { ++$fetches }
899 my $obj = &mytie(\$tied, 'tier');
900 is &mytied(\$tied), $obj, '&tie and &tied retvals';
902 is $fetches, 1, '&tie actually ties';
903 &CORE::untie(\$tied);
905 is $fetches, 1, '&untie unties';
910 like &mytime, qr/^\d+\z/, '&time in scalar context';
911 like join('-', &mytime), qr/^\d+\z/, '&time in list context';
915 like &mytimes, qr/^[\d.]+\z/, '× in scalar context';
916 like join('-',&mytimes), qr/^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z/,
917 '× in list context';
919 test_proto 'uc', 'aa', 'AA';
920 test_proto 'ucfirst', 'aa', "Aa";
924 is &myumask, umask, '&umask with no args';
928 is &myundef(), undef, '&undef returns undef';
929 lis [&myundef()], [undef], '&undef returns undef in list cx';
930 lis [&myundef(\$_)], [undef], '&undef(...) returns undef in list cx';
931 is \&myundef(), \undef, '&undef returns the right undef';
932 $_ = 'anserine questions';
934 is $_, undef, '&undef(\$_) undefines $_';
937 is @_, 0, '&undef(\@_) undefines @_';
940 ok !%_, '&undef(\%_) undefines %_';
941 &myundef(\&utf8::valid); # nobody should be using this :-)
942 ok !defined &utf8::valid, '&undef(\&foo) undefines &foo';
945 is *_{ARRAY}, undef, '@_=\*_, &undef undefines *_';
948 is *_{ARRAY}, undef, '&undef(\*_) undefines *_';
949 (&myundef(), @_) = 1..10;
950 lis \@_, [2..10], 'list assignment to &undef()';
951 ok !defined undef, 'list assignment to &undef() does not affect undef';
956 my $abcd_as_a_hex_string = join "", map
957 { sprintf("%2X", utf8::unicode_to_native($_)) }
958 0x61, 0x62, 0x63, 0x64;
959 my $bcde_as_a_hex_string = join "", map
960 { sprintf("%2X", utf8::unicode_to_native($_)) }
961 0x62, 0x63, 0x64, 0x65;
963 is &myunpack("H*"), $abcd_as_a_hex_string, '&unpack with one arg';
964 is &myunpack("H*", "bcde"), $bcde_as_a_hex_string, '&unpack with two arg';
967 test_proto 'untie'; # behaviour already tested along with tie(d)
971 is &myutime(undef,undef), 0, '&utime';
972 lis [&myutime(undef,undef)], [0], '&utime in list context';
976 is &myvec("foo", 0, 4), 6, '&vec';
977 lis [&myvec("foo", 0, 4)], [6], '&vec in list context';
980 is $tmp, "goo", 'lvalue &vec';
983 test_proto 'waitpid';
985 test_proto 'wantarray';
989 $context = qw[void scalar list][&mywantarray + defined mywantarray()]
992 is $context, 'list', '&wantarray with caller in list context';
994 is($context, 'scalar', '&wantarray with caller in scalar context');
996 is($context, 'void', '&wantarray with caller in void context');
997 lis [&mywantarray],[wantarray], '&wantarray itself in list context';
1002 local $SIG{__WARN__} = sub { $w = shift };
1003 is &mywarn('a'), 1, '&warn retval';
1004 is $w, "a at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'warning';
1005 lis [&mywarn()], [1], '&warn retval in list context';
1011 like $@, qr'^Undefined format "STDOUT" called',
1012 "&write without arguments can handle the null";
1014 # This is just a check to make sure we have tested everything. If we
1015 # haven’t, then either the sub needs to be tested or the list in
1018 last if is_miniperl;
1019 require File::Spec::Functions;
1021 File::Spec::Functions::catfile(
1022 File::Spec::Functions::updir,'regen','keywords.pl'
1024 open my $kh, $keywords_file
1025 or die "$0 cannot open $keywords_file: $!";
1027 if (m?__END__?..${\0} and /^[-+](.*)/) {
1030 $word =~ /^(?:s(?:tate|ort|ay|ub)?|d(?:ef
1031 ault|ump|o)|p(?:rintf?|ackag
1032 e)|e(?:ls(?:if|e)|val|q)|g(?:[et]|iven|oto
1033 |rep)|u(?:n(?:less|til)|se)|l(?:(?:as)?t|ocal|e)|re
1034 (?:quire|turn|do)|__(?:DATA|END)__|for(?:each|mat)?|(?:
1035 AUTOLOA|EN)D|n(?:e(?:xt)?|o)|C(?:HECK|ORE)|wh(?:ile|en)
1036 |(?:ou?|t)r|m(?:ap|y)?|UNITCHECK|q[qrwx]?|x(?:or)?|DEST
1037 ROY|BEGIN|INIT|and|cmp|if|y)\z/x;
1039 ok exists &{"my$word"}
1040 || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/),
1041 "$word either has been tested or is not ampable";
1046 # Add new tests above this line.
1048 # This test must come last (before the test count test):
1051 last if is_miniperl;
1055 require File::Temp ;
1056 my $dir = File::Temp::tempdir(uc cleanup => 1);
1060 # Make sure that implicit $_ is not applied to mkdir’s second argument.
1063 local $SIG{__WARN__} = sub { ++$warnings };
1065 no warnings 'experimental::lexical_topic';
1067 ok &mymkdir(), '&mkdir';
1068 like <*>, qr/^phoo(.DIR)?\z/i, 'mkdir works with implicit $_';
1070 is $warnings, undef, 'no implicit $_ for second argument to mkdir';
1072 chdir($cwd); # so auto-cleanup can remove $dir
1075 # ------------ END TESTING ----------- #
1077 done_testing $tests;
1081 sub file { &CORE::__FILE__ }
1082 sub line { &CORE::__LINE__ } # 5
1083 sub dier { &CORE::die(@_) } # 6
1085 sub main::pakg { &CORE::__PACKAGE__ }
1087 # Please do not add new tests here.
1090 I wandered lonely as a cloud
1091 That floats on high o'er vales and hills,
1092 And all at once I saw a crowd,
1093 A host of golden daffodils!
1094 Beside the lake, beneath the trees,
1095 Fluttering, dancing, in the breeze.