diff options
author | Jesse Luehrs <doy@tozt.net> | 2013-07-22 19:43:51 -0400 |
---|---|---|
committer | Jesse Luehrs <doy@tozt.net> | 2013-07-22 19:48:11 -0400 |
commit | 40ecb271cd82f320753f4593b8e902b1a6a4b2ed (patch) | |
tree | 63f93194d54bd08b47fbffec5adfb988d0a35d31 | |
parent | 2888936658f395416cb183aa8a5f24e6e3ea585c (diff) | |
download | parse-keyword-40ecb271cd82f320753f4593b8e902b1a6a4b2ed.tar.gz parse-keyword-40ecb271cd82f320753f4593b8e902b1a6a4b2ed.zip |
allow creating non-anonymous subs too
this makes a difference in some obscure cases dealing with closures. see
t/unavailable.t for more information.
-rw-r--r-- | Keyword.xs | 44 | ||||
-rw-r--r-- | lib/Parse/Keyword.pm | 12 | ||||
-rw-r--r-- | t/unavailable.t | 48 |
3 files changed, 82 insertions, 22 deletions
@@ -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; |