lib/Function/Parameters.pm

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