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

package Function::Parameters;

use strict;
use warnings;

our $VERSION = '0.03';

use Devel::Declare;
use B::Hooks::EndOfScope;
use B::Compiling;

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;
		#warn "? $pkg, $function";
		$function =~ /::import\z/ or return $caller;
		$caller = $pkg;
	}
	$defcaller
}

sub _fun ($) { $_[0] }

sub import {
	my $class = shift;
	my $keyword = shift;
	my $caller = guess_caller;
	#warn "caller = $caller";

	Devel::Declare->setup_for(
		$caller,
		{ $keyword => { const => \&parser } }
	);

	no strict 'refs';
	*{$caller . '::' . $keyword} = \&_fun;
}

sub report_pos {
	my ($offset, $name) = @_;
	$name ||= '';
	my $line = Devel::Declare::get_linestr();
	substr $line, $offset + 1, 0, "\x{20de}\e[m";
	substr $line, $offset, 0, "\e[31;1m";
	print STDERR "$name($offset)>> $line\n";
}

sub parser {
	my ($declarator, $start) = @_;
	my $offset = $start;
	my $line = Devel::Declare::get_linestr();

	my $fail = do {
		my $_file = PL_compiling->file;
		my $_line = PL_compiling->line;
		sub {
			my $n = $_line + substr($line, $start, $offset - $start) =~ tr[\n][];
			die join('', @_) . " at $_file line $n\n";
		}
	};

	my $atomically = sub {
		my ($pars) = @_;
		sub {
			my $tmp = $offset;
			my @ret = eval { $pars->(@_) };
			if ($@) {
				$offset = $tmp;
				die $@;
			}
			wantarray ? @ret : $ret[0]
		}
	};

	my $try = sub {
		my ($pars) = @_;
		my @ret = eval { $pars->() };
		if ($@) {
			return;
		}
		wantarray ? @ret : $ret[0]
	};

	my $skipws = sub {
		#warn ">> $line";
		my $skip = Devel::Declare::toke_skipspace($offset);
		if ($skip < 0) {
			$skip == -$offset or die "Internal error: offset=$offset, skip=$skip";
			Devel::Declare::set_linestr($line);
			return;
		}
		$line = Devel::Declare::get_linestr();
		#warn "toke_skipspace($offset) = $skip\n== $line";
		$offset += $skip;
	};

	$offset += Devel::Declare::toke_move_past_token($offset);
	$skipws->();
	my $manip_start = $offset;

	my $name;
	if (my $len = Devel::Declare::toke_scan_word($offset, 1)) {
		$name = substr $line, $offset, $len;
		$offset += $len;
		$skipws->();
	}

	my $scan_token = sub {
		my ($str) = @_;
		my $len = length $str;
		substr($line, $offset, $len) eq $str or $fail->(qq{Missing "$str"});
		$offset += $len;
		$skipws->();
	};

	my $scan_id = sub {
		my $len = Devel::Declare::toke_scan_word($offset, 0) or $fail->('Missing identifier');
		my $name = substr $line, $offset, $len;
		$offset += $len;
		$skipws->();
		$name
	};

	my $scan_var = $atomically->(sub {
		(my $sigil = substr($line, $offset, 1)) =~ /^[\$\@%]\z/ or $fail->('Missing [$@%]');
		$offset += 1;
		$skipws->();
		my $name = $scan_id->();
		$sigil . $name
	});

	my $separated_by = $atomically->(sub {
		my ($sep, $pars) = @_;
		my $len = length $sep;
		defined(my $x = $try->($pars)) or return;
		my @res = $x;
		while () {
			substr($line, $offset, $len) eq $sep or return @res;
			$offset += $len;
			$skipws->();
			push @res, $pars->();
		}
	});

	my $many_till = $atomically->(sub {
		my ($end, $pars) = @_;
		my $len = length $end;
		my @res;
		until (substr($line, $offset, $len) eq $end) {
			push @res, $pars->();
		}
		@res
	});

	my $scan_params = $atomically->(sub {
		if ($try->(sub { $scan_token->('('); 1 })) {
			my @param = $separated_by->(',', $scan_var);
			$scan_token->(')');
			return @param;
		}
		$try->($scan_var)
	});

	my @param = $scan_params->();

	my $scan_pargroup_opt = sub {
		substr($line, $offset, 1) eq '(' or return '';
		my $len = Devel::Declare::toke_scan_str($offset);
		my $res = Devel::Declare::get_lex_stuff();
		Devel::Declare::clear_lex_stuff();
		$res eq '' and $fail->(qq{Can't find ")" anywhere before EOF});
		$offset += $len;
		$skipws->();
		"($res)"
	};

	my $scan_attr = sub {
		my $name = $scan_id->();
		my $param = $scan_pargroup_opt->() || '';
		$name . $param
	};

	my $scan_attributes = $atomically->(sub {
		$try->(sub { $scan_token->(':'); 1 }) or return '', [];
		my $proto = $scan_pargroup_opt->();
		my @attrs = $many_till->('{', $scan_attr);
		' ' . $proto, \@attrs
	});

	my ($proto, $attributes) = $scan_attributes->();
	my $attr = @$attributes ? ' : ' . join(' ', @$attributes) : '';

	$scan_token->('{');

	my $manip_end = $offset;
	my $manip_len = $manip_end - $manip_start;
	#print STDERR "($manip_start:$manip_len:$manip_end)\n";

	my $params = @param ? 'my (' . join(', ', @param) . ') = @_;' : '';
	#report_pos $offset;
	$proto =~ tr[\n][ ];

	if (defined $name) {
		my $pkg = __PACKAGE__;
		#print STDERR "($manip_start:$manip_len) [$line]\n";
		substr $line, $manip_start, $manip_len, " do { sub $name$proto; sub $name$proto$attr { BEGIN { ${pkg}::terminate_me(q[$name]); } $params ";
	} else {
		substr $line, $manip_start, $manip_len, " sub$proto$attr { $params ";
	}
	#print STDERR ".> $line\n";
	Devel::Declare::set_linestr($line);
}

sub terminate_me {
	my ($name) = @_;
	on_scope_end {
		my $line = Devel::Declare::get_linestr();
		#print STDERR "~~> $line\n";
		my $offset = Devel::Declare::get_linestr_offset();
		substr $line, $offset, 0, " \\&$name };";
		Devel::Declare::set_linestr($line);
		#print STDERR "??> $line\n";
	};
}

1

__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;

=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 parens. 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/"@_">.

=head2 Advanced stuff

If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, you can
put them after the parameter list with their usual syntax. There's one
exception, though: you can only use one colon (to start the attribute list);
multiple attributes have to be separated by spaces.

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).

Normally, Perl subroutines are not in scope in their own body, meaning the
parser doesn't know the name C<foo> or its prototype when 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 }>.

=head1 AUTHOR

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

=head1 COPYRIGHT & LICENSE

Copyright 2009 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
	6	our $VERSION = '0.03';
	7
	8	use Devel::Declare;
	9	use B::Hooks::EndOfScope;
	10	use B::Compiling;
	11
	12	sub guess_caller {
	13	my ($start) = @_;
	14	$start \|\|= 1;
	15
	16	my $defcaller = (caller $start)[0];
	17	my $caller = $defcaller;
	18
	19	for (my $level = $start; ; ++$level) {
	20	my ($pkg, $function) = (caller $level)[0, 3] or last;
	21	#warn "? $pkg, $function";
	22	$function =~ /::import\z/ or return $caller;
	23	$caller = $pkg;
	24	}
	25	$defcaller
	26	}
	27
	28	sub _fun ($) { $_[0] }
	29
	30	sub import {
	31	my $class = shift;
b4fcf7d0	32	my $keyword = shift;
7a63380c	33	my $caller = guess_caller;
	34	#warn "caller = $caller";
	35
	36	Devel::Declare->setup_for(
	37	$caller,
b4fcf7d0	38	{ $keyword => { const => \&parser } }
7a63380c	39	);
	40
	41	no strict 'refs';
b4fcf7d0	42	*{$caller . '::' . $keyword} = \&_fun;
7a63380c	43	}
	44
	45	sub report_pos {
	46	my ($offset, $name) = @_;
	47	$name \|\|= '';
	48	my $line = Devel::Declare::get_linestr();
	49	substr $line, $offset + 1, 0, "\x{20de}\e[m";
	50	substr $line, $offset, 0, "\e[31;1m";
	51	print STDERR "$name($offset)>> $line\n";
	52	}
	53
	54	sub parser {
	55	my ($declarator, $start) = @_;
	56	my $offset = $start;
	57	my $line = Devel::Declare::get_linestr();
	58
	59	my $fail = do {
	60	my $_file = PL_compiling->file;
	61	my $_line = PL_compiling->line;
	62	sub {
	63	my $n = $_line + substr($line, $start, $offset - $start) =~ tr[\n][];
	64	die join('', @_) . " at $_file line $n\n";
	65	}
	66	};
	67
	68	my $atomically = sub {
	69	my ($pars) = @_;
	70	sub {
	71	my $tmp = $offset;
	72	my @ret = eval { $pars->(@_) };
	73	if ($@) {
	74	$offset = $tmp;
	75	die $@;
	76	}
	77	wantarray ? @ret : $ret[0]
	78	}
	79	};
	80
	81	my $try = sub {
	82	my ($pars) = @_;
	83	my @ret = eval { $pars->() };
	84	if ($@) {
	85	return;
	86	}
	87	wantarray ? @ret : $ret[0]
	88	};
	89
	90	my $skipws = sub {
	91	#warn ">> $line";
	92	my $skip = Devel::Declare::toke_skipspace($offset);
	93	if ($skip < 0) {
	94	$skip == -$offset or die "Internal error: offset=$offset, skip=$skip";
	95	Devel::Declare::set_linestr($line);
	96	return;
	97	}
	98	$line = Devel::Declare::get_linestr();
	99	#warn "toke_skipspace($offset) = $skip\n== $line";
	100	$offset += $skip;
	101	};
	102
	103	$offset += Devel::Declare::toke_move_past_token($offset);
	104	$skipws->();
	105	my $manip_start = $offset;
	106
107	my $name;
108	if (my $len = Devel::Declare::toke_scan_word($offset, 1)) {
109	$name = substr $line, $offset, $len;
110	$offset += $len;
111	$skipws->();
112	}
113
114	my $scan_token = sub {
115	my ($str) = @_;
116	my $len = length $str;
117	substr($line, $offset, $len) eq $str or $fail->(qq{Missing "$str"});
118	$offset += $len;
119	$skipws->();
120	};
121
122	my $scan_id = sub {
123	my $len = Devel::Declare::toke_scan_word($offset, 0) or $fail->('Missing identifier');
124	my $name = substr $line, $offset, $len;
125	$offset += $len;
126	$skipws->();
127	$name
128	};
129
130	my $scan_var = $atomically->(sub {
131	(my $sigil = substr($line, $offset, 1)) =~ /^[\$\@%]\z/ or $fail->('Missing [$@%]');
132	$offset += 1;
133	$skipws->();
134	my $name = $scan_id->();
135	$sigil . $name
136	});
137
138	my $separated_by = $atomically->(sub {
139	my ($sep, $pars) = @_;
140	my $len = length $sep;
141	defined(my $x = $try->($pars)) or return;
142	my @res = $x;
143	while () {
144	substr($line, $offset, $len) eq $sep or return @res;
145	$offset += $len;
146	$skipws->();
147	push @res, $pars->();
148	}
149	});
150
151	my $many_till = $atomically->(sub {
152	my ($end, $pars) = @_;
153	my $len = length $end;
154	my @res;
155	until (substr($line, $offset, $len) eq $end) {
156	push @res, $pars->();
157	}
158	@res
159	});
160
161	my $scan_params = $atomically->(sub {
162	if ($try->(sub { $scan_token->('('); 1 })) {
163	my @param = $separated_by->(',', $scan_var);
164	$scan_token->(')');
165	return @param;
166	}
167	$try->($scan_var)
168	});
169
170	my @param = $scan_params->();
171
172	my $scan_pargroup_opt = sub {
173	substr($line, $offset, 1) eq '(' or return '';
174	my $len = Devel::Declare::toke_scan_str($offset);
175	my $res = Devel::Declare::get_lex_stuff();
176	Devel::Declare::clear_lex_stuff();
177	$res eq '' and $fail->(qq{Can't find ")" anywhere before EOF});
178	$offset += $len;
179	$skipws->();
180	"($res)"
181	};
182
183	my $scan_attr = sub {
184	my $name = $scan_id->();
185	my $param = $scan_pargroup_opt->() \|\| '';
186	$name . $param
187	};
188
189	my $scan_attributes = $atomically->(sub {
190	$try->(sub { $scan_token->(':'); 1 }) or return '', [];
191	my $proto = $scan_pargroup_opt->();
192	my @attrs = $many_till->('{', $scan_attr);
193	' ' . $proto, \@attrs
194	});
195
196	my ($proto, $attributes) = $scan_attributes->();
197	my $attr = @$attributes ? ' : ' . join(' ', @$attributes) : '';
198
199	$scan_token->('{');
200
201	my $manip_end = $offset;
202	my $manip_len = $manip_end - $manip_start;
203	#print STDERR "($manip_start:$manip_len:$manip_end)\n";
204
205	my $params = @param ? 'my (' . join(', ', @param) . ') = @_;' : '';
206	#report_pos $offset;
207	$proto =~ tr[\n][ ];
208
209	if (defined $name) {
210	my $pkg = __PACKAGE__;
211	#print STDERR "($manip_start:$manip_len) [$line]\n";
212	substr $line, $manip_start, $manip_len, " do { sub $name$proto; sub $name$proto$attr { BEGIN { ${pkg}::terminate_me(q[$name]); } $params ";
213	} else {
214	substr $line, $manip_start, $manip_len, " sub$proto$attr { $params ";
215	}
216	#print STDERR ".> $line\n";
217	Devel::Declare::set_linestr($line);
218	}
219
220	sub terminate_me {
221	my ($name) = @_;
222	on_scope_end {
223	my $line = Devel::Declare::get_linestr();
224	#print STDERR "~~> $line\n";
225	my $offset = Devel::Declare::get_linestr_offset();
226	substr $line, $offset, 0, " \\&$name };";
227	Devel::Declare::set_linestr($line);
228	#print STDERR "??> $line\n";
229	};
230	}
231
232	1
233
234	__END__
235
236	=head1 NAME
237
238	Function::Parameters - subroutine definitions with parameter lists
239
240	=head1 SYNOPSIS
241
242	use Function::Parameters;
243
244	fun foo($bar, $baz) {
245	return $bar + $baz;
246	}
247
248	fun mymap($fun, @args) :(&@) {
249	my @res;
250	for (@args) {
251	push @res, $fun->($_);
252	}
253	@res
254	}
255
256	print "$_\n" for mymap { $_ * 2 } 1 .. 4;
257
258	=head1 DESCRIPTION
259
260	This module lets you use parameter lists in your subroutines. Thanks to
261	L<Devel::Declare> it works without source filters.
262
263	WARNING: This is my first attempt at using L<Devel::Declare> and I have
264	almost no experience with perl's internals. So while this module might
265	appear to work, it could also conceivably make your programs segfault.
266	Consider this module alpha quality.
267
268	=head2 Basic stuff
269
270	To use this new functionality, you have to use C<fun> instead of C<sub> -
271	C<sub> continues to work as before. The syntax is almost the same as for
272	C<sub>, but after the subroutine name (or directly after C<fun> if you're
273	writing an anonymous sub) you can write a parameter list in parens. This
274	list consists of comma-separated variables.
275
276	The effect of C<fun foo($bar, $baz) {> is as if you'd written
277	C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply
278	copied into C<my> and initialized from L<@_\|perlvar/"@_">.
279
280	=head2 Advanced stuff
281
282	If you need L<subroutine attributes\|perlsub/"Subroutine Attributes">, you can
283	put them after the parameter list with their usual syntax. There's one
284	exception, though: you can only use one colon (to start the attribute list);
285	multiple attributes have to be separated by spaces.
286
287	Syntactically, these new parameter lists live in the spot normally occupied
288	by L<prototypes\|perlsub/"Prototypes">. However, you can include a prototype by
289	specifying it as the first attribute (this is syntactically unambiguous
290	because normal attributes have to start with a letter).
291
292	Normally, Perl subroutines are not in scope in their own body, meaning the
293	parser doesn't know the name C<foo> or its prototype when processing
294	C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
295	C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
296	interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
297	a I<foo() called too early to check prototype> warning. This module attempts
298	to fix all of this by adding a subroutine declaration before the definition,
299	so the parser knows the name (and possibly prototype) while it processes the
300	body. Thus C<fun foo($x) :($) { $x }> really turns into
301	C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>.
302
303	=head1 AUTHOR
304
305	Lukas Mai, C<< <l.mai at web.de> >>
306
307	=head1 COPYRIGHT & LICENSE
308
309	Copyright 2009 Lukas Mai.
310
311	This program is free software; you can redistribute it and/or modify it
312	under the terms of either: the GNU General Public License as published
313	by the Free Software Foundation; or the Artistic License.
314
315	See http://dev.perl.org/licenses/ for more information.
316
317	=cut