From c72a562989087cf45b7abfdbbfb4a823adac1604 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Wed, 24 Aug 2011 09:09:58 -0700
Subject: &CORE::lock()
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

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.
---
 t/op/coresubs.t | 33 +++++++++++++++++++++++++++++++++
 1 file changed, 33 insertions(+)

(limited to 't/op/coresubs.t')

diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 7a00694b7e..84fc223502 100644
--- 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 );
 
-- 
cgit v1.2.1