[p5sagit/Function-Parameters.git] / lib / Function / Parameters.pm

package Function::Parameters;

use strict;
use warnings;

our $VERSION = '0.05';

use Carp qw(croak confess);
use Devel::Declare;
use B::Hooks::EndOfScope;

our @CARP_NOT = qw(Devel::Declare);


# Make our import chainable so a wrapper module that wants to turn on F:P
# for its users can just say
#    sub import { Function::Parameters->import; }
#
# To make that possible we skip all subs named 'import' in our search for the
# target package.
#
sub guess_caller {
	my ($start) = @_;
	$start ||= 1;

	my $defcaller = (caller $start)[0];
	my $caller = $defcaller;

	for (my $level = $start; ; ++$level) {
		my ($pkg, $function) = (caller $level)[0, 3] or last;
		$function =~ /::import\z/ or return $caller;
		$caller = $pkg;
	}
	$defcaller
}


# Parse import spec and make shit happen.
#
my @bare_arms = qw(function method);

sub import_into {
	my $victim = shift;

	@_ or @_ = ('fun', 'method');
	if (@_ == 1 && ref($_[0]) eq 'HASH') {
		@_ = map [$_, $_[0]{$_}], keys %{$_[0]}
			or return;
	}

	my %spec;

	my $bare = 0;
	for my $proto (@_) {
		my $item = ref $proto
			? $proto
			: [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})]
		;
		my ($name, $type) = @$item;
		$name =~ /^[^\W\d]\w*\z/
			or confess qq{"$name" doesn't look like a valid identifier};
		my ($index) = grep $bare_arms[$_] eq $type, 0 .. $#bare_arms
			or confess qq{"$type" doesn't look like a valid type (one of ${\join ', ', @bare_arms})};
		
		$spec{$name} = {const => mk_parse($index)};
	}
	
	Devel::Declare->setup_for($victim, \%spec);
	for my $name (keys %spec) {
		no strict 'refs';
		*{$victim . '::' . $name} = \&_declarator;
	}
}

sub import {
	my $class = shift;
	my $caller = guess_caller;
	import_into $caller, @_;
}

sub _declarator {
	$_[0]
}


# Wrapper around substr where param 3 is an end offset, not a length.
#
sub _substring {
	@_ >= 4
	? substr $_[0], $_[1], $_[2] - $_[1], $_[3]
	: substr $_[0], $_[1], $_[2] - $_[1]
}

sub _skip_space {
	my ($ctx, $key) = @_;
	my $cur = my $start = $ctx->{offset};
	while (my $d = Devel::Declare::toke_skipspace $cur) {
		$cur += $d;
	}
	$ctx->{space}{$key} .= _substring Devel::Declare::get_linestr, $start, $cur if $key;
	$ctx->{offset} = $cur;
}

sub _grab_name {
	my ($ctx) = @_;
	my $p = $ctx->{offset};
	my $namlen = Devel::Declare::toke_scan_word $p, !!'handle_package'
		or return;
	my $str = Devel::Declare::get_linestr;
	$ctx->{name} = substr $str, $p, $namlen;
	$ctx->{offset} += $namlen;
	_skip_space $ctx, 'name';
}

sub _grab_params {
	my ($ctx) = @_;
	substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '('
		or return;
	$ctx->{offset}++;
	_skip_space $ctx, 'params';

	my $pcount = 0;

	LOOP: {
		my $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1;

		if ($c =~ /^[\$\@%]\z/) {
			$ctx->{offset}++;
			_skip_space $ctx, "params_$pcount";
			my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package'
				or croak "Missing identifier";
			my $name = substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen;
			$ctx->{params} .= $c . $name . ',';
			$ctx->{offset} += $namlen;
			_skip_space $ctx, "params_$pcount";

			$c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1;
			if ($c eq ',') {
				$ctx->{offset}++;
				_skip_space $ctx, "params_$pcount";
				$pcount++;
				redo LOOP;
			}
		}

		if ($c eq ')') {
			$ctx->{offset}++;
			_skip_space $ctx, 'params';
			return;
		}

		if ($c eq '') {
			croak "Unexpected EOF in parameter list";
		}

		croak "Unexpected '$c' in parameter list";
	}
}

sub _parse_parens {
	my ($ctx) = @_;

	my $strlen = Devel::Declare::toke_scan_str $ctx->{offset};
	$strlen == 0 || $strlen == -1 and return;

	$strlen < 0 and confess "Devel::Declare::toke_scan_str done fucked up ($strlen); see https://rt.cpan.org/Ticket/Display.html?id=51679";

	my $str = Devel::Declare::get_lex_stuff;
	Devel::Declare::clear_lex_stuff;

	$ctx->{offset} += $strlen;

	$str
}

sub _grab_proto {
	my ($ctx) = @_;

	my $savepos = $ctx->{offset};

	substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':'
		or return;
	$ctx->{offset}++;
	_skip_space $ctx, 'proto_tmp';

	unless (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') {
		$ctx->{offset} = $savepos;
		delete $ctx->{space}{proto_tmp};
		return;
	}
	$_->{proto} .= delete $_->{proto_tmp} for $ctx->{space};

	defined(my $str = _parse_parens $ctx)
		or croak "Malformed prototype";
	$ctx->{proto} = $str;

	_skip_space $ctx, 'proto';
}

sub _grab_attr {
	my ($ctx) = @_;

	my $pcount = 0;

	if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') {
		$ctx->{offset}++;
		_skip_space $ctx, "attr_$pcount";
	} elsif (!defined $ctx->{proto}) {
		return;
	}

	while () {
		my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package'
			or return;
		$ctx->{attr} .= substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen;
		$ctx->{offset} += $namlen;
		_skip_space $ctx, "attr_$pcount";
		if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') {
			defined(my $str = _parse_parens $ctx)
				or croak "Malformed attribute argument list";
			$ctx->{attr} .= "($str)";
			_skip_space $ctx, "attr_$pcount";
		}
		$pcount++;

		if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') {
			$ctx->{offset}++;
			_skip_space $ctx, "attr_$pcount";
		}
	}
}

# IN:
#  fun name (params) :(proto) :attr { ... }
# OUT:
#  fun (do { sub                        (proto) :attr { self? my (params) = @_; ... } })
#  fun (do { sub name (proto); sub name (proto) :attr { self? my (params) = @_; ... } });
#
sub _generate {
	my ($ctx, $declarator, $implicit_self) = @_;

	my $gen = '(do{sub';

	my $skipped = join '', values %{$ctx->{space}};
	my $lines = $skipped =~ tr/\n//;
	$gen .= "\n" x $lines;

	my $proto = defined $ctx->{proto} ? "($ctx->{proto})" : '';

	my $is_stmt = 0;
	if (defined(my $name = $ctx->{name})) {
		$is_stmt = 1;
		$gen .= " $name$proto;";
		$gen .= "sub $name";
	}

	$gen .= $proto;

	if (defined $ctx->{attr}) {
		$gen .= ":$ctx->{attr}";
	}

	$gen .= '{';
	$gen .= "BEGIN{${\__PACKAGE__}::_fini($is_stmt)}";

	if ($implicit_self) {
		$gen .= 'my$self=shift;';
	}
	if (defined $ctx->{params}) {
		$gen .= "my($ctx->{params})=\@_;";
	}
	$gen
}

sub mk_parse {
	my ($implicit_self) = @_;

	sub {
		my ($declarator, $offset_orig) = @_;
		my $ctx = {
			offset => $offset_orig,
			space => {},
		};

		$ctx->{offset} += Devel::Declare::toke_move_past_token($ctx->{offset});
		_skip_space $ctx;

		my $start = $ctx->{offset};

		_grab_name $ctx;
		_grab_params $ctx;
		_grab_proto $ctx;
		_grab_attr $ctx;

		my $offset = $ctx->{offset};

		my $linestr = Devel::Declare::get_linestr;
		substr($linestr, $offset, 1) eq '{'
			or croak qq[I was expecting a function body, not "${\substr $linestr, $offset}"];

		my $gen = _generate $ctx, $declarator, $implicit_self;
		my $oldlen = $offset + 1 - $start;
		_substring $linestr, $start, $offset + 1, (' ' x $oldlen) . $gen;
		Devel::Declare::set_linestr $linestr;
	}
}

# Patch in the end of our synthetic 'do' block, close argument list, and
# optionally terminate the statement.
#
sub _fini {
	my ($stmt) = @_;
	on_scope_end {
		my $off = Devel::Declare::get_linestr_offset;
		my $str = Devel::Declare::get_linestr;
		substr $str, $off, 0, '})' . ($stmt ? ';' : '');
		Devel::Declare::set_linestr $str;
	};
}

'ok'

__END__

=head1 NAME

Function::Parameters - subroutine definitions with parameter lists

=head1 SYNOPSIS

 use Function::Parameters;
 
 fun foo($bar, $baz) {
   return $bar + $baz;
 }
 
 fun mymap($fun, @args) :(&@) {
   my @res;
   for (@args) {
     push @res, $fun->($_);
   }
   @res
 }
 
 print "$_\n" for mymap { $_ * 2 } 1 .. 4;
 
 method set_name($name) {
   $self->{name} = $name;
 }

=cut

=pod

 use Function::Parameters 'proc', 'meth';
 
 my $f = proc ($x) { $x * 2 };
 meth get_age() {
   return $self->{age};
 }

=head1 DESCRIPTION

This module lets you use parameter lists in your subroutines. Thanks to
L<Devel::Declare> it works without source filters.

WARNING: This is my first attempt at using L<Devel::Declare> and I have
almost no experience with perl's internals. So while this module might
appear to work, it could also conceivably make your programs segfault.
Consider this module alpha quality.

=head2 Basic stuff

To use this new functionality, you have to use C<fun> instead of C<sub> -
C<sub> continues to work as before. The syntax is almost the same as for
C<sub>, but after the subroutine name (or directly after C<fun> if you're
writing an anonymous sub) you can write a parameter list in parentheses. This
list consists of comma-separated variables.

The effect of C<fun foo($bar, $baz) {> is as if you'd written
C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply
copied into C<my> and initialized from L<@_|perlvar/"@_">.

In addition you can use C<method>, which understands the same syntax as C<fun>
but automatically creates a C<$self> variable for you. So by writing
C<method foo($bar, $baz) {> you get the same effect as
C<sub foo { my $self = shift; my ($bar, $baz) = @_; >.

=head2 Customizing the generated keywords

You can customize the names of the keywords injected in your package. To do that
you pass a hash reference in the import list:

 use Function::Parameters { proc => 'function', meth => 'method' }; # -or-
 use Function::Parameters { proc => 'function' }; # -or-
 use Function::Parameters { meth => 'method' };

The first line creates two keywords, C<proc> and C<meth> (for defining
functions and methods, respectively). The last two lines only create one
keyword. Generally the hash keys can be any identifiers you want while the
values have to be either C<function> or C<method>. The difference between
C<function> and C<method> is that C<method>s automatically
L<shift|perlfunc/shift> their first argument into C<$self>.

The following shortcuts are available:

 use Function::Parameters;
    # is equivalent to #
 use Function::Parameters { fun => 'function', method => 'method' };

=cut

=pod

 use Function::Parameters 'foo';
   # is equivalent to #
 use Function::Parameters { 'foo' => 'function' };

=cut

=pod

 use Function::Parameters 'foo', 'bar';
   # is equivalent to #
 use Function::Parameters { 'foo' => 'function', 'bar' => 'method' };

=head2 Other advanced stuff

Normally, Perl subroutines are not in scope in their own body, meaning the
parser doesn't know the name C<foo> or its prototype while processing
C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
a I<foo() called too early to check prototype> warning. This module attempts
to fix all of this by adding a subroutine declaration before the definition,
so the parser knows the name (and possibly prototype) while it processes the
body. Thus C<fun foo($x) :($) { $x }> really turns into
C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>.

If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, you can
put them after the parameter list with their usual syntax.

Syntactically, these new parameter lists live in the spot normally occupied
by L<prototypes|perlsub/"Prototypes">. However, you can include a prototype by
specifying it as the first attribute (this is syntactically unambiguous
because normal attributes have to start with a letter).

If you want to wrap C<Function::Parameters>, you may find C<import_into>
helpful. It lets you specify a target package for the syntax magic, as in:

  package Some::Wrapper;
  use Function::Parameters ();
  sub import {
    my $caller = caller;
    Function::Parameters::import_into $caller;
    # or Function::Parameters::import_into $caller, @other_import_args;
  }

C<import_into> is not exported by this module, so you have to use a fully
qualified name to call it.

=head1 AUTHOR

Lukas Mai, C<< <l.mai at web.de> >>

=head1 COPYRIGHT & LICENSE

Copyright 2010, 2011 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
Commit	Line	Data
7a63380c	1	package Function::Parameters;
	2
	3	use strict;
	4	use warnings;
	5
125c067e	6	our $VERSION = '0.05';
7a63380c	7
125c067e	8	use Carp qw(croak confess);
7a63380c	9	use Devel::Declare;
7a63380c	10	use B::Hooks::EndOfScope;
7a63380c	11
125c067e	12	our @CARP_NOT = qw(Devel::Declare);
	13
	14
	15	# Make our import chainable so a wrapper module that wants to turn on F:P
	16	# for its users can just say
	17	# sub import { Function::Parameters->import; }
	18	#
	19	# To make that possible we skip all subs named 'import' in our search for the
	20	# target package.
	21	#
7a63380c	22	sub guess_caller {
	23	my ($start) = @_;
	24	$start \|\|= 1;
	25
	26	my $defcaller = (caller $start)[0];
	27	my $caller = $defcaller;
	28
	29	for (my $level = $start; ; ++$level) {
	30	my ($pkg, $function) = (caller $level)[0, 3] or last;
7a63380c	31	$function =~ /::import\z/ or return $caller;
	32	$caller = $pkg;
	33	}
	34	$defcaller
	35	}
	36
7a63380c	37
125c067e	38	# Parse import spec and make shit happen.
	39	#
	40	my @bare_arms = qw(function method);
c9a39f6b	41
eeb7df5f	42	sub import_into {
eeb7df5f	43	my $victim = shift;
7a63380c	44
125c067e	45	@_ or @_ = ('fun', 'method');
	46	if (@_ == 1 && ref($_[0]) eq 'HASH') {
	47	@_ = map [$_, $_[0]{$_}], keys %{$_[0]}
	48	or return;
	49	}
7a63380c	50
125c067e	51	my %spec;
	52
	53	my $bare = 0;
	54	for my $proto (@_) {
	55	my $item = ref $proto
	56	? $proto
	57	: [$proto, $bare_arms[$bare++] \|\| confess(qq{Don't know what to do with "$proto"})]
	58	;
	59	my ($name, $type) = @$item;
	60	$name =~ /^[^\W\d]\w*\z/
	61	or confess qq{"$name" doesn't look like a valid identifier};
	62	my ($index) = grep $bare_arms[$_] eq $type, 0 .. $#bare_arms
	63	or confess qq{"$type" doesn't look like a valid type (one of ${\join ', ', @bare_arms})};
	64
	65	$spec{$name} = {const => mk_parse($index)};
	66	}
	67
	68	Devel::Declare->setup_for($victim, \%spec);
	69	for my $name (keys %spec) {
	70	no strict 'refs';
	71	*{$victim . '::' . $name} = \&_declarator;
	72	}
eeb7df5f	73	}
	74
	75	sub import {
	76	my $class = shift;
eeb7df5f	77	my $caller = guess_caller;
eeb7df5f	78	import_into $caller, @_;
7a63380c	79	}
7a63380c	80
125c067e	81	sub _declarator {
125c067e	82	$_[0]
7a63380c	83	}
7a63380c	84
7a63380c	85
125c067e	86	# Wrapper around substr where param 3 is an end offset, not a length.
	87	#
	88	sub _substring {
	89	@_ >= 4
	90	? substr $_[0], $_[1], $_[2] - $_[1], $_[3]
	91	: substr $_[0], $_[1], $_[2] - $_[1]
	92	}
	93
	94	sub _skip_space {
	95	my ($ctx, $key) = @_;
	96	my $cur = my $start = $ctx->{offset};
	97	while (my $d = Devel::Declare::toke_skipspace $cur) {
	98	$cur += $d;
	99	}
	100	$ctx->{space}{$key} .= _substring Devel::Declare::get_linestr, $start, $cur if $key;
	101	$ctx->{offset} = $cur;
	102	}
	103
	104	sub _grab_name {
	105	my ($ctx) = @_;
	106	my $p = $ctx->{offset};
	107	my $namlen = Devel::Declare::toke_scan_word $p, !!'handle_package'
	108	or return;
	109	my $str = Devel::Declare::get_linestr;
	110	$ctx->{name} = substr $str, $p, $namlen;
	111	$ctx->{offset} += $namlen;
	112	_skip_space $ctx, 'name';
	113	}
	114
	115	sub _grab_params {
	116	my ($ctx) = @_;
	117	substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '('
	118	or return;
	119	$ctx->{offset}++;
	120	_skip_space $ctx, 'params';
	121
	122	my $pcount = 0;
	123
	124	LOOP: {
	125	my $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1;
	126
	127	if ($c =~ /^[\$\@%]\z/) {
	128	$ctx->{offset}++;
	129	_skip_space $ctx, "params_$pcount";
	130	my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package'
	131	or croak "Missing identifier";
	132	my $name = substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen;
	133	$ctx->{params} .= $c . $name . ',';
	134	$ctx->{offset} += $namlen;
	135	_skip_space $ctx, "params_$pcount";
	136
	137	$c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1;
	138	if ($c eq ',') {
	139	$ctx->{offset}++;
	140	_skip_space $ctx, "params_$pcount";
	141	$pcount++;
	142	redo LOOP;
7a63380c	143	}
7a63380c	144	}
7a63380c	145
125c067e	146	if ($c eq ')') {
	147	$ctx->{offset}++;
	148	_skip_space $ctx, 'params';
7a63380c	149	return;
7a63380c	150	}
7a63380c	151
125c067e	152	if ($c eq '') {
125c067e	153	croak "Unexpected EOF in parameter list";
7a63380c	154	}
7a63380c	155
125c067e	156	croak "Unexpected '$c' in parameter list";
	157	}
	158	}
	159
	160	sub _parse_parens {
	161	my ($ctx) = @_;
	162
	163	my $strlen = Devel::Declare::toke_scan_str $ctx->{offset};
	164	$strlen == 0 \|\| $strlen == -1 and return;
	165
	166	$strlen < 0 and confess "Devel::Declare::toke_scan_str done fucked up ($strlen); see https://rt.cpan.org/Ticket/Display.html?id=51679";
	167
	168	my $str = Devel::Declare::get_lex_stuff;
	169	Devel::Declare::clear_lex_stuff;
	170
	171	$ctx->{offset} += $strlen;
7a63380c	172
125c067e	173	$str
	174	}
	175
	176	sub _grab_proto {
	177	my ($ctx) = @_;
	178
	179	my $savepos = $ctx->{offset};
	180
	181	substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':'
	182	or return;
	183	$ctx->{offset}++;
	184	_skip_space $ctx, 'proto_tmp';
	185
	186	unless (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') {
	187	$ctx->{offset} = $savepos;
	188	delete $ctx->{space}{proto_tmp};
	189	return;
7a63380c	190	}
125c067e	191	$_->{proto} .= delete $_->{proto_tmp} for $ctx->{space};
7a63380c	192
125c067e	193	defined(my $str = _parse_parens $ctx)
	194	or croak "Malformed prototype";
	195	$ctx->{proto} = $str;
7a63380c	196
125c067e	197	_skip_space $ctx, 'proto';
125c067e	198	}
7a63380c	199
125c067e	200	sub _grab_attr {
	201	my ($ctx) = @_;
	202
	203	my $pcount = 0;
	204
	205	if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') {
	206	$ctx->{offset}++;
	207	_skip_space $ctx, "attr_$pcount";
	208	} elsif (!defined $ctx->{proto}) {
	209	return;
	210	}
	211
	212	while () {
	213	my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package'
	214	or return;
	215	$ctx->{attr} .= substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen;
	216	$ctx->{offset} += $namlen;
	217	_skip_space $ctx, "attr_$pcount";
	218	if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') {
	219	defined(my $str = _parse_parens $ctx)
	220	or croak "Malformed attribute argument list";
	221	$ctx->{attr} .= "($str)";
	222	_skip_space $ctx, "attr_$pcount";
7a63380c	223	}
125c067e	224	$pcount++;
	225
	226	if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') {
	227	$ctx->{offset}++;
	228	_skip_space $ctx, "attr_$pcount";
7a63380c	229	}
125c067e	230	}
125c067e	231	}
7a63380c	232
125c067e	233	# IN:
	234	# fun name (params) :(proto) :attr { ... }
	235	# OUT:
	236	# fun (do { sub (proto) :attr { self? my (params) = @_; ... } })
	237	# fun (do { sub name (proto); sub name (proto) :attr { self? my (params) = @_; ... } });
	238	#
	239	sub _generate {
	240	my ($ctx, $declarator, $implicit_self) = @_;
7a63380c	241
125c067e	242	my $gen = '(do{sub';
7a63380c	243
125c067e	244	my $skipped = join '', values %{$ctx->{space}};
	245	my $lines = $skipped =~ tr/\n//;
	246	$gen .= "\n" x $lines;
7a63380c	247
125c067e	248	my $proto = defined $ctx->{proto} ? "($ctx->{proto})" : '';
7a63380c	249
125c067e	250	my $is_stmt = 0;
	251	if (defined(my $name = $ctx->{name})) {
	252	$is_stmt = 1;
	253	$gen .= " $name$proto;";
	254	$gen .= "sub $name";
	255	}
	256
	257	$gen .= $proto;
	258
	259	if (defined $ctx->{attr}) {
	260	$gen .= ":$ctx->{attr}";
	261	}
7a63380c	262
125c067e	263	$gen .= '{';
125c067e	264	$gen .= "BEGIN{${\__PACKAGE__}::_fini($is_stmt)}";
7a63380c	265
125c067e	266	if ($implicit_self) {
125c067e	267	$gen .= 'my$self=shift;';
7a63380c	268	}
125c067e	269	if (defined $ctx->{params}) {
	270	$gen .= "my($ctx->{params})=\@_;";
	271	}
	272	$gen
7a63380c	273	}
7a63380c	274
125c067e	275	sub mk_parse {
	276	my ($implicit_self) = @_;
	277
	278	sub {
	279	my ($declarator, $offset_orig) = @_;
	280	my $ctx = {
	281	offset => $offset_orig,
	282	space => {},
	283	};
	284
	285	$ctx->{offset} += Devel::Declare::toke_move_past_token($ctx->{offset});
	286	_skip_space $ctx;
	287
	288	my $start = $ctx->{offset};
	289
	290	_grab_name $ctx;
	291	_grab_params $ctx;
	292	_grab_proto $ctx;
	293	_grab_attr $ctx;
	294
	295	my $offset = $ctx->{offset};
	296
	297	my $linestr = Devel::Declare::get_linestr;
	298	substr($linestr, $offset, 1) eq '{'
	299	or croak qq[I was expecting a function body, not "${\substr $linestr, $offset}"];
	300
	301	my $gen = _generate $ctx, $declarator, $implicit_self;
	302	my $oldlen = $offset + 1 - $start;
	303	_substring $linestr, $start, $offset + 1, (' ' x $oldlen) . $gen;
	304	Devel::Declare::set_linestr $linestr;
	305	}
	306	}
	307
	308	# Patch in the end of our synthetic 'do' block, close argument list, and
	309	# optionally terminate the statement.
	310	#
	311	sub _fini {
	312	my ($stmt) = @_;
7a63380c	313	on_scope_end {
125c067e	314	my $off = Devel::Declare::get_linestr_offset;
	315	my $str = Devel::Declare::get_linestr;
	316	substr $str, $off, 0, '})' . ($stmt ? ';' : '');
	317	Devel::Declare::set_linestr $str;
7a63380c	318	};
	319	}
	320
125c067e	321	'ok'
7a63380c	322
	323	__END__
	324
	325	=head1 NAME
	326
	327	Function::Parameters - subroutine definitions with parameter lists
	328
	329	=head1 SYNOPSIS
	330
	331	use Function::Parameters;
	332
	333	fun foo($bar, $baz) {
	334	return $bar + $baz;
	335	}
	336
	337	fun mymap($fun, @args) :(&@) {
	338	my @res;
	339	for (@args) {
	340	push @res, $fun->($_);
	341	}
	342	@res
	343	}
	344
	345	print "$_\n" for mymap { $_ * 2 } 1 .. 4;
125c067e	346
	347	method set_name($name) {
	348	$self->{name} = $name;
	349	}
7a63380c	350
125c067e	351	=cut
	352
	353	=pod
	354
	355	use Function::Parameters 'proc', 'meth';
c9a39f6b	356
125c067e	357	my $f = proc ($x) { $x * 2 };
	358	meth get_age() {
	359	return $self->{age};
	360	}
	361
7a63380c	362	=head1 DESCRIPTION
	363
	364	This module lets you use parameter lists in your subroutines. Thanks to
	365	L<Devel::Declare> it works without source filters.
	366
	367	WARNING: This is my first attempt at using L<Devel::Declare> and I have
	368	almost no experience with perl's internals. So while this module might
	369	appear to work, it could also conceivably make your programs segfault.
	370	Consider this module alpha quality.
	371
	372	=head2 Basic stuff
	373
	374	To use this new functionality, you have to use C<fun> instead of C<sub> -
	375	C<sub> continues to work as before. The syntax is almost the same as for
	376	C<sub>, but after the subroutine name (or directly after C<fun> if you're
125c067e	377	writing an anonymous sub) you can write a parameter list in parentheses. This
7a63380c	378	list consists of comma-separated variables.
	379
	380	The effect of C<fun foo($bar, $baz) {> is as if you'd written
	381	C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply
	382	copied into C<my> and initialized from L<@_\|perlvar/"@_">.
	383
125c067e	384	In addition you can use C<method>, which understands the same syntax as C<fun>
	385	but automatically creates a C<$self> variable for you. So by writing
	386	C<method foo($bar, $baz) {> you get the same effect as
	387	C<sub foo { my $self = shift; my ($bar, $baz) = @_; >.
7a63380c	388
125c067e	389	=head2 Customizing the generated keywords
c9a39f6b	390
125c067e	391	You can customize the names of the keywords injected in your package. To do that
125c067e	392	you pass a hash reference in the import list:
7a63380c	393
125c067e	394	use Function::Parameters { proc => 'function', meth => 'method' }; # -or-
	395	use Function::Parameters { proc => 'function' }; # -or-
	396	use Function::Parameters { meth => 'method' };
	397
	398	The first line creates two keywords, C<proc> and C<meth> (for defining
	399	functions and methods, respectively). The last two lines only create one
	400	keyword. Generally the hash keys can be any identifiers you want while the
	401	values have to be either C<function> or C<method>. The difference between
	402	C<function> and C<method> is that C<method>s automatically
	403	L<shift\|perlfunc/shift> their first argument into C<$self>.
	404
	405	The following shortcuts are available:
	406
	407	use Function::Parameters;
	408	# is equivalent to #
	409	use Function::Parameters { fun => 'function', method => 'method' };
	410
	411	=cut
	412
	413	=pod
	414
	415	use Function::Parameters 'foo';
	416	# is equivalent to #
	417	use Function::Parameters { 'foo' => 'function' };
	418
	419	=cut
	420
	421	=pod
	422
	423	use Function::Parameters 'foo', 'bar';
	424	# is equivalent to #
	425	use Function::Parameters { 'foo' => 'function', 'bar' => 'method' };
	426
	427	=head2 Other advanced stuff
7a63380c	428
7a63380c	429	Normally, Perl subroutines are not in scope in their own body, meaning the
125c067e	430	parser doesn't know the name C<foo> or its prototype while processing
7a63380c	431	C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
	432	C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
	433	interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
	434	a I<foo() called too early to check prototype> warning. This module attempts
	435	to fix all of this by adding a subroutine declaration before the definition,
	436	so the parser knows the name (and possibly prototype) while it processes the
	437	body. Thus C<fun foo($x) :($) { $x }> really turns into
	438	C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>.
	439
125c067e	440	If you need L<subroutine attributes\|perlsub/"Subroutine Attributes">, you can
	441	put them after the parameter list with their usual syntax.
	442
	443	Syntactically, these new parameter lists live in the spot normally occupied
	444	by L<prototypes\|perlsub/"Prototypes">. However, you can include a prototype by
	445	specifying it as the first attribute (this is syntactically unambiguous
	446	because normal attributes have to start with a letter).
	447
eeb7df5f	448	If you want to wrap C<Function::Parameters>, you may find C<import_into>
	449	helpful. It lets you specify a target package for the syntax magic, as in:
	450
	451	package Some::Wrapper;
	452	use Function::Parameters ();
	453	sub import {
	454	my $caller = caller;
	455	Function::Parameters::import_into $caller;
125c067e	456	# or Function::Parameters::import_into $caller, @other_import_args;
eeb7df5f	457	}
	458
	459	C<import_into> is not exported by this module, so you have to use a fully
	460	qualified name to call it.
	461
7a63380c	462	=head1 AUTHOR
	463
	464	Lukas Mai, C<< <l.mai at web.de> >>
	465
	466	=head1 COPYRIGHT & LICENSE
	467
125c067e	468	Copyright 2010, 2011 Lukas Mai.
7a63380c	469
	470	This program is free software; you can redistribute it and/or modify it
	471	under the terms of either: the GNU General Public License as published
	472	by the Free Software Foundation; or the Artistic License.
	473
	474	See http://dev.perl.org/licenses/ for more information.
	475
	476	=cut