&CORE::foo() for dbmopen and dbmclose

This commit allows the subs in the CORE package for close, getc and
readline to be called through references and via ampersand syntax.  A
special case for each of them is added to pp_coreargs to deal with
calls with no arguments.  Pushing a null on to the stack (which I’m
doing for other ops) won’t work, as a null already means something for
these cases: close($f) won’t vivify a typeglob if $f is a string, so
the implicit rv2gv pushes a null on to the stack.

4 files changed, 51 insertions, 3 deletions

diff --git a/gv.c b/gv.c
index c95942f4e3..0ecbf96036 100644
--- a/gv.c
+++ b/gv.c
@@ -1353,7 +1353,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		return gv;
 	    case KEY_chdir:
 	    case KEY_chomp: case KEY_chop:
-	    case KEY_dbmclose: case KEY_dbmopen:
 	    case KEY_each: case KEY_eof: case KEY_exec: case KEY_exit:
 	    case KEY_getpgrp: case KEY_gmtime:
 	    case KEY_index: case KEY_keys:
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 88a63ecefb..45322c2541 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -4662,6 +4662,13 @@ disallowed. See L<Safe>.
 (F) Your machine doesn't implement a file truncation mechanism that
 Configure knows about.
 
+=item Type of arg %d to &CORE::%s must be %s
+
+(F) The subroutine in question in the CORE package requires its argument
+to be a hard reference to data of the specified type.  Overloading is
+ignored, so a reference to an object that is not the specified type, but
+nonetheless has overloading to handle it, will still not be accepted.
+
 =item Type of arg %d to %s must be %s (not %s)
 
 (F) This function requires the argument in that position to be of a
diff --git a/pp.c b/pp.c
index 1a92796d91..e185cadd84 100644
--- a/pp.c
+++ b/pp.c
@@ -6010,10 +6010,10 @@ PP(pp_coreargs)
 {
     dSP;
     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
-    int defgv = PL_opargs[opnum] & OA_DEFGV;
+    int defgv = PL_opargs[opnum] & OA_DEFGV, whicharg = 0;
     AV * const at_ = GvAV(PL_defgv);
     SV **svp = AvARRAY(at_);
-    I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1, whicharg = 0;
+    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;
@@ -6084,6 +6084,16 @@ PP(pp_coreargs)
 		svp++;
 	    }
 	    RETURN;
+	case OA_HVREF:
+	    if (!svp || !*svp || !SvROK(*svp)
+	     || SvTYPE(SvRV(*svp)) != SVt_PVHV)
+		DIE(aTHX_
+		/* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
+		 "Type of arg %d to &CORE::%s must be hash reference",
+		  whicharg, OP_DESC(PL_op->op_next)
+		);
+	    PUSHs(SvRV(*svp));
+	    break;
 	case OA_FILEREF:
 	    if (!numargs) PUSHs(NULL);
 	    else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index a3c1eb3dec..9ed64ccbe7 100644
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -136,6 +136,26 @@ 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(" . 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)";
+  }
 
   else {
     die "Please add tests for the $p prototype";
@@ -280,6 +300,18 @@ CORE::given(1) {
 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';
+}
+
 test_proto 'die';
 eval { dier('quinquangle') };
 is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++;