From: Lukas Mai Date: Sat, 3 Nov 2012 20:18:32 +0000 (+0100) Subject: record and extract metadata X-Git-Tag: v1.00_02~13 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FFunction-Parameters.git;a=commitdiff_plain;h=53c979f03d47fc61fcbbb9c922d755bd21fa139e record and extract metadata --- diff --git a/MANIFEST b/MANIFEST index 622f678..d223f48 100644 --- 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 --- 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 --- 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 --- 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 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 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, '@_'; +} +