From: Lukas Mai <l.mai@web.de>
Date: Tue, 5 Feb 2013 00:57:40 +0000 (+0100)
Subject: Merge branch 'master' into metadata
X-Git-Tag: v1.0101~3^2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b9c12f70b2c7b73970cefbb5b41982ef22477ace;hp=7bb8e9228c380101ddee2692d71c2f43003fe3dc;p=p5sagit%2FFunction-Parameters.git

Merge branch 'master' into metadata
---

diff --git a/MANIFEST b/MANIFEST
index 4fb8566..1c86126 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
@@ -75,6 +76,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/Parameters.xs b/Parameters.xs
index 9300113..f2ac0da 100644
--- a/Parameters.xs
+++ b/Parameters.xs
@@ -753,6 +753,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 ? (size_t)(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;
@@ -1493,32 +1610,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;
 	}
 }
 
@@ -1546,9 +1669,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 *xcv;
+		HV *hv;
+		GV *gv;
+	CODE:
+		xcv = sv_2cv(sv, &hv, &gv, 0);
+		RETVAL = PTR2UV(xcv ? CvROOT(xcv) : 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 59d9bdc..a3afc55 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__
@@ -569,6 +613,19 @@ C<< use Function::Parameters { fun => 'function', method => 'method' } >>.
 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.
+
+Note: This feature is implemented using L<Moo>, so you'll need to have L<Moo>
+installed if you want to call C<Function::Parameters::info>.
+
+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
@@ -599,6 +656,10 @@ generated code corresponds 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> >>
diff --git a/lib/Function/Parameters/Info.pm b/lib/Function/Parameters/Info.pm
new file mode 100644
index 0000000..ac2b466
--- /dev/null
+++ b/lib/Function/Parameters/Info.pm
@@ -0,0 +1,144 @@
+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
diff --git a/t/info.t b/t/info.t
new file mode 100644
index 0000000..57e2696
--- /dev/null
+++ b/t/info.t
@@ -0,0 +1,151 @@
+#!perl
+use warnings FATAL => 'all';
+use strict;
+
+use Test::More
+	eval { require Moo; 1 }
+	? (tests => 122)
+	: (skip_all => "Moo required for testing parameter introspection")
+;
+
+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;
+	}
+}