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