[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 $caller = guess_caller;
	#warn "caller = $caller";

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

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