Commit | Line | Data |
7a63380c |
1 | package Function::Parameters; |
2 | |
7dd35535 |
3 | use v5.14.0; |
4 | |
7a63380c |
5 | use strict; |
6 | use warnings; |
7 | |
63915d26 |
8 | use Carp qw(confess); |
9 | |
db81d362 |
10 | use XSLoader; |
11 | BEGIN { |
751c40ba |
12 | our $VERSION = '0.10_02'; |
db81d362 |
13 | XSLoader::load; |
7a63380c |
14 | } |
15 | |
2d5cf47a |
16 | sub _assert_valid_identifier { |
17 | my ($name, $with_dollar) = @_; |
18 | my $bonus = $with_dollar ? '\$' : ''; |
19 | $name =~ /^${bonus}[^\W\d]\w*\z/ |
20 | or confess qq{"$name" doesn't look like a valid identifier}; |
21 | } |
22 | |
b72eb6ee |
23 | sub _assert_valid_attributes { |
24 | my ($attrs) = @_; |
25 | $attrs =~ /^\s*:\s*[^\W\d]\w*\s*(?:(?:\s|:\s*)[^\W\d]\w*\s*)*(?:\(|\z)/ |
26 | or confess qq{"$attrs" doesn't look like valid attributes}; |
27 | } |
28 | |
125c067e |
29 | my @bare_arms = qw(function method); |
2d5cf47a |
30 | my %type_map = ( |
63915d26 |
31 | function => { |
32 | name => 'optional', |
33 | default_arguments => 1, |
34 | check_argument_count => 0, |
e158cf8f |
35 | named_parameters => 1, |
63915d26 |
36 | }, |
7947f7ce |
37 | method => { |
38 | name => 'optional', |
63915d26 |
39 | default_arguments => 1, |
40 | check_argument_count => 0, |
e158cf8f |
41 | named_parameters => 1, |
7947f7ce |
42 | attrs => ':method', |
63915d26 |
43 | shift => '$self', |
d8e5d540 |
44 | invocant => 1, |
7947f7ce |
45 | }, |
a23979e1 |
46 | classmethod => { |
47 | name => 'optional', |
63915d26 |
48 | default_arguments => 1, |
49 | check_argument_count => 0, |
e158cf8f |
50 | named_parameters => 1, |
698e861c |
51 | attributes => ':method', |
63915d26 |
52 | shift => '$class', |
d8e5d540 |
53 | invocant => 1, |
a23979e1 |
54 | }, |
2d5cf47a |
55 | ); |
7817d698 |
56 | for my $k (keys %type_map) { |
57 | $type_map{$k . '_strict'} = { |
58 | %{$type_map{$k}}, |
59 | check_argument_count => 1, |
60 | }; |
61 | } |
c9a39f6b |
62 | |
db81d362 |
63 | sub import { |
64 | my $class = shift; |
7a63380c |
65 | |
fcaf7811 |
66 | if (!@_) { |
67 | @_ = { |
68 | fun => 'function', |
69 | method => 'method', |
70 | }; |
71 | } |
72 | if (@_ == 1 && $_[0] eq ':strict') { |
73 | @_ = { |
74 | fun => 'function_strict', |
75 | method => 'method_strict', |
76 | }; |
77 | } |
125c067e |
78 | if (@_ == 1 && ref($_[0]) eq 'HASH') { |
fcaf7811 |
79 | @_ = map [$_, $_[0]{$_}], keys %{$_[0]}; |
125c067e |
80 | } |
7a63380c |
81 | |
125c067e |
82 | my %spec; |
83 | |
84 | my $bare = 0; |
85 | for my $proto (@_) { |
86 | my $item = ref $proto |
87 | ? $proto |
88 | : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})] |
89 | ; |
ae6e00b5 |
90 | my ($name, $proto_type) = @$item; |
2d5cf47a |
91 | _assert_valid_identifier $name; |
92 | |
ae6e00b5 |
93 | unless (ref $proto_type) { |
94 | # use '||' instead of 'or' to preserve $proto_type in the error message |
95 | $proto_type = $type_map{$proto_type} |
96 | || confess qq["$proto_type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})]; |
2d5cf47a |
97 | } |
b72eb6ee |
98 | |
ae6e00b5 |
99 | my %type = %$proto_type; |
100 | my %clean; |
10acc8b1 |
101 | |
ae6e00b5 |
102 | $clean{name} = delete $type{name} || 'optional'; |
103 | $clean{name} =~ /^(?:optional|required|prohibited)\z/ |
104 | or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)]; |
10acc8b1 |
105 | |
ae6e00b5 |
106 | $clean{shift} = delete $type{shift} || ''; |
10acc8b1 |
107 | _assert_valid_identifier $clean{shift}, 1 if $clean{shift}; |
108 | |
698e861c |
109 | $clean{attrs} = join ' ', map delete $type{$_} || (), qw(attributes attrs); |
10acc8b1 |
110 | _assert_valid_attributes $clean{attrs} if $clean{attrs}; |
125c067e |
111 | |
59f51b8b |
112 | $clean{default_arguments} = |
113 | exists $type{default_arguments} |
114 | ? !!delete $type{default_arguments} |
115 | : 1 |
116 | ; |
63915d26 |
117 | $clean{check_argument_count} = !!delete $type{check_argument_count}; |
d8e5d540 |
118 | $clean{invocant} = !!delete $type{invocant}; |
e158cf8f |
119 | $clean{named_parameters} = !!delete $type{named_parameters}; |
63915d26 |
120 | |
ae6e00b5 |
121 | %type and confess "Invalid keyword property: @{[keys %type]}"; |
122 | |
123 | $spec{$name} = \%clean; |
125c067e |
124 | } |
125 | |
db81d362 |
126 | for my $kw (keys %spec) { |
127 | my $type = $spec{$kw}; |
128 | |
63915d26 |
129 | my $flags = |
130 | $type->{name} eq 'prohibited' ? FLAG_ANON_OK : |
131 | $type->{name} eq 'required' ? FLAG_NAME_OK : |
132 | FLAG_ANON_OK | FLAG_NAME_OK |
133 | ; |
134 | $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments}; |
135 | $flags |= FLAG_CHECK_NARGS if $type->{check_argument_count}; |
d8e5d540 |
136 | $flags |= FLAG_INVOCANT if $type->{invocant}; |
e158cf8f |
137 | $flags |= FLAG_NAMED_PARAMS if $type->{named_parameters}; |
63915d26 |
138 | $^H{HINTK_FLAGS_ . $kw} = $flags; |
ae6e00b5 |
139 | $^H{HINTK_SHIFT_ . $kw} = $type->{shift}; |
10acc8b1 |
140 | $^H{HINTK_ATTRS_ . $kw} = $type->{attrs}; |
db81d362 |
141 | $^H{+HINTK_KEYWORDS} .= "$kw "; |
125c067e |
142 | } |
eeb7df5f |
143 | } |
144 | |
db81d362 |
145 | sub unimport { |
eeb7df5f |
146 | my $class = shift; |
125c067e |
147 | |
db81d362 |
148 | if (!@_) { |
149 | delete $^H{+HINTK_KEYWORDS}; |
125c067e |
150 | return; |
151 | } |
152 | |
db81d362 |
153 | for my $kw (@_) { |
154 | $^H{+HINTK_KEYWORDS} =~ s/(?<![^ ])\Q$kw\E //g; |
125c067e |
155 | } |
156 | } |
157 | |
db81d362 |
158 | |
125c067e |
159 | 'ok' |
7a63380c |
160 | |
161 | __END__ |
162 | |
f2541b7d |
163 | =encoding UTF-8 |
164 | |
7a63380c |
165 | =head1 NAME |
166 | |
167 | Function::Parameters - subroutine definitions with parameter lists |
168 | |
169 | =head1 SYNOPSIS |
170 | |
171 | use Function::Parameters; |
172 | |
698e861c |
173 | # simple function |
7a63380c |
174 | fun foo($bar, $baz) { |
175 | return $bar + $baz; |
176 | } |
177 | |
698e861c |
178 | # function with prototype |
d71d548b |
179 | fun mymap($fun, @args) |
180 | :(&@) |
181 | { |
7a63380c |
182 | my @res; |
183 | for (@args) { |
184 | push @res, $fun->($_); |
185 | } |
186 | @res |
187 | } |
188 | |
189 | print "$_\n" for mymap { $_ * 2 } 1 .. 4; |
125c067e |
190 | |
698e861c |
191 | # method with implicit $self |
125c067e |
192 | method set_name($name) { |
193 | $self->{name} = $name; |
194 | } |
d8e5d540 |
195 | |
196 | # method with explicit invocant |
197 | method new($class: %init) { |
198 | return bless { %init }, $class; |
199 | } |
200 | |
698e861c |
201 | # function with default arguments |
202 | fun search($haystack, $needle = qr/^(?!)/, $offset = 0) { |
203 | ... |
204 | } |
d8e5d540 |
205 | |
698e861c |
206 | # method with default arguments |
207 | method skip($amount = 1) { |
208 | $self->{position} += $amount; |
209 | } |
210 | |
125c067e |
211 | =cut |
212 | |
213 | =pod |
214 | |
8dbfd12d |
215 | use Function::Parameters qw(:strict); |
216 | |
217 | fun greet($x) { |
218 | print "Hello, $x\n"; |
219 | } |
220 | |
221 | greet "foo", "bar"; |
222 | # Dies at runtime with "Too many arguments for fun greet" |
223 | |
224 | greet; |
225 | # Dies at runtime with "Not enough arguments for fun greet" |
226 | |
227 | =cut |
228 | |
229 | =pod |
230 | |
698e861c |
231 | # use different keywords |
63a24d7c |
232 | use Function::Parameters { |
233 | proc => 'function', |
234 | meth => 'method', |
235 | }; |
c9a39f6b |
236 | |
125c067e |
237 | my $f = proc ($x) { $x * 2 }; |
238 | meth get_age() { |
239 | return $self->{age}; |
240 | } |
241 | |
7a63380c |
242 | =head1 DESCRIPTION |
243 | |
244 | This module lets you use parameter lists in your subroutines. Thanks to |
63a24d7c |
245 | L<PL_keyword_plugin|perlapi/PL_keyword_plugin> it works without source filters. |
7a63380c |
246 | |
7a63380c |
247 | =head2 Basic stuff |
248 | |
249 | To use this new functionality, you have to use C<fun> instead of C<sub> - |
250 | C<sub> continues to work as before. The syntax is almost the same as for |
251 | C<sub>, but after the subroutine name (or directly after C<fun> if you're |
125c067e |
252 | writing an anonymous sub) you can write a parameter list in parentheses. This |
7a63380c |
253 | list consists of comma-separated variables. |
254 | |
255 | The effect of C<fun foo($bar, $baz) {> is as if you'd written |
256 | C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply |
95915793 |
257 | copied into L<my|perlfunc/my-EXPR> and initialized from L<@_|perlvar/"@_">. |
7a63380c |
258 | |
125c067e |
259 | In addition you can use C<method>, which understands the same syntax as C<fun> |
260 | but automatically creates a C<$self> variable for you. So by writing |
261 | C<method foo($bar, $baz) {> you get the same effect as |
262 | C<sub foo { my $self = shift; my ($bar, $baz) = @_; >. |
7a63380c |
263 | |
125c067e |
264 | =head2 Customizing the generated keywords |
c9a39f6b |
265 | |
63a24d7c |
266 | You can customize the names of the keywords injected into your scope. To do |
698e861c |
267 | that you pass a reference to a hash mapping keywords to types in the import |
268 | list: |
269 | |
270 | use Function::Parameters { |
271 | KEYWORD1 => TYPE1, |
272 | KEYWORD2 => TYPE2, |
273 | ... |
274 | }; |
275 | |
276 | Or more concretely: |
7a63380c |
277 | |
125c067e |
278 | use Function::Parameters { proc => 'function', meth => 'method' }; # -or- |
279 | use Function::Parameters { proc => 'function' }; # -or- |
a23979e1 |
280 | use Function::Parameters { meth => 'method' }; # etc. |
125c067e |
281 | |
282 | The first line creates two keywords, C<proc> and C<meth> (for defining |
283 | functions and methods, respectively). The last two lines only create one |
698e861c |
284 | keyword. Generally the hash keys (keywords) can be any identifiers you want |
7817d698 |
285 | while the values (types) have to be either a hash reference (see below) or |
286 | C<'function'>, C<'method'>, C<'classmethod'>, C<'function_strict'>, |
287 | C<'method_strict'>, or C<'classmethod_strict'>. The main difference between |
698e861c |
288 | C<'function'> and C<'method'> is that C<'method'>s automatically |
289 | L<shift|perlfunc/shift> their first argument into C<$self> (C<'classmethod'>s |
290 | are similar but shift into C<$class>). |
125c067e |
291 | |
292 | The following shortcuts are available: |
293 | |
294 | use Function::Parameters; |
295 | # is equivalent to # |
296 | use Function::Parameters { fun => 'function', method => 'method' }; |
297 | |
298 | =cut |
299 | |
300 | =pod |
301 | |
fcaf7811 |
302 | use Function::Parameters ':strict'; |
303 | # is equivalent to # |
304 | use Function::Parameters { fun => 'function_strict', method => 'method_strict' }; |
305 | |
306 | =pod |
307 | |
63a24d7c |
308 | The following shortcuts are deprecated and may be removed from a future version |
698e861c |
309 | of this module: |
63a24d7c |
310 | |
311 | # DEPRECATED |
125c067e |
312 | use Function::Parameters 'foo'; |
313 | # is equivalent to # |
314 | use Function::Parameters { 'foo' => 'function' }; |
315 | |
316 | =cut |
317 | |
318 | =pod |
319 | |
63a24d7c |
320 | # DEPRECATED |
125c067e |
321 | use Function::Parameters 'foo', 'bar'; |
322 | # is equivalent to # |
323 | use Function::Parameters { 'foo' => 'function', 'bar' => 'method' }; |
324 | |
fcaf7811 |
325 | That is, if you want to create custom keywords with L<Function::Parameters>, |
326 | use a hashref, not a list of strings. |
63a24d7c |
327 | |
fcaf7811 |
328 | You can tune the properties of the generated keywords even more by passing |
698e861c |
329 | a hashref instead of a string. This hash can have the following keys: |
ce052c57 |
330 | |
331 | =over |
332 | |
333 | =item C<name> |
334 | |
335 | Valid values: C<optional> (default), C<required> (all uses of this keyword must |
336 | specify a function name), and C<prohibited> (all uses of this keyword must not |
337 | specify a function name). This means a C<< name => 'prohibited' >> keyword can |
338 | only be used for defining anonymous functions. |
339 | |
340 | =item C<shift> |
341 | |
342 | Valid values: strings that look like a scalar variable. Any function created by |
343 | this keyword will automatically L<shift|perlfunc/shift> its first argument into |
63a24d7c |
344 | a local variable whose name is specified here. |
ce052c57 |
345 | |
d8e5d540 |
346 | =item C<invocant> |
347 | |
348 | Valid values: booleans. This lets users of this keyword specify an explicit |
349 | invocant, that is, the first parameter may be followed by a C<:> (colon) |
350 | instead of a comma and will by initialized by shifting the first element off |
351 | C<@_>. |
352 | |
353 | You can combine C<shift> and C<invocant>, in which case the variable named in |
8dbfd12d |
354 | C<shift> serves as a default shift target for functions that don't specify an |
d8e5d540 |
355 | explicit invocant. |
356 | |
698e861c |
357 | =item C<attributes>, C<attrs> |
273c6544 |
358 | |
359 | Valid values: strings that are valid source code for attributes. Any value |
360 | specified here will be inserted as a subroutine attribute in the generated |
361 | code. Thus: |
362 | |
698e861c |
363 | use Function::Parameters { sub_l => { attributes => ':lvalue' } }; |
273c6544 |
364 | sub_l foo() { |
365 | ... |
366 | } |
367 | |
368 | turns into |
369 | |
370 | sub foo :lvalue { |
371 | ... |
372 | } |
373 | |
698e861c |
374 | It is recommended that you use C<attributes> in new code but C<attrs> is also |
375 | accepted for now. |
376 | |
377 | =item C<default_arguments> |
378 | |
379 | Valid values: booleans. This property is on by default, so you have to pass |
380 | C<< default_arguments => 0 >> to turn it off. If it is disabled, using C<=> in |
381 | a parameter list causes a syntax error. Otherwise it lets you specify |
382 | default arguments directly in the parameter list: |
383 | |
384 | fun foo($x, $y = 42, $z = []) { |
385 | ... |
386 | } |
387 | |
388 | turns into |
389 | |
390 | sub foo { |
391 | my ($x, $y, $z) = @_; |
392 | $y = 42 if @_ < 2; |
393 | $z = [] if @_ < 3; |
394 | ... |
395 | } |
396 | |
1e0f1595 |
397 | You can even refer to previous parameters in the same parameter list: |
698e861c |
398 | |
1e0f1595 |
399 | print fun ($x, $y = $x + 1) { "$x and $y" }->(9); # "9 and 10" |
698e861c |
400 | |
1e0f1595 |
401 | This also works with the implicit first parameter of methods: |
698e861c |
402 | |
1e0f1595 |
403 | method scale($factor = $self->default_factor) { |
404 | $self->{amount} *= $factor; |
405 | } |
698e861c |
406 | |
407 | =item C<check_argument_count> |
408 | |
409 | Valid values: booleans. This property is off by default. If it is enabled, the |
410 | generated code will include checks to make sure the number of passed arguments |
411 | is correct (and otherwise throw an exception via L<Carp::croak|Carp>): |
412 | |
413 | fun foo($x, $y = 42, $z = []) { |
414 | ... |
415 | } |
416 | |
417 | turns into |
418 | |
419 | sub foo { |
420 | Carp::croak "Not enough arguments for fun foo" if @_ < 1; |
421 | Carp::croak "Too many arguments for fun foo" if @_ > 3; |
422 | my ($x, $y, $z) = @_; |
423 | $y = 42 if @_ < 2; |
424 | $z = [] if @_ < 3; |
425 | ... |
426 | } |
427 | |
ce052c57 |
428 | =back |
429 | |
698e861c |
430 | Plain C<'function'> is equivalent to: |
431 | |
432 | { |
433 | name => 'optional', |
434 | default_arguments => 1, |
435 | check_argument_count => 0, |
436 | } |
437 | |
438 | (These are all default values so C<'function'> is also equivalent to C<{}>.) |
439 | |
7817d698 |
440 | C<'function_strict'> is like C<'function'> but with |
441 | C<< check_argument_count => 1 >>. |
442 | |
698e861c |
443 | C<'method'> is equivalent to: |
444 | |
445 | { |
446 | name => 'optional', |
447 | default_arguments => 1, |
448 | check_argument_count => 0, |
449 | attributes => ':method', |
450 | shift => '$self', |
d8e5d540 |
451 | invocant => 1, |
698e861c |
452 | } |
453 | |
7817d698 |
454 | C<'method_strict'> is like C<'method'> but with |
455 | C<< check_argument_count => 1 >>. |
456 | |
698e861c |
457 | C<'classmethod'> is equivalent to: |
458 | |
459 | { |
460 | name => 'optional', |
461 | default_arguments => 1, |
462 | check_argument_count => 0, |
463 | attributes => ':method', |
464 | shift => '$class', |
d8e5d540 |
465 | invocant => 1, |
698e861c |
466 | } |
ce052c57 |
467 | |
7817d698 |
468 | C<'classmethod_strict'> is like C<'classmethod'> but with |
469 | C<< check_argument_count => 1 >>. |
470 | |
63a24d7c |
471 | =head2 Syntax and generated code |
7a63380c |
472 | |
473 | Normally, Perl subroutines are not in scope in their own body, meaning the |
63a24d7c |
474 | parser doesn't know the name C<foo> or its prototype while processing the body |
475 | of C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as |
7a63380c |
476 | C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the |
477 | interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger |
478 | a I<foo() called too early to check prototype> warning. This module attempts |
698e861c |
479 | to fix all of this by adding a subroutine declaration before the function body, |
7a63380c |
480 | so the parser knows the name (and possibly prototype) while it processes the |
481 | body. Thus C<fun foo($x) :($) { $x }> really turns into |
698e861c |
482 | C<sub foo ($) { sub foo ($); my ($x) = @_; $x }>. |
7a63380c |
483 | |
95915793 |
484 | If you need L<subroutine attributes|perlsub/Subroutine-Attributes>, you can |
125c067e |
485 | put them after the parameter list with their usual syntax. |
486 | |
487 | Syntactically, these new parameter lists live in the spot normally occupied |
488 | by L<prototypes|perlsub/"Prototypes">. However, you can include a prototype by |
489 | specifying it as the first attribute (this is syntactically unambiguous |
63a24d7c |
490 | because normal attributes have to start with a letter while a prototype starts |
491 | with C<(>). |
492 | |
698e861c |
493 | As an example, the following declaration uses every available feature |
494 | (subroutine name, parameter list, default arguments, prototype, default |
d8e5d540 |
495 | attributes, attributes, argument count checks, and implicit C<$self> overriden |
496 | by an explicit invocant declaration): |
63a24d7c |
497 | |
d8e5d540 |
498 | method foo($this: $x, $y, $z = sqrt 5) |
d71d548b |
499 | :($$$;$) |
500 | :lvalue |
501 | :Banana(2 + 2) |
502 | { |
63a24d7c |
503 | ... |
504 | } |
505 | |
506 | And here's what it turns into: |
507 | |
698e861c |
508 | sub foo ($$$;$) :method :lvalue :Banana(2 + 2) { |
509 | sub foo ($$$;$); |
3087bda1 |
510 | Carp::croak "Not enough arguments for method foo" if @_ < 3; |
698e861c |
511 | Carp::croak "Too many arguments for method foo" if @_ > 4; |
d8e5d540 |
512 | my $this = shift; |
698e861c |
513 | my ($x, $y, $z) = @_; |
514 | $z = sqrt 5 if @_ < 3; |
63a24d7c |
515 | ... |
516 | } |
517 | |
518 | Another example: |
519 | |
d71d548b |
520 | my $coderef = fun ($p, $q) |
521 | :(;$$) |
63a24d7c |
522 | :lvalue |
523 | :Gazebo((>:O)) { |
524 | ... |
525 | }; |
526 | |
527 | And the generated code: |
528 | |
698e861c |
529 | my $coderef = sub (;$$) :lvalue :Gazebo((>:O)) { |
530 | # vvv only if check_argument_count is enabled vvv |
531 | Carp::croak "Not enough arguments for fun (anon)" if @_ < 2; |
532 | Carp::croak "Too many arguments for fun (anon)" if @_ > 2; |
7817d698 |
533 | # ^^^ ^^^ |
698e861c |
534 | my ($p, $q) = @_; |
63a24d7c |
535 | ... |
536 | }; |
537 | |
538 | =head2 Wrapping Function::Parameters |
125c067e |
539 | |
db81d362 |
540 | If you want to wrap L<Function::Parameters>, you just have to call its |
541 | C<import> method. It always applies to the file that is currently being parsed |
95915793 |
542 | and its effects are L<lexical|perlpragma> (i.e. it works like L<warnings> or |
543 | L<strict>). |
63a24d7c |
544 | |
545 | package Some::Wrapper; |
546 | use Function::Parameters (); |
547 | sub import { |
548 | Function::Parameters->import; |
698e861c |
549 | # or Function::Parameters->import(@custom_import_args); |
63a24d7c |
550 | } |
eeb7df5f |
551 | |
7a63380c |
552 | =head1 AUTHOR |
553 | |
554 | Lukas Mai, C<< <l.mai at web.de> >> |
555 | |
556 | =head1 COPYRIGHT & LICENSE |
557 | |
db81d362 |
558 | Copyright 2010, 2011, 2012 Lukas Mai. |
7a63380c |
559 | |
560 | This program is free software; you can redistribute it and/or modify it |
561 | under the terms of either: the GNU General Public License as published |
562 | by the Free Software Foundation; or the Artistic License. |
563 | |
564 | See http://dev.perl.org/licenses/ for more information. |
565 | |
566 | =cut |