&CORE::lock()

This commit allows &CORE::lock to be called through references and
via ampersand syntax.  It adds code to pp_coreargs for handling the
OA_SCALARREF case, though what it adds is currently lock-specific.
(Subsequent commits will address that.)  Since lock returns the scalar
passed to it, not a copy, &CORE::lock needs to use op_leavesublv,
rather than op_leavesub.  But it can’t be an lvalue sub, as
&CORE::lock = 3 should be disallowed.  So we use the sneaky trick of
turning on the lvalue flag before attaching the op tree to the sub
(which causes newATTRSUB to use op_leavesublv), and then turning it
off afterwards.

diff --git a/gv.c b/gv.c
index 9dd2787..392c249 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1355,7 +1355,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            case KEY_chomp: case KEY_chop:
            case KEY_each: case KEY_eof: case KEY_exec:
            case KEY_keys:
-           case KEY_lock: case KEY_lstat:
+           case KEY_lstat:
            case KEY_mkdir: case KEY_open: case KEY_pop:
            case KEY_push: case KEY_rand: case KEY_read:
            case KEY_recv: case KEY_reset:
@@ -1402,7 +1402,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                   new ATTRSUB. */
            (void)core_prototype((SV *)cv, name, code, &opnum);
            if (ampable) {
-               if (opnum == OP_VEC) CvLVALUE_on(cv);
+               if (opnum == OP_VEC || opnum == OP_LOCK) CvLVALUE_on(cv);
                newATTRSUB(oldsavestack_ix,
                           newSVOP(
                                 OP_CONST, 0,
@@ -1417,6 +1417,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                           )
                );
                assert(GvCV(gv) == cv);
+               if (opnum == OP_LOCK)
+                   CvLVALUE_off(cv); /* Now *that* was a neat trick. */
                LEAVE;
                PL_parser = oldparser;
                PL_curcop = oldcurcop;

diff --git a/pp.c b/pp.c
index de2b35c..fd17bc1 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -6109,6 +6109,18 @@ PP(pp_coreargs)
                ));
            }
            break;
+       case OA_SCALARREF:
+           if (!svp || !*svp || !SvROK(*svp)
+            || SvTYPE(SvRV(*svp)) > 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)
+               );
+           PUSHs(SvRV(*svp));
+           break;
        default:
            DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
        }

diff --git a/pp_ctl.c b/pp_ctl.c
index 76786c0..971e78b 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2570,7 +2570,6 @@ PP(pp_leavesublv)
 
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* temporarily protect top context */
-    assert(CvLVALUE(cx->blk_sub.cv));
 
     TAINT_NOT;
 

diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 7a00694..84fc223 100644 (file)
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -156,6 +156,30 @@ 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;
+
+    eval " &CORE::$o(1,2) ";
+    like $@, qr/^Too many arguments for $o at /,
+         "&$o with too many args";
+    eval " &CORE::$o() ";
+    like $@, qr/^Not enough arguments for $o at /,
+         "&$o with too few args";
+    eval " &CORE::$o(2) ";
+    like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
+                ) \[\$\@%&\*] at /,
+        "&$o with non-ref arg";
+    eval " &CORE::$o(*STDOUT{IO}) ";
+    like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
+                ) \[\$\@%&\*] at /,
+        "&$o with ioref arg";
+    my $class = ref *DATA{IO};
+    eval " &CORE::$o(bless(*DATA{IO}, 'hov')) ";
+    like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x:
+                ) \[\$\@%&\*] at /,
+        "&$o with ioref arg with hash overload (which does not count)";
+    bless *DATA{IO}, $class;
+  }
 
   else {
     die "Please add tests for the $p prototype";
@@ -406,6 +430,15 @@ test_proto 'localtime';
 &CORE::localtime;
 pass '&localtime without args does not crash'; ++$tests;
 
+test_proto 'lock';
+$tests += 6;
+is \&mylock(\$foo), \$foo, '&lock retval when passed a scalar ref';
+lis [\&mylock(\$foo)], [\$foo], '&lock in list context';
+is &mylock(\@foo), \@foo, '&lock retval when passed an array ref';
+is &mylock(\%foo), \%foo, '&lock retval when passed a ash ref';
+is &mylock(\&foo), \&foo, '&lock retval when passed a code ref';
+is \&mylock(\*foo), \*foo, '&lock retval when passed a glob ref';
+
 test_proto 'log';
 test_proto "msg$_" for qw( ctl get rcv snd );