lib/Function/Parameters.pm

   1 package Function::Parameters;
   2
   3 use v5.14.0;
   4
   5 use strict;
   6 use warnings;
   7
   8 use XSLoader;
   9 BEGIN {
  10         our $VERSION = '0.05_03';
  11         XSLoader::load;
  12 }
  13
  14 use Carp qw(confess);
  15
  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
  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
  29 my @bare_arms = qw(function method);
  30 my %type_map = (
  31         function => { name => 'optional' },
  32         method   => {
  33                 name => 'optional',
  34                 shift => '$self',
  35                 attrs => ':method',
  36         },
  37         classmethod   => {
  38                 name => 'optional',
  39                 shift => '$class',
  40                 attrs => ':method',
  41         },
  42 );
  43
  44 sub import {
  45         my $class = shift;
  46
  47         @_ or @_ = {
  48                 fun => 'function',
  49                 method => 'method',
  50         };
  51         if (@_ == 1 && ref($_[0]) eq 'HASH') {
  52                 @_ = map [$_, $_[0]{$_}], keys %{$_[0]}
  53                         or return;
  54         }
  55
  56         my %spec;
  57
  58         my $bare = 0;
  59         for my $proto (@_) {
  60                 my $item = ref $proto
  61                         ? $proto
  62                         : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})]
  63                 ;
  64                 my ($name, $proto_type) = @$item;
  65                 _assert_valid_identifier $name;
  66
  67                 unless (ref $proto_type) {
  68                         # use '||' instead of 'or' to preserve $proto_type in the error message
  69                         $proto_type = $type_map{$proto_type}
  70                                 || confess qq["$proto_type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
  71                 }
  72
  73                 my %type = %$proto_type;
  74                 my %clean;
  75
  76                 $clean{name} = delete $type{name} || 'optional';
  77                 $clean{name} =~ /^(?:optional|required|prohibited)\z/
  78                         or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
  79
  80                 $clean{shift} = delete $type{shift} || '';
  81                 _assert_valid_identifier $clean{shift}, 1 if $clean{shift};
  82
  83                 $clean{attrs} = delete $type{attrs} || '';
  84                 _assert_valid_attributes $clean{attrs} if $clean{attrs};
  85
  86                 %type and confess "Invalid keyword property: @{[keys %type]}";
  87
  88                 $spec{$name} = \%clean;
  89         }
  90
  91         for my $kw (keys %spec) {
  92                 my $type = $spec{$kw};
  93
  94                 $^H{HINTK_SHIFT_ . $kw} = $type->{shift};
  95                 $^H{HINTK_ATTRS_ . $kw} = $type->{attrs};
  96                 $^H{HINTK_NAME_ . $kw} =
  97                         $type->{name} eq 'prohibited' ? FLAG_NAME_PROHIBITED :
  98                         $type->{name} eq 'required' ? FLAG_NAME_REQUIRED :
  99                         FLAG_NAME_OPTIONAL
 100                 ;
 101                 $^H{+HINTK_KEYWORDS} .= "$kw ";
 102         }
 103 }
 104
 105 sub unimport {
 106         my $class = shift;
 107
 108         if (!@_) {
 109                 delete $^H{+HINTK_KEYWORDS};
 110                 return;
 111         }
 112
 113         for my $kw (@_) {
 114                 $^H{+HINTK_KEYWORDS} =~ s/(?<![^ ])\Q$kw\E //g;
 115         }
 116 }
 117
 118
 119 'ok'
 120
 121 __END__
 122
 123 =encoding UTF-8
 124
 125 =head1 NAME
 126
 127 Function::Parameters - subroutine definitions with parameter lists
 128
 129 =head1 SYNOPSIS
 130
 131  use Function::Parameters;
 132
 133  fun foo($bar, $baz) {
 134    return $bar + $baz;
 135  }
 136
 137  fun mymap($fun, @args) :(&@) {
 138    my @res;
 139    for (@args) {
 140      push @res, $fun->($_);
 141    }
 142    @res
 143  }
 144
 145  print "$_\n" for mymap { $_ * 2 } 1 .. 4;
 146
 147  method set_name($name) {
 148    $self->{name} = $name;
 149  }
 150
 151 =cut
 152
 153 =pod
 154
 155  use Function::Parameters {
 156    proc => 'function',
 157    meth => 'method',
 158  };
 159
 160  my $f = proc ($x) { $x * 2 };
 161  meth get_age() {
 162    return $self->{age};
 163  }
 164
 165 =head1 DESCRIPTION
 166
 167 This module lets you use parameter lists in your subroutines. Thanks to
 168 L<PL_keyword_plugin|perlapi/PL_keyword_plugin> it works without source filters.
 169
 170 WARNING: This is my first attempt at writing L<XS code|perlxs> and I have
 171 almost no experience with perl's internals. So while this module might
 172 appear to work, it could also conceivably make your programs segfault.
 173 Consider this module alpha quality.
 174
 175 =head2 Basic stuff
 176
 177 To use this new functionality, you have to use C<fun> instead of C<sub> -
 178 C<sub> continues to work as before. The syntax is almost the same as for
 179 C<sub>, but after the subroutine name (or directly after C<fun> if you're
 180 writing an anonymous sub) you can write a parameter list in parentheses. This
 181 list consists of comma-separated variables.
 182
 183 The effect of C<fun foo($bar, $baz) {> is as if you'd written
 184 C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply
 185 copied into C<my> and initialized from L<@_|perlvar/"@_">.
 186
 187 In addition you can use C<method>, which understands the same syntax as C<fun>
 188 but automatically creates a C<$self> variable for you. So by writing
 189 C<method foo($bar, $baz) {> you get the same effect as
 190 C<sub foo { my $self = shift; my ($bar, $baz) = @_; >.
 191
 192 =head2 Customizing the generated keywords
 193
 194 You can customize the names of the keywords injected into your scope. To do
 195 that you pass a hash reference in the import list:
 196
 197  use Function::Parameters { proc => 'function', meth => 'method' }; # -or-
 198  use Function::Parameters { proc => 'function' }; # -or-
 199  use Function::Parameters { meth => 'method' }; # etc.
 200
 201 The first line creates two keywords, C<proc> and C<meth> (for defining
 202 functions and methods, respectively). The last two lines only create one
 203 keyword. Generally the hash keys can be any identifiers you want while the
 204 values have to be either C<function>, C<method>, C<classmethod> or a hash
 205 reference (see below). The difference between C<function> and C<method> is that
 206 C<method>s automatically L<shift|perlfunc/shift> their first argument into
 207 C<$self> (C<classmethod>s are similar but shift into C<$class>).
 208
 209 The following shortcuts are available:
 210
 211  use Function::Parameters;
 212     # is equivalent to #
 213  use Function::Parameters { fun => 'function', method => 'method' };
 214
 215 =cut
 216
 217 =pod
 218
 219 The following shortcuts are deprecated and may be removed from a future version
 220 of the module:
 221
 222  # DEPRECATED
 223  use Function::Parameters 'foo';
 224    # is equivalent to #
 225  use Function::Parameters { 'foo' => 'function' };
 226
 227 =cut
 228
 229 =pod
 230
 231  # DEPRECATED
 232  use Function::Parameters 'foo', 'bar';
 233    # is equivalent to #
 234  use Function::Parameters { 'foo' => 'function', 'bar' => 'method' };
 235
 236 That is, if you want to pass arguments to L<Function::Parameters>, use a
 237 hashref, not a list of strings.
 238
 239 You can customize things even more by passing a hashref instead of C<function>
 240 or C<method>. This hash can have the following keys:
 241
 242 =over
 243
 244 =item C<name>
 245
 246 Valid values: C<optional> (default), C<required> (all uses of this keyword must
 247 specify a function name), and C<prohibited> (all uses of this keyword must not
 248 specify a function name). This means a C<< name => 'prohibited' >> keyword can
 249 only be used for defining anonymous functions.
 250
 251 =item C<shift>
 252
 253 Valid values: strings that look like a scalar variable. Any function created by
 254 this keyword will automatically L<shift|perlfunc/shift> its first argument into
 255 a local variable whose name is specified here.
 256
 257 =item C<attrs>
 258
 259 Valid values: strings that are valid source code for attributes. Any value
 260 specified here will be inserted as a subroutine attribute in the generated
 261 code. Thus:
 262
 263  use Function::Parameters { sub_l => { attrs => ':lvalue' } };
 264  sub_l foo() {
 265    ...
 266  }
 267
 268 turns into
 269
 270  sub foo :lvalue {
 271    ...
 272  }
 273
 274 =back
 275
 276 Plain C<'function'> is equivalent to C<< { name => 'optional' } >>, plain
 277 C<'method'> is equivalent to
 278 C<< { name => 'optional', shift => '$self', attrs => ':method' } >>, and plain
 279 C<'classmethod'> is equivalent to
 280 C<< { name => 'optional', shift => '$class', attrs => ':method' } >>.
 281
 282 =head2 Syntax and generated code
 283
 284 Normally, Perl subroutines are not in scope in their own body, meaning the
 285 parser doesn't know the name C<foo> or its prototype while processing the body
 286 of C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
 287 C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
 288 interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
 289 a I<foo() called too early to check prototype> warning. This module attempts
 290 to fix all of this by adding a subroutine declaration before the definition,
 291 so the parser knows the name (and possibly prototype) while it processes the
 292 body. Thus C<fun foo($x) :($) { $x }> really turns into
 293 C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>.
 294
 295 If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, you can
 296 put them after the parameter list with their usual syntax.
 297
 298 Syntactically, these new parameter lists live in the spot normally occupied
 299 by L<prototypes|perlsub/"Prototypes">. However, you can include a prototype by
 300 specifying it as the first attribute (this is syntactically unambiguous
 301 because normal attributes have to start with a letter while a prototype starts
 302 with C<(>).
 303
 304 As an example, the following declaration uses every feature available
 305 (subroutine name, parameter list, prototype, attributes, and implicit
 306 C<$self>):
 307
 308  method foo($x, $y, @z) :($;$@) :lvalue :Banana(2 + 2) {
 309    ...
 310  }
 311
 312 And here's what it turns into:
 313
 314  sub foo ($;$@); sub foo ($;$@) :lvalue :Banana(2 + 2) { my $self = shift; my ($x, $y, @z) = @_;
 315    ...
 316  }
 317
 318 Another example:
 319
 320  my $coderef = fun ($p, $q) :(;$$)
 321    :lvalue
 322    :Gazebo((>:O)) {
 323    ...
 324  };
 325
 326 And the generated code:
 327
 328  my $coderef = sub (;$$) :lvalue :Gazebo((>:O)) { my ($p, $q) = @_;
 329    ...
 330  };
 331
 332 =head2 Wrapping Function::Parameters
 333
 334 If you want to wrap L<Function::Parameters>, you just have to call its
 335 C<import> method. It always applies to the file that is currently being parsed
 336 and its effects are lexical (i.e. it works like L<warnings> or L<strict>):
 337
 338  package Some::Wrapper;
 339  use Function::Parameters ();
 340  sub import {
 341    Function::Parameters->import;
 342    # or Function::Parameters->import(@other_import_args);
 343  }
 344
 345 =head1 AUTHOR
 346
 347 Lukas Mai, C<< <l.mai at web.de> >>
 348
 349 =head1 COPYRIGHT & LICENSE
 350
 351 Copyright 2010, 2011, 2012 Lukas Mai.
 352
 353 This program is free software; you can redistribute it and/or modify it
 354 under the terms of either: the GNU General Public License as published
 355 by the Free Software Foundation; or the Artistic License.
 356
 357 See http://dev.perl.org/licenses/ for more information.
 358
 359 =cut