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