lib/Function/Parameters.pm

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