lib/Function/Parameters.pm

   1 package Function::Parameters;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.04';
   7
   8 use Devel::Declare;
   9 use B::Hooks::EndOfScope;
  10 use B::Compiling;
  11
  12 sub guess_caller {
  13         my ($start) = @_;
  14         $start ||= 1;
  15
  16         my $defcaller = (caller $start)[0];
  17         my $caller = $defcaller;
  18
  19         for (my $level = $start; ; ++$level) {
  20                 my ($pkg, $function) = (caller $level)[0, 3] or last;
  21                 #warn "? $pkg, $function";
  22                 $function =~ /::import\z/ or return $caller;
  23                 $caller = $pkg;
  24         }
  25         $defcaller
  26 }
  27
  28 sub _fun ($) { $_[0] }
  29
  30 sub _croak {
  31         require Carp;
  32         {
  33                 no warnings qw(redefine);
  34                 *_croak = \&Carp::croak;
  35         }
  36         goto &Carp::croak;
  37 }
  38
  39 sub import_into {
  40         my $victim = shift;
  41         my $keyword = @_ ? shift : 'fun';
  42
  43         _croak qq["$_" is not exported by the ${\__PACKAGE__} module] for @_;
  44
  45         $keyword =~ /^[[:alpha:]_]\w*\z/ or _croak qq{"$keyword" does not look like a valid identifier};
  46
  47         Devel::Declare->setup_for(
  48                 $victim,
  49                 { $keyword => { const => \&parser } }
  50         );
  51
  52         no strict 'refs';
  53         *{$victim . '::' . $keyword} = \&_fun;
  54 }
  55
  56 sub import {
  57         my $class = shift;
  58
  59         my $caller = guess_caller;
  60         #warn "caller = $caller";
  61
  62         import_into $caller, @_;
  63 }
  64
  65 sub report_pos {
  66         my ($offset, $name) = @_;
  67         $name ||= '';
  68         my $line = Devel::Declare::get_linestr();
  69         substr $line, $offset + 1, 0, "\x{20de}\e[m";
  70         substr $line, $offset, 0, "\e[31;1m";
  71         print STDERR "$name($offset)>> $line\n";
  72 }
  73
  74 sub _quote {
  75         my ($str) = @_;
  76         $str =~ s/([\$\@\\"])/\\$1/g;
  77         $str =~ s/\n/\\n/g;
  78         qq{"$str"}
  79 }
  80
  81 sub parser {
  82         my ($declarator, $start) = @_;
  83         my $offset = $start;
  84         my $line = Devel::Declare::get_linestr();
  85
  86         my $fail = do {
  87                 my $_file = PL_compiling->file;
  88                 my $_line = PL_compiling->line;
  89                 sub {
  90                         my $n = $_line + substr($line, $start, $offset - $start) =~ tr[\n][];
  91                         die join('', @_) . " at $_file line $n\n";
  92                 }
  93         };
  94
  95         my $atomically = sub {
  96                 my ($pars) = @_;
  97                 sub {
  98                         my $tmp = $offset;
  99                         my @ret = eval { $pars->(@_) };
 100                         if ($@) {
 101                                 $offset = $tmp;
 102                                 die $@;
 103                         }
 104                         wantarray ? @ret : $ret[0]
 105                 }
 106         };
 107
 108         my $try = sub {
 109                 my ($pars) = @_;
 110                 my @ret = eval { $pars->() };
 111                 if ($@) {
 112                         return;
 113                 }
 114                 wantarray ? @ret : $ret[0]
 115         };
 116
 117         my $skipws = sub {
 118                 #warn ">> $line";
 119                 my $skip = Devel::Declare::toke_skipspace($offset);
 120                 if ($skip < 0) {
 121                         $skip == -$offset or die "Internal error: offset=$offset, skip=$skip";
 122                         Devel::Declare::set_linestr($line);
 123                         return;
 124                 }
 125                 $line = Devel::Declare::get_linestr();
 126                 #warn "toke_skipspace($offset) = $skip\n== $line";
 127                 $offset += $skip;
 128         };
 129
 130         $offset += Devel::Declare::toke_move_past_token($offset);
 131         $skipws->();
 132         my $manip_start = $offset;
 133
 134         my $name;
 135         if (my $len = Devel::Declare::toke_scan_word($offset, 1)) {
 136                 $name = substr $line, $offset, $len;
 137                 $offset += $len;
 138                 $skipws->();
 139         }
 140
 141         my $peek_str = sub {
 142                 my ($str) = @_;
 143                 my $len = length $str;
 144                 substr($line, $offset, $len) eq $str
 145         };
 146
 147         my $scan_token = sub {
 148                 my ($str) = @_;
 149                 my $len = length $str;
 150                 substr($line, $offset, $len) eq $str or $fail->(qq{Missing "$str"});
 151                 $offset += $len;
 152                 $skipws->();
 153         };
 154
 155         my $scan_id = sub {
 156                 my $len = Devel::Declare::toke_scan_word($offset, 0) or $fail->('Missing identifier');
 157                 my $name = substr $line, $offset, $len;
 158                 $offset += $len;
 159                 $skipws->();
 160                 $name
 161         };
 162
 163         my $scan_var = $atomically->(sub {
 164                 (my $sigil = substr($line, $offset, 1)) =~ /^[\$\@%]\z/ or $fail->('Missing [$@%]');
 165                 $offset += 1;
 166                 $skipws->();
 167                 my $name = $scan_id->();
 168                 $sigil . $name
 169         });
 170
 171         my $separated_by = $atomically->(sub {
 172                 my ($sep, $pars) = @_;
 173                 my $len = length $sep;
 174                 defined(my $x = $try->($pars)) or return;
 175                 my @res = $x;
 176                 while () {
 177                         substr($line, $offset, $len) eq $sep or return @res;
 178                         $offset += $len;
 179                         $skipws->();
 180                         push @res, $pars->();
 181                 }
 182         });
 183
 184         my $many_till = $atomically->(sub {
 185                 my ($end, $pars) = @_;
 186                 my $len = length $end;
 187                 my @res;
 188                 until (substr($line, $offset, $len) eq $end) {
 189                         push @res, $pars->();
 190                 }
 191                 @res
 192         });
 193
 194         my $scan_params = $atomically->(sub {
 195                 if ($try->(sub { $scan_token->('('); 1 })) {
 196                         my @param = $separated_by->(',', $scan_var);
 197                         $scan_token->(')');
 198                         return @param;
 199                 }
 200                 $try->($scan_var)
 201         });
 202
 203         #report_pos $offset, "param";
 204         my @param = $scan_params->();
 205         my @extra;
 206         #report_pos $offset, "extra";
 207         while ($peek_str->('(')) {
 208                 push @extra, [$scan_params->()];
 209                 #report_pos $offset, "extra";
 210         }
 211
 212         my $scan_pargroup_opt = sub {
 213                 substr($line, $offset, 1) eq '(' or return '';
 214                 my $len = Devel::Declare::toke_scan_str($offset);
 215                 my $res = Devel::Declare::get_lex_stuff();
 216                 Devel::Declare::clear_lex_stuff();
 217                 $res eq '' and $fail->(qq{Can't find ")" anywhere before EOF});
 218                 $offset += $len;
 219                 $skipws->();
 220                 "($res)"
 221         };
 222
 223         my $scan_attr = sub {
 224                 my $name = $scan_id->();
 225                 my $param = $scan_pargroup_opt->() || '';
 226                 $name . $param
 227         };
 228
 229         my $scan_attributes = $atomically->(sub {
 230                 $try->(sub { $scan_token->(':'); 1 }) or return '', [];
 231                 my $proto = $scan_pargroup_opt->();
 232                 my @attrs = $many_till->('{', $scan_attr);
 233                 ' ' . $proto, \@attrs
 234         });
 235
 236         #report_pos $offset, "attr";
 237         my ($proto, $attributes) = $scan_attributes->();
 238         my $attr = @$attributes ? ' : ' . join(' ', @$attributes) : '';
 239
 240         #report_pos $offset, "'{'";
 241         $scan_token->('{');
 242
 243         my $manip_end = $offset;
 244         my $manip_len = $manip_end - $manip_start;
 245         #print STDERR "($manip_start:$manip_len:$manip_end)\n";
 246
 247         my $params = @param ? 'my (' . join(', ', @param) . ') = @_; ' : '';
 248         my $extra_a = join '', map 'sub { ' . (@$_ ? 'my (' . join(', ', @$_) . ') = @_; ' : ''), @extra;
 249         my $extra_z = '}' x @extra;
 250         #report_pos $offset;
 251         $proto =~ tr[\n][ ];
 252
 253         my $term = sub {
 254                 my ($str) = @_;
 255                 $str eq '' and return '';
 256                 'BEGIN { ' . __PACKAGE__ . '::_terminate_me(' . _quote($str) . '); } '
 257         };
 258
 259         if (defined $name) {
 260                 #print STDERR "($manip_start:$manip_len) [$line]\n";
 261                 substr $line, $manip_start, $manip_len, " do { sub $name$proto; sub $name$proto$attr { $params$extra_a${\$term->(qq[$extra_z \\&$name };])}";
 262         } else {
 263                 substr $line, $manip_start, $manip_len, " sub$proto$attr { $params$extra_a${\$term->(qq[$extra_z])}";
 264         }
 265         print STDERR ".> $line\n";
 266         Devel::Declare::set_linestr($line);
 267         print STDERR ".< $line\n";
 268 }
 269
 270 sub _terminate_me {
 271         print STDERR "..>\n";
 272         my ($str) = @_;
 273         on_scope_end {
 274                 my $line = Devel::Declare::get_linestr();
 275                 print STDERR "~~> $line\n";
 276                 my $offset = Devel::Declare::get_linestr_offset();
 277                 substr $line, $offset, 0, $str;
 278                 Devel::Declare::set_linestr($line);
 279                 print STDERR "??> $line\n";
 280         };
 281 }
 282
 283 1
 284
 285 __END__
 286
 287 =head1 NAME
 288
 289 Function::Parameters - subroutine definitions with parameter lists
 290
 291 =head1 SYNOPSIS
 292
 293  use Function::Parameters;
 294
 295  fun foo($x, $y) {
 296    return $x + $y;
 297  }
 298  foo(2, 3);  # 5
 299
 300  fun bar($x)($y) {
 301         return $x + $y;
 302  }
 303  bar(2)(3);  # 5
 304
 305  fun mymap($fun, @args) :(&@) {
 306    my @res;
 307    for (@args) {
 308      push @res, $fun->($_);
 309    }
 310    @res
 311  }
 312
 313  print "$_\n" for mymap { $_ * 2 } 1 .. 4;
 314
 315  use Function::Parameters 'proc';
 316  my $f = proc ($x) { $x * 2 };
 317
 318 =head1 DESCRIPTION
 319
 320 This module lets you use parameter lists in your subroutines. Thanks to
 321 L<Devel::Declare> it works without source filters.
 322
 323 WARNING: This is my first attempt at using L<Devel::Declare> and I have
 324 almost no experience with perl's internals. So while this module might
 325 appear to work, it could also conceivably make your programs segfault.
 326 Consider this module alpha quality.
 327
 328 =head2 Basic stuff
 329
 330 To use this new functionality, you have to use C<fun> instead of C<sub> -
 331 C<sub> continues to work as before. The syntax is almost the same as for
 332 C<sub>, but after the subroutine name (or directly after C<fun> if you're
 333 writing an anonymous sub) you can write a parameter list in parens. This
 334 list consists of comma-separated variables.
 335
 336 The effect of C<fun foo($bar, $baz) {> is as if you'd written
 337 C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply
 338 copied into C<my> and initialized from L<@_|perlvar/"@_">.
 339
 340 =head2 Autocurrying
 341
 342 You can actually use multiple parameter lists:
 343 C<fun foo(LIST1)(LIST2)(LIST3)...> is valid (and the parameter lists
 344 are completely separate). You use the same syntax to call the function:
 345 C<foo(1)(2, 3)(4, 5, 6)>.
 346
 347 What this actually does is to generate nested subs, each returning a reference
 348 to the next, as if you'd written
 349 C<fun foo(LIST1) { fun (LIST2) { fun (LIST3) { ... } } }>.
 350
 351 =head2 Advanced stuff
 352
 353 You can change the name of the new keyword from C<fun> to anything you want by
 354 specifying it in the import list, i.e. C<use Function::Parameters 'spork'> lets
 355 you write C<spork> instead of C<fun>.
 356
 357 If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, you can
 358 put them after the parameter list with their usual syntax. There's one
 359 exception, though: you can only use one colon (to start the attribute list);
 360 multiple attributes have to be separated by spaces.
 361
 362 Syntactically, these new parameter lists live in the spot normally occupied
 363 by L<prototypes|perlsub/"Prototypes">. However, you can include a prototype by
 364 specifying it as the first attribute (this is syntactically unambiguous
 365 because normal attributes have to start with a letter).
 366
 367 Normally, Perl subroutines are not in scope in their own body, meaning the
 368 parser doesn't know the name C<foo> or its prototype when processing
 369 C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
 370 C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
 371 interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
 372 a I<foo() called too early to check prototype> warning. This module attempts
 373 to fix all of this by adding a subroutine declaration before the definition,
 374 so the parser knows the name (and possibly prototype) while it processes the
 375 body. Thus C<fun foo($x) :($) { $x }> really turns into
 376 C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>.
 377
 378 If you want to wrap C<Function::Parameters>, you may find C<import_into>
 379 helpful. It lets you specify a target package for the syntax magic, as in:
 380
 381   package Some::Wrapper;
 382   use Function::Parameters ();
 383   sub import {
 384     my $caller = caller;
 385     Function::Parameters::import_into $caller;
 386     # or Function::Parameters::import_into $caller, 'other_keyword';
 387   }
 388
 389 C<import_into> is not exported by this module, so you have to use a fully
 390 qualified name to call it.
 391
 392 =head1 AUTHOR
 393
 394 Lukas Mai, C<< <l.mai at web.de> >>
 395
 396 =head1 COPYRIGHT & LICENSE
 397
 398 Copyright 2010 Lukas Mai.
 399
 400 This program is free software; you can redistribute it and/or modify it
 401 under the terms of either: the GNU General Public License as published
 402 by the Free Software Foundation; or the Artistic License.
 403
 404 See http://dev.perl.org/licenses/ for more information.
 405
 406 =cut