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