From: Lukas Mai Date: Sun, 28 Feb 2010 21:19:03 +0000 (+0100) Subject: initial import X-Git-Tag: v0.04~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7a63380c0b53866e900e842840736a040f733eb7;p=p5sagit%2FFunction-Parameters.git initial import --- 7a63380c0b53866e900e842840736a040f733eb7 diff --git a/Changes b/Changes new file mode 100644 index 0000000..082ac95 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Function-Parameters + +0.03 2009-12-14 + First version, released on an unsuspecting world. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..cf1abca --- /dev/null +++ b/MANIFEST @@ -0,0 +1,8 @@ +Changes +MANIFEST +Makefile.PL +README +lib/Function/Parameters.pm +t/pod.t +t/00-load.t +t/01-compiles.t diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..51e68a0 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,24 @@ +use strict; +use warnings; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Function::Parameters', + AUTHOR => q{Lukas Mai }, + VERSION_FROM => 'lib/Function/Parameters.pm', + ABSTRACT_FROM => 'lib/Function/Parameters.pm', + ($ExtUtils::MakeMaker::VERSION >= 6.3002 + ? ('LICENSE'=> 'perl') + : ()), + PL_FILES => {}, + PREREQ_PM => { + 'Test::More' => 0, + 'warnings' => 0, + 'strict' => 0, + 'Devel::Declare' => 0, + 'B::Hooks::EndOfScope' => 0, + 'B::Compiling' => 0, + }, + dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, + clean => { FILES => 'Function-Parameters-*' }, +); diff --git a/README b/README new file mode 100644 index 0000000..b5e7069 --- /dev/null +++ b/README @@ -0,0 +1,46 @@ +Function-Parameters + +Simple parameter lists for perl subroutines. + + +INSTALLATION + +To install this module, run the following commands: + + perl Makefile.PL + make + make test + make install + +SUPPORT AND DOCUMENTATION + +After installing, you can find documentation for this module with the +perldoc command. + + perldoc Function::Parameters + +You can also look for information at: + + RT, CPAN's request tracker + http://rt.cpan.org/NoAuth/Bugs.html?Dist=Function-Parameters + + AnnoCPAN, Annotated CPAN documentation + http://annocpan.org/dist/Function-Parameters + + CPAN Ratings + http://cpanratings.perl.org/d/Function-Parameters + + Search CPAN + http://search.cpan.org/dist/Function-Parameters/ + + +COPYRIGHT AND LICENCE + +Copyright (C) 2009 Lukas Mai + +This program is free software; you can redistribute it and/or modify it +under the terms of either: the GNU General Public License as published +by the Free Software Foundation; or the Artistic License. + +See http://dev.perl.org/licenses/ for more information. + diff --git a/ignore.txt b/ignore.txt new file mode 100644 index 0000000..319a58f --- /dev/null +++ b/ignore.txt @@ -0,0 +1,10 @@ +blib* +Makefile +Makefile.old +Build +_build* +pm_to_blib* +*.tar.gz +.lwpcookies +Function-Parameters-* +cover_db diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm new file mode 100644 index 0000000..6d5a148 --- /dev/null +++ b/lib/Function/Parameters.pm @@ -0,0 +1,316 @@ +package Function::Parameters; + +use strict; +use warnings; + +our $VERSION = '0.03'; + +use Devel::Declare; +use B::Hooks::EndOfScope; +use B::Compiling; + +sub guess_caller { + my ($start) = @_; + $start ||= 1; + + my $defcaller = (caller $start)[0]; + my $caller = $defcaller; + + for (my $level = $start; ; ++$level) { + my ($pkg, $function) = (caller $level)[0, 3] or last; + #warn "? $pkg, $function"; + $function =~ /::import\z/ or return $caller; + $caller = $pkg; + } + $defcaller +} + +sub _fun ($) { $_[0] } + +sub import { + my $class = shift; + my $caller = guess_caller; + #warn "caller = $caller"; + + Devel::Declare->setup_for( + $caller, + { fun => { const => \&parser } } + ); + + no strict 'refs'; + *{$caller . '::fun'} = \&_fun; +} + +sub report_pos { + my ($offset, $name) = @_; + $name ||= ''; + my $line = Devel::Declare::get_linestr(); + substr $line, $offset + 1, 0, "\x{20de}\e[m"; + substr $line, $offset, 0, "\e[31;1m"; + print STDERR "$name($offset)>> $line\n"; +} + +sub parser { + my ($declarator, $start) = @_; + my $offset = $start; + my $line = Devel::Declare::get_linestr(); + + my $fail = do { + my $_file = PL_compiling->file; + my $_line = PL_compiling->line; + sub { + my $n = $_line + substr($line, $start, $offset - $start) =~ tr[\n][]; + die join('', @_) . " at $_file line $n\n"; + } + }; + + my $atomically = sub { + my ($pars) = @_; + sub { + my $tmp = $offset; + my @ret = eval { $pars->(@_) }; + if ($@) { + $offset = $tmp; + die $@; + } + wantarray ? @ret : $ret[0] + } + }; + + my $try = sub { + my ($pars) = @_; + my @ret = eval { $pars->() }; + if ($@) { + return; + } + wantarray ? @ret : $ret[0] + }; + + my $skipws = sub { + #warn ">> $line"; + my $skip = Devel::Declare::toke_skipspace($offset); + if ($skip < 0) { + $skip == -$offset or die "Internal error: offset=$offset, skip=$skip"; + Devel::Declare::set_linestr($line); + return; + } + $line = Devel::Declare::get_linestr(); + #warn "toke_skipspace($offset) = $skip\n== $line"; + $offset += $skip; + }; + + $offset += Devel::Declare::toke_move_past_token($offset); + $skipws->(); + my $manip_start = $offset; + + my $name; + if (my $len = Devel::Declare::toke_scan_word($offset, 1)) { + $name = substr $line, $offset, $len; + $offset += $len; + $skipws->(); + } + + my $scan_token = sub { + my ($str) = @_; + my $len = length $str; + substr($line, $offset, $len) eq $str or $fail->(qq{Missing "$str"}); + $offset += $len; + $skipws->(); + }; + + my $scan_id = sub { + my $len = Devel::Declare::toke_scan_word($offset, 0) or $fail->('Missing identifier'); + my $name = substr $line, $offset, $len; + $offset += $len; + $skipws->(); + $name + }; + + my $scan_var = $atomically->(sub { + (my $sigil = substr($line, $offset, 1)) =~ /^[\$\@%]\z/ or $fail->('Missing [$@%]'); + $offset += 1; + $skipws->(); + my $name = $scan_id->(); + $sigil . $name + }); + + my $separated_by = $atomically->(sub { + my ($sep, $pars) = @_; + my $len = length $sep; + defined(my $x = $try->($pars)) or return; + my @res = $x; + while () { + substr($line, $offset, $len) eq $sep or return @res; + $offset += $len; + $skipws->(); + push @res, $pars->(); + } + }); + + my $many_till = $atomically->(sub { + my ($end, $pars) = @_; + my $len = length $end; + my @res; + until (substr($line, $offset, $len) eq $end) { + push @res, $pars->(); + } + @res + }); + + my $scan_params = $atomically->(sub { + if ($try->(sub { $scan_token->('('); 1 })) { + my @param = $separated_by->(',', $scan_var); + $scan_token->(')'); + return @param; + } + $try->($scan_var) + }); + + my @param = $scan_params->(); + + my $scan_pargroup_opt = sub { + substr($line, $offset, 1) eq '(' or return ''; + my $len = Devel::Declare::toke_scan_str($offset); + my $res = Devel::Declare::get_lex_stuff(); + Devel::Declare::clear_lex_stuff(); + $res eq '' and $fail->(qq{Can't find ")" anywhere before EOF}); + $offset += $len; + $skipws->(); + "($res)" + }; + + my $scan_attr = sub { + my $name = $scan_id->(); + my $param = $scan_pargroup_opt->() || ''; + $name . $param + }; + + my $scan_attributes = $atomically->(sub { + $try->(sub { $scan_token->(':'); 1 }) or return '', []; + my $proto = $scan_pargroup_opt->(); + my @attrs = $many_till->('{', $scan_attr); + ' ' . $proto, \@attrs + }); + + my ($proto, $attributes) = $scan_attributes->(); + my $attr = @$attributes ? ' : ' . join(' ', @$attributes) : ''; + + $scan_token->('{'); + + my $manip_end = $offset; + my $manip_len = $manip_end - $manip_start; + #print STDERR "($manip_start:$manip_len:$manip_end)\n"; + + my $params = @param ? 'my (' . join(', ', @param) . ') = @_;' : ''; + #report_pos $offset; + $proto =~ tr[\n][ ]; + + if (defined $name) { + my $pkg = __PACKAGE__; + #print STDERR "($manip_start:$manip_len) [$line]\n"; + substr $line, $manip_start, $manip_len, " do { sub $name$proto; sub $name$proto$attr { BEGIN { ${pkg}::terminate_me(q[$name]); } $params "; + } else { + substr $line, $manip_start, $manip_len, " sub$proto$attr { $params "; + } + #print STDERR ".> $line\n"; + Devel::Declare::set_linestr($line); +} + +sub terminate_me { + my ($name) = @_; + on_scope_end { + my $line = Devel::Declare::get_linestr(); + #print STDERR "~~> $line\n"; + my $offset = Devel::Declare::get_linestr_offset(); + substr $line, $offset, 0, " \\&$name };"; + Devel::Declare::set_linestr($line); + #print STDERR "??> $line\n"; + }; +} + +1 + +__END__ + +=head1 NAME + +Function::Parameters - subroutine definitions with parameter lists + +=head1 SYNOPSIS + + use Function::Parameters; + + fun foo($bar, $baz) { + return $bar + $baz; + } + + fun mymap($fun, @args) :(&@) { + my @res; + for (@args) { + push @res, $fun->($_); + } + @res + } + + print "$_\n" for mymap { $_ * 2 } 1 .. 4; + +=head1 DESCRIPTION + +This module lets you use parameter lists in your subroutines. Thanks to +L it works without source filters. + +WARNING: This is my first attempt at using L and I have +almost no experience with perl's internals. So while this module might +appear to work, it could also conceivably make your programs segfault. +Consider this module alpha quality. + +=head2 Basic stuff + +To use this new functionality, you have to use C instead of C - +C continues to work as before. The syntax is almost the same as for +C, but after the subroutine name (or directly after C if you're +writing an anonymous sub) you can write a parameter list in parens. This +list consists of comma-separated variables. + +The effect of C is as if you'd written +C, i.e. the parameter list is simply +copied into C and initialized from L<@_|perlvar/"@_">. + +=head2 Advanced stuff + +If you need L, you can +put them after the parameter list with their usual syntax. There's one +exception, though: you can only use one colon (to start the attribute list); +multiple attributes have to be separated by spaces. + +Syntactically, these new parameter lists live in the spot normally occupied +by L. However, you can include a prototype by +specifying it as the first attribute (this is syntactically unambiguous +because normal attributes have to start with a letter). + +Normally, Perl subroutines are not in scope in their own body, meaning the +parser doesn't know the name C or its prototype when processing +C, parsing it as +C<$bar-Efoo([1], $bar[0])>. Yes. You can add parens to change the +interpretation of this code, but C will only trigger +a I warning. This module attempts +to fix all of this by adding a subroutine declaration before the definition, +so the parser knows the name (and possibly prototype) while it processes the +body. Thus C really turns into +C. + +=head1 AUTHOR + +Lukas Mai, C<< >> + +=head1 COPYRIGHT & LICENSE + +Copyright 2009 Lukas Mai. + +This program is free software; you can redistribute it and/or modify it +under the terms of either: the GNU General Public License as published +by the Free Software Foundation; or the Artistic License. + +See http://dev.perl.org/licenses/ for more information. + +=cut diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..2fdf461 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,9 @@ +#!perl -T + +use Test::More tests => 1; + +BEGIN { + use_ok( 'Function::Parameters' ); +} + +diag( "Testing Function::Parameters $Function::Parameters::VERSION, Perl $], $^X" ); diff --git a/t/01-compiles.t b/t/01-compiles.t new file mode 100644 index 0000000..89129eb --- /dev/null +++ b/t/01-compiles.t @@ -0,0 +1,60 @@ +#!perl + +use Test::More tests => 10; + +use warnings FATAL => 'all'; +use strict; + +use Function::Parameters; + +fun id_1($x) { $x } + +fun id_2 + ( + $x + ) + : + ( + $ + ) + { + $x + } + +fun id_3 ## + ( $x ## + ) ## + { ## + $x ## + } ## + +fun add($x, $y) { + $x + $y +} + +fun mymap($fun, @args) :(&@) { + my @res; + for (@args) { + push @res, $fun->($_); + } + @res +} + +fun fac_1($n) { + $n < 2 ? 1 : $n * fac_1 $n - 1 +} + +fun fac_2($n) :($) { + $n < 2 ? 1 : $n * fac_2 $n - 1 +} + +ok id_1 1; +ok id_1(1), 'basic sanity'; +ok id_2 1, 'simple prototype'; +ok id_3(1), 'definition over multiple lines'; +is add(2, 2), 4, '2 + 2 = 4'; +is add(39, 3), 42, '39 + 3 = 42'; +is_deeply [mymap { $_ * 2 } 2, 3, 5, 9], [4, 6, 10, 18], 'mymap works'; +is fac_1(5), 120, 'fac_1'; +is fac_2 6, 720, 'fac_2'; +is fun ($x, $y) { $x . $y }->(fun ($foo) { $foo + 1 }->(3), fun ($bar) { $bar * 2 }->(1)), '42', 'anonyfun'; diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..ee8b18a --- /dev/null +++ b/t/pod.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.22; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +all_pod_files_ok();