[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
}


sub _assert_valid_identifier {
	my ($name, $with_dollar) = @_;
	my $bonus = $with_dollar ? '\$' : '';
	$name =~ /^${bonus}[^\W\d]\w*\z/
		or confess qq{"$name" doesn't look like a valid identifier};
}

# Parse import spec and make shit happen.
#
my @bare_arms = qw(function method);
my %type_map = (
	function => { name => 'optional' },
	method   => { name => 'optional', shift => '$self' },
);

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;
		_assert_valid_identifier $name;

		unless (ref $type) {
			# use '||' instead of 'or' to preserve $type in the error message
			$type = $type_map{$type}
				|| confess qq["$type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
		}
		$type->{name} ||= 'optional';
		$type->{name} =~ /^(?:optional|required|prohibited)\z/
			or confess qq["$type->{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
		
		$spec{$name} = {const => mk_parse($type)};
	}
	
	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, $shift) = @_;

	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 ($shift) {
		_assert_valid_identifier $shift, 1;
		$gen .= "my$shift=shift;";
	}
	if (defined $ctx->{params}) {
		$gen .= "my($ctx->{params})=\@_;";
	}
	$gen
}

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

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