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