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

package Function::Parameters;

use strict;
use warnings;

our $VERSION = '0.04';

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_into {
	my $victim = shift;
	my $keyword = @_ ? shift : 'fun';
	
	_croak qq["$_" is not exported by the ${\__PACKAGE__} module] for @_;

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

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

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

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

	import_into $caller, @_;
}

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

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_keyword';
  }

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