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