From: Lukas Mai Date: Sun, 21 Oct 2012 16:29:21 +0000 (+0200) Subject: implement $invocant: syntax X-Git-Tag: v0.10~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d8e5d54068b89a5b18cfd3a38c8c9f38a1c54df1;p=p5sagit%2FFunction-Parameters.git implement $invocant: syntax --- diff --git a/MANIFEST b/MANIFEST index cd62cf6..4470c4c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -22,6 +22,7 @@ t/eating_strict_error.t t/eating_strict_error_2.fail t/elsewhere.t t/imports.t +t/invocant.t t/lexical.t t/lineno-torture.t t/lineno.t diff --git a/Parameters.xs b/Parameters.xs index 36c7ed3..2031f0b 100644 --- a/Parameters.xs +++ b/Parameters.xs @@ -83,7 +83,8 @@ enum { FLAG_NAME_OK = 0x01, FLAG_ANON_OK = 0x02, FLAG_DEFAULT_ARGS = 0x04, - FLAG_CHECK_NARGS = 0x08 + FLAG_CHECK_NARGS = 0x08, + FLAG_INVOCANT = 0x10 }; DEFSTRUCT(KWSpec) { @@ -442,6 +443,8 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len int save_ix; SV *saw_name; OP **prelude_sentinel; + int did_invocant_decl; + SV *invocant; AV *params; DefaultParamSpec *defaults; int args_min, args_max; @@ -499,21 +502,13 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len SAVEDESTRUCTOR_X(free_ptr_op, prelude_sentinel); /* parameters */ + did_invocant_decl = 0; + invocant = NULL; params = NULL; defaults = NULL; args_min = 0; args_max = -1; - /* my $self; */ - if (SvTRUE(spec->shift)) { - OP *var; - - var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); - var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL); - - *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); - } - c = lex_peek_unichar(0); if (c == '(') { DefaultParamSpec **pdefaults_tail = &defaults; @@ -551,39 +546,78 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len args_max = -1; saw_slurpy = param; } - av_push(params, SvREFCNT_inc_simple_NN(param)); - lex_read_space(0); + lex_read_space(0); c = lex_peek_unichar(0); - if (!(c == '=' && (spec->flags & FLAG_DEFAULT_ARGS))) { - if (sigil == '$' && !defaults) { - args_min++; + assert(param_count >= 1); + + if (c == ':') { + if (invocant) { + croak("In %"SVf": invalid double invocants %"SVf", %"SVf"", SVfARG(declarator), SVfARG(invocant), SVfARG(param)); + } + if (param_count != 1) { + croak("In %"SVf": invocant %"SVf" must be first in parameter list", SVfARG(declarator), SVfARG(param)); + } + if (!(spec->flags & FLAG_INVOCANT)) { + croak("In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(param)); + } + if (sigil != '$') { + croak("In %"SVf": invocant %"SVf" can't be a %s", SVfARG(declarator), SVfARG(param), sigil == '@' ? "array" : "hash"); } - } else if (sigil != '$') { - croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(saw_slurpy)); - } else { - DefaultParamSpec *curdef; lex_read_unichar(0); lex_read_space(0); - Newx(curdef, 1, DefaultParamSpec); - curdef->next = NULL; - curdef->limit = param_count; - curdef->name = param; - curdef->init = NULL; - SAVEDESTRUCTOR_X(free_defspec, curdef); + args_max--; + param_count--; + invocant = param; + } else { + av_push(params, SvREFCNT_inc_simple_NN(param)); + + if (c == '=' && (spec->flags & FLAG_DEFAULT_ARGS)) { + DefaultParamSpec *curdef; - curdef->next = *pdefaults_tail; - *pdefaults_tail = curdef; - pdefaults_tail = &curdef->next; + if (sigil != '$') { + croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(saw_slurpy)); + } - /* let perl parse the default parameter value */ - curdef->init = parse_termexpr(0); + lex_read_unichar(0); + lex_read_space(0); - lex_read_space(0); - c = lex_peek_unichar(0); + /* my $self; # in scope for default argument */ + if (!invocant && !did_invocant_decl && SvTRUE(spec->shift)) { + OP *var; + + var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); + var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL); + + *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); + + did_invocant_decl = 1; + } + + Newx(curdef, 1, DefaultParamSpec); + curdef->next = NULL; + curdef->limit = param_count; + curdef->name = param; + curdef->init = NULL; + SAVEDESTRUCTOR_X(free_defspec, curdef); + + curdef->next = *pdefaults_tail; + *pdefaults_tail = curdef; + pdefaults_tail = &curdef->next; + + /* let perl parse the default parameter value */ + curdef->init = parse_termexpr(0); + + lex_read_space(0); + c = lex_peek_unichar(0); + } else { + if (sigil == '$' && !defaults) { + args_min++; + } + } } /* my $param; */ @@ -596,6 +630,10 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); } + if (param_count == 0) { + continue; + } + if (c == ',') { lex_read_unichar(0); lex_read_space(0); @@ -734,9 +772,23 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len CvSPECIAL_on(PL_compcv); } + if (!invocant) { + invocant = spec->shift; + + /* my $self; # wasn't needed yet */ + if (SvTRUE(invocant) && !did_invocant_decl) { + OP *var; + + var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); + var->op_targ = pad_add_name_sv(invocant, 0, NULL, NULL); + + *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); + } + } + /* min/max argument count checks */ if (spec->flags & FLAG_CHECK_NARGS) { - if (SvTRUE(spec->shift)) { + if (SvTRUE(invocant)) { args_min++; if (args_max != -1) { args_max++; @@ -782,11 +834,11 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len } /* $self = shift; */ - if (SvTRUE(spec->shift)) { + if (SvTRUE(invocant)) { OP *var, *shift; var = newOP(OP_PADSV, OPf_WANT_SCALAR); - var->op_targ = pad_findmy_sv(spec->shift, 0); + var->op_targ = pad_findmy_sv(invocant, 0); shift = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0)); *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, shift)); @@ -917,14 +969,15 @@ BOOT: WARNINGS_ENABLE { HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); /**/ - newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK)); - newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK)); + newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK)); + newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK)); newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS)); - newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS)); + newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS)); + newCONSTSUB(stash, "FLAG_INVOCANT", newSViv(FLAG_INVOCANT)); newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); - newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_)); - newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); - newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_)); + newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_)); + newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); + newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_)); /**/ next_keyword_plugin = PL_keyword_plugin; PL_keyword_plugin = my_keyword_plugin; diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm index c3d7125..3c15410 100644 --- a/lib/Function/Parameters.pm +++ b/lib/Function/Parameters.pm @@ -39,6 +39,7 @@ my %type_map = ( check_argument_count => 0, attrs => ':method', shift => '$self', + invocant => 1, }, classmethod => { name => 'optional', @@ -46,6 +47,7 @@ my %type_map = ( check_argument_count => 0, attributes => ':method', shift => '$class', + invocant => 1, }, ); for my $k (keys %type_map) { @@ -110,6 +112,7 @@ sub import { : 1 ; $clean{check_argument_count} = !!delete $type{check_argument_count}; + $clean{invocant} = !!delete $type{invocant}; %type and confess "Invalid keyword property: @{[keys %type]}"; @@ -126,6 +129,7 @@ sub import { ; $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments}; $flags |= FLAG_CHECK_NARGS if $type->{check_argument_count}; + $flags |= FLAG_INVOCANT if $type->{invocant}; $^H{HINTK_FLAGS_ . $kw} = $flags; $^H{HINTK_SHIFT_ . $kw} = $type->{shift}; $^H{HINTK_ATTRS_ . $kw} = $type->{attrs}; @@ -183,12 +187,17 @@ Function::Parameters - subroutine definitions with parameter lists method set_name($name) { $self->{name} = $name; } - + + # method with explicit invocant + method new($class: %init) { + return bless { %init }, $class; + } + # function with default arguments fun search($haystack, $needle = qr/^(?!)/, $offset = 0) { ... } - + # method with default arguments method skip($amount = 1) { $self->{position} += $amount; @@ -318,6 +327,17 @@ Valid values: strings that look like a scalar variable. Any function created by this keyword will automatically L its first argument into a local variable whose name is specified here. +=item C + +Valid values: booleans. This lets users of this keyword specify an explicit +invocant, that is, the first parameter may be followed by a C<:> (colon) +instead of a comma and will by initialized by shifting the first element off +C<@_>. + +You can combine C and C, in which case the variable named in +C serves as a default shift target for functions that don't use an +explicit invocant. + =item C, C Valid values: strings that are valid source code for attributes. Any value @@ -412,6 +432,7 @@ C<'method'> is equivalent to: check_argument_count => 0, attributes => ':method', shift => '$self', + invocant => 1, } C<'method_strict'> is like C<'method'> but with @@ -425,6 +446,7 @@ C<'classmethod'> is equivalent to: check_argument_count => 0, attributes => ':method', shift => '$class', + invocant => 1, } C<'classmethod_strict'> is like C<'classmethod'> but with @@ -454,9 +476,10 @@ with C<(>). As an example, the following declaration uses every available feature (subroutine name, parameter list, default arguments, prototype, default -attributes, attributes, argument count checks, and implicit C<$self>): +attributes, attributes, argument count checks, and implicit C<$self> overriden +by an explicit invocant declaration): - method foo($x, $y, $z = sqrt 5) + method foo($this: $x, $y, $z = sqrt 5) :($$$;$) :lvalue :Banana(2 + 2) @@ -470,7 +493,7 @@ And here's what it turns into: sub foo ($$$;$); Carp::croak "Not enough arguments for method foo" if @_ < 3; Carp::croak "Too many arguments for method foo" if @_ > 4; - my $self = shift; + my $this = shift; my ($x, $y, $z) = @_; $z = sqrt 5 if @_ < 3; ... diff --git a/t/invocant.t b/t/invocant.t new file mode 100644 index 0000000..6af02ae --- /dev/null +++ b/t/invocant.t @@ -0,0 +1,80 @@ +#!perl + +use Test::More tests => 25; + +use warnings FATAL => 'all'; +use strict; + +use Function::Parameters { fun => 'function_strict', method => 'method_strict' }; + +{ + package Foo; + + method new($class : ) { + return bless { + x => 1, + y => 2, + z => 3, + }, $class; + } + + method get_x() { $self->{x} } + method get_y($self:) { $self->{y} } + method get_z($this:) { $this->{z} } + + method set_x($val) { $self->{x} = $val; } + method set_y($self:$val) { $self->{y} = $val; } + method set_z($this: $val) { $this->{z} = $val; } +} + +my $o = Foo->new; +ok $o->isa('Foo'), "Foo->new->isa('Foo')"; + +is $o->get_x, 1; +is $o->get_y, 2; +is $o->get_z, 3; + +$o->set_x("A"); +$o->set_y("B"); +$o->set_z("C"); + +is $o->get_x, "A"; +is $o->get_y, "B"; +is $o->get_z, "C"; + +is eval { $o->get_z(42) }, undef; +like $@, qr/many arguments/; + +is eval { $o->set_z }, undef; +like $@, qr/enough arguments/; + +is eval q{fun ($self:) {}}, undef; +like $@, qr/invocant/; + +is eval q{fun ($x : $y) {}}, undef; +like $@, qr/invocant/; + +is eval q{method (@x:) {}}, undef; +like $@, qr/invocant/; + +is eval q{method (%x:) {}}, undef; +like $@, qr/invocant/; + +{ + use Function::Parameters { + def => { + invocant => 1, + } + }; + + def foo1($x) { join ' ', $x, @_ } + def foo2($x: $y) { join ' ', $x, $y, @_ } + def foo3($x, $y) { join ' ', $x, $y, @_ } + + is foo1("a"), "a a"; + is foo2("a", "b"), "a b b"; + is foo3("a", "b"), "a b a b"; + is foo1("a", "b"), "a a b"; + is foo2("a", "b", "c"), "a b b c"; + is foo3("a", "b", "c"), "a b a b c"; +}