&CORE::foo() for (sys)read and recv

These are grouped together because they all have \$ in their
prototypes.

This commit allows the subs in the CORE package under those names to
be called through references and via &ampersand syntax.

The coreargs op in the subroutine is marked with the OPpSCALARMOD
flag.  (scalar_mod_type in op.c returns true for these three ops,
indicating that the OA_SCALARREF parameter is \$, not \[$@%(&)*].)

pp_coreargs uses that flag to decide what arguments to reject.

4 files changed, 59 insertions, 7 deletions

diff --git a/gv.c b/gv.c
index 91d4cffc5e..cbbf326136 100644
--- a/gv.c
+++ b/gv.c
@@ -1357,13 +1357,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    case KEY_keys:
 	    case KEY_lstat:
 	    case KEY_pop:
-	    case KEY_push: case KEY_read:
-	    case KEY_recv: case KEY_reset:
+	    case KEY_push: case KEY_reset:
 	    case KEY_select: case KEY_send:
 	    case KEY_setpgrp: case KEY_shift: case KEY_sleep:
 	    case KEY_splice:
 	    case KEY_srand: case KEY_stat: case KEY_substr:
-	    case KEY_sysopen: case KEY_sysread:
+	    case KEY_sysopen:
 	    case KEY_system: case KEY_syswrite:
 	    case KEY_tell: case KEY_tie: case KEY_tied:
 	    case KEY_truncate: case KEY_umask: case KEY_unlink:
diff --git a/op.c b/op.c
index 4f42daa1da..73dccf8f17 100644
--- a/op.c
+++ b/op.c
@@ -10382,6 +10382,8 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
 	    o = convert(opnum,0,argop);
 	    if (is_handle_constructor(o, 2))
 		argop->op_private |= OPpCOREARGS_DEREF2;
+	    if (scalar_mod_type(NULL, opnum))
+		argop->op_private |= OPpCOREARGS_SCALARMOD;
 	    goto onearg;
 	}
     }
diff --git a/pp.c b/pp.c
index fe2c4ab389..8ea7eb57d8 100644
--- a/pp.c
+++ b/pp.c
@@ -6114,17 +6114,28 @@ PP(pp_coreargs)
 	    }
 	    break;
 	case OA_SCALARREF:
+	  {
+	    const bool wantscalar =
+		PL_op->op_private & OPpCOREARGS_SCALARMOD;
 	    if (!svp || !*svp || !SvROK(*svp)
-	     || SvTYPE(SvRV(*svp)) > SVt_PVCV
+	        /* We have to permit globrefs even for the \$ proto, as
+	           *foo is indistinguishable from ${\*foo}, and the proto-
+	           type permits the latter. */
+	     || SvTYPE(SvRV(*svp)) > (
+	             wantscalar ? SVt_PVLV : SVt_PVCV
+	        )
 	       )
 		DIE(aTHX_
 		/* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
-		 "Type of arg %d to &CORE::%s must be reference to one of "
-		 "[$@%%&*]",
-		  whicharg, OP_DESC(PL_op->op_next)
+		 "Type of arg %d to &CORE::%s must be %s",
+		  whicharg, OP_DESC(PL_op->op_next),
+		  wantscalar
+		    ? "scalar reference"
+		    : "reference to one of [$@%&*]"
 		);
 	    PUSHs(SvRV(*svp));
 	    break;
+	  }
 	default:
 	    DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
 	}
diff --git a/t/op/coreamp.t b/t/op/coreamp.t
index 3d866e3379..b77d56a939 100644
--- a/t/op/coreamp.t
+++ b/t/op/coreamp.t
@@ -22,6 +22,13 @@ sub lis($$;$) {
   &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
 }
 
+package hov {
+  use overload '%{}' => sub { +{} }
+}
+package sov {
+  use overload '${}' => sub { \my $x }
+}
+
 my %op_desc = (
  join     => 'join or string',
  readline => '<HANDLE>',
@@ -141,6 +148,25 @@ sub test_proto {
     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;
 
@@ -491,6 +517,18 @@ like &CORE::rand, qr/^0[.\d]*\z/, '&rand';
 unlike join(" ", &CORE::rand), qr/ /, '&rand in list context';
 &cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 2 args');
 
+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';
@@ -520,6 +558,7 @@ END
 
 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';
@@ -583,6 +622,7 @@ lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context';
 test_proto 'sqrt', 4, 2;
 test_proto 'symlink';
 test_proto 'syscall';
+test_proto 'sysread';
 test_proto 'sysseek';
 test_proto 'telldir';