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