Allow &CORE::foo() with array functions

gv.c

@@ -533,14 +533,10 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
     case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
     case KEY_eof  : case KEY_exec: case KEY_exists :
     case KEY_lstat:
-    case KEY_pop:
-    case KEY_push:
-    case KEY_shift:
-    case KEY_splice: case KEY_split:
+    case KEY_split:
     case KEY_stat:
     case KEY_system:
     case KEY_truncate: case KEY_unlink:
-    case KEY_unshift:
 	ampable = FALSE;
     }
     if (!gv) {

pp.c

@@ -6241,6 +6241,18 @@ PP(unimplemented_op)
     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,	op_type);
 }
 
+static void
+S_maybe_unwind_defav(pTHX)
+{
+    if (CX_CUR()->cx_type & CXp_HASARGS) {
+	PERL_CONTEXT *cx = CX_CUR();
+
+        assert(CxHASARGS(cx));
+        cx_popsub_args(cx);
+	cx->cx_type &= ~CXp_HASARGS;
+    }
+}
+
 /* For sorting out arguments passed to a &CORE:: subroutine */
 PP(pp_coreargs)
 {
@@ -6311,6 +6323,27 @@ PP(pp_coreargs)
 		svp++;
 	    }
 	    RETURN;
+	case OA_AVREF:
+	    if (!numargs) {
+		GV *gv;
+		if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
+		    gv = PL_argvgv;
+		else {
+		    S_maybe_unwind_defav(aTHX);
+		    gv = PL_defgv;
+		}
+		PUSHs((SV *)GvAVn(gv));
+		break;
+	    }
+	    if (!svp || !*svp || !SvROK(*svp)
+	     || SvTYPE(SvRV(*svp)) != SVt_PVAV)
+		DIE(aTHX_
+		/* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
+		 "Type of arg %d to &CORE::%s must be array reference",
+		  whicharg, PL_op_desc[opnum]
+		);
+	    PUSHs(SvRV(*svp));
+	    break;
 	case OA_HVREF:
 	    if (!svp || !*svp || !SvROK(*svp)
 	     || (  SvTYPE(SvRV(*svp)) != SVt_PVHV
@@ -6367,15 +6400,10 @@ PP(pp_coreargs)
 		       : "reference to one of [$@%*]"
 		);
 	    PUSHs(SvRV(*svp));
-	    if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
-	     && CX_CUR()->cx_type & CXp_HASARGS) {
+	    if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
 		/* Undo @_ localisation, so that sub exit does not undo
 		   part of our undeffing. */
-		PERL_CONTEXT *cx = CX_CUR();
-
-                assert(CxHASARGS(cx));
-                cx_popsub_args(cx);;
-		cx->cx_type &= ~CXp_HASARGS;
+		S_maybe_unwind_defav(aTHX);
 	    }
 	  }
 	  break;

t/op/coreamp.t

@@ -23,6 +23,9 @@ sub lis($$;$) {
 package hov {
   use overload '%{}' => sub { +{} }
 }
+package aov {
+  use overload '@{}' => sub { [] }
+}
 package sov {
   use overload '${}' => sub { \my $x }
 }
@@ -205,6 +208,40 @@ sub test_proto {
         "&$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;
 
@@ -663,6 +700,21 @@ 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";
@@ -682,6 +734,14 @@ 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';
@@ -847,12 +907,44 @@ 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';
@@ -982,6 +1074,14 @@ 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';