From 40ecb271cd82f320753f4593b8e902b1a6a4b2ed Mon Sep 17 00:00:00 2001
From: Jesse Luehrs <doy@tozt.net>
Date: Mon, 22 Jul 2013 19:43:51 -0400
Subject: allow creating non-anonymous subs too

this makes a difference in some obscure cases dealing with closures. see
t/unavailable.t for more information.
---
 Keyword.xs           | 44 ++++++++++++++++++++++++++------------------
 lib/Parse/Keyword.pm | 12 ++++++++----
 t/unavailable.t      | 48 ++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 82 insertions(+), 22 deletions(-)
 create mode 100644 t/unavailable.t

diff --git a/Keyword.xs b/Keyword.xs
index eaaa9dd..9a6d28d 100644
--- a/Keyword.xs
+++ b/Keyword.xs
@@ -15,14 +15,14 @@
 
 #define LEAVE_PARSER LEAVE
 
-static SV *parser_fn(OP *(fn)(U32))
+static SV *parser_fn(OP *(fn)(U32), bool named)
 {
     I32 floor;
     CV *code;
 
     REENTER_PARSER;
 
-    floor = start_subparse(0, CVf_ANON);
+    floor = start_subparse(0, named ? 0 : CVf_ANON);
     code = newATTRSUB(floor, NULL, NULL, NULL, fn(0));
 
     LEAVE_PARSER;
@@ -143,58 +143,66 @@ lex_stuff(str)
     lex_stuff_sv(str, 0);
 
 SV *
-parse_block()
+parse_block(named = false)
+    bool named
   CODE:
-    RETVAL = parser_fn(Perl_parse_block);
+    RETVAL = parser_fn(Perl_parse_block, named);
   OUTPUT:
     RETVAL
 
 SV *
-parse_stmtseq()
+parse_stmtseq(named = false)
+    bool named
   CODE:
-    RETVAL = parser_fn(Perl_parse_stmtseq);
+    RETVAL = parser_fn(Perl_parse_stmtseq, named);
   OUTPUT:
     RETVAL
 
 SV *
-parse_fullstmt()
+parse_fullstmt(named = false)
+    bool named
   CODE:
-    RETVAL = parser_fn(Perl_parse_fullstmt);
+    RETVAL = parser_fn(Perl_parse_fullstmt, named);
   OUTPUT:
     RETVAL
 
 SV *
-parse_barestmt()
+parse_barestmt(named = false)
+    bool named
   CODE:
-    RETVAL = parser_fn(Perl_parse_barestmt);
+    RETVAL = parser_fn(Perl_parse_barestmt, named);
   OUTPUT:
     RETVAL
 
 SV *
-parse_fullexpr()
+parse_fullexpr(named = false)
+    bool named
   CODE:
-    RETVAL = parser_fn(Perl_parse_fullexpr);
+    RETVAL = parser_fn(Perl_parse_fullexpr, named);
   OUTPUT:
     RETVAL
 
 SV *
-parse_listexpr()
+parse_listexpr(named = false)
+    bool named
   CODE:
-    RETVAL = parser_fn(Perl_parse_listexpr);
+    RETVAL = parser_fn(Perl_parse_listexpr, named);
   OUTPUT:
     RETVAL
 
 SV *
-parse_termexpr()
+parse_termexpr(named = false)
+    bool named
   CODE:
-    RETVAL = parser_fn(Perl_parse_termexpr);
+    RETVAL = parser_fn(Perl_parse_termexpr, named);
   OUTPUT:
     RETVAL
 
 SV *
-parse_arithexpr()
+parse_arithexpr(named = false)
+    bool named
   CODE:
-    RETVAL = parser_fn(Perl_parse_arithexpr);
+    RETVAL = parser_fn(Perl_parse_arithexpr, named);
   OUTPUT:
     RETVAL
 
diff --git a/lib/Parse/Keyword.pm b/lib/Parse/Keyword.pm
index f459937..1c270de 100644
--- a/lib/Parse/Keyword.pm
+++ b/lib/Parse/Keyword.pm
@@ -105,10 +105,14 @@ reverse order. See L<perlapi/lex_stuff_sv> for more information.
 parse_fullexpr, parse_listexpr, parse_termexpr, parse_arithexpr
 
 These functions parse the specified amount of Perl code, and return a coderef
-which will evaluate that code when executed. See L<perlapi/parse_block>,
-L<perlapi/parse_stmtseq>, L<perlapi/parse_fullstmt>, L<perlapi/parse_barestmt>,
-L<perlapi/parse_fullexpr>, L<parse_listexpr>, L<parse_termexpr>, and
-L<perlapi/parse_arithexpr> for more details.
+which will evaluate that code when executed. They each take an optional boolean
+parameter that should be true if you are creating a subroutine which will be
+going in the symbol table, or in other more obscure situations involving
+closures (the CVf_ANON flag will be set on the created coderef if this is not
+passed - see C<t/unavailable.t> in this distribution). See
+L<perlapi/parse_block>, L<perlapi/parse_stmtseq>, L<perlapi/parse_fullstmt>,
+L<perlapi/parse_barestmt>, L<perlapi/parse_fullexpr>, L<parse_listexpr>,
+L<parse_termexpr>, and L<perlapi/parse_arithexpr> for more details.
 
 =func compiling_package
 
diff --git a/t/unavailable.t b/t/unavailable.t
new file mode 100644
index 0000000..06db914
--- /dev/null
+++ b/t/unavailable.t
@@ -0,0 +1,48 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+    package My::Parser;
+    use Exporter 'import';
+    our @EXPORT = ('foo', 'bar');
+
+    use Parse::Keyword {
+        foo => \&parse_foo,
+        bar => \&parse_bar,
+    };
+
+    sub foo {}
+
+    sub parse_foo {
+        lex_read_space;
+        die unless lex_peek eq '{';
+        parse_block(1)->();
+        return (sub {}, 1);
+    }
+
+    sub bar { $::body = $_[0] }
+
+    sub parse_bar {
+        lex_read_space;
+        die unless lex_peek eq '{';
+        my $body = parse_block;
+        return (sub { $body }, 1);
+    }
+
+    $INC{'My/Parser.pm'} = __FILE__;
+}
+
+use My::Parser;
+
+my $bar;
+my $baz = 5;
+
+foo {
+    bar { $baz }
+}
+
+is($::body->(), 5);
+
+done_testing;
-- 
cgit v1.2.3-54-g00ecf