lib/Function/Parameters.pm

   1 package Function::Parameters;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.05';
   7
   8 use Carp qw(croak confess);
   9 use Devel::Declare;
  10 use B::Hooks::EndOfScope;
  11
  12 our @CARP_NOT = qw(Devel::Declare);
  13
  14
  15 # Make our import chainable so a wrapper module that wants to turn on F:P
  16 # for its users can just say
  17 #    sub import { Function::Parameters->import; }
  18 #
  19 # To make that possible we skip all subs named 'import' in our search for the
  20 # target package.
  21 #
  22 sub guess_caller {
  23         my ($start) = @_;
  24         $start ||= 1;
  25
  26         my $defcaller = (caller $start)[0];
  27         my $caller = $defcaller;
  28
  29         for (my $level = $start; ; ++$level) {
  30                 my ($pkg, $function) = (caller $level)[0, 3] or last;
  31                 $function =~ /::import\z/ or return $caller;
  32                 $caller = $pkg;
  33         }
  34         $defcaller
  35 }
  36
  37
  38 sub _assert_valid_identifier {
  39         my ($name, $with_dollar) = @_;
  40         my $bonus = $with_dollar ? '\$' : '';
  41         $name =~ /^${bonus}[^\W\d]\w*\z/
  42                 or confess qq{"$name" doesn't look like a valid identifier};
  43 }
  44
  45 # Parse import spec and make shit happen.
  46 #
  47 my @bare_arms = qw(function method);
  48 my %type_map = (
  49         function => { name => 'optional' },
  50         method   => { name => 'optional', shift => '$self' },
  51 );
  52
  53 sub import_into {
  54         my $victim = shift;
  55
  56         @_ or @_ = ('fun', 'method');
  57         if (@_ == 1 && ref($_[0]) eq 'HASH') {
  58                 @_ = map [$_, $_[0]{$_}], keys %{$_[0]}
  59                         or return;
  60         }
  61
  62         my %spec;
  63
  64         my $bare = 0;
  65         for my $proto (@_) {
  66                 my $item = ref $proto
  67                         ? $proto
  68                         : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})]
  69                 ;
  70                 my ($name, $type) = @$item;
  71                 _assert_valid_identifier $name;
  72
  73                 unless (ref $type) {
  74                         # use '||' instead of 'or' to preserve $type in the error message
  75                         $type = $type_map{$type}
  76                                 || confess qq["$type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
  77                 }
  78                 $type->{name} ||= 'optional';
  79                 $type->{name} =~ /^(?:optional|required|prohibited)\z/
  80                         or confess qq["$type->{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
  81
  82                 $spec{$name} = {const => mk_parse($type)};
  83         }
  84
  85         Devel::Declare->setup_for($victim, \%spec);
  86         for my $name (keys %spec) {
  87                 no strict 'refs';
  88                 *{$victim . '::' . $name} = \&_declarator;
  89         }
  90 }
  91
  92 sub import {
  93         my $class = shift;
  94         my $caller = guess_caller;
  95         import_into $caller, @_;
  96 }
  97
  98 sub _declarator {
  99         $_[0]
 100 }
 101
 102
 103 # Wrapper around substr where param 3 is an end offset, not a length.
 104 #
 105 sub _substring {
 106         @_ >= 4
 107         ? substr $_[0], $_[1], $_[2] - $_[1], $_[3]
 108         : substr $_[0], $_[1], $_[2] - $_[1]
 109 }
 110
 111 sub _skip_space {
 112         my ($ctx, $key) = @_;
 113         my $cur = my $start = $ctx->{offset};
 114         while (my $d = Devel::Declare::toke_skipspace $cur) {
 115                 $cur += $d;
 116         }
 117         $ctx->{space}{$key} .= _substring Devel::Declare::get_linestr, $start, $cur if $key;
 118         $ctx->{offset} = $cur;
 119 }
 120
 121 sub _grab_name {
 122         my ($ctx) = @_;
 123         my $p = $ctx->{offset};
 124         my $namlen = Devel::Declare::toke_scan_word $p, !!'handle_package'
 125                 or return;
 126         my $str = Devel::Declare::get_linestr;
 127         $ctx->{name} = substr $str, $p, $namlen;
 128         $ctx->{offset} += $namlen;
 129         _skip_space $ctx, 'name';
 130 }
 131
 132 sub _grab_params {
 133         my ($ctx) = @_;
 134         substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '('
 135                 or return;
 136         $ctx->{offset}++;
 137         _skip_space $ctx, 'params';
 138
 139         my $pcount = 0;
 140
 141         LOOP: {
 142                 my $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1;
 143
 144                 if ($c =~ /^[\$\@%]\z/) {
 145                         $ctx->{offset}++;
 146                         _skip_space $ctx, "params_$pcount";
 147                         my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package'
 148                                 or croak "Missing identifier";
 149                         my $name = substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen;
 150                         $ctx->{params} .= $c . $name . ',';
 151                         $ctx->{offset} += $namlen;
 152                         _skip_space $ctx, "params_$pcount";
 153
 154                         $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1;
 155                         if ($c eq ',') {
 156                                 $ctx->{offset}++;
 157                                 _skip_space $ctx, "params_$pcount";
 158                                 $pcount++;
 159                                 redo LOOP;
 160                         }
 161                 }
 162
 163                 if ($c eq ')') {
 164                         $ctx->{offset}++;
 165                         _skip_space $ctx, 'params';
 166                         return;
 167                 }
 168
 169                 if ($c eq '') {
 170                         croak "Unexpected EOF in parameter list";
 171                 }
 172
 173                 croak "Unexpected '$c' in parameter list";
 174         }
 175 }
 176
 177 sub _parse_parens {
 178         my ($ctx) = @_;
 179
 180         my $strlen = Devel::Declare::toke_scan_str $ctx->{offset};
 181         $strlen == 0 || $strlen == -1 and return;
 182
 183         $strlen < 0 and confess "Devel::Declare::toke_scan_str done fucked up ($strlen); see https://rt.cpan.org/Ticket/Display.html?id=51679";
 184
 185         my $str = Devel::Declare::get_lex_stuff;
 186         Devel::Declare::clear_lex_stuff;
 187
 188         $ctx->{offset} += $strlen;
 189
 190         $str
 191 }
 192
 193 sub _grab_proto {
 194         my ($ctx) = @_;
 195
 196         my $savepos = $ctx->{offset};
 197
 198         substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':'
 199                 or return;
 200         $ctx->{offset}++;
 201         _skip_space $ctx, 'proto_tmp';
 202
 203         unless (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') {
 204                 $ctx->{offset} = $savepos;
 205                 delete $ctx->{space}{proto_tmp};
 206                 return;
 207         }
 208         $_->{proto} .= delete $_->{proto_tmp} for $ctx->{space};
 209
 210         defined(my $str = _parse_parens $ctx)
 211                 or croak "Malformed prototype";
 212         $ctx->{proto} = $str;
 213
 214         _skip_space $ctx, 'proto';
 215 }
 216
 217 sub _grab_attr {
 218         my ($ctx) = @_;
 219
 220         my $pcount = 0;
 221
 222         if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') {
 223                 $ctx->{offset}++;
 224                 _skip_space $ctx, "attr_$pcount";
 225         } elsif (!defined $ctx->{proto}) {
 226                 return;
 227         }
 228
 229         while () {
 230                 my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package'
 231                         or return;
 232                 $ctx->{attr} .= substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen;
 233                 $ctx->{offset} += $namlen;
 234                 _skip_space $ctx, "attr_$pcount";
 235                 if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') {
 236                         defined(my $str = _parse_parens $ctx)
 237                                 or croak "Malformed attribute argument list";
 238                         $ctx->{attr} .= "($str)";
 239                         _skip_space $ctx, "attr_$pcount";
 240                 }
 241                 $pcount++;
 242
 243                 if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') {
 244                         $ctx->{offset}++;
 245                         _skip_space $ctx, "attr_$pcount";
 246                 }
 247         }
 248 }
 249
 250 # IN:
 251 #  fun name (params) :(proto) :attr { ... }
 252 # OUT:
 253 #  fun (do { sub                        (proto) :attr { self? my (params) = @_; ... } })
 254 #  fun (do { sub name (proto); sub name (proto) :attr { self? my (params) = @_; ... } });
 255 #
 256 sub _generate {
 257         my ($ctx, $declarator, $shift) = @_;
 258
 259         my $gen = '(do{sub';
 260
 261         my $skipped = join '', values %{$ctx->{space}};
 262         my $lines = $skipped =~ tr/\n//;
 263         $gen .= "\n" x $lines;
 264
 265         my $proto = defined $ctx->{proto} ? "($ctx->{proto})" : '';
 266
 267         my $is_stmt = 0;
 268         if (defined(my $name = $ctx->{name})) {
 269                 $is_stmt = 1;
 270                 $gen .= " $name$proto;";
 271                 $gen .= "sub $name";
 272         }
 273
 274         $gen .= $proto;
 275
 276         if (defined $ctx->{attr}) {
 277                 $gen .= ":$ctx->{attr}";
 278         }
 279
 280         $gen .= '{';
 281         $gen .= "BEGIN{${\__PACKAGE__}::_fini($is_stmt)}";
 282
 283         if ($shift) {
 284                 _assert_valid_identifier $shift, 1;
 285                 $gen .= "my$shift=shift;";
 286         }
 287         if (defined $ctx->{params}) {
 288                 $gen .= "my($ctx->{params})=\@_;";
 289         }
 290         $gen
 291 }
 292
 293 sub mk_parse {
 294         my ($spec) = @_;
 295
 296         sub {
 297                 my ($declarator, $offset_orig) = @_;
 298                 my $ctx = {
 299                         offset => $offset_orig,
 300                         space => {},
 301                 };
 302
 303                 $ctx->{offset} += Devel::Declare::toke_move_past_token($ctx->{offset});
 304                 _skip_space $ctx;
 305
 306                 my $start = $ctx->{offset};
 307
 308                 _grab_name $ctx unless $spec->{name} eq 'prohibited';
 309                 $ctx->{name} or croak qq[I was expecting a function name, not "${\substr Devel::Declare::get_linestr, $ctx->{offset}}"] if $spec->{name} eq 'required';
 310                 _grab_params $ctx;
 311                 _grab_proto $ctx;
 312                 _grab_attr $ctx;
 313
 314                 my $offset = $ctx->{offset};
 315
 316                 my $linestr = Devel::Declare::get_linestr;
 317                 substr($linestr, $offset, 1) eq '{'
 318                         or croak qq[I was expecting a function body, not "${\substr $linestr, $offset}"];
 319
 320                 my $gen = _generate $ctx, $declarator, $spec->{shift};
 321                 my $oldlen = $offset + 1 - $start;
 322                 _substring $linestr, $start, $offset + 1, (' ' x $oldlen) . $gen;
 323                 Devel::Declare::set_linestr $linestr;
 324         }
 325 }
 326
 327 # Patch in the end of our synthetic 'do' block, close argument list, and
 328 # optionally terminate the statement.
 329 #
 330 sub _fini {
 331         my ($stmt) = @_;
 332         on_scope_end {
 333                 my $off = Devel::Declare::get_linestr_offset;
 334                 my $str = Devel::Declare::get_linestr;
 335                 substr $str, $off, 0, '})' . ($stmt ? ';' : '');
 336                 Devel::Declare::set_linestr $str;
 337         };
 338 }
 339
 340 'ok'
 341
 342 __END__
 343
 344 =head1 NAME
 345
 346 Function::Parameters - subroutine definitions with parameter lists
 347
 348 =head1 SYNOPSIS
 349
 350  use Function::Parameters;
 351
 352  fun foo($bar, $baz) {
 353    return $bar + $baz;
 354  }
 355
 356  fun mymap($fun, @args) :(&@) {
 357    my @res;
 358    for (@args) {
 359      push @res, $fun->($_);
 360    }
 361    @res
 362  }
 363
 364  print "$_\n" for mymap { $_ * 2 } 1 .. 4;
 365
 366  method set_name($name) {
 367    $self->{name} = $name;
 368  }
 369
 370 =cut
 371
 372 =pod
 373
 374  use Function::Parameters 'proc', 'meth';
 375
 376  my $f = proc ($x) { $x * 2 };
 377  meth get_age() {
 378    return $self->{age};
 379  }
 380
 381 =head1 DESCRIPTION
 382
 383 This module lets you use parameter lists in your subroutines. Thanks to
 384 L<Devel::Declare> it works without source filters.
 385
 386 WARNING: This is my first attempt at using L<Devel::Declare> and I have
 387 almost no experience with perl's internals. So while this module might
 388 appear to work, it could also conceivably make your programs segfault.
 389 Consider this module alpha quality.
 390
 391 =head2 Basic stuff
 392
 393 To use this new functionality, you have to use C<fun> instead of C<sub> -
 394 C<sub> continues to work as before. The syntax is almost the same as for
 395 C<sub>, but after the subroutine name (or directly after C<fun> if you're
 396 writing an anonymous sub) you can write a parameter list in parentheses. This
 397 list consists of comma-separated variables.
 398
 399 The effect of C<fun foo($bar, $baz) {> is as if you'd written
 400 C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply
 401 copied into C<my> and initialized from L<@_|perlvar/"@_">.
 402
 403 In addition you can use C<method>, which understands the same syntax as C<fun>
 404 but automatically creates a C<$self> variable for you. So by writing
 405 C<method foo($bar, $baz) {> you get the same effect as
 406 C<sub foo { my $self = shift; my ($bar, $baz) = @_; >.
 407
 408 =head2 Customizing the generated keywords
 409
 410 You can customize the names of the keywords injected in your package. To do that
 411 you pass a hash reference in the import list:
 412
 413  use Function::Parameters { proc => 'function', meth => 'method' }; # -or-
 414  use Function::Parameters { proc => 'function' }; # -or-
 415  use Function::Parameters { meth => 'method' };
 416
 417 The first line creates two keywords, C<proc> and C<meth> (for defining
 418 functions and methods, respectively). The last two lines only create one
 419 keyword. Generally the hash keys can be any identifiers you want while the
 420 values have to be either C<function> or C<method>. The difference between
 421 C<function> and C<method> is that C<method>s automatically
 422 L<shift|perlfunc/shift> their first argument into C<$self>.
 423
 424 The following shortcuts are available:
 425
 426  use Function::Parameters;
 427     # is equivalent to #
 428  use Function::Parameters { fun => 'function', method => 'method' };
 429
 430 =cut
 431
 432 =pod
 433
 434  use Function::Parameters 'foo';
 435    # is equivalent to #
 436  use Function::Parameters { 'foo' => 'function' };
 437
 438 =cut
 439
 440 =pod
 441
 442  use Function::Parameters 'foo', 'bar';
 443    # is equivalent to #
 444  use Function::Parameters { 'foo' => 'function', 'bar' => 'method' };
 445
 446 =head2 Other advanced stuff
 447
 448 Normally, Perl subroutines are not in scope in their own body, meaning the
 449 parser doesn't know the name C<foo> or its prototype while processing
 450 C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
 451 C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
 452 interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
 453 a I<foo() called too early to check prototype> warning. This module attempts
 454 to fix all of this by adding a subroutine declaration before the definition,
 455 so the parser knows the name (and possibly prototype) while it processes the
 456 body. Thus C<fun foo($x) :($) { $x }> really turns into
 457 C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>.
 458
 459 If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, you can
 460 put them after the parameter list with their usual syntax.
 461
 462 Syntactically, these new parameter lists live in the spot normally occupied
 463 by L<prototypes|perlsub/"Prototypes">. However, you can include a prototype by
 464 specifying it as the first attribute (this is syntactically unambiguous
 465 because normal attributes have to start with a letter).
 466
 467 If you want to wrap C<Function::Parameters>, you may find C<import_into>
 468 helpful. It lets you specify a target package for the syntax magic, as in:
 469
 470   package Some::Wrapper;
 471   use Function::Parameters ();
 472   sub import {
 473     my $caller = caller;
 474     Function::Parameters::import_into $caller;
 475     # or Function::Parameters::import_into $caller, @other_import_args;
 476   }
 477
 478 C<import_into> is not exported by this module, so you have to use a fully
 479 qualified name to call it.
 480
 481 =head1 AUTHOR
 482
 483 Lukas Mai, C<< <l.mai at web.de> >>
 484
 485 =head1 COPYRIGHT & LICENSE
 486
 487 Copyright 2010, 2011 Lukas Mai.
 488
 489 This program is free software; you can redistribute it and/or modify it
 490 under the terms of either: the GNU General Public License as published
 491 by the Free Software Foundation; or the Artistic License.
 492
 493 See http://dev.perl.org/licenses/ for more information.
 494
 495 =cut