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