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 my $caller = guess_caller;
34 #warn "caller = $caller";
36 Devel::Declare->setup_for(
38 { $keyword => { const => \&parser } }
42 *{$caller . '::' . $keyword} = \&_fun;
46 my ($offset, $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";
55 my ($declarator, $start) = @_;
57 my $line = Devel::Declare::get_linestr();
60 my $_file = PL_compiling->file;
61 my $_line = PL_compiling->line;
63 my $n = $_line + substr($line, $start, $offset - $start) =~ tr[\n][];
64 die join('', @_) . " at $_file line $n\n";
68 my $atomically = sub {
72 my @ret = eval { $pars->(@_) };
77 wantarray ? @ret : $ret[0]
83 my @ret = eval { $pars->() };
87 wantarray ? @ret : $ret[0]
92 my $skip = Devel::Declare::toke_skipspace($offset);
94 $skip == -$offset or die "Internal error: offset=$offset, skip=$skip";
95 Devel::Declare::set_linestr($line);
98 $line = Devel::Declare::get_linestr();
99 #warn "toke_skipspace($offset) = $skip\n== $line";
103 $offset += Devel::Declare::toke_move_past_token($offset);
105 my $manip_start = $offset;
108 if (my $len = Devel::Declare::toke_scan_word($offset, 1)) {
109 $name = substr $line, $offset, $len;
114 my $scan_token = sub {
116 my $len = length $str;
117 substr($line, $offset, $len) eq $str or $fail->(qq{Missing "$str"});
123 my $len = Devel::Declare::toke_scan_word($offset, 0) or $fail->('Missing identifier');
124 my $name = substr $line, $offset, $len;
130 my $scan_var = $atomically->(sub {
131 (my $sigil = substr($line, $offset, 1)) =~ /^[\$\@%]\z/ or $fail->('Missing [$@%]');
134 my $name = $scan_id->();
138 my $separated_by = $atomically->(sub {
139 my ($sep, $pars) = @_;
140 my $len = length $sep;
141 defined(my $x = $try->($pars)) or return;
144 substr($line, $offset, $len) eq $sep or return @res;
147 push @res, $pars->();
151 my $many_till = $atomically->(sub {
152 my ($end, $pars) = @_;
153 my $len = length $end;
155 until (substr($line, $offset, $len) eq $end) {
156 push @res, $pars->();
161 my $scan_params = $atomically->(sub {
162 if ($try->(sub { $scan_token->('('); 1 })) {
163 my @param = $separated_by->(',', $scan_var);
170 my @param = $scan_params->();
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});
183 my $scan_attr = sub {
184 my $name = $scan_id->();
185 my $param = $scan_pargroup_opt->() || '';
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
196 my ($proto, $attributes) = $scan_attributes->();
197 my $attr = @$attributes ? ' : ' . join(' ', @$attributes) : '';
201 my $manip_end = $offset;
202 my $manip_len = $manip_end - $manip_start;
203 #print STDERR "($manip_start:$manip_len:$manip_end)\n";
205 my $params = @param ? 'my (' . join(', ', @param) . ') = @_;' : '';
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 ";
214 substr $line, $manip_start, $manip_len, " sub$proto$attr { $params ";
216 #print STDERR ".> $line\n";
217 Devel::Declare::set_linestr($line);
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";
238 Function::Parameters - subroutine definitions with parameter lists
242 use Function::Parameters;
244 fun foo($bar, $baz) {
248 fun mymap($fun, @args) :(&@) {
251 push @res, $fun->($_);
256 print "$_\n" for mymap { $_ * 2 } 1 .. 4;
260 This module lets you use parameter lists in your subroutines. Thanks to
261 L<Devel::Declare> it works without source filters.
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.
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.
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/"@_">.
280 =head2 Advanced stuff
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.
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).
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 }>.
305 Lukas Mai, C<< <l.mai at web.de> >>
307 =head1 COPYRIGHT & LICENSE
309 Copyright 2009 Lukas Mai.
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.
315 See http://dev.perl.org/licenses/ for more information.