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