Merge branch 'keyword-rewrite-magic' into method-attr

diff --git a/Makefile.PL b/Makefile.PL
index b3023ab..b7a2f86 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -19,7 +19,6 @@ WriteMakefile(
     PREREQ_PM => {
        'Carp' => 0,
        'XSLoader' => 0,
-       'bytes' => 0,
         'warnings' => 0,
         'strict' => 0,
     },

diff --git a/Parameters.xs b/Parameters.xs
index f618a60..4e9a214 100644 (file)
--- a/Parameters.xs
+++ b/Parameters.xs
@@ -56,6 +56,7 @@ WARNINGS_ENABLE
 #define HINTK_KEYWORDS MY_PKG "/keywords"
 #define HINTK_NAME_    MY_PKG "/name:"
 #define HINTK_SHIFT_   MY_PKG "/shift:"
+#define HINTK_ATTRS_   MY_PKG "/attrs:"
 
 #define HAVE_PERL_VERSION(R, V, S) \
        (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
@@ -66,7 +67,8 @@ typedef struct {
                FLAG_NAME_REQUIRED,
                FLAG_NAME_PROHIBITED
        } name;
-       char shift[256];
+       SV *shift;
+       SV *attrs;
 } Spec;
 
 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
@@ -78,7 +80,8 @@ static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
        STRLEN kw_active_len;
 
        spec->name = 0;
-       spec->shift[0] = '\0';
+       spec->shift = sv_2mortal(newSVpvs(""));
+       spec->attrs = sv_2mortal(newSVpvs(""));
 
        if (!(hints = GvHV(PL_hintgv))) {
                return FALSE;
@@ -97,26 +100,29 @@ static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
                        p[kw_len] == ' ' &&
                        memcmp(kw_ptr, p, kw_len) == 0
                ) {
-                       const char *kf_ptr;
-                       STRLEN kf_len;
-                       SV *kf_sv;
-
-                       kf_sv = sv_2mortal(newSVpvs(HINTK_NAME_));
-                       sv_catpvn(kf_sv, kw_ptr, kw_len);
-                       kf_ptr = SvPV(kf_sv, kf_len);
-                       if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
-                               croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
-                       }
+
+#define FETCH_HINTK_INTO(NAME, PTR, LEN, X) do { \
+       const char *fk_ptr_; \
+       STRLEN fk_len_; \
+       SV *fk_sv_; \
+       fk_sv_ = sv_2mortal(newSVpvs(HINTK_ ## NAME)); \
+       sv_catpvn(fk_sv_, PTR, LEN); \
+       fk_ptr_ = SvPV(fk_sv_, fk_len_); \
+       if (!((X) = hv_fetch(hints, fk_ptr_, fk_len_, 0))) { \
+               croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \
+       } \
+} while (0)
+
+                       FETCH_HINTK_INTO(NAME_, kw_ptr, kw_len, psv);
                        spec->name = SvIV(*psv);
 
-                       kf_sv = sv_2mortal(newSVpvs(HINTK_SHIFT_));
-                       sv_catpvn(kf_sv, kw_ptr, kw_len);
-                       kf_ptr = SvPV(kf_sv, kf_len);
-                       if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
-                               croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
-                       }
-                       my_sprintf(spec->shift, "%.*s", (int)(sizeof spec->shift - 1), SvPV_nolen(*psv));
+                       FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
+                       SvSetSV(spec->shift, *psv);
 
+                       FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
+                       SvSetSV(spec->attrs, *psv);
+
+#undef FETCH_HINTK_INTO
                        return TRUE;
                }
        }
@@ -238,6 +244,10 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
        }
 
        /* attributes */
+       if (SvTRUE(spec->attrs)) {
+               sv_catsv(gen, spec->attrs);
+       }
+
        if (!saw_colon) {
                c = lex_peek_unichar(0);
                if (c == ':') {
@@ -280,8 +290,10 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
        }
        lex_read_unichar(0);
        sv_catpvs(gen, "{");
-       if (spec->shift[0]) {
-               sv_catpvf(gen, "my%s=shift;", spec->shift);
+       if (SvTRUE(spec->shift)) {
+               sv_catpvs(gen, "my");
+               sv_catsv(gen, spec->shift);
+               sv_catpvs(gen, "=shift;");
        }
        if (SvCUR(params)) {
                sv_catpvs(gen, "my(");
@@ -364,6 +376,7 @@ WARNINGS_ENABLE {
        newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
        newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_));
        newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
+       newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
        newCONSTSUB(stash, "SHIFT_NAME_LIMIT", newSViv(sizeof ((Spec *)NULL)->shift));
        next_keyword_plugin = PL_keyword_plugin;
        PL_keyword_plugin = my_keyword_plugin;

diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm
index 4bb18a8..88c3e66 100644 (file)
--- a/lib/Function/Parameters.pm
+++ b/lib/Function/Parameters.pm
@@ -12,7 +12,6 @@ BEGIN {
 }
 
 use Carp qw(confess);
-use bytes ();
 
 sub _assert_valid_identifier {
        my ($name, $with_dollar) = @_;
@@ -21,16 +20,29 @@ sub _assert_valid_identifier {
                or confess qq{"$name" doesn't look like a valid identifier};
 }
 
+sub _assert_valid_attributes {
+       my ($attrs) = @_;
+       $attrs =~ /^\s*:\s*[^\W\d]\w*\s*(?:(?:\s|:\s*)[^\W\d]\w*\s*)*(?:\(|\z)/
+               or confess qq{"$attrs" doesn't look like valid attributes};
+}
+
 my @bare_arms = qw(function method);
 my %type_map = (
        function => { name => 'optional' },
-       method   => { name => 'optional', shift => '$self' },
+       method   => {
+               name => 'optional',
+               shift => '$self',
+               attrs => ':method',
+       },
 );
 
 sub import {
        my $class = shift;
 
-       @_ or @_ = ('fun', 'method');
+       @_ or @_ = {
+               fun => 'function',
+               method => 'method',
+       };
        if (@_ == 1 && ref($_[0]) eq 'HASH') {
                @_ = map [$_, $_[0]{$_}], keys %{$_[0]}
                        or return;
@@ -52,17 +64,19 @@ sub import {
                        $proto_type = $type_map{$proto_type}
                                || confess qq["$proto_type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
                }
+
                my %type = %$proto_type;
                my %clean;
+
                $clean{name} = delete $type{name} || 'optional';
                $clean{name} =~ /^(?:optional|required|prohibited)\z/
                        or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
+
                $clean{shift} = delete $type{shift} || '';
-               if ($clean{shift}) {
-                       _assert_valid_identifier $clean{shift}, 1;
-                       bytes::length($clean{shift}) < SHIFT_NAME_LIMIT
-                               or confess qq["$clean{shift}" is longer than I can handle];
-               }
+               _assert_valid_identifier $clean{shift}, 1 if $clean{shift};
+
+               $clean{attrs} = delete $type{attrs} || '';
+               _assert_valid_attributes $clean{attrs} if $clean{attrs};
                
                %type and confess "Invalid keyword property: @{[keys %type]}";
 
@@ -73,6 +87,7 @@ sub import {
                my $type = $spec{$kw};
 
                $^H{HINTK_SHIFT_ . $kw} = $type->{shift};
+               $^H{HINTK_ATTRS_ . $kw} = $type->{attrs};
                $^H{HINTK_NAME_ . $kw} =
                        $type->{name} eq 'prohibited' ? FLAG_NAME_PROHIBITED :
                        $type->{name} eq 'required' ? FLAG_NAME_REQUIRED :
@@ -231,10 +246,28 @@ Valid values: strings that look like a scalar variable. Any function created by
 this keyword will automatically L<shift|perlfunc/shift> its first argument into
 a local variable whose name is specified here.
 
+=item C<attrs>
+
+Valid values: strings that are valid source code for attributes. Any value
+specified here will be inserted as a subroutine attribute in the generated
+code. Thus:
+
+ use Function::Parameters { sub_l => { attrs => ':lvalue' } };
+ sub_l foo() {
+   ...
+ }
+
+turns into
+
+ sub foo :lvalue {
+   ...
+ }
+
 =back
 
 Plain C<'function'> is equivalent to C<< { name => 'optional' } >>, and plain
-C<'method'> is equivalent to C<< { name => 'optional', shift => '$self' } >>.
+C<'method'> is equivalent to
+C<< { name => 'optional', shift => '$self', attrs => ':method' } >>.
 
 =head2 Syntax and generated code