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