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 except that none of the parameters are in scope in the expressions that specify
 347 default values. Thus:
 348
 349   my $var = "outer";
 350
 351   fun foo($var, $wat = $var) {
 352     # $wat will default to "outer", not to what was passed
 353     # as the first argument!
 354     ...
 355   }
 356
 357 This may change in a future version of this module.
 358
 359 =item C<check_argument_count>
 360
 361 Valid values: booleans. This property is off by default. If it is enabled, the
 362 generated code will include checks to make sure the number of passed arguments
 363 is correct (and otherwise throw an exception via L<Carp::croak|Carp>):
 364
 365   fun foo($x, $y = 42, $z = []) {
 366     ...
 367   }
 368
 369 turns into
 370
 371  sub foo {
 372    Carp::croak "Not enough arguments for fun foo" if @_ < 1;
 373    Carp::croak "Too many arguments for fun foo" if @_ > 3;
 374    my ($x, $y, $z) = @_;
 375    $y = 42 if @_ < 2;
 376    $z = [] if @_ < 3;
 377    ...
 378  }
 379
 380 =back
 381
 382 Plain C<'function'> is equivalent to:
 383
 384  {
 385    name => 'optional',
 386    default_arguments => 1,
 387    check_argument_count => 0,
 388  }
 389
 390 (These are all default values so C<'function'> is also equivalent to C<{}>.)
 391
 392 C<'function_strict'> is like C<'function'> but with
 393 C<< check_argument_count => 1 >>.
 394
 395 C<'method'> is equivalent to:
 396
 397  {
 398    name => 'optional',
 399    default_arguments => 1,
 400    check_argument_count => 0,
 401    attributes => ':method',
 402    shift => '$self',
 403  }
 404
 405 C<'method_strict'> is like C<'method'> but with
 406 C<< check_argument_count => 1 >>.
 407
 408 C<'classmethod'> is equivalent to:
 409
 410  {
 411    name => 'optional',
 412    default_arguments => 1,
 413    check_argument_count => 0,
 414    attributes => ':method',
 415    shift => '$class',
 416  }
 417
 418 C<'classmethod_strict'> is like C<'classmethod'> but with
 419 C<< check_argument_count => 1 >>.
 420
 421 =head2 Syntax and generated code
 422
 423 Normally, Perl subroutines are not in scope in their own body, meaning the
 424 parser doesn't know the name C<foo> or its prototype while processing the body
 425 of C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
 426 C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
 427 interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
 428 a I<foo() called too early to check prototype> warning. This module attempts
 429 to fix all of this by adding a subroutine declaration before the function body,
 430 so the parser knows the name (and possibly prototype) while it processes the
 431 body. Thus C<fun foo($x) :($) { $x }> really turns into
 432 C<sub foo ($) { sub foo ($); my ($x) = @_; $x }>.
 433
 434 If you need L<subroutine attributes|perlsub/Subroutine-Attributes>, you can
 435 put them after the parameter list with their usual syntax.
 436
 437 Syntactically, these new parameter lists live in the spot normally occupied
 438 by L<prototypes|perlsub/"Prototypes">. However, you can include a prototype by
 439 specifying it as the first attribute (this is syntactically unambiguous
 440 because normal attributes have to start with a letter while a prototype starts
 441 with C<(>).
 442
 443 As an example, the following declaration uses every available feature
 444 (subroutine name, parameter list, default arguments, prototype, default
 445 attributes, attributes, argument count checks, and implicit C<$self>):
 446
 447  method foo($x, $y, $z = sqrt 5) :($$$;$) :lvalue :Banana(2 + 2) {
 448    ...
 449  }
 450
 451 And here's what it turns into:
 452
 453  sub foo ($$$;$) :method :lvalue :Banana(2 + 2) {
 454    sub foo ($$$;$);
 455    Carp::croak "Not enough arguments for method foo" if @_ < 2;
 456    Carp::croak "Too many arguments for method foo" if @_ > 4;
 457    my $self = shift;
 458    my ($x, $y, $z) = @_;
 459    $z = sqrt 5 if @_ < 3;
 460    ...
 461  }
 462
 463 Another example:
 464
 465  my $coderef = fun ($p, $q) :(;$$)
 466    :lvalue
 467    :Gazebo((>:O)) {
 468    ...
 469  };
 470
 471 And the generated code:
 472
 473  my $coderef = sub (;$$) :lvalue :Gazebo((>:O)) {
 474    # vvv   only if check_argument_count is enabled    vvv
 475    Carp::croak "Not enough arguments for fun (anon)" if @_ < 2;
 476    Carp::croak "Too many arguments for fun (anon)" if @_ > 2;
 477    # ^^^                                              ^^^
 478    my ($p, $q) = @_;
 479    ...
 480  };
 481
 482 =head2 Wrapping Function::Parameters
 483
 484 If you want to wrap L<Function::Parameters>, you just have to call its
 485 C<import> method. It always applies to the file that is currently being parsed
 486 and its effects are L<lexical|perlpragma> (i.e. it works like L<warnings> or
 487 L<strict>).
 488
 489  package Some::Wrapper;
 490  use Function::Parameters ();
 491  sub import {
 492    Function::Parameters->import;
 493    # or Function::Parameters->import(@custom_import_args);
 494  }
 495
 496 =head1 AUTHOR
 497
 498 Lukas Mai, C<< <l.mai at web.de> >>
 499
 500 =head1 COPYRIGHT & LICENSE
 501
 502 Copyright 2010, 2011, 2012 Lukas Mai.
 503
 504 This program is free software; you can redistribute it and/or modify it
 505 under the terms of either: the GNU General Public License as published
 506 by the Free Software Foundation; or the Artistic License.
 507
 508 See http://dev.perl.org/licenses/ for more information.
 509
 510 =cut