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
t/foreign/signatures/weird.t
t/hueg.t
t/imports.t
+t/info.t
t/invocant.t
t/lexical.t
t/lineno-torture.t
},
PREREQ_PM => {
'Carp' => 0,
+ 'Moo' => 0,
'XSLoader' => 0,
'warnings' => 0,
},
#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;
/* 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;
}
}
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);
}
+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__
C<use Function::Parameters qw(:strict)> is equivalent to
C<< use Function::Parameters { fun => 'function_strict', method => 'method_strict' } >>.
+=head2 Introspection
+
+You can ask a function at runtime what parameters it has. This functionality is
+available through the function C<Function::Parameters::info> (which is not
+exported, so you have to call it by its full name). It takes a reference to a
+function, and returns either C<undef> (if it knows nothing about the function)
+or a L<Function::Parameters::Info> object describing the parameter list.
+
+See L<Function::Parameters::Info> for examples.
+
=head2 Wrapping C<Function::Parameters>
If you want to write a wrapper around C<Function::Parameters>, you only have to
# ... turns into ...
sub bar :method { my $self = shift; my ($x, $y, @z) = @_; sub bar; ... }
+=head1 SEE ALSO
+
+L<Function::Parameters::Info>
+
=head1 AUTHOR
Lukas Mai, C<< <l.mai at web.de> >>
--- /dev/null
+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 $@;
+}
+
+sub args_min {
+ my $self = shift;
+ my $r = 0;
+ $r++ if defined $self->invocant;
+ $r += $self->positional_required;
+ $r += $self->named_required * 2;
+ $r
+}
+
+sub args_max {
+ my $self = shift;
+ return 0 + 'Inf' if defined $self->slurpy || $self->named_required || $self->named_optional;
+ my $r = 0;
+ $r++ if defined $self->invocant;
+ $r += $self->positional_required;
+ $r += $self->positional_optional;
+ $r
+}
+
+'ok'
+
+__END__
+
+=encoding UTF-8
+
+=head1 NAME
+
+Function::Parameters::Info - Information about parameter lists
+
+=head1 SYNOPSIS
+
+ use Function::Parameters;
+
+ fun foo($x, $y, :$hello, :$world = undef) {}
+
+ my $info = Function::Parameters::info \&foo;
+ my $p0 = $info->invocant; # undef
+ my @p1 = $info->positional_required; # ('$x', '$y')
+ my @p2 = $info->positional_optional; # ()
+ my @p3 = $info->named_required; # ('$hello')
+ my @p4 = $info->named_optional; # ('$world')
+ my $p5 = $info->slurpy; # undef
+ my $min = $info->args_min; # 4
+ my $max = $info->args_max; # inf
+
+ my $invocant = Function::Parameters::info(method () { 42 })->invocant; # '$self'
+
+ my $slurpy = Function::Parameters::info(fun {})->slurpy; # '@_'
+
+=head1 DESCRIPTION
+
+L<C<Function::Parameters::info>|Function::Parameters/Introspection> returns
+objects of this class to describe parameter lists of functions. The following
+methods are available:
+
+=head2 $info->invocant
+
+Returns the name of the variable into which the first argument is
+L<C<shift>|perlfunc/shift>ed automatically, or C<undef> if no such thing
+exists. This will usually return C<'$self'> for methods.
+
+=head2 $info->positional_required
+
+Returns a list of the names of the required positional parameters (or a count
+in scalar context).
+
+=head2 $info->positional_optional
+
+Returns a list of the names of the optional positional parameters (or a count
+in scalar context).
+
+=head2 $info->named_required
+
+Returns a list of the names of the required named parameters (or a count
+in scalar context).
+
+=head2 $info->named_optional
+
+Returns a list of the names of the optional named parameters (or a count
+in scalar context).
+
+=head2 $info->slurpy
+
+Returns the name of the final array or hash that gobbles up all remaining
+arguments, or C<undef> if no such thing exists.
+
+As a special case, functions defined without an explicit parameter list (i.e.
+without C<( )>) will return C<'@_'> here because they accept any number of
+arguments.
+
+=head2 $info->args_min
+
+Returns the minimum number of arguments this function requires. This is
+computed as follows: Invocant and required positional parameters count 1 each.
+Optional parameters don't count. Required named parameters count 2 each (key +
+value). Slurpy parameters don't count either because they accept empty lists.
+
+=head2 $info->args_max
+
+Returns the maximum number of arguments this function accepts. This is computed
+as follows: If there is any named or slurpy parameter, the result is C<Inf>.
+Otherwise the result is the sum of all invocant and positional parameters.
+
+=head1 SEE ALSO
+
+L<Function::Parameters>
+
+=head1 AUTHOR
+
+Lukas Mai, C<< <l.mai at web.de> >>
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2012 Lukas Mai.
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See http://dev.perl.org/licenses/ for more information.
+
+=cut
--- /dev/null
+#!perl
+use warnings FATAL => 'all';
+use strict;
+
+use Test::More tests => 122;
+
+use Function::Parameters;
+
+sub Inf () { 0 + 'Inf' }
+
+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';
+ is $info->args_min, 2;
+ is $info->args_max, Inf;
+}
+
+{
+ 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;
+ is $info->args_min, 5;
+ is $info->args_max, Inf;
+}
+
+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';
+ is $info->args_min, 1;
+ is $info->args_max, Inf;
+}
+
+{
+ 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;
+ is $info->args_min, 1;
+ is $info->args_max, 1;
+}
+
+{
+ 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, '@_';
+ is $info->args_min, 0;
+ is $info->args_max, Inf;
+}
+
+{
+ 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, '@_';
+ is $info->args_min, 1;
+ is $info->args_max, Inf;
+}
+
+{
+ my @fs;
+ for my $i (qw(aku soku zan)) {
+ push @fs, [$i => fun (:$sin, :$swift, :$slay) { $i }];
+ }
+ for my $kf (@fs) {
+ my ($i, $f) = @$kf;
+ my $info = Function::Parameters::info $f;
+ is $info->keyword, 'fun';
+ 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], [qw($sin $swift $slay)];
+ is scalar $info->named_required, 3;
+ is_deeply [$info->named_optional], [];
+ is scalar $info->named_optional, 0;
+ is $info->slurpy, undef;
+ is $info->args_min, 6;
+ is $info->args_max, Inf;
+ is $f->(), $i;
+ }
+}
projects / p5sagit/Function-Parameters.git / commitdiff