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