Allow ampersand calls to CORE subs with (_) proto

This commit adds all subs with a (_) prototype to the list of those
that can be called with ampersand syntax or through references.  These
have bodies like this:

$ ./perl -Ilib -MO=Concise,CORE::abs -e 'BEGIN{\&CORE::abs}'
CORE::abs:
3  <1> leavesub[1 ref] K/REFC,1 ->(end)
2     <1> abs[t1] sK/1 ->3
1        <$> coreargs(IV 111) s ->2
-e syntax OK

coreargs fetches the caller’s $_ if there are no arguments passed.

3 files changed, 141 insertions, 8 deletions

diff --git a/gv.c b/gv.c
index 55dbd4706f..a4cfbb00db 100644
--- a/gv.c
+++ b/gv.c
@@ -1353,15 +1353,21 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    case KEY_or: case KEY_x: case KEY_xor:
 		return gv;
 	    case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
-	    case KEY_break:
-	    case KEY_continue: case KEY_endgrent: case KEY_endhostent:
+	    case KEY_abs: case KEY_alarm: case KEY_chr: case KEY_chroot:
+	    case KEY_break: case KEY_continue: case KEY_cos:
+	    case KEY_endgrent: case KEY_endhostent:
 	    case KEY_endnetent: case KEY_endprotoent: case KEY_endpwent:
-	    case KEY_endservent: case KEY_getgrent: case KEY_gethostent:
+	    case KEY_endservent: case KEY_exp:
+	    case KEY_getgrent: case KEY_gethostent:
 	    case KEY_fork:
 	    case KEY_getlogin: case KEY_getnetent: case KEY_getppid:
 	    case KEY_getprotoent: case KEY_getservent: case KEY_getpwent:
-	    case KEY_setgrent:
-	    case KEY_setpwent: case KEY_time: case KEY_times:
+	    case KEY_hex: case KEY_int: case KEY_lc: case KEY_lcfirst: 
+	    case KEY_length: case KEY_log: case KEY_oct: case KEY_ord:
+	    case KEY_quotemeta: case KEY_readlink: case KEY_readpipe:
+	    case KEY_ref: case KEY_rmdir: case KEY_setgrent:
+	    case KEY_setpwent: case KEY_sin: case KEY_sqrt: case KEY_time:
+	    case KEY_times: case KEY_uc: case KEY_ucfirst:
 	    case KEY_wait: case KEY_wantarray:
 		ampable = TRUE;
 	    }
@@ -1419,13 +1425,20 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 			break;
 		    }
 		default:
-		    o = op_append_elem(OP_LINESEQ, argop,
+		    switch (PL_opargs[opnum] & OA_CLASS_MASK) {
+		    case OA_BASEOP:
+			o = op_append_elem(
+			               OP_LINESEQ, argop,
 		                       newOP(opnum,
 		                             opnum == OP_WANTARRAY
 		                               ? OPpOFFBYONE << 8
 		                               : 0
 		                            )
 		                      );
+			break;
+		    default:
+			o = newUNOP(opnum,0,argop);
+		    }
 		}
 		newATTRSUB(oldsavestack_ix,
 		           newSVOP(
diff --git a/pp.c b/pp.c
index 2894e3b378..34ee45dfb0 100644
--- a/pp.c
+++ b/pp.c
@@ -5981,13 +5981,18 @@ PP(pp_coreargs)
     dSP;
     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
     AV * const at_ = GvAV(PL_defgv);
+    SV **svp = AvARRAY(at_);
     I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1;
     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
+    bool seen_question = 0;
     const char *err = NULL;
 
-    /* Count how many args there are. */
+    /* Count how many args there are first, to get some idea how far to
+       extend the stack. */
     while (oa) {
 	maxargs++;
+	if (oa & OA_OPTIONAL) seen_question = 1;
+	if (!seen_question) minargs++;
 	oa >>= 4;
     }
 
@@ -6007,6 +6012,37 @@ PP(pp_coreargs)
        nextstate. */
     SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 
+    if(!maxargs) RETURN;
+
+    EXTEND(SP, maxargs);
+
+    oa = PL_opargs[opnum] >> OASHIFT;
+    if (!numargs) {
+	PERL_SI * const oldsi = PL_curstackinfo;
+	I32 const oldcxix = oldsi->si_cxix;
+	CV *caller;
+	if (oldcxix) oldsi->si_cxix--;
+	else PL_curstackinfo = oldsi->si_prev;
+	caller = find_runcv(NULL);
+	PL_curstackinfo = oldsi;
+	oldsi->si_cxix = oldcxix;
+	PUSHs(
+	 find_rundefsv2(caller,cxstack[cxstack_ix].blk_oldcop->cop_seq)
+	);
+	oa >>= 4;
+    }
+    for (;oa;numargs&&(++svp,--numargs)) {
+	switch (oa & 7) {
+	case OA_SCALAR:
+	    PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
+	    break;
+	default:
+	    PUTBACK;
+	    DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
+	}
+	oa = oa >> 4;
+    }
+
     RETURN;
 }
 
diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 4d4ae03f9c..1866c0d398 100644
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -25,8 +25,17 @@ sub lis($$;$) {
   &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
 }
 
+my %op_desc = (
+ readpipe => 'quoted execution (``, qx)',
+ ref      => 'reference-type operator',
+);
+sub op_desc($) {
+  return $op_desc{$_[0]} || $_[0];
+}
+
+
 # This tests that the &{} syntax respects the number of arguments implied
-# by the prototype.
+# by the prototype, plus some extra tests for the (_) prototype.
 sub test_proto {
   my($o) = shift;
 
@@ -42,6 +51,54 @@ sub test_proto {
     like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
 
   }
+  elsif ($p eq '_') {
+    $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 += 6;
+
+    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";
+
+    # Since there is special code to deal with lexical $_, make sure it
+    # works in all cases.
+    undef $_;
+    {
+      my $_ = $in;
+      is &{"CORE::$o"}(), $out, "&$o with no args uses lexical \$_";
+    }
+    # Make sure we get the right pad under recursion
+    my $r;
+    $r = sub {
+      if($_[0]) {
+        my $_ = $in;
+        is &{"CORE::$o"}(), $out,
+           "&$o with no args uses the right lexical \$_ under recursion";
+      }
+      else {
+        &$r(1)
+      }
+    };
+    &$r(0);
+    my $_ = $in;
+    eval {
+       is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval"
+    };   
+  }
 
   else {
     die "Please add tests for the $p prototype";
@@ -56,6 +113,9 @@ 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;
 
+test_proto 'abs', -5, 5;
+test_proto 'alarm';
+
 test_proto 'break';
 { $tests ++;
   my $tmp;
@@ -68,6 +128,8 @@ test_proto 'break';
   is $tmp, undef, '&break';
 }
 
+test_proto 'chr', 5, "\5";
+test_proto 'chroot';
 test_proto 'continue';
 $tests ++;
 CORE::given(1) {
@@ -77,11 +139,14 @@ CORE::given(1) {
   pass "&continue";
 }
 
+test_proto 'cos';
+
 test_proto $_ for qw(
  endgrent endhostent endnetent endprotoent endpwent endservent
 );
 
 test_proto 'fork';
+test_proto 'exp';
 
 test_proto "get$_" for qw '
   grent hostent login
@@ -89,10 +154,27 @@ test_proto "get$_" for qw '
   pwent servent
 ';
 
+test_proto 'hex', ff=>255;
+test_proto 'int', 1.5=>1;
+test_proto 'lc', 'A', 'a';
+test_proto 'lcfirst', 'AA', 'aA';
+test_proto 'length', 'aaa', 3;
+test_proto 'log';
+test_proto 'oct', '666', 438;
+test_proto 'ord', chr(64), 64;
+test_proto 'quotemeta', '$', '\$';
+test_proto 'readlink';
+test_proto 'readpipe';
+test_proto 'ref', [], 'ARRAY';
+test_proto 'rmdir';
+
 test_proto "set$_" for qw '
   grent pwent
 ';
 
+test_proto 'sin';
+test_proto 'sqrt', 4, 2;
+
 test_proto 'time';
 $tests += 2;
 like &mytime, '^\d+\z', '&time in scalar context';
@@ -104,6 +186,8 @@ like &mytimes, '^[\d.]+\z', '&times in scalar context';
 like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
    '&times in list context';
 
+test_proto 'uc', 'aa', 'AA';
+test_proto 'ucfirst', 'aa', "Aa";
 test_proto 'wait';
 
 test_proto 'wantarray';