&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.

diff --git a/gv.c b/gv.c
index 91d4cff..cbbf326 100644 (file)
--- 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 4f42daa..73dccf8 100644 (file)
--- 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 fe2c4ab..8ea7eb5 100644 (file)
--- 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 3d866e3..b77d56a 100644 (file)
--- 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';