&CORE::foo() for tie functions

This commit allows the tie, tied and untie subroutines in the CORE
namespace to be called through references and via &ampersand() syntax.
pp_coreargs is modified to handle the functions with \[$@%*] in their
prototypes (which happen to be just the tie functions).

diff --git a/gv.c b/gv.c
index 373f571..46559c7 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1362,9 +1362,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            case KEY_splice:
            case KEY_stat:
            case KEY_system:
-           case KEY_tie: case KEY_tied:
            case KEY_truncate: case KEY_umask: case KEY_unlink:
-           case KEY_unpack: case KEY_unshift: case KEY_untie:
+           case KEY_unpack: case KEY_unshift:
            case KEY_values: case KEY_write:
                ampable = FALSE;
            }

diff --git a/pp.c b/pp.c
index 630dd12..8057c69 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -6097,7 +6097,9 @@ PP(pp_coreargs)
                   *foo is indistinguishable from ${\*foo}, and the proto-
                   type permits the latter. */
             || SvTYPE(SvRV(*svp)) > (
-                    wantscalar ? SVt_PVLV : SVt_PVCV
+                    wantscalar       ? SVt_PVLV
+                  : opnum == OP_LOCK ? SVt_PVCV
+                  :                    SVt_PVHV
                )
               )
                DIE(aTHX_
@@ -6106,7 +6108,9 @@ PP(pp_coreargs)
                  whicharg, OP_DESC(PL_op->op_next),
                  wantscalar
                    ? "scalar reference"
-                   : "reference to one of [$@%&*]"
+                   : opnum == OP_LOCK
+                      ? "reference to one of [$@%&*]"
+                      : "reference to one of [$@%*]"
                );
            PUSHs(SvRV(*svp));
            break;

diff --git a/t/op/coreamp.t b/t/op/coreamp.t
index d45aead..b03e834 100644 (file)
--- a/t/op/coreamp.t
+++ b/t/op/coreamp.t
@@ -188,29 +188,40 @@ sub test_proto {
     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)";
   }
-  elsif ($p eq '\[$@%&*]') {
-    $tests += 5;
+  elsif ($p =~ /^\\\[(\$\@%&?\*)](\$\@)?\z/) {
+    $tests += 4;
 
-    eval " &CORE::$o(1,2) ";
-    like $@, qr/^Too many arguments for $o at /,
-         "&$o with too many args";
-    eval " &CORE::$o() ";
+    unless ($2) {
+      $tests ++;
+      eval " &CORE::$o(1,2) ";
+      like $@, qr/^Too many arguments for $o at /,
+        "&$o with too many args";
+    }
+    eval { &{"CORE::$o"}($2 ? 1 : ()) };
     like $@, qr/^Not enough arguments for $o at /,
          "&$o with too few args";
-    eval " &CORE::$o(2) ";
+    my $more_args = $2 ? ',1' : '';
+    eval " &CORE::$o(2$more_args) ";
     like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
-                ) \[\$\@%&\*] at /,
+                ) \[\Q$1\E] at /,
         "&$o with non-ref arg";
-    eval " &CORE::$o(*STDOUT{IO}) ";
+    eval " &CORE::$o(*STDOUT{IO}$more_args) ";
     like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
-                ) \[\$\@%&\*] at /,
+                ) \[\Q$1\E] at /,
         "&$o with ioref arg";
     my $class = ref *DATA{IO};
-    eval " &CORE::$o(bless(*DATA{IO}, 'hov')) ";
+    eval " &CORE::$o(bless(*DATA{IO}, 'hov')$more_args) ";
     like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
-                ) \[\$\@%&\*] at /,
+                ) \[\Q$1\E] at /,
         "&$o with ioref arg with hash overload (which does not count)";
     bless *DATA{IO}, $class;
+    if (do {$1 !~ /&/}) {
+      $tests++;
+      eval " &CORE::$o(\\&scriggle$more_args) ";
+      like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one (?x:
+                  )of \[\Q$1\E] at /,
+        "&$o with coderef arg";
+    }    
   }
 
   else {
@@ -725,6 +736,25 @@ test_proto 'tell';
 
 test_proto 'telldir';
 
+test_proto 'tie';
+test_proto 'tied';
+$tests += 3;
+{
+  my $fetches;
+  package tier {
+    sub TIESCALAR { bless[] }
+    sub FETCH { ++$fetches }
+  }
+  my $tied;
+  my $obj = &mytie(\$tied, 'tier');
+  is &mytied(\$tied), $obj, '&tie and &tied retvals';
+  () = "$tied";
+  is $fetches, 1, '&tie actually ties';
+  &CORE::untie(\$tied);
+  () = "$tied";
+  is $fetches, 1, '&untie unties';
+}
+
 test_proto 'time';
 $tests += 2;
 like &mytime, '^\d+\z', '&time in scalar context';
@@ -738,6 +768,7 @@ like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
 
 test_proto 'uc', 'aa', 'AA';
 test_proto 'ucfirst', 'aa', "Aa";
+test_proto 'untie'; # behaviour already tested along with tie(d)
 
 test_proto 'utime';
 $tests += 2;