Make lock(&foo) syntax nominally lock the subroutine

In 5.10, lock(&foo) was an error for non-lvalue subs.  For lvalue
subs, it passed &foo to the lockhook and return \&foo.

In 5.12, lock(&foo) was still an error for non-lvalue subs.  For
lvalue subs, it would pass &foo to the lockhook and then either
trip an assertion (-DDEBUGGING) or return &foo, resulting in inter-
esting bugs.

Commit f4df43b5e changed lock(&lvalue_sub) to call the sub and lock
its return value.

As Reini Urban pointed out in
<CAHiT=DE5cVZbuCR3kb=Q5oCa18vo3jr5jZKmURHYha2PwF4pEQ@mail.gmail.com>,
locking a subroutine does have its uses.

Since lock(&foo) has never really worked anyway, we can still
change this.

So, for lvalue subs, this reverts back to the 5.10 behaviour.  For
non-lvalue subs, it now behaves the same way, the lvalue flag making
no difference.  Note that it still causes an error at run-time, if
threads::shared is loaded, as its lockhook is conservative in what
it accepts.

But this change allows for future extensibility, unlike f4df43b5e.

A note about the implementation: There are two pieces of code (at
least) in op.c that convert an entersub op into an rv2cv, one in
S_doref and the other in Perl_op_lvalue_flags.  Originally (before
f4df43b5e) it was S_doref that took care of that for OP_LOCK.  But
Perl_op_lvalue_flags is called first, so it would assume it was an
assignment to a sub call and croak if there was no lvalue sub in the
symbol table.  This commit adds back the special case for OP_LOCK, but
in Perl_op_lvalue_flags, not S_doref.

diff --git a/op.c b/op.c
index 4f8693a..b3c5f86 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1705,7 +1705,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
            break;
        goto nomod;
     case OP_ENTERSUB:
-       if ((type == OP_UNDEF || type == OP_REFGEN) &&
+       if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
            !(o->op_flags & OPf_STACKED)) {
            o->op_type = OP_RV2CV;              /* entersub => rv2cv */
            /* Both ENTERSUB and RV2CV use this bit, but for different pur-
@@ -10415,6 +10415,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
            str[n++] = '$';
            str[n++] = '@';
            str[n++] = '%';
+           if (i == OP_LOCK) str[n++] = '&';
            str[n++] = '*';
            str[n++] = ']';
        }

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 0d87c3a..2309a09 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -480,14 +480,17 @@ L</Modules and Pragmata>.
 
 =item *
 
-Locking an lvalue subroutine (via C<lock &lvsub>) now locks the return
-value, instead of trying to lock the sub (which has no effect).  It also no
-longer tries to return the sub as a scalar, resulting in strange side
-effects like C<ref \$_> returning "CODE" in some instances.
+Locking a subroutine (via C<lock &sub>) is no longer a compile-time error
+for regular subs.  For lvalue subroutines, it no longer tries to return the
+sub as a scalar, resulting in strange side effects like C<ref \$_>
+returning "CODE" in some instances.
+
+C<lock &sub> is now a run-time error if L<threads::shared> is loaded (a
+no-op otherwise), but that may be rectified in a future version.
 
 =item *
 
-C<lock>'s prototype has been corrected to C<(\[$@%*])> from C<(\$)>, which
+C<lock>'s prototype has been corrected to C<(\[$@%&*])> from C<(\$)>, which
 was just wrong.
 
 =item *

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 264fbdc..04c6a05 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -3095,7 +3095,7 @@ This function places an advisory lock on a shared variable or referenced
 object contained in I<THING> until the lock goes out of scope.
 
 The value returned is the scalar itself, if the argument is a scalar, or a
-reference, if the argument is a hash or array.
+reference, if the argument is a hash, array or subroutine.
 
 lock() is a "weak keyword" : this means that if you've defined a function
 by this name (before any calls to it), that function will be called

diff --git a/pp.c b/pp.c
index ca94935..3421d97 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -5914,9 +5914,9 @@ PP(pp_lock)
     dSP;
     dTOPss;
     SV *retsv = sv;
-    assert(SvTYPE(retsv) != SVt_PVCV);
     SvLOCK(sv);
-    if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
+    if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
+     || SvTYPE(retsv) == SVt_PVCV) {
        retsv = refto(retsv);
     }
     SETs(retsv);

diff --git a/t/op/cproto.t b/t/op/cproto.t
index 1476ae6..e995416 100644 (file)
--- a/t/op/cproto.t
+++ b/t/op/cproto.t
@@ -138,7 +138,7 @@ link ($$)
 listen (*$)
 local undef
 localtime (;$)
-lock (\[$@%*])
+lock (\[$@%&*])
 log (_)
 lstat (;*)
 lt undef

diff --git a/t/op/lock.t b/t/op/lock.t
index 2fd6782..c40ec4c 100644 (file)
--- a/t/op/lock.t
+++ b/t/op/lock.t
@@ -10,9 +10,7 @@ plan tests => 5;
 is \lock $foo, \$foo, 'lock returns a scalar argument';
 is  lock @foo, \@foo, 'lock returns a ref to its array argument';
 is  lock %foo, \%foo, 'lock returns a ref to its hash argument';
-eval { lock &foo }; my $file = __FILE__; my $line = __LINE__;
-is $@, "Can't modify non-lvalue subroutine call at $file line $line.\n",
-     'Error when locking non-lvalue sub';
+is  lock &foo, \&foo, 'lock returns a ref to its code argument';
 
 sub eulavl : lvalue { $x }
-is \lock &eulavl, \$x, 'locking lvalue sub acts on retval, just like tie';
+is  lock &eulavl, \&eulavl, 'lock returns a ref to its lvalue sub arg';