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