Commit | Line | Data |
7a63380c |
1 | package Function::Parameters; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
125c067e |
6 | our $VERSION = '0.05'; |
7a63380c |
7 | |
125c067e |
8 | use Carp qw(croak confess); |
7a63380c |
9 | use Devel::Declare; |
10 | use B::Hooks::EndOfScope; |
7a63380c |
11 | |
125c067e |
12 | our @CARP_NOT = qw(Devel::Declare); |
13 | |
14 | |
15 | # Make our import chainable so a wrapper module that wants to turn on F:P |
16 | # for its users can just say |
17 | # sub import { Function::Parameters->import; } |
18 | # |
19 | # To make that possible we skip all subs named 'import' in our search for the |
20 | # target package. |
21 | # |
7a63380c |
22 | sub guess_caller { |
23 | my ($start) = @_; |
24 | $start ||= 1; |
25 | |
26 | my $defcaller = (caller $start)[0]; |
27 | my $caller = $defcaller; |
28 | |
29 | for (my $level = $start; ; ++$level) { |
30 | my ($pkg, $function) = (caller $level)[0, 3] or last; |
7a63380c |
31 | $function =~ /::import\z/ or return $caller; |
32 | $caller = $pkg; |
33 | } |
34 | $defcaller |
35 | } |
36 | |
7a63380c |
37 | |
125c067e |
38 | # Parse import spec and make shit happen. |
39 | # |
40 | my @bare_arms = qw(function method); |
c9a39f6b |
41 | |
eeb7df5f |
42 | sub import_into { |
43 | my $victim = shift; |
7a63380c |
44 | |
125c067e |
45 | @_ or @_ = ('fun', 'method'); |
46 | if (@_ == 1 && ref($_[0]) eq 'HASH') { |
47 | @_ = map [$_, $_[0]{$_}], keys %{$_[0]} |
48 | or return; |
49 | } |
7a63380c |
50 | |
125c067e |
51 | my %spec; |
52 | |
53 | my $bare = 0; |
54 | for my $proto (@_) { |
55 | my $item = ref $proto |
56 | ? $proto |
57 | : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})] |
58 | ; |
59 | my ($name, $type) = @$item; |
60 | $name =~ /^[^\W\d]\w*\z/ |
61 | or confess qq{"$name" doesn't look like a valid identifier}; |
62 | my ($index) = grep $bare_arms[$_] eq $type, 0 .. $#bare_arms |
63 | or confess qq{"$type" doesn't look like a valid type (one of ${\join ', ', @bare_arms})}; |
64 | |
65 | $spec{$name} = {const => mk_parse($index)}; |
66 | } |
67 | |
68 | Devel::Declare->setup_for($victim, \%spec); |
69 | for my $name (keys %spec) { |
70 | no strict 'refs'; |
71 | *{$victim . '::' . $name} = \&_declarator; |
72 | } |
eeb7df5f |
73 | } |
74 | |
75 | sub import { |
76 | my $class = shift; |
eeb7df5f |
77 | my $caller = guess_caller; |
eeb7df5f |
78 | import_into $caller, @_; |
7a63380c |
79 | } |
80 | |
125c067e |
81 | sub _declarator { |
82 | $_[0] |
7a63380c |
83 | } |
84 | |
7a63380c |
85 | |
125c067e |
86 | # Wrapper around substr where param 3 is an end offset, not a length. |
87 | # |
88 | sub _substring { |
89 | @_ >= 4 |
90 | ? substr $_[0], $_[1], $_[2] - $_[1], $_[3] |
91 | : substr $_[0], $_[1], $_[2] - $_[1] |
92 | } |
93 | |
94 | sub _skip_space { |
95 | my ($ctx, $key) = @_; |
96 | my $cur = my $start = $ctx->{offset}; |
97 | while (my $d = Devel::Declare::toke_skipspace $cur) { |
98 | $cur += $d; |
99 | } |
100 | $ctx->{space}{$key} .= _substring Devel::Declare::get_linestr, $start, $cur if $key; |
101 | $ctx->{offset} = $cur; |
102 | } |
103 | |
104 | sub _grab_name { |
105 | my ($ctx) = @_; |
106 | my $p = $ctx->{offset}; |
107 | my $namlen = Devel::Declare::toke_scan_word $p, !!'handle_package' |
108 | or return; |
109 | my $str = Devel::Declare::get_linestr; |
110 | $ctx->{name} = substr $str, $p, $namlen; |
111 | $ctx->{offset} += $namlen; |
112 | _skip_space $ctx, 'name'; |
113 | } |
114 | |
115 | sub _grab_params { |
116 | my ($ctx) = @_; |
117 | substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(' |
118 | or return; |
119 | $ctx->{offset}++; |
120 | _skip_space $ctx, 'params'; |
121 | |
122 | my $pcount = 0; |
123 | |
124 | LOOP: { |
125 | my $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1; |
126 | |
127 | if ($c =~ /^[\$\@%]\z/) { |
128 | $ctx->{offset}++; |
129 | _skip_space $ctx, "params_$pcount"; |
130 | my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package' |
131 | or croak "Missing identifier"; |
132 | my $name = substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen; |
133 | $ctx->{params} .= $c . $name . ','; |
134 | $ctx->{offset} += $namlen; |
135 | _skip_space $ctx, "params_$pcount"; |
136 | |
137 | $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1; |
138 | if ($c eq ',') { |
139 | $ctx->{offset}++; |
140 | _skip_space $ctx, "params_$pcount"; |
141 | $pcount++; |
142 | redo LOOP; |
7a63380c |
143 | } |
7a63380c |
144 | } |
7a63380c |
145 | |
125c067e |
146 | if ($c eq ')') { |
147 | $ctx->{offset}++; |
148 | _skip_space $ctx, 'params'; |
7a63380c |
149 | return; |
150 | } |
7a63380c |
151 | |
125c067e |
152 | if ($c eq '') { |
153 | croak "Unexpected EOF in parameter list"; |
7a63380c |
154 | } |
7a63380c |
155 | |
125c067e |
156 | croak "Unexpected '$c' in parameter list"; |
157 | } |
158 | } |
159 | |
160 | sub _parse_parens { |
161 | my ($ctx) = @_; |
162 | |
163 | my $strlen = Devel::Declare::toke_scan_str $ctx->{offset}; |
164 | $strlen == 0 || $strlen == -1 and return; |
165 | |
166 | $strlen < 0 and confess "Devel::Declare::toke_scan_str done fucked up ($strlen); see https://rt.cpan.org/Ticket/Display.html?id=51679"; |
167 | |
168 | my $str = Devel::Declare::get_lex_stuff; |
169 | Devel::Declare::clear_lex_stuff; |
170 | |
171 | $ctx->{offset} += $strlen; |
7a63380c |
172 | |
125c067e |
173 | $str |
174 | } |
175 | |
176 | sub _grab_proto { |
177 | my ($ctx) = @_; |
178 | |
179 | my $savepos = $ctx->{offset}; |
180 | |
181 | substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':' |
182 | or return; |
183 | $ctx->{offset}++; |
184 | _skip_space $ctx, 'proto_tmp'; |
185 | |
186 | unless (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') { |
187 | $ctx->{offset} = $savepos; |
188 | delete $ctx->{space}{proto_tmp}; |
189 | return; |
7a63380c |
190 | } |
125c067e |
191 | $_->{proto} .= delete $_->{proto_tmp} for $ctx->{space}; |
7a63380c |
192 | |
125c067e |
193 | defined(my $str = _parse_parens $ctx) |
194 | or croak "Malformed prototype"; |
195 | $ctx->{proto} = $str; |
7a63380c |
196 | |
125c067e |
197 | _skip_space $ctx, 'proto'; |
198 | } |
7a63380c |
199 | |
125c067e |
200 | sub _grab_attr { |
201 | my ($ctx) = @_; |
202 | |
203 | my $pcount = 0; |
204 | |
205 | if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') { |
206 | $ctx->{offset}++; |
207 | _skip_space $ctx, "attr_$pcount"; |
208 | } elsif (!defined $ctx->{proto}) { |
209 | return; |
210 | } |
211 | |
212 | while () { |
213 | my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package' |
214 | or return; |
215 | $ctx->{attr} .= substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen; |
216 | $ctx->{offset} += $namlen; |
217 | _skip_space $ctx, "attr_$pcount"; |
218 | if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') { |
219 | defined(my $str = _parse_parens $ctx) |
220 | or croak "Malformed attribute argument list"; |
221 | $ctx->{attr} .= "($str)"; |
222 | _skip_space $ctx, "attr_$pcount"; |
7a63380c |
223 | } |
125c067e |
224 | $pcount++; |
225 | |
226 | if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') { |
227 | $ctx->{offset}++; |
228 | _skip_space $ctx, "attr_$pcount"; |
7a63380c |
229 | } |
125c067e |
230 | } |
231 | } |
7a63380c |
232 | |
125c067e |
233 | # IN: |
234 | # fun name (params) :(proto) :attr { ... } |
235 | # OUT: |
236 | # fun (do { sub (proto) :attr { self? my (params) = @_; ... } }) |
237 | # fun (do { sub name (proto); sub name (proto) :attr { self? my (params) = @_; ... } }); |
238 | # |
239 | sub _generate { |
240 | my ($ctx, $declarator, $implicit_self) = @_; |
7a63380c |
241 | |
125c067e |
242 | my $gen = '(do{sub'; |
7a63380c |
243 | |
125c067e |
244 | my $skipped = join '', values %{$ctx->{space}}; |
245 | my $lines = $skipped =~ tr/\n//; |
246 | $gen .= "\n" x $lines; |
7a63380c |
247 | |
125c067e |
248 | my $proto = defined $ctx->{proto} ? "($ctx->{proto})" : ''; |
7a63380c |
249 | |
125c067e |
250 | my $is_stmt = 0; |
251 | if (defined(my $name = $ctx->{name})) { |
252 | $is_stmt = 1; |
253 | $gen .= " $name$proto;"; |
254 | $gen .= "sub $name"; |
255 | } |
256 | |
257 | $gen .= $proto; |
258 | |
259 | if (defined $ctx->{attr}) { |
260 | $gen .= ":$ctx->{attr}"; |
261 | } |
7a63380c |
262 | |
125c067e |
263 | $gen .= '{'; |
264 | $gen .= "BEGIN{${\__PACKAGE__}::_fini($is_stmt)}"; |
7a63380c |
265 | |
125c067e |
266 | if ($implicit_self) { |
267 | $gen .= 'my$self=shift;'; |
7a63380c |
268 | } |
125c067e |
269 | if (defined $ctx->{params}) { |
270 | $gen .= "my($ctx->{params})=\@_;"; |
271 | } |
272 | $gen |
7a63380c |
273 | } |
274 | |
125c067e |
275 | sub mk_parse { |
276 | my ($implicit_self) = @_; |
277 | |
278 | sub { |
279 | my ($declarator, $offset_orig) = @_; |
280 | my $ctx = { |
281 | offset => $offset_orig, |
282 | space => {}, |
283 | }; |
284 | |
285 | $ctx->{offset} += Devel::Declare::toke_move_past_token($ctx->{offset}); |
286 | _skip_space $ctx; |
287 | |
288 | my $start = $ctx->{offset}; |
289 | |
290 | _grab_name $ctx; |
291 | _grab_params $ctx; |
292 | _grab_proto $ctx; |
293 | _grab_attr $ctx; |
294 | |
295 | my $offset = $ctx->{offset}; |
296 | |
297 | my $linestr = Devel::Declare::get_linestr; |
298 | substr($linestr, $offset, 1) eq '{' |
299 | or croak qq[I was expecting a function body, not "${\substr $linestr, $offset}"]; |
300 | |
301 | my $gen = _generate $ctx, $declarator, $implicit_self; |
302 | my $oldlen = $offset + 1 - $start; |
303 | _substring $linestr, $start, $offset + 1, (' ' x $oldlen) . $gen; |
304 | Devel::Declare::set_linestr $linestr; |
305 | } |
306 | } |
307 | |
308 | # Patch in the end of our synthetic 'do' block, close argument list, and |
309 | # optionally terminate the statement. |
310 | # |
311 | sub _fini { |
312 | my ($stmt) = @_; |
7a63380c |
313 | on_scope_end { |
125c067e |
314 | my $off = Devel::Declare::get_linestr_offset; |
315 | my $str = Devel::Declare::get_linestr; |
316 | substr $str, $off, 0, '})' . ($stmt ? ';' : ''); |
317 | Devel::Declare::set_linestr $str; |
7a63380c |
318 | }; |
319 | } |
320 | |
125c067e |
321 | 'ok' |
7a63380c |
322 | |
323 | __END__ |
324 | |
325 | =head1 NAME |
326 | |
327 | Function::Parameters - subroutine definitions with parameter lists |
328 | |
329 | =head1 SYNOPSIS |
330 | |
331 | use Function::Parameters; |
332 | |
333 | fun foo($bar, $baz) { |
334 | return $bar + $baz; |
335 | } |
336 | |
337 | fun mymap($fun, @args) :(&@) { |
338 | my @res; |
339 | for (@args) { |
340 | push @res, $fun->($_); |
341 | } |
342 | @res |
343 | } |
344 | |
345 | print "$_\n" for mymap { $_ * 2 } 1 .. 4; |
125c067e |
346 | |
347 | method set_name($name) { |
348 | $self->{name} = $name; |
349 | } |
7a63380c |
350 | |
125c067e |
351 | =cut |
352 | |
353 | =pod |
354 | |
355 | use Function::Parameters 'proc', 'meth'; |
c9a39f6b |
356 | |
125c067e |
357 | my $f = proc ($x) { $x * 2 }; |
358 | meth get_age() { |
359 | return $self->{age}; |
360 | } |
361 | |
7a63380c |
362 | =head1 DESCRIPTION |
363 | |
364 | This module lets you use parameter lists in your subroutines. Thanks to |
365 | L<Devel::Declare> it works without source filters. |
366 | |
367 | WARNING: This is my first attempt at using L<Devel::Declare> and I have |
368 | almost no experience with perl's internals. So while this module might |
369 | appear to work, it could also conceivably make your programs segfault. |
370 | Consider this module alpha quality. |
371 | |
372 | =head2 Basic stuff |
373 | |
374 | To use this new functionality, you have to use C<fun> instead of C<sub> - |
375 | C<sub> continues to work as before. The syntax is almost the same as for |
376 | C<sub>, but after the subroutine name (or directly after C<fun> if you're |
125c067e |
377 | writing an anonymous sub) you can write a parameter list in parentheses. This |
7a63380c |
378 | list consists of comma-separated variables. |
379 | |
380 | The effect of C<fun foo($bar, $baz) {> is as if you'd written |
381 | C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply |
382 | copied into C<my> and initialized from L<@_|perlvar/"@_">. |
383 | |
125c067e |
384 | In addition you can use C<method>, which understands the same syntax as C<fun> |
385 | but automatically creates a C<$self> variable for you. So by writing |
386 | C<method foo($bar, $baz) {> you get the same effect as |
387 | C<sub foo { my $self = shift; my ($bar, $baz) = @_; >. |
7a63380c |
388 | |
125c067e |
389 | =head2 Customizing the generated keywords |
c9a39f6b |
390 | |
125c067e |
391 | You can customize the names of the keywords injected in your package. To do that |
392 | you pass a hash reference in the import list: |
7a63380c |
393 | |
125c067e |
394 | use Function::Parameters { proc => 'function', meth => 'method' }; # -or- |
395 | use Function::Parameters { proc => 'function' }; # -or- |
396 | use Function::Parameters { meth => 'method' }; |
397 | |
398 | The first line creates two keywords, C<proc> and C<meth> (for defining |
399 | functions and methods, respectively). The last two lines only create one |
400 | keyword. Generally the hash keys can be any identifiers you want while the |
401 | values have to be either C<function> or C<method>. The difference between |
402 | C<function> and C<method> is that C<method>s automatically |
403 | L<shift|perlfunc/shift> their first argument into C<$self>. |
404 | |
405 | The following shortcuts are available: |
406 | |
407 | use Function::Parameters; |
408 | # is equivalent to # |
409 | use Function::Parameters { fun => 'function', method => 'method' }; |
410 | |
411 | =cut |
412 | |
413 | =pod |
414 | |
415 | use Function::Parameters 'foo'; |
416 | # is equivalent to # |
417 | use Function::Parameters { 'foo' => 'function' }; |
418 | |
419 | =cut |
420 | |
421 | =pod |
422 | |
423 | use Function::Parameters 'foo', 'bar'; |
424 | # is equivalent to # |
425 | use Function::Parameters { 'foo' => 'function', 'bar' => 'method' }; |
426 | |
427 | =head2 Other advanced stuff |
7a63380c |
428 | |
429 | Normally, Perl subroutines are not in scope in their own body, meaning the |
125c067e |
430 | parser doesn't know the name C<foo> or its prototype while processing |
7a63380c |
431 | C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as |
432 | C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the |
433 | interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger |
434 | a I<foo() called too early to check prototype> warning. This module attempts |
435 | to fix all of this by adding a subroutine declaration before the definition, |
436 | so the parser knows the name (and possibly prototype) while it processes the |
437 | body. Thus C<fun foo($x) :($) { $x }> really turns into |
438 | C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>. |
439 | |
125c067e |
440 | If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, you can |
441 | put them after the parameter list with their usual syntax. |
442 | |
443 | Syntactically, these new parameter lists live in the spot normally occupied |
444 | by L<prototypes|perlsub/"Prototypes">. However, you can include a prototype by |
445 | specifying it as the first attribute (this is syntactically unambiguous |
446 | because normal attributes have to start with a letter). |
447 | |
eeb7df5f |
448 | If you want to wrap C<Function::Parameters>, you may find C<import_into> |
449 | helpful. It lets you specify a target package for the syntax magic, as in: |
450 | |
451 | package Some::Wrapper; |
452 | use Function::Parameters (); |
453 | sub import { |
454 | my $caller = caller; |
455 | Function::Parameters::import_into $caller; |
125c067e |
456 | # or Function::Parameters::import_into $caller, @other_import_args; |
eeb7df5f |
457 | } |
458 | |
459 | C<import_into> is not exported by this module, so you have to use a fully |
460 | qualified name to call it. |
461 | |
7a63380c |
462 | =head1 AUTHOR |
463 | |
464 | Lukas Mai, C<< <l.mai at web.de> >> |
465 | |
466 | =head1 COPYRIGHT & LICENSE |
467 | |
125c067e |
468 | Copyright 2010, 2011 Lukas Mai. |
7a63380c |
469 | |
470 | This program is free software; you can redistribute it and/or modify it |
471 | under the terms of either: the GNU General Public License as published |
472 | by the Free Software Foundation; or the Artistic License. |
473 | |
474 | See http://dev.perl.org/licenses/ for more information. |
475 | |
476 | =cut |