record and extract metadata

diff --git a/MANIFEST b/MANIFEST
index 622f678..d223f48 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5,6 +5,7 @@ Makefile.PL
 Parameters.xs
 README
 lib/Function/Parameters.pm
+lib/Function/Parameters/Info.pm
 padop_on_crack.c.inc
 t/00-load.t
 t/01-compiles.t
@@ -64,6 +65,7 @@ t/foreign/signatures/proto.t
 t/foreign/signatures/weird.t
 t/hueg.t
 t/imports.t
+t/info.t
 t/invocant.t
 t/lexical.t
 t/lineno-torture.t

diff --git a/Makefile.PL b/Makefile.PL
index 8713ef9..8505863 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -23,6 +23,7 @@ WriteMakefile(
     },
     PREREQ_PM => {
         'Carp' => 0,
+        'Moo' => 0,
         'XSLoader' => 0,
         'warnings' => 0,
     },

diff --git a/Parameters.xs b/Parameters.xs
index 542b078..d1aa2aa 100644 (file)
--- a/Parameters.xs
+++ b/Parameters.xs
@@ -786,6 +786,123 @@ static OP *mkconstpv(pTHX_ const char *p, size_t n) {
 
 #define mkconstpvs(S) mkconstpv(aTHX_ "" S "", sizeof S - 1)
 
+static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const ParamSpec *ps) {
+       dSP;
+
+       ENTER;
+       SAVETMPS;
+
+       PUSHMARK(SP);
+       EXTEND(SP, 8);
+
+       /* 0 */ {
+               mPUSHu(key);
+       }
+       /* 1 */ {
+               size_t n;
+               char *p = SvPV(declarator, n);
+               char *q = memchr(p, ' ', n);
+               mPUSHp(p, q ? q - p : n);
+       }
+       if (!ps) {
+               if (SvTRUE(kws->shift)) {
+                       PUSHs(kws->shift);
+               } else {
+                       PUSHmortal;
+               }
+               mPUSHs(newRV_noinc((SV *)newAV()));
+               mPUSHs(newRV_noinc((SV *)newAV()));
+               mPUSHs(newRV_noinc((SV *)newAV()));
+               mPUSHs(newRV_noinc((SV *)newAV()));
+               mPUSHp("@_", 2);
+       } else {
+               /* 2 */ {
+                       if (ps->invocant.name) {
+                               PUSHs(ps->invocant.name);
+                       } else {
+                               PUSHmortal;
+                       }
+               }
+               /* 3 */ {
+                       size_t i, lim;
+                       AV *av;
+
+                       lim = ps->positional_required.used;
+
+                       av = newAV();
+                       if (lim) {
+                               av_extend(av, lim - 1);
+                               for (i = 0; i < lim; i++) {
+                                       av_push(av, SvREFCNT_inc_simple_NN(ps->positional_required.data[i].name));
+                               }
+                       }
+
+                       mPUSHs(newRV_noinc((SV *)av));
+               }
+               /* 4 */ {
+                       size_t i, lim;
+                       AV *av;
+
+                       lim = ps->positional_optional.used;
+
+                       av = newAV();
+                       if (lim) {
+                               av_extend(av, lim - 1);
+                               for (i = 0; i < lim; i++) {
+                                       av_push(av, SvREFCNT_inc_simple_NN(ps->positional_optional.data[i].param.name));
+                               }
+                       }
+
+                       mPUSHs(newRV_noinc((SV *)av));
+               }
+               /* 5 */ {
+                       size_t i, lim;
+                       AV *av;
+
+                       lim = ps->named_required.used;
+
+                       av = newAV();
+                       if (lim) {
+                               av_extend(av, lim - 1);
+                               for (i = 0; i < lim; i++) {
+                                       av_push(av, SvREFCNT_inc_simple_NN(ps->named_required.data[i].name));
+                               }
+                       }
+
+                       mPUSHs(newRV_noinc((SV *)av));
+               }
+               /* 6 */ {
+                       size_t i, lim;
+                       AV *av;
+
+                       lim = ps->named_optional.used;
+
+                       av = newAV();
+                       if (lim) {
+                               av_extend(av, lim - 1);
+                               for (i = 0; i < lim; i++) {
+                                       av_push(av, SvREFCNT_inc_simple_NN(ps->named_optional.data[i].param.name));
+                               }
+                       }
+
+                       mPUSHs(newRV_noinc((SV *)av));
+               }
+               /* 7 */ {
+                       if (ps->slurpy.name) {
+                               PUSHs(ps->slurpy.name);
+                       } else {
+                               PUSHmortal;
+                       }
+               }
+       }
+       PUTBACK;
+
+       call_pv(MY_PKG "::_register_info", G_VOID);
+
+       FREETMPS;
+       LEAVE;
+}
+
 static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) {
        ParamSpec *param_spec;
        SV *declarator;
@@ -1525,32 +1642,38 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL
 
        /* it's go time. */
        {
+               CV *cv;
                OP *const attrs = *attrs_sentinel;
                *attrs_sentinel = NULL;
+
                SvREFCNT_inc_simple_void(PL_compcv);
 
                /* close outer block: '}' */
                S_block_end(aTHX_ save_ix, body);
 
-               if (!saw_name) {
-                       *pop = newANONATTRSUB(
-                               floor_ix,
-                               proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
-                               attrs,
-                               body
-                       );
-                       return KEYWORD_PLUGIN_EXPR;
-               }
-
-               newATTRSUB(
+               cv = newATTRSUB(
                        floor_ix,
-                       newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
+                       saw_name ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)) : NULL,
                        proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
                        attrs,
                        body
                );
-               *pop = newOP(OP_NULL, 0);
-               return KEYWORD_PLUGIN_STMT;
+
+               register_info(aTHX_ PTR2UV(CvROOT(cv)), declarator, spec, param_spec);
+
+               if (saw_name) {
+                       *pop = newOP(OP_NULL, 0);
+                       return KEYWORD_PLUGIN_STMT;
+               }
+
+               *pop = newUNOP(
+                       OP_REFGEN, 0,
+                       newSVOP(
+                               OP_ANONCODE, 0,
+                               (SV *)cv
+                       )
+               );
+               return KEYWORD_PLUGIN_EXPR;
        }
 }
 
@@ -1578,9 +1701,22 @@ static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **o
 
 WARNINGS_RESET
 
-MODULE = Function::Parameters   PACKAGE = Function::Parameters
+MODULE = Function::Parameters   PACKAGE = Function::Parameters   PREFIX = fp_
 PROTOTYPES: ENABLE
 
+UV
+fp__cv_root(sv)
+       SV * sv
+       PREINIT:
+               CV *cv;
+               HV *hv;
+               GV *gv;
+       CODE:
+               cv = sv_2cv(sv, &hv, &gv, 0);
+               RETVAL = PTR2UV(cv ? CvROOT(cv) : NULL);
+       OUTPUT:
+               RETVAL
+
 BOOT:
 WARNINGS_ENABLE {
        HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);

diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm
index fd8c459..5734c7d 100644 (file)
--- a/lib/Function/Parameters.pm
+++ b/lib/Function/Parameters.pm
@@ -155,6 +155,50 @@ sub unimport {
 }
 
 
+our %metadata;
+
+sub _register_info {
+       my (
+               $key,
+               $declarator,
+               $invocant,
+               $positional_required,
+               $positional_optional,
+               $named_required,
+               $named_optional,
+               $slurpy,
+       ) = @_;
+
+       my $blob = pack '(Z*)*',
+               $declarator,
+               $invocant // '',
+               join(' ', @$positional_required),
+               join(' ', @$positional_optional),
+               join(' ', @$named_required),
+               join(' ', @$named_optional),
+               $slurpy // '',
+       ;
+
+       $metadata{$key} = $blob;
+}
+
+sub info {
+       my ($func) = @_;
+       my $key = _cv_root $func or return undef;
+       my $blob = $metadata{$key} or return undef;
+       my @info = unpack '(Z*)*', $blob;
+       require Function::Parameters::Info;
+       Function::Parameters::Info->new(
+               keyword => $info[0],
+               invocant => $info[1] || undef,
+               _positional_required => [split ' ', $info[2]],
+               _positional_optional => [split ' ', $info[3]],
+               _named_required => [split ' ', $info[4]],
+               _named_optional => [split ' ', $info[5]],
+               slurpy => $info[6] || undef,
+       )
+}
+
 'ok'
 
 __END__

diff --git a/lib/Function/Parameters/Info.pm b/lib/Function/Parameters/Info.pm
new file mode 100644 (file)
index 0000000..1519629
--- /dev/null
+++ b/lib/Function/Parameters/Info.pm
@@ -0,0 +1,25 @@
+package Function::Parameters::Info;
+
+use v5.14.0;
+
+use warnings;
+
+use Moo;
+
+our $VERSION = '0.01';
+
+my @pn_ro = glob '{positional,named}_{required,optional}';
+
+for my $attr (qw[keyword invocant slurpy], map "_$_", @pn_ro) {
+       has $attr => (
+               is => 'ro',
+       );
+}
+
+for my $gen (join "\n", map "sub $_ { \@{\$_[0]->_$_} }", @pn_ro) {
+       eval "$gen\n1" or die $@;
+}
+
+'ok'
+
+__END__

diff --git a/t/info.t b/t/info.t
new file mode 100644 (file)
index 0000000..a241450
--- /dev/null
+++ b/t/info.t
@@ -0,0 +1,109 @@
+#!perl
+use warnings FATAL => 'all';
+use strict;
+
+use Test::More tests => 68;
+
+use Function::Parameters;
+
+fun foo($pr1, $pr2, $po1 = 1, $po2 = 2, :$no1 = 3, :$no2 = 4, %r) {}
+
+{
+       my $info = Function::Parameters::info \&foo;
+       is $info->keyword, 'fun';
+       is $info->invocant, undef;
+       is_deeply [$info->positional_required], [qw($pr1 $pr2)];
+       is scalar $info->positional_required, 2;
+       is_deeply [$info->positional_optional], [qw($po1 $po2)];
+       is scalar $info->positional_optional, 2;
+       is_deeply [$info->named_required], [];
+       is scalar $info->named_required, 0;
+       is_deeply [$info->named_optional], [qw($no1 $no2)];
+       is scalar $info->named_optional, 2;
+       is $info->slurpy, '%r';
+}
+
+{
+       my $info = Function::Parameters::info fun ($pr1, :$nr1, :$nr2) {};
+       is $info->keyword, 'fun';
+       is $info->invocant, undef;
+       is_deeply [$info->positional_required], [qw($pr1)];
+       is scalar $info->positional_required, 1;
+       is_deeply [$info->positional_optional], [];
+       is scalar $info->positional_optional, 0;
+       is_deeply [$info->named_required], [qw($nr1 $nr2)];
+       is scalar $info->named_required, 2;
+       is_deeply [$info->named_optional], [];
+       is scalar $info->named_optional, 0;
+       is $info->slurpy, undef;
+}
+
+sub bar {}
+
+is Function::Parameters::info(\&bar), undef;
+
+is Function::Parameters::info(sub {}), undef;
+
+method baz($class: $po1 = 1, $po2 = 2, $po3 = 3, :$no1 = 4, @rem) {}
+
+{
+       my $info = Function::Parameters::info \&baz;
+       is $info->keyword, 'method';
+       is $info->invocant, '$class';
+       is_deeply [$info->positional_required], [];
+       is scalar $info->positional_required, 0;
+       is_deeply [$info->positional_optional], [qw($po1 $po2 $po3)];
+       is scalar $info->positional_optional, 3;
+       is_deeply [$info->named_required], [];
+       is scalar $info->named_required, 0;
+       is_deeply [$info->named_optional], [qw($no1)];
+       is scalar $info->named_optional, 1;
+       is $info->slurpy, '@rem';
+}
+
+{
+       my $info = Function::Parameters::info method () {};
+       is $info->keyword, 'method';
+       is $info->invocant, '$self';
+       is_deeply [$info->positional_required], [];
+       is scalar $info->positional_required, 0;
+       is_deeply [$info->positional_optional], [];
+       is scalar $info->positional_optional, 0;
+       is_deeply [$info->named_required], [];
+       is scalar $info->named_required, 0;
+       is_deeply [$info->named_optional], [];
+       is scalar $info->named_optional, 0;
+       is $info->slurpy, undef;
+}
+
+{
+       use Function::Parameters { proc => 'function' };
+       my $info = Function::Parameters::info proc {};
+       is $info->keyword, 'proc';
+       is $info->invocant, undef;
+       is_deeply [$info->positional_required], [];
+       is scalar $info->positional_required, 0;
+       is_deeply [$info->positional_optional], [];
+       is scalar $info->positional_optional, 0;
+       is_deeply [$info->named_required], [];
+       is scalar $info->named_required, 0;
+       is_deeply [$info->named_optional], [];
+       is scalar $info->named_optional, 0;
+       is $info->slurpy, '@_';
+}
+
+{
+       my $info = Function::Parameters::info method {};
+       is $info->keyword, 'method';
+       is $info->invocant, '$self';
+       is_deeply [$info->positional_required], [];
+       is scalar $info->positional_required, 0;
+       is_deeply [$info->positional_optional], [];
+       is scalar $info->positional_optional, 0;
+       is_deeply [$info->named_required], [];
+       is scalar $info->named_required, 0;
+       is_deeply [$info->named_optional], [];
+       is scalar $info->named_optional, 0;
+       is $info->slurpy, '@_';
+}
+