#!/@unixroot/usr/bin/perl

# This file tests the results of calling subroutines in the CORE::
# namespace with ampersand syntax.  In other words, it tests the bodies of
# the subroutines themselves, not the ops that they might inline themselves
# as when called as barewords.

# Other tests for CORE subs are in coresubs.t

BEGIN {
  chdir 't' if -d 't';
  require "./test.pl";
  set_up_inc( qw(. ../lib ../dist/if) );
  require './charset_tools.pl';
  $^P |= 0x100; # Provide informative "file" names for evals
}

sub lis($$;$) {
  &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
}

package hov {
  use overload '%{}' => sub { +{} }
}
package aov {
  use overload '@{}' => sub { [] }
}
package sov {
  use overload '${}' => sub { \my $x }
}

my %op_desc = (
  evalbytes => 'eval "string"',
  join      => 'join or string',
  pos       => 'match position',
  prototype => 'subroutine prototype',
  readline  => '<HANDLE>',
  readpipe  => 'quoted execution (``, qx)',
  reset     => 'symbol reset',
  ref       => 'reference-type operator',
  undef     => 'undef operator',
);
sub op_desc($) {
  return $op_desc{$_[0]} || $_[0];
}


# This tests that the &{} syntax respects the number of arguments implied
# by the prototype, plus some extra tests for the (_) prototype.
sub test_proto {
  my($o) = shift;

  # Create an alias, for the caller’s convenience.
  *{"my$o"} = \&{"CORE::$o"};

  my $p = prototype "CORE::$o";
  $p = '$;$' if $p eq '$_';

  if ($p eq '') {
    $tests ++;

    eval " &CORE::$o(1) ";
    like $@, qr/^Too many arguments for $o at /, "&$o with too many args";

  }
  elsif ($p =~ /^_;?\z/) {
    $tests ++;

    eval " &CORE::$o(1,2) ";
    my $desc = quotemeta op_desc($o);
    like $@, qr/^Too many arguments for $desc at /,
      "&$o with too many args";

    if (!@_) { return }

    $tests += 3;

    my($in,$out) = @_; # for testing implied $_

    # Since we have $in and $out values, we might as well test basic amper-
    # sand calls, too.

    is &{"CORE::$o"}($in), $out, "&$o";
    lis [&{"CORE::$o"}($in)], [$out], "&$o in list context";

    $_ = $in;
    is &{"CORE::$o"}(), $out, "&$o with no args";
  }
  elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc.
    my $maxargs = length $1;
    $tests += 1;    
    eval " &CORE::$o((1)x($maxargs+1)) ";
    my $desc = quotemeta op_desc($o);
    like $@, qr/^Too many arguments for $desc at /,
      "&$o with too many args";
  }
  elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or ***
    my $args = length $1;
    $tests += 2;    
    my $desc = quotemeta op_desc($o);
    eval " &CORE::$o((1)x($args-1)) ";
    like $@, qr/^Not enough arguments for $desc at /, "&$o w/too few args";
    eval " &CORE::$o((1)x($args+1)) ";
    like $@, qr/^Too many arguments for $desc at /, "&$o w/too many args";
  }
  elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or ***
    my $minargs = length $1;
    my $maxargs = $minargs + length $2;
    $tests += 2;    
    eval " &CORE::$o((1)x($minargs-1)) ";
    like $@, qr/^Not enough arguments for $o at /, "&$o with too few args";
    eval " &CORE::$o((1)x($maxargs+1)) ";
    like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
  }
  elsif ($p eq '_;$') {
    $tests += 1;

    eval " &CORE::$o(1,2,3) ";
    like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
  }
  elsif ($p eq '@') {
    # Do nothing, as we cannot test for too few or too many arguments.
  }
  elsif ($p =~ '^[$*;]+@\z') {
    $tests ++;    
    $p =~ ';@';
    my $minargs = $-[0];
    eval " &CORE::$o((1)x($minargs-1)) ";
    my $desc = quotemeta op_desc($o);
    like $@, qr/^Not enough arguments for $desc at /,
      "&$o with too few args";
  }
  elsif ($p =~ /^\*\\\$\$(;?)\$\z/) { #  *\$$$ and *\$$;$
    $tests += 5;

    eval "&CORE::$o(1,1,1,1,1)";
    like $@, qr/^Too many arguments for $o at /,
      "&$o with too many args";
    eval " &CORE::$o((1)x(\$1?2:3)) ";
    like $@, qr/^Not enough arguments for $o at /,
      "&$o with too few args";
    eval " &CORE::$o(1,[],1,1) ";
    like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /,
      "&$o with array ref arg";
    eval " &CORE::$o(1,1,1,1) ";
    like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /,
      "&$o with scalar arg";
    eval " &CORE::$o(1,bless([], 'sov'),1,1) ";
    like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /,
      "&$o with non-scalar arg w/scalar overload (which does not count)";
  }
  elsif ($p =~ /^\\%\$*\z/) { #  \% and \%$$
    $tests += 5;

    eval "&CORE::$o(" . join(",", (1) x length $p) . ")";
    like $@, qr/^Too many arguments for $o at /,
      "&$o with too many args";
    eval " &CORE::$o(" . join(",", (1) x (length($p)-2)) . ") ";
    like $@, qr/^Not enough arguments for $o at /,
      "&$o with too few args";
    my $moreargs = ",1" x (length($p) - 2);
    eval " &CORE::$o([]$moreargs) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /,
      "&$o with array ref arg";
    eval " &CORE::$o(*foo$moreargs) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /,
      "&$o with typeglob arg";
    eval " &CORE::$o(bless([], 'hov')$moreargs) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /,
      "&$o with non-hash arg with hash overload (which does not count)";
  }
  elsif ($p =~ /^(;)?\\\[(\$\@%&?\*)](\$\@)?\z/) {
    $tests += 3;

    unless ($3) {
      $tests ++;
      eval " &CORE::$o(1,2) ";
      like $@, qr/^Too many arguments for ${\op_desc($o)} at /,
        "&$o with too many args";
    }
    unless ($1) {
      $tests ++;
      eval { &{"CORE::$o"}($3 ? 1 : ()) };
      like $@, qr/^Not enough arguments for $o at /,
         "&$o with too few args";
    }
    my $more_args = $3 ? ',1' : '';
    eval " &CORE::$o(2$more_args) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
                ) \[\Q$2\E\] at /,
      "&$o with non-ref arg";
    eval " &CORE::$o(*STDOUT{IO}$more_args) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
                ) \[\Q$2\E\] at /,
      "&$o with ioref arg";
    my $class = ref *DATA{IO};
    eval " &CORE::$o(bless(*DATA{IO}, 'hov')$more_args) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
                ) \[\Q$2\E\] at /,
      "&$o with ioref arg with hash overload (which does not count)";
    bless *DATA{IO}, $class;
    if (do {$2 !~ /&/}) {
      $tests++;
      eval " &CORE::$o(\\&scriggle$more_args) ";
      like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one (?x:
                  )of \[\Q$2\E\] at /,
        "&$o with coderef arg";
    }
  }
  elsif ($p =~ /^;?\\\@([\@;])?/) { #   ;\@   \@@   \@;$$@
    $tests += 7;

    if ($1) {
      eval { &{"CORE::$o"}() };
      like $@, qr/^Not enough arguments for $o at /,
        "&$o with too few args";
    }
    else {
      eval " &CORE::$o(\\\@1,2) ";
      like $@, qr/^Too many arguments for $o at /,
        "&$o with too many args";
    }
    eval " &CORE::$o(2) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
      "&$o with non-ref arg";
    eval " &CORE::$o(*STDOUT{IO}) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
      "&$o with ioref arg";
    my $class = ref *DATA{IO};
    eval " &CORE::$o(bless(*DATA{IO}, 'aov')) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
      "&$o with ioref arg with array overload (which does not count)";
    bless *DATA{IO}, $class;
    eval " &CORE::$o(\\&scriggle) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
      "&$o with coderef arg";
    eval " &CORE::$o(\\\$_) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
      "&$o with scalarref arg";
    eval " &CORE::$o({}) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
      "&$o with hashref arg";
  }
  elsif ($p eq '\[%@]') {
    $tests += 7;

    eval " &CORE::$o(\\%1,2) ";
    like $@, qr/^Too many arguments for ${\op_desc($o)} at /,
      "&$o with too many args";
    eval { &{"CORE::$o"}() };
    like $@, qr/^Not enough arguments for $o at /,
      "&$o with too few args";
    eval " &CORE::$o(2) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
                )reference at /,
      "&$o with non-ref arg";
    eval " &CORE::$o(*STDOUT{IO}) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
                )reference at /,
      "&$o with ioref arg";
    my $class = ref *DATA{IO};
    eval " &CORE::$o(bless(*DATA{IO}, 'hov')) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
                )reference at /,
      "&$o with ioref arg with hash overload (which does not count)";
    bless *DATA{IO}, $class;
    eval " &CORE::$o(\\&scriggle) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
                )reference at /,
      "&$o with coderef arg";
    eval " &CORE::$o(\\\$_) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
                )reference at /,
      "&$o with scalarref arg";
  }
  elsif ($p eq ';\[$*]') {
    $tests += 4;

    my $desc = quotemeta op_desc($o);
    eval " &CORE::$o(1,2) ";
    like $@, qr/^Too many arguments for $desc at /,
      "&$o with too many args";
    eval " &CORE::$o([]) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
      "&$o with array ref arg";
    eval " &CORE::$o(1) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
      "&$o with scalar arg";
    eval " &CORE::$o(bless([], 'sov')) ";
    like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
      "&$o with non-scalar arg w/scalar overload (which does not count)";
  }

  else {
    die "Please add tests for the $p prototype";
  }
}

# Test that &CORE::foo calls without parentheses (no new @_) can handle the
# total absence of any @_ without crashing.
undef *_;
&CORE::wantarray;
$tests++;
pass('no crash with &CORE::foo when *_{ARRAY} is undef');

test_proto '__CLASS__';
test_proto '__FILE__';
test_proto '__LINE__';
test_proto '__PACKAGE__';
test_proto '__SUB__';

is file(), 'frob'    , '__FILE__ does check its caller'   ; ++ $tests;
is line(),  5        , '__LINE__ does check its caller'   ; ++ $tests;
is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests;
sub __SUB__test { &my__SUB__ }
is __SUB__test, \&__SUB__test, '&__SUB__';                  ++ $tests;

test_proto 'abs', -5, 5;

SKIP:
{
  if ($^O eq "MSWin32" && is_miniperl) {
    $tests += 8;
    skip "accept() not available in Win32 miniperl", 8
  }
  $tests += 6;
  test_proto 'accept';
  eval q{
    is &CORE::accept(qw{foo bar}), undef, "&accept";
    lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context";

    &myaccept(my $foo, my $bar);
    is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument';
    is $bar, undef, 'CORE::accept does not autovivify its second argument';
    use strict;
    undef $foo;
    eval { 'myaccept'->($foo, $bar) };
    like $@, qr/^Can't use an undefined value as a symbol reference at/,
    'CORE::accept will not accept undef 2nd arg under strict';
    is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict';
  };
}

test_proto 'alarm';
test_proto 'atan2';

test_proto 'bind';
$tests += 3;
SKIP:
{
  skip "bind() not available in Win32 miniperl", 3
    if $^O eq "MSWin32" && is_miniperl();
  is &CORE::bind('foo', 'bear'), undef, "&bind";
  lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context";
  eval { &mybind(my $foo, "bear") };
  like $@, qr/^Bad symbol for filehandle at/,
    'CORE::bind dies with undef first arg';
}

test_proto 'binmode';
$tests += 3;
is &CORE::binmode(qw[foo bar]), undef, "&binmode";
lis [&CORE::binmode(qw[foo bar])], [undef], "&binmode in list context";
is &mybinmode(foo), undef, '&binmode with one arg';

test_proto 'bless';
$tests += 3;
like &CORE::bless([],'parcel'), qr/^parcel=ARRAY/, "&bless";
like join(" ", &CORE::bless([],'parcel')), qr/^parcel=ARRAY(?!.* )/,
  "&bless in list context";
like &mybless([]), qr/^main=ARRAY/, '&bless with one arg';

test_proto 'break';
{
  $tests ++;
  my $tmp;
  no warnings 'deprecated';
  CORE::given(1) {
    CORE::when(1) {
      &mybreak;
      $tmp = 'bad';
    }
  }
  is $tmp, undef, '&break';
}

test_proto 'caller';
$tests += 4;
sub caller_test {
  is scalar &CORE::caller, 'hadhad', '&caller';
  is scalar &CORE::caller(1), 'main', '&caller(1)';
  lis [&CORE::caller], [caller], '&caller in list context';
  # The last element of caller in list context is a hint hash, which
  # may be a different hash for caller vs &CORE::caller, so an eq com-
  # parison (which lis() uses for convenience) won’t work.  So just
  # pop the last element, since the rest are sufficient to prove that
  # &CORE::caller works.
  my @ampcaller = &CORE::caller(1);
  my @caller    = caller(1);
  pop @ampcaller; pop @caller;
  lis \@ampcaller, \@caller, '&caller(1) in list context';
}
sub {
  package hadhad;
  ::caller_test();
}->();

use if !is_miniperl, File::Spec::Functions, qw(curdir);

test_proto 'chdir';
unless (is_miniperl) {
    $tests += 7;
    my ($false, $true) = (!!0, !!1);
    my $good_dir = curdir();
    my $bad_dir = 'no_such_dir+*?~';
    is mychdir($good_dir), $true, 'mychdir(".") succeeds';
    is mychdir($bad_dir), $false, 'mychdir($bad_dir) fails';
    is &CORE::chdir($good_dir), $true, '&chdir(".") succeeds';
    is &CORE::chdir($bad_dir), $false, '&chdir($bad_dir) fails';
    {
        local $ENV{HOME} = $good_dir;
        is &CORE::chdir(), $true, '&chdir() succeeds with $ENV{HOME} = "."';
        $ENV{HOME} = $bad_dir;
        is &CORE::chdir(), $false, '&chdir() fails with $ENV{HOME} = $bad_dir';
    }
    SKIP: {
        # I don't know enough about VMS to tell whether it is possible to
        # delete $ENV{'SYS$LOGIN'} and what that would mean, so just be
        # cautious and skip this test there until someone can verify.
        skip 'not messing with SYS$LOGIN on VMS', 1
            if $^O eq 'VMS';
        delete local @ENV{qw(HOME LOGDIR SYS$LOGIN)};
        is &CORE::chdir(), $false, '&chdir() fails with @ENV{qw(HOME LOGDIR SYS$LOGIN)} unset';
    }
}

test_proto 'chmod';
$tests += 3;
is &CORE::chmod(), 0, '&chmod with no args';
is &CORE::chmod(0666), 0, '&chmod';
lis [&CORE::chmod(0666)], [0], '&chmod in list context';

test_proto 'chown';
$tests += 4;
is &CORE::chown(), 0, '&chown with no args';
is &CORE::chown(1), 0, '&chown with 1 arg';
is &CORE::chown(1,2), 0, '&chown';
lis [&CORE::chown(1,2)], [0], '&chown in list context';

test_proto 'chr', 5, "\5";
test_proto 'chroot';

test_proto 'close';
{
  last if is_miniperl;
  $tests += 3;

  open my $fh, ">", \my $buffalo;
  print $fh 'an address in the outskirts of Jersey';
  ok &CORE::close($fh), '&CORE::close retval';
  print $fh 'lalala';
  is $buffalo, 'an address in the outskirts of Jersey',
    'effect of &CORE::close';
  # This has to be a separate variable from $fh, as re-using the same
  # variable can cause the tests to pass by accident.  That actually hap-
  # pened during developement, because the second close() was reading
  # beyond the end of the stack and finding a $fh left over from before.
  open my $fh2, ">", \($buffalo = '');
  select+(select($fh2), do {
    print "Nasusiro Tokasoni";
    &CORE::close();
    print "jfd";
    is $buffalo, "Nasusiro Tokasoni", '&CORE::close with no args';
  })[0];
}
lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests;

test_proto 'closedir';
$tests += 2;
is &CORE::closedir(foo), undef, '&CORE::closedir';
lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context';

test_proto 'connect';
$tests += 2;
SKIP:
{
  skip "connect() not available in Win32 miniperl", 2
    if $^O eq "MSWin32" && is_miniperl();
  is &CORE::connect('foo','bar'), undef, '&connect';
  lis [&myconnect('foo','bar')], [undef], '&connect in list context';
}

test_proto 'continue';
$tests ++;
no warnings 'deprecated';
CORE::given(1) {
  CORE::when(1) {
    &mycontinue();
  }
  pass "&continue";
}

test_proto 'cos';
test_proto 'crypt';

test_proto 'dbmclose';
test_proto 'dbmopen';
{
  last unless eval { require AnyDBM_File };
  $tests ++;
  my $filename = tempfile();
  &mydbmopen(\my %db, $filename, 0666);
  $db{1} = 2; $db{3} = 4;
  &mydbmclose(\%db);
  is scalar keys %db, 0, '&dbmopen and &dbmclose';
  my $Dfile = "$filename.pag";
  if (! -e $Dfile) {
    ($Dfile) = <$filename*>;
  }
  if ($^O eq 'VMS') {
    unlink "$filename.sdbm_dir", $Dfile;
  } else {
    unlink "$filename.dir", $Dfile;
  }
}

test_proto 'die';
eval { dier('quinquangle') };
is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++;

test_proto $_ for qw(
  endgrent endhostent endnetent endprotoent endpwent endservent
);

test_proto 'evalbytes';
$tests += 4;
{
  my $U_100_bytes = byte_utf8a_to_utf8n("\xc4\x80");
  chop(my $upgraded = "use utf8; $U_100_bytes" . chr 256);
  is &myevalbytes($upgraded), chr 256, '&evalbytes';
  # Test hints
  require strict;
  strict->import;
  &myevalbytes('
    is someone, "someone", "run-time hint bits do not leak into &evalbytes"
  ');
  use strict;
  BEGIN { $^H{coreamp} = 42 }
  $^H{coreamp} = 75;
  &myevalbytes('
    BEGIN {
      is $^H{coreamp}, 42, "compile-time hh propagates into &evalbytes";
    }
    ${"frobnicate"}
  ');
  like $@, qr/strict/, 'compile-time hint bits propagate into &evalbytes';
}

test_proto 'exit';
$tests ++;
is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n",
  '&exit with no args';

test_proto 'fork';

test_proto 'formline';
$tests += 3;
is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval';
is $^A,        ' 1       2', 'effect of &myformline';
lis [&myformline('@')], [1], '&myformline in list context';

test_proto 'each';
$tests += 4;
is &myeach({ "a","b" }), "a", '&myeach(\%hash) in scalar cx';
lis [&myeach({qw<a b>})], [qw<a b>], '&myeach(\%hash) in list cx';
is &myeach([ "a","b" ]), 0, '&myeach(\@array) in scalar cx';
lis [&myeach([qw<a b>])], [qw<0 a>], '&myeach(\@array) in list cx';

test_proto 'exp';

test_proto 'fc';
$tests += 2;
{
  my $sharp_s = uni_to_native("\xdf");
  is &myfc($sharp_s), $sharp_s, '&fc, no unicode_strings';
  use feature 'unicode_strings';
  is &myfc($sharp_s), "ss", '&fc, unicode_strings';
}

test_proto 'fcntl';

test_proto 'fileno';
$tests += 2;
is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno';
lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx';

test_proto 'flock';
test_proto 'fork';

test_proto 'getc';
{
  last if is_miniperl;
  $tests += 3;
  local *STDIN;
  open my $fh, "<", \(my $buf='falo');
  open STDIN, "<", \(my $buf2 = 'bison');
  is &mygetc($fh), 'f', '&mygetc';
  is &mygetc(), 'b', '&mygetc with no args';
  lis [&mygetc($fh)], ['a'], '&mygetc in list context';
}

test_proto "get$_" for qw '
  grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname
  netent peername
';

test_proto 'getpgrp';
eval {&mygetpgrp()};
pass '&getpgrp with no args does not crash'; $tests++;

test_proto "get$_" for qw '
  ppid priority protobyname protobynumber protoent
  pwent pwnam pwuid servbyname servbyport servent sockname sockopt
';

# Make sure the following tests test what we think they are testing.
ok ! $CORE::{glob}, '*CORE::glob not autovivified yet'; $tests ++;
{
  # Make sure ck_glob does not respect the override when &CORE::glob is
  # autovivified (by test_proto).
  local *CORE::GLOBAL::glob = sub {};
  test_proto 'glob';
}
$_ = "t/*.t";
@_ = &myglob($_);
is join($", &myglob()), "@_", '&glob without arguments';
is join($", &myglob("t/*.t")), "@_", '&glob with an arg';
$tests += 2;

test_proto 'gmtime';
&CORE::gmtime;
pass '&gmtime without args does not crash'; ++$tests;

test_proto 'hex', ff=>255;

test_proto 'index';
$tests += 3;
is &myindex("foffooo","o",2),4,'&index';
lis [&myindex("foffooo","o",2)],[4],'&index in list context';
is &myindex("foffooo","o"),1,'&index with 2 args';

test_proto 'int', 1.5=>1;
test_proto 'ioctl';

test_proto 'join';
$tests += 2;
is &myjoin('a','b','c'), 'bac', '&join';
lis [&myjoin('a','b','c')], ['bac'], '&join in list context';

test_proto 'keys';
$tests += 6;
is &mykeys({ 1..4 }), 2, '&mykeys(\%hash) in scalar cx';
lis [sort &mykeys({1..4})], [1,3], '&mykeys(\%hash) in list cx';
is &mykeys([ 1..4 ]), 4, '&mykeys(\@array) in scalar cx';
lis [&mykeys([ 1..4 ])], [0..3], '&mykeys(\@array) in list cx';

SKIP: {
  skip "no Hash::Util on miniperl", 2, if is_miniperl;
  require Hash::Util;
  sub Hash::Util::bucket_ratio (\%);

  my %h = 1..2;
  &mykeys(\%h) = 1024;
  like Hash::Util::bucket_ratio(%h), qr!/(?:1024|2048)\z!, '&mykeys = changed number of buckets allocated';
  eval { (&mykeys(\%h)) = 1025; };
  like $@, qr/^Can't modify keys in list assignment at /;
}

test_proto 'kill'; # set up mykill alias
if ($^O ne 'riscos') {
  $tests ++;
  ok( &mykill(0, $$), '&kill' );
}

test_proto 'lc', 'A', 'a';
test_proto 'lcfirst', 'AA', 'aA';
test_proto 'length', 'aaa', 3;
test_proto 'link';
test_proto 'listen';

test_proto 'localtime';
&CORE::localtime;
pass '&localtime without args does not crash'; ++$tests;

test_proto 'lock';
$tests += 6;
is \&mylock(\$foo), \$foo, '&lock retval when passed a scalar ref';
lis [\&mylock(\$foo)], [\$foo], '&lock in list context';
is &mylock(\@foo), \@foo, '&lock retval when passed an array ref';
is &mylock(\%foo), \%foo, '&lock retval when passed a ash ref';
is &mylock(\&foo), \&foo, '&lock retval when passed a code ref';
is \&mylock(\*foo), \*foo, '&lock retval when passed a glob ref';

test_proto 'log';

test_proto 'mkdir';
# mkdir is tested with implicit $_ at the end, to make the test easier

test_proto "msg$_" for qw( ctl get rcv snd );

test_proto 'not';
$tests += 2;
is &mynot(1), !1, '&not';
lis [&mynot(0)], [!0], '&not in list context';

test_proto 'oct', '666', 438;

test_proto 'open';
$tests += 5;
$file = 'test.pl';
ok &myopen('file'), '&open with 1 arg' or warn "1-arg open: $!";
like <file>, qr|^#|, 'result of &open with 1 arg';
close file;
{
  ok &myopen(my $fh, "test.pl"), 'two-arg &open';
  ok $fh, '&open autovivifies';
  like <$fh>, qr '^#', 'result of &open with 2 args';
  last if is_miniperl;
  $tests +=2;
  ok &myopen(my $fh2, "<", \"sharummbles"), 'retval of 3-arg &open';
  is <$fh2>, 'sharummbles', 'result of three-arg &open';
}

test_proto 'opendir';
test_proto 'ord', chr(utf8::unicode_to_native(64)), utf8::unicode_to_native(64);

test_proto 'pack';
$tests += 2;
my $Perl_as_a_hex_string =
  join "", map { sprintf("%2X", utf8::unicode_to_native($_)) } 0x50, 0x65, 0x72, 0x6c;
is &mypack("H*", $Perl_as_a_hex_string), 'Perl', '&pack';
lis [&mypack("H*", $Perl_as_a_hex_string)], ['Perl'], '&pack in list context';

test_proto 'pipe';

test_proto 'pop';
$tests += 6;
@ARGV = qw<a b c>;
is &mypop(), 'c', 'retval of &pop with no args (@ARGV)';
is "@ARGV", "a b", 'effect of &pop on @ARGV';
sub {
  is &mypop(), 'k', 'retval of &pop with no args (@_)';
  is "@_", "q j", 'effect of &pop on @_';
}->(qw(q j k));
{
  my @a = 1..4;
  is &mypop(\@a), 4, 'retval of &pop';
  lis [@a], [1..3], 'effect of &pop';
}

test_proto 'pos';
$tests += 4;
$_ = "hello";
pos = 3;
is &mypos, 3, 'reading &pos without args';
&mypos = 4;
is pos, 4, 'writing to &pos without args';
{
  my $x = "gubai";
  pos $x = 3;
  is &mypos(\$x), 3, 'reading &pos without args';
  &mypos(\$x) = 4;
  is pos $x, 4, 'writing to &pos without args';
}

test_proto 'prototype';
$tests++;
is &myprototype(\&myprototype), prototype("CORE::prototype"), '&prototype';

test_proto 'push';
$tests += 2;
{
  my @a = qw<a b c>;
  is &mypush(\@a, "d", "e"), 5, 'retval of &push';
  is "@a", "a b c d e", 'effect of &push';
}

test_proto 'quotemeta', '$', '\$';

test_proto 'rand';
$tests += 3;
my $r = &CORE::rand;
ok eval {
  use warnings FATAL => qw{numeric uninitialized};
  $r >= 0 && $r < 1;
}, '&rand returns a valid number';
unlike join(" ", &CORE::rand), qr/ /, '&rand in list context';
&cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 1 arg');

test_proto 'read';
{
  last if is_miniperl;
  $tests += 5;
  open my $fh, "<", \(my $buff = 'morays have their mores');
  ok &myread($fh, \my $input, 6), '&read with 3 args';
  is $input, 'morays', 'value read by 3-arg &read';
  ok &myread($fh, \$input, 6, 6), '&read with 4 args';
  is $input, 'morays have ', 'value read by 4-arg &read';
  is +()=&myread($fh, \$input, 6), 1, '&read in list context';
}

test_proto 'readdir';

test_proto 'readline';
{
  local *ARGV = *DATA;
  $tests ++;
  is scalar &myreadline,
    "I wandered lonely as a cloud\n", '&readline w/no args';
}
{
  last if is_miniperl;
  $tests += 2;
  open my $fh, "<", \(my $buff = <<END);
The Recursive Problem
---------------------
I have a problem I cannot solve.
The problem is that I cannot solve it.
END
  is &myreadline($fh), "The Recursive Problem\n",
    '&readline with 1 arg';
  lis [&myreadline($fh)], [
       "---------------------\n",
       "I have a problem I cannot solve.\n",
       "The problem is that I cannot solve it.\n",
      ], '&readline in list context';
}

test_proto 'readlink';
test_proto 'readpipe';
test_proto 'recv';

use if !is_miniperl, File::Spec::Functions, qw "catfile";
use if !is_miniperl, File::Temp, 'tempdir';

test_proto 'rename';
{
  last if is_miniperl;
  $tests ++;
  my $dir = tempdir(uc cleanup => 1);
  my $tmpfilenam = catfile $dir, 'aaa';
  open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!";
  close $fh or die "cannot close $tmpfilenam: $!";
  &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb');
  ok open(my $fh, '>', $tmpfilenam), '&rename';
}

test_proto 'ref', [], 'ARRAY';

test_proto 'reset';
$tests += 2;
my $oncer = sub { "a" =~ m?a? };
&$oncer;
&myreset;
ok &$oncer, '&reset with no args';
package resettest {
  $b = "c";
  $banana = "cream";
  &::myreset('b');
  ::lis [$b,$banana],[(undef)x2], '1-arg &reset';
}

test_proto 'reverse';
$tests += 2;
is &myreverse('reward'), 'drawer', '&reverse';
lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'],
  '&reverse in list context';

test_proto 'rewinddir';

test_proto 'rindex';
$tests += 3;
is &myrindex("foffooo","o",2),1,'&rindex';
lis [&myrindex("foffooo","o",2)],[1],'&rindex in list context';
is &myrindex("foffooo","o"),6,'&rindex with 2 args';

test_proto 'rmdir';

test_proto 'scalar';
$tests += 2;
is &myscalar(3), 3, '&scalar';
lis [&myscalar(3)], [3], '&scalar in list cx';

test_proto 'seek';
{
  last if is_miniperl;
  $tests += 1;
  open my $fh, "<", \"misled" or die $!;
  &myseek($fh, 2, 0);
  is <$fh>, 'sled', '&seek in action';
}

test_proto 'seekdir';

# Can’t test_proto, as it has none
$tests += 8;
*myselect = \&CORE::select;
is defined prototype &myselect, defined prototype "CORE::select",
  'prototype of &select (or lack thereof)';
is &myselect, select, '&select with no args';
{
  my $prev = select;
  is &myselect(my $fh), $prev, '&select($arg) retval';
  is lc ref $fh, 'glob', '&select autovivifies';
  is select, $fh, '&select selects';
  select $prev;
}
eval { &myselect(1,2) };
like $@, qr/^Not enough arguments for select system call at /,
  '&myselect($two,$args)';
eval { &myselect(1,2,3) };
like $@, qr/^Not enough arguments for select system call at /,
  '&myselect($with,$three,$args)';
eval { &myselect(1,2,3,4,5) };
like $@, qr/^Too many arguments for select system call at /,
  '&myselect($a,$total,$of,$five,$args)';
unless ($^O eq "MSWin32" && is_miniperl) {
  &myselect((undef)x3,.25);
  # Just have to assume that worked. :-) If we get here, at least it didn’t
  # crash or anything.
  # select() is unimplemented in Win32 miniperl
}

test_proto "sem$_" for qw "ctl get op";

test_proto 'send';

test_proto "set$_" for qw '
  grent hostent netent
';

test_proto 'setpgrp';
$tests +=2;
eval { &mysetpgrp( 0) };
pass "&setpgrp with one argument";
eval { &mysetpgrp };
pass "&setpgrp with no arguments";

test_proto "set$_" for qw '
  priority protoent pwent servent sockopt
';

test_proto 'shift';
$tests += 6;
@ARGV = qw<a b c>;
is &myshift(), 'a', 'retval of &shift with no args (@ARGV)';
is "@ARGV", "b c", 'effect of &shift on @ARGV';
sub {
  is &myshift(), 'q', 'retval of &shift with no args (@_)';
  is "@_", "j k", 'effect of &shift on @_';
}->(qw(q j k));
{
  my @a = 1..4;
  is &myshift(\@a), 1, 'retval of &shift';
  lis [@a], [2..4], 'effect of &shift';
}

test_proto "shm$_" for qw "ctl get read write";
test_proto 'shutdown';
test_proto 'sin';
test_proto 'sleep';
test_proto "socket$_" for "", "pair";

test_proto 'splice';
$tests += 8;
{
  my @a = qw<a b c>;
  is &mysplice(\@a, 1), 'c', 'retval of 2-arg &splice in scalar context';
  lis \@a, ['a'], 'effect of 2-arg &splice in scalar context';
  @a = qw<a b c>;
  lis [&mysplice(\@a, 1)], ['b','c'], 'retval of 2-arg &splice in list cx';
  lis \@a, ['a'], 'effect of 2-arg &splice in list context';
  @a = qw<a b c d>;
  lis [&mysplice(\@a,1,2)],['b','c'], 'retval of 3-arg &splice in list cx';
  lis \@a, ['a','d'], 'effect of 3-arg &splice in list context';
  @a = qw<a b c d>;
  lis [&mysplice(\@a,1,1,'e')],['b'], 'retval of 4-arg &splice in list cx';
  lis \@a, [qw<a e c d>], 'effect of 4-arg &splice in list context';
}

test_proto 'sprintf';
$tests += 2;
is &mysprintf("%x", 65), '41', '&sprintf';
lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context';

test_proto 'sqrt', 4, 2;

test_proto 'srand';
$tests ++;
&CORE::srand;
() = &CORE::srand;
pass '&srand with no args does not crash';

test_proto 'study';

test_proto 'substr';
$tests += 5;
$_ = "abc";
is &mysubstr($_, 1, 1, "d"), 'b', '4-arg &substr';
is $_, 'adc', 'what 4-arg &substr does';
is &mysubstr("abc", 1, 1), 'b', '3-arg &substr';
is &mysubstr("abc", 1), 'bc', '2-arg &substr';
&mysubstr($_, 1) = 'long';
is $_, 'along', 'lvalue &substr';

test_proto 'symlink';
test_proto 'syscall';

test_proto 'sysopen';
$tests +=2;
{
  &mysysopen(my $fh, 'test.pl', 0);
  pass '&sysopen does not crash with 3 args';
  ok $fh, 'sysopen autovivifies';
}

test_proto 'sysread';
test_proto 'sysseek';
test_proto 'syswrite';

test_proto 'tell';
{
  $tests += 2;
  open my $fh, "test.pl" or die "Cannot open test.pl";
  <$fh>;
  is &mytell(), tell($fh), '&tell with no args';
  is &mytell($fh), tell($fh), '&tell with an arg';
}

test_proto 'telldir';

test_proto 'tie';
test_proto 'tied';
$tests += 3;
{
  my $fetches;
  package tier {
    sub TIESCALAR { bless[] }
    sub FETCH { ++$fetches }
  }
  my $tied;
  my $obj = &mytie(\$tied, 'tier');
  is &mytied(\$tied), $obj, '&tie and &tied retvals';
  () = "$tied";
  is $fetches, 1, '&tie actually ties';
  &CORE::untie(\$tied);
  () = "$tied";
  is $fetches, 1, '&untie unties';
}

test_proto 'time';
$tests += 2;
like &mytime, qr/^\d+\z/, '&time in scalar context';
like join('-', &mytime), qr/^\d+\z/, '&time in list context';

test_proto 'times';
$tests += 2;
like &mytimes, qr/^[\d.]+\z/, '&times in scalar context';
like join('-',&mytimes), qr/^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z/,
  '&times in list context';

test_proto 'uc', 'aa', 'AA';
test_proto 'ucfirst', 'aa', "Aa";

test_proto 'umask';
$tests ++;
is &myumask, umask, '&umask with no args';

test_proto 'undef';
$tests += 12;
is &myundef(), undef, '&undef returns undef';
lis [&myundef()], [undef], '&undef returns undef in list cx';
lis [&myundef(\$_)], [undef], '&undef(...) returns undef in list cx';
is \&myundef(), \undef, '&undef returns the right undef';
$_ = 'anserine questions';
&myundef(\$_);
is $_, undef, '&undef(\$_) undefines $_';
@_ = 1..3;
&myundef(\@_);
is @_, 0, '&undef(\@_) undefines @_';
%_ = 1..4;
&myundef(\%_);
ok !%_, '&undef(\%_) undefines %_';
&myundef(\&utf8::valid); # nobody should be using this :-)
ok !defined &utf8::valid, '&undef(\&foo) undefines &foo';
@_ = \*_;
&myundef;
is *_{ARRAY}, undef, '@_=\*_, &undef undefines *_';
@_ = \*_;
&myundef(\*_);
is *_{ARRAY}, undef, '&undef(\*_) undefines *_';
(&myundef(), @_) = 1..10;
lis \@_, [2..10], 'list assignment to &undef()';
ok !defined undef, 'list assignment to &undef() does not affect undef'; 
undef @_;

test_proto 'unpack';
$tests += 2;
my $abcd_as_a_hex_string =
  join "", map { sprintf("%2X", utf8::unicode_to_native($_)) } 0x61, 0x62, 0x63, 0x64;
my $bcde_as_a_hex_string =
  join "", map { sprintf("%2X", utf8::unicode_to_native($_)) } 0x62, 0x63, 0x64, 0x65;
$_ = 'abcd';
is &myunpack("H*"), $abcd_as_a_hex_string, '&unpack with one arg';
is &myunpack("H*", "bcde"), $bcde_as_a_hex_string, '&unpack with two arg';


test_proto 'unshift';
$tests += 2;
{
  my @a = qw<a b c>;
  is &myunshift(\@a, "d", "e"), 5, 'retval of &unshift';
  is "@a", "d e a b c", 'effect of &unshift';
}

test_proto 'untie'; # behaviour already tested along with tie(d)

test_proto 'utime';
$tests += 2;
is &myutime(undef,undef), 0, '&utime';
lis [&myutime(undef,undef)], [0], '&utime in list context';

test_proto 'values';
$tests += 4;
is &myvalues({ 1..4 }), 2, '&myvalues(\%hash) in scalar cx';
lis [sort &myvalues({1..4})], [2,4], '&myvalues(\%hash) in list cx';
is &myvalues([ 1..4 ]), 4, '&myvalues(\@array) in scalar cx';
lis [&myvalues([ 1..4 ])], [1..4], '&myvalues(\@array) in list cx';

test_proto 'vec';
$tests += 3;
is &myvec("foo", 0, 4), 6, '&vec';
lis [&myvec("foo", 0, 4)], [6], '&vec in list context';
$tmp = "foo";
++&myvec($tmp,0,4);
is $tmp, "goo", 'lvalue &vec';

test_proto 'wait';
test_proto 'waitpid';

test_proto 'wantarray';
$tests += 4;
my $context;
my $cx_sub = sub {
  $context = qw[void scalar list][&mywantarray + defined mywantarray()]
};
() = &$cx_sub;
is $context, 'list', '&wantarray with caller in list context';
scalar &$cx_sub;
is($context, 'scalar', '&wantarray with caller in scalar context');
&$cx_sub;
is($context, 'void', '&wantarray with caller in void context');
lis [&mywantarray],[wantarray], '&wantarray itself in list context';

test_proto 'warn';
{ $tests += 3;
  my $w;
  local $SIG{__WARN__} = sub { $w = shift };
  is &mywarn('a'), 1, '&warn retval';
  is $w, "a at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'warning';
  lis [&mywarn()], [1], '&warn retval in list context';
}

test_proto 'write';
$tests ++;
eval {&mywrite};
like $@, qr'^Undefined format "STDOUT" called',
  "&write without arguments can handle the null";

# This is just a check to make sure we have tested everything.  If we
# haven’t, then either the sub needs to be tested or the list in
# gv.c is wrong.
{
  last if is_miniperl;
  require File::Spec::Functions;
  my $keywords_file =
    File::Spec::Functions::catfile(
      File::Spec::Functions::updir,'regen','keywords.pl'
    );
  my %nottest_words = map { $_ => 1 } qw(
    ADJUST AUTOLOAD BEGIN CHECK CORE DESTROY END INIT UNITCHECK
    __DATA__ __END__
    all and any catch class cmp default defer do dump else elsif
    eq eval field finally
    for foreach format ge given goto grep gt if isa last le local lt m map
    method my ne next no or our package print printf q qq qr qw qx redo require
    return s say sort state sub tr try unless until use when while x xor y
  );
  open my $kh, $keywords_file
    or die "$0 cannot open $keywords_file: $!";
  while(<$kh>) {
    if (m?__END__?..${\0} and /^[-+](.*)/) {
      my $word = $1;
      next if $nottest_words{$word};
      $tests ++;
      ok   exists &{"my$word"}
        || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/),
        "$word either has been tested or is not ampable";
    }
  }
}

# Add new tests above this line.

# This test must come last (before the test count test):

{
  last if is_miniperl;
  require Cwd;
  Cwd->import;
  $tests += 3;
  require File::Temp ;
  my $dir = File::Temp::tempdir(uc cleanup => 1);
  my $cwd = cwd();
  chdir($dir);

  # Make sure that implicit $_ is not applied to mkdir’s second argument.
  local $^W = 1;
  my $warnings;
  local $SIG{__WARN__} = sub { ++$warnings };

  local $_ = 'Phoo';
  ok &mymkdir(), '&mkdir';
  like <*>, qr/^phoo(.DIR)?\z/i, 'mkdir works with implicit $_';

  is $warnings, undef, 'no implicit $_ for second argument to mkdir';

  chdir($cwd); # so auto-cleanup can remove $dir
}

# ------------ END TESTING ----------- #

done_testing $tests;

#line 3 frob

sub file { &CORE::__FILE__ }
sub line { &CORE::__LINE__ } # 5
sub dier { &CORE::die(@_)  } # 6
package stribble;
sub main::pakg { &CORE::__PACKAGE__ }

# Please do not add new tests here.
package main;
CORE::__DATA__
I wandered lonely as a cloud
That floats on high o'er vales and hills,
And all at once I saw a crowd, 
A host of golden daffodils!
Beside the lake, beneath the trees,
Fluttering, dancing, in the breeze.
-- Wordsworth
