[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 _croak {
	require Carp;
	{
		no warnings qw(redefine);
		*_croak = \&Carp::croak;
	}
	goto &Carp::croak;
}

sub import {
	my $class = shift;
	my $keyword = @_ ? shift : 'fun';
	my $caller = guess_caller;
	#warn "caller = $caller";
	
	_croak qq{"$_" is not exported by the $class module} for @_;

	$keyword =~ /^[[:alpha:]_]\w*\z/ or _croak qq{"$keyword" does not look like a valid identifier};

	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;

 use Function::Parameters 'proc';
 my $f = proc ($x) { $x * 2 };
 
=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

You can change the name of the new keyword from C<fun> to anything you want by
specifying it in the import list, i.e. C<use Function::Parameters 'spork'> lets
you write C<spork> instead of C<fun>.

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