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                 attrs => ':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} = delete $type{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  fun foo($bar, $baz) {
 152    return $bar + $baz;
 153  }
 154
 155  fun mymap($fun, @args) :(&@) {
 156    my @res;
 157    for (@args) {
 158      push @res, $fun->($_);
 159    }
 160    @res
 161  }
 162
 163  print "$_\n" for mymap { $_ * 2 } 1 .. 4;
 164
 165  method set_name($name) {
 166    $self->{name} = $name;
 167  }
 168
 169 =cut
 170
 171 =pod
 172
 173  use Function::Parameters {
 174    proc => 'function',
 175    meth => 'method',
 176  };
 177
 178  my $f = proc ($x) { $x * 2 };
 179  meth get_age() {
 180    return $self->{age};
 181  }
 182
 183 =head1 DESCRIPTION
 184
 185 This module lets you use parameter lists in your subroutines. Thanks to
 186 L<PL_keyword_plugin|perlapi/PL_keyword_plugin> it works without source filters.
 187
 188 WARNING: This is my first attempt at writing L<XS code|perlxs> and I have
 189 almost no experience with perl's internals. So while this module might
 190 appear to work, it could also conceivably make your programs segfault.
 191 Consider this module alpha quality.
 192
 193 =head2 Basic stuff
 194
 195 To use this new functionality, you have to use C<fun> instead of C<sub> -
 196 C<sub> continues to work as before. The syntax is almost the same as for
 197 C<sub>, but after the subroutine name (or directly after C<fun> if you're
 198 writing an anonymous sub) you can write a parameter list in parentheses. This
 199 list consists of comma-separated variables.
 200
 201 The effect of C<fun foo($bar, $baz) {> is as if you'd written
 202 C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply
 203 copied into C<my> and initialized from L<@_|perlvar/"@_">.
 204
 205 In addition you can use C<method>, which understands the same syntax as C<fun>
 206 but automatically creates a C<$self> variable for you. So by writing
 207 C<method foo($bar, $baz) {> you get the same effect as
 208 C<sub foo { my $self = shift; my ($bar, $baz) = @_; >.
 209
 210 =head2 Customizing the generated keywords
 211
 212 You can customize the names of the keywords injected into your scope. To do
 213 that you pass a hash reference in the import list:
 214
 215  use Function::Parameters { proc => 'function', meth => 'method' }; # -or-
 216  use Function::Parameters { proc => 'function' }; # -or-
 217  use Function::Parameters { meth => 'method' }; # etc.
 218
 219 The first line creates two keywords, C<proc> and C<meth> (for defining
 220 functions and methods, respectively). The last two lines only create one
 221 keyword. Generally the hash keys can be any identifiers you want while the
 222 values have to be either C<function>, C<method>, C<classmethod> or a hash
 223 reference (see below). The difference between C<function> and C<method> is that
 224 C<method>s automatically L<shift|perlfunc/shift> their first argument into
 225 C<$self> (C<classmethod>s are similar but shift into C<$class>).
 226
 227 The following shortcuts are available:
 228
 229  use Function::Parameters;
 230     # is equivalent to #
 231  use Function::Parameters { fun => 'function', method => 'method' };
 232
 233 =cut
 234
 235 =pod
 236
 237 The following shortcuts are deprecated and may be removed from a future version
 238 of the module:
 239
 240  # DEPRECATED
 241  use Function::Parameters 'foo';
 242    # is equivalent to #
 243  use Function::Parameters { 'foo' => 'function' };
 244
 245 =cut
 246
 247 =pod
 248
 249  # DEPRECATED
 250  use Function::Parameters 'foo', 'bar';
 251    # is equivalent to #
 252  use Function::Parameters { 'foo' => 'function', 'bar' => 'method' };
 253
 254 That is, if you want to pass arguments to L<Function::Parameters>, use a
 255 hashref, not a list of strings.
 256
 257 You can customize things even more by passing a hashref instead of C<function>
 258 or C<method>. This hash can have the following keys:
 259
 260 =over
 261
 262 =item C<name>
 263
 264 Valid values: C<optional> (default), C<required> (all uses of this keyword must
 265 specify a function name), and C<prohibited> (all uses of this keyword must not
 266 specify a function name). This means a C<< name => 'prohibited' >> keyword can
 267 only be used for defining anonymous functions.
 268
 269 =item C<shift>
 270
 271 Valid values: strings that look like a scalar variable. Any function created by
 272 this keyword will automatically L<shift|perlfunc/shift> its first argument into
 273 a local variable whose name is specified here.
 274
 275 =item C<attrs>
 276
 277 Valid values: strings that are valid source code for attributes. Any value
 278 specified here will be inserted as a subroutine attribute in the generated
 279 code. Thus:
 280
 281  use Function::Parameters { sub_l => { attrs => ':lvalue' } };
 282  sub_l foo() {
 283    ...
 284  }
 285
 286 turns into
 287
 288  sub foo :lvalue {
 289    ...
 290  }
 291
 292 =back
 293
 294 Plain C<'function'> is equivalent to C<< { name => 'optional' } >>, plain
 295 C<'method'> is equivalent to
 296 C<< { name => 'optional', shift => '$self', attrs => ':method' } >>, and plain
 297 C<'classmethod'> is equivalent to
 298 C<< { name => 'optional', shift => '$class', attrs => ':method' } >>.
 299
 300 =head2 Syntax and generated code
 301
 302 Normally, Perl subroutines are not in scope in their own body, meaning the
 303 parser doesn't know the name C<foo> or its prototype while processing the body
 304 of C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
 305 C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
 306 interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
 307 a I<foo() called too early to check prototype> warning. This module attempts
 308 to fix all of this by adding a subroutine declaration before the definition,
 309 so the parser knows the name (and possibly prototype) while it processes the
 310 body. Thus C<fun foo($x) :($) { $x }> really turns into
 311 C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>.
 312
 313 If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, you can
 314 put them after the parameter list with their usual syntax.
 315
 316 Syntactically, these new parameter lists live in the spot normally occupied
 317 by L<prototypes|perlsub/"Prototypes">. However, you can include a prototype by
 318 specifying it as the first attribute (this is syntactically unambiguous
 319 because normal attributes have to start with a letter while a prototype starts
 320 with C<(>).
 321
 322 As an example, the following declaration uses every feature available
 323 (subroutine name, parameter list, prototype, attributes, and implicit
 324 C<$self>):
 325
 326  method foo($x, $y, @z) :($;$@) :lvalue :Banana(2 + 2) {
 327    ...
 328  }
 329
 330 And here's what it turns into:
 331
 332  sub foo ($;$@); sub foo ($;$@) :lvalue :Banana(2 + 2) { my $self = shift; my ($x, $y, @z) = @_;
 333    ...
 334  }
 335
 336 Another example:
 337
 338  my $coderef = fun ($p, $q) :(;$$)
 339    :lvalue
 340    :Gazebo((>:O)) {
 341    ...
 342  };
 343
 344 And the generated code:
 345
 346  my $coderef = sub (;$$) :lvalue :Gazebo((>:O)) { my ($p, $q) = @_;
 347    ...
 348  };
 349
 350 =head2 Wrapping Function::Parameters
 351
 352 If you want to wrap L<Function::Parameters>, you just have to call its
 353 C<import> method. It always applies to the file that is currently being parsed
 354 and its effects are lexical (i.e. it works like L<warnings> or L<strict>):
 355
 356  package Some::Wrapper;
 357  use Function::Parameters ();
 358  sub import {
 359    Function::Parameters->import;
 360    # or Function::Parameters->import(@other_import_args);
 361  }
 362
 363 =head1 AUTHOR
 364
 365 Lukas Mai, C<< <l.mai at web.de> >>
 366
 367 =head1 COPYRIGHT & LICENSE
 368
 369 Copyright 2010, 2011, 2012 Lukas Mai.
 370
 371 This program is free software; you can redistribute it and/or modify it
 372 under the terms of either: the GNU General Public License as published
 373 by the Free Software Foundation; or the Artistic License.
 374
 375 See http://dev.perl.org/licenses/ for more information.
 376
 377 =cut