1 package Function::Parameters;
9 use B::Hooks::EndOfScope;
16 my $defcaller = (caller $start)[0];
17 my $caller = $defcaller;
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;
28 sub _fun ($) { $_[0] }
33 no warnings qw(redefine);
34 *_croak = \&Carp::croak;
41 my $keyword = @_ ? shift : 'fun';
43 _croak qq["$_" is not exported by the ${\__PACKAGE__} module] for @_;
45 $keyword =~ /^[[:alpha:]_]\w*\z/ or _croak qq{"$keyword" does not look like a valid identifier};
47 Devel::Declare->setup_for(
49 { $keyword => { const => \&parser } }
53 *{$victim . '::' . $keyword} = \&_fun;
59 my $caller = guess_caller;
60 #warn "caller = $caller";
62 import_into $caller, @_;
66 my ($offset, $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";
75 my ($declarator, $start) = @_;
77 my $line = Devel::Declare::get_linestr();
80 my $_file = PL_compiling->file;
81 my $_line = PL_compiling->line;
83 my $n = $_line + substr($line, $start, $offset - $start) =~ tr[\n][];
84 die join('', @_) . " at $_file line $n\n";
88 my $atomically = sub {
92 my @ret = eval { $pars->(@_) };
97 wantarray ? @ret : $ret[0]
103 my @ret = eval { $pars->() };
107 wantarray ? @ret : $ret[0]
112 my $skip = Devel::Declare::toke_skipspace($offset);
114 $skip == -$offset or die "Internal error: offset=$offset, skip=$skip";
115 Devel::Declare::set_linestr($line);
118 $line = Devel::Declare::get_linestr();
119 #warn "toke_skipspace($offset) = $skip\n== $line";
123 $offset += Devel::Declare::toke_move_past_token($offset);
125 my $manip_start = $offset;
128 if (my $len = Devel::Declare::toke_scan_word($offset, 1)) {
129 $name = substr $line, $offset, $len;
134 my $scan_token = sub {
136 my $len = length $str;
137 substr($line, $offset, $len) eq $str or $fail->(qq{Missing "$str"});
143 my $len = Devel::Declare::toke_scan_word($offset, 0) or $fail->('Missing identifier');
144 my $name = substr $line, $offset, $len;
150 my $scan_var = $atomically->(sub {
151 (my $sigil = substr($line, $offset, 1)) =~ /^[\$\@%]\z/ or $fail->('Missing [$@%]');
154 my $name = $scan_id->();
158 my $separated_by = $atomically->(sub {
159 my ($sep, $pars) = @_;
160 my $len = length $sep;
161 defined(my $x = $try->($pars)) or return;
164 substr($line, $offset, $len) eq $sep or return @res;
167 push @res, $pars->();
171 my $many_till = $atomically->(sub {
172 my ($end, $pars) = @_;
173 my $len = length $end;
175 until (substr($line, $offset, $len) eq $end) {
176 push @res, $pars->();
181 my $scan_params = $atomically->(sub {
182 if ($try->(sub { $scan_token->('('); 1 })) {
183 my @param = $separated_by->(',', $scan_var);
190 my @param = $scan_params->();
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});
203 my $scan_attr = sub {
204 my $name = $scan_id->();
205 my $param = $scan_pargroup_opt->() || '';
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
216 my ($proto, $attributes) = $scan_attributes->();
217 my $attr = @$attributes ? ' : ' . join(' ', @$attributes) : '';
221 my $manip_end = $offset;
222 my $manip_len = $manip_end - $manip_start;
223 #print STDERR "($manip_start:$manip_len:$manip_end)\n";
225 my $params = @param ? 'my (' . join(', ', @param) . ') = @_;' : '';
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 ";
234 substr $line, $manip_start, $manip_len, " sub$proto$attr { $params ";
236 #print STDERR ".> $line\n";
237 Devel::Declare::set_linestr($line);
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";
258 Function::Parameters - subroutine definitions with parameter lists
262 use Function::Parameters;
264 fun foo($bar, $baz) {
268 fun mymap($fun, @args) :(&@) {
271 push @res, $fun->($_);
276 print "$_\n" for mymap { $_ * 2 } 1 .. 4;
278 use Function::Parameters 'proc';
279 my $f = proc ($x) { $x * 2 };
283 This module lets you use parameter lists in your subroutines. Thanks to
284 L<Devel::Declare> it works without source filters.
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.
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.
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/"@_">.
303 =head2 Advanced stuff
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>.
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.
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).
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 }>.
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:
333 package Some::Wrapper;
334 use Function::Parameters ();
337 Function::Parameters::import_into $caller;
338 # or Function::Parameters::import_into $caller, 'other_keyword';
341 C<import_into> is not exported by this module, so you have to use a fully
342 qualified name to call it.
346 Lukas Mai, C<< <l.mai at web.de> >>
348 =head1 COPYRIGHT & LICENSE
350 Copyright 2010 Lukas Mai.
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.
356 See http://dev.perl.org/licenses/ for more information.