implement $invocant: syntax

diff --git a/MANIFEST b/MANIFEST
index cd62cf6..4470c4c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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<shift|perlfunc/shift> its first argument into
 a local variable whose name is specified here.
 
+=item C<invocant>
+
+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<shift> and C<invocant>, in which case the variable named in
+C<shift> serves as a default shift target for functions that don't use an
+explicit invocant.
+
 =item C<attributes>, C<attrs>
 
 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 (file)
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";
+}