lib/Function/Parameters.pm

   1 package Function::Parameters;
   2
   3 use v5.14.0;
   4
   5 use strict;
   6 use warnings;
   7
   8 use XSLoader;
   9 BEGIN {
  10         our $VERSION = '0.05_03';
  11         XSLoader::load;
  12 }
  13
  14 use Carp qw(confess);
  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 => { name => 'optional' },
  32         method   => {
  33                 name => 'optional',
  34                 shift => '$self',
  35                 attrs => ':method',
  36         },
  37         classmethod   => {
  38                 name => 'optional',
  39                 shift => '$class',
  40                 attrs => ':method',
  41         },
  42 );
  43
  44 sub import {
  45         my $class = shift;
  46
  47         @_ or @_ = {
  48                 fun => 'function',
  49                 method => 'method',
  50         };
  51         if (@_ == 1 && ref($_[0]) eq 'HASH') {
  52                 @_ = map [$_, $_[0]{$_}], keys %{$_[0]}
  53                         or return;
  54         }
  55
  56         my %spec;
  57
  58         my $bare = 0;
  59         for my $proto (@_) {
  60                 my $item = ref $proto
  61                         ? $proto
  62                         : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})]
  63                 ;
  64                 my ($name, $proto_type) = @$item;
  65                 _assert_valid_identifier $name;
  66
  67                 unless (ref $proto_type) {
  68                         # use '||' instead of 'or' to preserve $proto_type in the error message
  69                         $proto_type = $type_map{$proto_type}
  70                                 || confess qq["$proto_type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
  71                 }
  72
  73                 my %type = %$proto_type;
  74                 my %clean;
  75
  76                 $clean{name} = delete $type{name} || 'optional';
  77                 $clean{name} =~ /^(?:optional|required|prohibited)\z/
  78                         or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
  79
  80                 $clean{shift} = delete $type{shift} || '';
  81                 _assert_valid_identifier $clean{shift}, 1 if $clean{shift};
  82
  83                 $clean{attrs} = delete $type{attrs} || '';
  84                 _assert_valid_attributes $clean{attrs} if $clean{attrs};
  85
  86                 %type and confess "Invalid keyword property: @{[keys %type]}";
  87
  88                 $spec{$name} = \%clean;
  89         }
  90
  91         for my $kw (keys %spec) {
  92                 my $type = $spec{$kw};
  93
  94                 $^H{HINTK_SHIFT_ . $kw} = $type->{shift};
  95                 $^H{HINTK_ATTRS_ . $kw} = $type->{attrs};
  96                 $^H{HINTK_NAME_ . $kw} =
  97                         $type->{name} eq 'prohibited' ? FLAG_NAME_PROHIBITED :
  98                         $type->{name} eq 'required' ? FLAG_NAME_REQUIRED :
  99                         FLAG_NAME_OPTIONAL
 100                 ;
 101                 $^H{+HINTK_KEYWORDS} .= "$kw ";
 102         }
 103 }
 104
 105 sub unimport {
 106         my $class = shift;
 107
 108         if (!@_) {
 109                 delete $^H{+HINTK_KEYWORDS};
 110                 return;
 111         }
 112
 113         for my $kw (@_) {
 114                 $^H{+HINTK_KEYWORDS} =~ s/(?<![^ ])\Q$kw\E //g;
 115         }
 116 }
 117
 118
 119 'ok'
 120
 121 __END__
 122
 123 =head1 NAME
 124
 125 Function::Parameters - subroutine definitions with parameter lists
 126
 127 =head1 SYNOPSIS
 128
 129  use Function::Parameters;
 130
 131  fun foo($bar, $baz) {
 132    return $bar + $baz;
 133  }
 134
 135  fun mymap($fun, @args) :(&@) {
 136    my @res;
 137    for (@args) {
 138      push @res, $fun->($_);
 139    }
 140    @res
 141  }
 142
 143  print "$_\n" for mymap { $_ * 2 } 1 .. 4;
 144
 145  method set_name($name) {
 146    $self->{name} = $name;
 147  }
 148
 149 =cut
 150
 151 =pod
 152
 153  use Function::Parameters {
 154    proc => 'function',
 155    meth => 'method',
 156  };
 157
 158  my $f = proc ($x) { $x * 2 };
 159  meth get_age() {
 160    return $self->{age};
 161  }
 162
 163 =head1 DESCRIPTION
 164
 165 This module lets you use parameter lists in your subroutines. Thanks to
 166 L<PL_keyword_plugin|perlapi/PL_keyword_plugin> it works without source filters.
 167
 168 WARNING: This is my first attempt at writing L<XS code|perlxs> and I have
 169 almost no experience with perl's internals. So while this module might
 170 appear to work, it could also conceivably make your programs segfault.
 171 Consider this module alpha quality.
 172
 173 =head2 Basic stuff
 174
 175 To use this new functionality, you have to use C<fun> instead of C<sub> -
 176 C<sub> continues to work as before. The syntax is almost the same as for
 177 C<sub>, but after the subroutine name (or directly after C<fun> if you're
 178 writing an anonymous sub) you can write a parameter list in parentheses. This
 179 list consists of comma-separated variables.
 180
 181 The effect of C<fun foo($bar, $baz) {> is as if you'd written
 182 C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply
 183 copied into C<my> and initialized from L<@_|perlvar/"@_">.
 184
 185 In addition you can use C<method>, which understands the same syntax as C<fun>
 186 but automatically creates a C<$self> variable for you. So by writing
 187 C<method foo($bar, $baz) {> you get the same effect as
 188 C<sub foo { my $self = shift; my ($bar, $baz) = @_; >.
 189
 190 =head2 Customizing the generated keywords
 191
 192 You can customize the names of the keywords injected into your scope. To do
 193 that you pass a hash reference in the import list:
 194
 195  use Function::Parameters { proc => 'function', meth => 'method' }; # -or-
 196  use Function::Parameters { proc => 'function' }; # -or-
 197  use Function::Parameters { meth => 'method' }; # etc.
 198
 199 The first line creates two keywords, C<proc> and C<meth> (for defining
 200 functions and methods, respectively). The last two lines only create one
 201 keyword. Generally the hash keys can be any identifiers you want while the
 202 values have to be either C<function>, C<method>, C<classmethod> or a hash
 203 reference (see below). The difference between C<function> and C<method> is that
 204 C<method>s automatically L<shift|perlfunc/shift> their first argument into
 205 C<$self> (C<classmethod>s are similar but shift into C<$class>).
 206
 207 The following shortcuts are available:
 208
 209  use Function::Parameters;
 210     # is equivalent to #
 211  use Function::Parameters { fun => 'function', method => 'method' };
 212
 213 =cut
 214
 215 =pod
 216
 217 The following shortcuts are deprecated and may be removed from a future version
 218 of the module:
 219
 220  # DEPRECATED
 221  use Function::Parameters 'foo';
 222    # is equivalent to #
 223  use Function::Parameters { 'foo' => 'function' };
 224
 225 =cut
 226
 227 =pod
 228
 229  # DEPRECATED
 230  use Function::Parameters 'foo', 'bar';
 231    # is equivalent to #
 232  use Function::Parameters { 'foo' => 'function', 'bar' => 'method' };
 233
 234 That is, if you want to pass arguments to L<Function::Parameters>, use a
 235 hashref, not a list of strings.
 236
 237 You can customize things even more by passing a hashref instead of C<function>
 238 or C<method>. This hash can have the following keys:
 239
 240 =over
 241
 242 =item C<name>
 243
 244 Valid values: C<optional> (default), C<required> (all uses of this keyword must
 245 specify a function name), and C<prohibited> (all uses of this keyword must not
 246 specify a function name). This means a C<< name => 'prohibited' >> keyword can
 247 only be used for defining anonymous functions.
 248
 249 =item C<shift>
 250
 251 Valid values: strings that look like a scalar variable. Any function created by
 252 this keyword will automatically L<shift|perlfunc/shift> its first argument into
 253 a local variable whose name is specified here.
 254
 255 =item C<attrs>
 256
 257 Valid values: strings that are valid source code for attributes. Any value
 258 specified here will be inserted as a subroutine attribute in the generated
 259 code. Thus:
 260
 261  use Function::Parameters { sub_l => { attrs => ':lvalue' } };
 262  sub_l foo() {
 263    ...
 264  }
 265
 266 turns into
 267
 268  sub foo :lvalue {
 269    ...
 270  }
 271
 272 =back
 273
 274 Plain C<'function'> is equivalent to C<< { name => 'optional' } >>, plain
 275 C<'method'> is equivalent to
 276 C<< { name => 'optional', shift => '$self', attrs => ':method' } >>, and plain
 277 C<'classmethod'> is equivalent to
 278 C<< { name => 'optional', shift => '$class', attrs => ':method' } >>.
 279
 280 =head2 Syntax and generated code
 281
 282 Normally, Perl subroutines are not in scope in their own body, meaning the
 283 parser doesn't know the name C<foo> or its prototype while processing the body
 284 of C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
 285 C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
 286 interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
 287 a I<foo() called too early to check prototype> warning. This module attempts
 288 to fix all of this by adding a subroutine declaration before the definition,
 289 so the parser knows the name (and possibly prototype) while it processes the
 290 body. Thus C<fun foo($x) :($) { $x }> really turns into
 291 C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>.
 292
 293 If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, you can
 294 put them after the parameter list with their usual syntax.
 295
 296 Syntactically, these new parameter lists live in the spot normally occupied
 297 by L<prototypes|perlsub/"Prototypes">. However, you can include a prototype by
 298 specifying it as the first attribute (this is syntactically unambiguous
 299 because normal attributes have to start with a letter while a prototype starts
 300 with C<(>).
 301
 302 As an example, the following declaration uses every feature available
 303 (subroutine name, parameter list, prototype, attributes, and implicit
 304 C<$self>):
 305
 306  method foo($x, $y, @z) :($;$@) :lvalue :Banana(2 + 2) {
 307    ...
 308  }
 309
 310 And here's what it turns into:
 311
 312  sub foo ($;$@); sub foo ($;$@) :lvalue :Banana(2 + 2) { my $self = shift; my ($x, $y, @z) = @_;
 313    ...
 314  }
 315
 316 Another example:
 317
 318  my $coderef = fun ($p, $q) :(;$$)
 319    :lvalue
 320    :Gazebo((>:O)) {
 321    ...
 322  };
 323
 324 And the generated code:
 325
 326  my $coderef = sub (;$$) :lvalue :Gazebo((>:O)) { my ($p, $q) = @_;
 327    ...
 328  };
 329
 330 =head2 Wrapping Function::Parameters
 331
 332 If you want to wrap L<Function::Parameters>, you just have to call its
 333 C<import> method. It always applies to the file that is currently being parsed
 334 and its effects are lexical (i.e. it works like L<warnings> or L<strict>):
 335
 336  package Some::Wrapper;
 337  use Function::Parameters ();
 338  sub import {
 339    Function::Parameters->import;
 340    # or Function::Parameters->import(@other_import_args);
 341  }
 342
 343 =head1 AUTHOR
 344
 345 Lukas Mai, C<< <l.mai at web.de> >>
 346
 347 =head1 COPYRIGHT & LICENSE
 348
 349 Copyright 2010, 2011, 2012 Lukas Mai.
 350
 351 This program is free software; you can redistribute it and/or modify it
 352 under the terms of either: the GNU General Public License as published
 353 by the Free Software Foundation; or the Artistic License.
 354
 355 See http://dev.perl.org/licenses/ for more information.
 356
 357 =cut