From: Lukas Mai Date: Tue, 19 Jun 2012 03:41:04 +0000 (+0200) Subject: Merge branch 'method-attr' into classmethod X-Git-Tag: v0.06~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=34bfa89e94e1f64d3dcdedfe55dedfe872acd119;hp=a23979e19f7ed9c169b640d6c1079bd4f2a1833f;p=p5sagit%2FFunction-Parameters.git Merge branch 'method-attr' into classmethod --- diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..32144ce --- /dev/null +++ b/.gitignore @@ -0,0 +1,13 @@ +MANIFEST.bak +MYMETA.* +MYMETA.yml +Makefile +Makefile.old +Parameters.bs +Parameters.c +Parameters.o +Parameters.i +blib/ +pm_to_blib +*.tar.gz +/Function-Parameters-*/ diff --git a/Changes b/Changes index 2970d2d..bcaff46 100644 --- a/Changes +++ b/Changes @@ -3,19 +3,19 @@ Revision history for Function-Parameters 0.05_02 2012-06-17 - complete rewrite in XS - hopefully fix bug where it would get the line numbers wrong - - lexical pragma, remove import_into - - requires perl 5.14+ + - we're a lexical pragma now; remove import_into() + - require perl 5.14+ 0.05 2011-08-02 - complete rewrite - hopefully fix bug where it would swallow compilation errors or get the line numbers wrong - method keyword! - more flexible keyword customization - + 0.04 2010-03-03 - allow renaming the function keyword - provide import_into so you can mess with other packages - + 0.03 2009-12-14 First version, released on an unsuspecting world. diff --git a/Parameters.xs b/Parameters.xs index 0e7cc2c..4e9a214 100644 --- a/Parameters.xs +++ b/Parameters.xs @@ -301,10 +301,10 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len sv_catpvs(gen, ")=@_;"); } - /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ /* named sub */ if (saw_name) { + /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ lex_stuff_sv(gen, SvUTF8(gen)); *pop = parse_barestmt(0); return KEYWORD_PLUGIN_STMT; @@ -312,6 +312,7 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len /* anon sub */ sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}"); + /* fprintf(stderr, "!> [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ lex_stuff_sv(gen, SvUTF8(gen)); *pop = parse_arithexpr(0); s = PL_parser->bufptr; @@ -319,6 +320,7 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s); } lex_unstuff(s + 1); + /* fprintf(stderr, "!< [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ return KEYWORD_PLUGIN_EXPR; } @@ -341,6 +343,7 @@ static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **o static int magic_free(pTHX_ SV *sv, MAGIC *mg) { lex_stuff_pvn("}", 1, 0); + /* fprintf(stderr, "!~ [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ return 0; } diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm index 3a47996..5402a4d 100644 --- a/lib/Function/Parameters.pm +++ b/lib/Function/Parameters.pm @@ -61,29 +61,38 @@ sub import { ? $proto : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})] ; - my ($name, $type) = @$item; + my ($name, $proto_type) = @$item; _assert_valid_identifier $name; - unless (ref $type) { - # use '||' instead of 'or' to preserve $type in the error message - $type = $type_map{$type} - || confess qq["$type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})]; + unless (ref $proto_type) { + # use '||' instead of 'or' to preserve $proto_type in the error message + $proto_type = $type_map{$proto_type} + || confess qq["$proto_type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})]; } - $type->{name} ||= 'optional'; - $type->{name} =~ /^(?:optional|required|prohibited)\z/ - or confess qq["$type->{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)]; - $type->{shift} and _assert_valid_identifier $type->{shift}, 1; - $type->{attrs} and _assert_valid_attributes $type->{attrs}; + my %type = %$proto_type; + my %clean; + + $clean{name} = delete $type{name} || 'optional'; + $clean{name} =~ /^(?:optional|required|prohibited)\z/ + or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)]; + + $clean{shift} = delete $type{shift} || ''; + _assert_valid_identifier $clean{shift}, 1 if $clean{shift}; + + $clean{attrs} = delete $type{attrs} || ''; + _assert_valid_attributes $clean{attrs} if $clean{attrs}; - $spec{$name} = $type; + %type and confess "Invalid keyword property: @{[keys %type]}"; + + $spec{$name} = \%clean; } for my $kw (keys %spec) { my $type = $spec{$kw}; - $^H{HINTK_SHIFT_ . $kw} = $type->{shift} || ''; - $^H{HINTK_ATTRS_ . $kw} = $type->{attrs} || ''; + $^H{HINTK_SHIFT_ . $kw} = $type->{shift}; + $^H{HINTK_ATTRS_ . $kw} = $type->{attrs}; $^H{HINTK_NAME_ . $kw} = $type->{name} eq 'prohibited' ? FLAG_NAME_PROHIBITED : $type->{name} eq 'required' ? FLAG_NAME_REQUIRED : diff --git a/t/attrs.t b/t/attrs.t new file mode 100644 index 0000000..437d457 --- /dev/null +++ b/t/attrs.t @@ -0,0 +1,55 @@ +#!perl + +use Test::More tests => 10; + +use warnings FATAL => 'all'; +use strict; + +use Function::Parameters { + fun => 'function', + method => 'method', + elrond => { + attrs => ':lvalue', + }, +}; + +is eval('use Function::Parameters { fun => { attrs => "nope" } }; 1'), undef; +like $@, qr/nope.*attributes/; + +is eval('use Function::Parameters { fun => { attrs => ": in valid {" } }; 1'), undef; +like $@, qr/in valid.*attributes/; + +elrond hobbard($ref) { $$ref } +{ + my $x = 1; + hobbard(\$x) = 'bling'; + is $x, 'bling'; + +} +$_ = 'fool'; +chop hobbard \$_; +is $_, 'foo'; + +{ + package BatCountry; + + fun join($group, $peer) { + return "* $peer has joined $group"; + } + + ::is eval('join("left", "right")'), undef; + ::like $@, qr/Ambiguous.*CORE::/; +} + +{ + package CatCountry; + + method join($peer) { + return "* $peer has joined $self->{name}"; + } + + ::is join('!', 'left', 'right'), 'left!right'; + + my $obj = bless {name => 'kittens'}; + ::is $obj->join("twig"), "* twig has joined kittens"; +} diff --git a/t/eating_strict_error.fail b/t/eating_strict_error.fail index 8048652..ab33eee 100644 --- a/t/eating_strict_error.fail +++ b/t/eating_strict_error.fail @@ -1,3 +1,4 @@ +#!perl use strict; use Function::Parameters; @@ -9,3 +10,4 @@ fun get_record( $agent, $target_name ) { fun get_ip( $agent ) { } +'ok' diff --git a/t/eating_strict_error.t b/t/eating_strict_error.t index d9cf187..2412110 100644 --- a/t/eating_strict_error.t +++ b/t/eating_strict_error.t @@ -7,8 +7,9 @@ use strict; use Dir::Self; -for my $thing (map [__DIR__ . "/eating_strict_error$_->[0].fail", @$_[1 .. $#$_]], ['', 5], ['_2', 8]) { +for my $thing (map [__DIR__ . "/eating_strict_error$_->[0].fail", @$_[1 .. $#$_]], ['', 6], ['_2', 9]) { my ($file, $line) = @$thing; + $@ = undef; my $done = do $file; my $exc = $@; my $err = $!; diff --git a/t/eating_strict_error_2.fail b/t/eating_strict_error_2.fail index 22cdfcf..590c5c6 100644 --- a/t/eating_strict_error_2.fail +++ b/t/eating_strict_error_2.fail @@ -1,3 +1,4 @@ +#!perl use strict; use Function::Parameters; @@ -9,3 +10,4 @@ fun get_record( $agent, $target_name ) { } } +'ok' diff --git a/t/lexical.t b/t/lexical.t new file mode 100644 index 0000000..69382ef --- /dev/null +++ b/t/lexical.t @@ -0,0 +1,62 @@ +#!perl + +use Test::More tests => 16; + +use warnings FATAL => 'all'; +use strict; + +sub Burlap::fun (&) { $_[0]->() } + +{ + use Function::Parameters; + + is fun { 2 + 2 }->(), 4; + + package Burlap; + + ::ok fun { 0 }; +} + +{ + package Burlap; + + ::is fun { 'singing' }, 'singing'; +} + +{ + sub proc (&) { &Burlap::fun } + + use Function::Parameters { proc => 'function' }; + + proc add($x, $y) { + return $x + $y; + } + + is add(@{[2, 3]}), 5; + + { + use Function::Parameters; + + is proc () { 'bla' }->(), 'bla'; + is method () { $self }->('der'), 'der'; + + { + no Function::Parameters; + + is proc { 'unk' }, 'unk'; + + is eval('fun foo($x) { $x; } 1'), undef; + like $@, qr/syntax error/; + } + + is proc () { 'bla' }->(), 'bla'; + is method () { $self }->('der'), 'der'; + + no Function::Parameters 'proc'; + is proc { 'unk2' }, 'unk2'; + is method () { $self }->('der2'), 'der2'; + } + is proc () { 'bla3' }->(), 'bla3'; + is eval('fun foo($x) { $x; } 1'), undef; + like $@, qr/syntax error/; +} diff --git a/t/precedence.t b/t/precedence.t new file mode 100644 index 0000000..c988bab --- /dev/null +++ b/t/precedence.t @@ -0,0 +1,31 @@ +#!perl + +use Test::More tests => 11; + +use warnings FATAL => 'all'; +use strict; + +use Function::Parameters; + +fun four { 2 + 2 } fun five() { 1 + four } + +fun quantum :() {; 0xf00d +} + +is four, 4, "basic sanity 1"; +is five, 5, "basic sanity 2"; +is quantum, 0xf00d, "basic sanity 3"; +is quantum / 2 #/ +, 0xf00d / 2, "basic sanity 4 - () proto"; + +is eval('my $x = fun forbidden {}'), undef, "statements aren't expressions"; +like $@, qr/syntax error/; + +is eval('my $x = { fun forbidden {} }'), undef, "statements aren't expressions 2 - electric boogaloo"; +like $@, qr/syntax error/; + +is fun { join '.', five, four }->(), '5.4', "can immedicall anon subs"; + +is 0 * fun {} + 42, 42, "* binds tighter than +"; +is 0 * fun { quantum / q#/ } +# } + 42, 42, "* binds tighter than + 2 - electric boogaloo"; diff --git a/t/strict.t b/t/strict.t index 4ebc8d8..e06f04a 100644 --- a/t/strict.t +++ b/t/strict.t @@ -1,7 +1,7 @@ use warnings; use strict; -use Test::More tests => 8; +use Test::More tests => 10; use Dir::Self; @@ -11,8 +11,10 @@ for my $fail ( ['2', qr/expect.*\).*after.*"\@x".*"\$y"/], ['3', qr/expect.*\).*after.*"%y".*"\$z"/], ['4', qr/expect.*\).*after.*"\@y".*"\@z"/], + ['5', qr/Invalid.*rarity/], ) { my ($file, $pat) = @$fail; + $@ = undef; my $done = do $file; my $exc = $@; my $err = $!; diff --git a/t/strict_1.fail b/t/strict_1.fail index 6a9cfcd..0d89714 100644 --- a/t/strict_1.fail +++ b/t/strict_1.fail @@ -5,3 +5,5 @@ use strict; use Function::Parameters; fun bad_1($x, @y, $z) {} + +'ok' diff --git a/t/strict_2.fail b/t/strict_2.fail index edbc47b..bcd57cb 100644 --- a/t/strict_2.fail +++ b/t/strict_2.fail @@ -5,3 +5,5 @@ use strict; use Function::Parameters; fun bad_2(@x, $y) {} + +'ok' diff --git a/t/strict_3.fail b/t/strict_3.fail index 3560b99..b065e18 100644 --- a/t/strict_3.fail +++ b/t/strict_3.fail @@ -5,3 +5,5 @@ use strict; use Function::Parameters; fun bad_3($x, %y, $z) {} + +'ok' diff --git a/t/strict_4.fail b/t/strict_4.fail index 203afd5..dbfff82 100644 --- a/t/strict_4.fail +++ b/t/strict_4.fail @@ -5,3 +5,5 @@ use strict; use Function::Parameters; fun bad_4(@y, @z) {} + +'ok' diff --git a/t/strict_5.fail b/t/strict_5.fail new file mode 100644 index 0000000..9f09951 --- /dev/null +++ b/t/strict_5.fail @@ -0,0 +1,11 @@ +#!perl +use warnings; +use strict; + +use Function::Parameters { + spike => { + rarity => 'best', + }, +}; + +'ok'