Bug #129985 for Future-AsyncAwait: Parsing `async sub` attributes

It's not perfect because I had to reïmplement core perl's oh-so-well-defined attribute parsing logic, but attached is a patch that justabout handles it. -- Paul Evans

=== modified file 'lib/Future/AsyncAwait.xs' --- lib/Future/AsyncAwait.xs 2019-06-26 19:21:20 +0000 +++ lib/Future/AsyncAwait.xs 2019-07-05 14:49:01 +0000 @@ -1922,6 +1922,47 @@ return NULL; } +#define lex_scan_attr() MY_lex_scan_attr(aTHX) +static SV *MY_lex_scan_attr(pTHX) +{ + SV *ret = lex_scan_ident(); + if(!ret) + return ret; + + lex_read_space(0); + + if(lex_peek_unichar(0) != '(') + return ret; + sv_cat_c(ret, lex_read_unichar(0)); + + int count = 1; + I32 c = lex_peek_unichar(0); + while(count && c != -1) { + if(c == '(') + count++; + if(c == ')') + count--; + if(c == '\\') { + /* The next char does not bump count even if it is ( or ); + * the \\ is still captured + */ + sv_cat_c(ret, lex_read_unichar(0)); + c = lex_peek_unichar(0); + if(c == -1) + goto unterminated; + } + + sv_cat_c(ret, lex_read_unichar(0)); + c = lex_peek_unichar(0); + } + + if(c != -1) + return ret; + +unterminated: + croak("Unterminated attribute parameter in attribute list"); +} + enum { NO_FORBID, FORBID_FOREACH_NONLEXICAL, @@ -2022,12 +2063,34 @@ SV *name = lex_scan_ident(); lex_read_space(0); + I32 floor_ix = start_subparse(FALSE, name ? 0 : CVf_ANON); + SAVEFREESV(PL_compcv); + + /* Parse subroutine attrs + * These are supplied to newATTRSUB() as an OP_LIST containing OP_CONSTs, + * one attribute in each as a plain SV. Note that we don't have to parse + * inside the contents of the parens; that is handled by the attribute + * handlers themselves + */ + OP *attrs = NULL; + if(lex_peek_unichar(0) == ':') { + SV *attr; + lex_read_unichar(0); + lex_read_space(0); + + while((attr = lex_scan_attr())) { + lex_read_space(0); + + if(!attrs) + attrs = newLISTOP(OP_LIST, 0, NULL, NULL); + + attrs = op_append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, attr)); + } + } + if(lex_peek_unichar(0) != '{') croak("Expected async sub %sto be followed by '{'", name ? "NAME " : ""); - I32 floor_ix = start_subparse(FALSE, name ? 0 : CVf_ANON); - SAVEFREESV(PL_compcv); - /* Save the identity of the currently-compiling sub so that * await_keyword_plugin() can check */ @@ -2062,9 +2125,12 @@ CV *cv = newATTRSUB(floor_ix, name ? newSVOP(OP_CONST, 0, SvREFCNT_inc(name)) : NULL, NULL, - NULL, + attrs, op); + if(CvLVALUE(cv)) + warn("Pointless use of :lvalue on async sub"); + if(name) { *op_ptr = newOP(OP_NULL, 0); === added file 't/44sub-attrs.t' --- t/44sub-attrs.t 1970-01-01 00:00:00 +0000 +++ t/44sub-attrs.t 2019-07-05 14:27:23 +0000 @@ -0,0 +1,53 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use attributes; + +use Future::AsyncAwait; + +# :method +{ + async sub is_method :method { } + + my $cvf_method = grep { m/^method$/ } attributes::get( \&is_method ); + ok( $cvf_method, '&is_method has :method' ); +} + +# :lvalue - accepted but should warn +{ + my $warning; + BEGIN { $SIG{__WARN__} = sub { $warning++ } } + + async sub is_lvalue :lvalue { } + + my $cvf_lvalue = grep { m/^lvalue$/ } attributes::get( \&is_lvalue ); + ok( $cvf_lvalue, '&is_lvalue has :lvalue' ); + ok( $warning, 'async sub :lvalue produces a warning' ); + + BEGIN { undef $SIG{__WARN__} } +} + +# :const happens to break currently, but it would be meaningless anyway + +# some custom ones +{ + my $modify_invoked; + + sub MODIFY_CODE_ATTRIBUTES + { + my ( $pkg, $sub, $attr ) = @_; + + $modify_invoked++; + is( $attr, "MyCustomAttribute(value here)", 'MODIFY_CODE_ATTRIBUTES takes attr' ); + + return (); + } + + async sub is_attributed :MyCustomAttribute(value here) { } + ok( $modify_invoked, 'MODIFY_CODE_ATTRIBUTES invoked' ); +} + +done_testing;