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.

6 files changed, 16 insertions, 14 deletions

diff --git a/op.c b/op.c
index 4f8693a4b9..b3c5f86f31 100644
--- 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 0d87c3aea0..2309a09ad7 100644
--- 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 264fbdcbcd..04c6a05bf9 100644
--- 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 ca94935c30..3421d9701d 100644
--- 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 1476ae6ab4..e995416fb3 100644
--- 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 2fd67821eb..c40ec4c9fd 100644
--- 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';