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