diff --git a/MANIFEST b/MANIFEST
index 1500509..23229f0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4854,6 +4854,7 @@ t/op/lop.t See if logical operators work
t/op/magic_phase.t See if ${^GLOBAL_PHASE} works
t/op/magic.t See if magic variables work
t/op/method.t See if method calls work
+t/op/method_keyword.t See if method declarations work
t/op/mkdir.t See if mkdir works
t/op/mydef.t See if "my $_" works
t/op/my_stash.t See if my Package works
diff --git a/lib/feature.pm b/lib/feature.pm
index e5d6e83..0bf62da 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -1,12 +1,13 @@
package feature;
-our $VERSION = '1.19';
+our $VERSION = '1.20';
# (feature name) => (internal name, used in %^H)
my %feature = (
switch => 'feature_switch',
say => "feature_say",
state => "feature_state",
+ method => 'feature_method',
unicode_strings => "feature_unicode",
);
@@ -21,7 +22,7 @@ my %feature_bundle = (
"5.10" => [qw(switch say state)],
"5.11" => [qw(switch say state unicode_strings)],
"5.12" => [qw(switch say state unicode_strings)],
- "5.13" => [qw(switch say state unicode_strings)],
+ "5.13" => [qw(switch say state method unicode_strings)],
);
# special case
@@ -103,6 +104,12 @@ variables.
See L<perlsub/"Persistent Private Variables"> for details.
+=head2 the 'method' feature
+
+C<use feature 'method'> allows you to declare methods with the C<method>
+keyword instead of C<sub>. Within the body of the method, the invocant is
+available as C<$self>.
+
=head2 the 'unicode_strings' feature
C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
diff --git a/perly.y b/perly.y
index 596426f..10ef0e0 100644
--- a/perly.y
+++ b/perly.y
@@ -77,7 +77,7 @@
%token <opval> FUNC0SUB UNIOPSUB LSTOPSUB
%token <opval> PLUGEXPR PLUGSTMT
%token <p_tkval> LABEL
-%token <i_tkval> FORMAT SUB ANONSUB PACKAGE USE
+%token <i_tkval> FORMAT SUB ANONSUB METH PACKAGE USE
%token <i_tkval> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
%token <i_tkval> GIVEN WHEN DEFAULT
%token <i_tkval> LOOPEX DOTDOT YADAYADA
@@ -97,10 +97,10 @@
%type <opval> stmtseq fullstmt labfullstmt barestmt block mblock else
%type <opval> expr term subscripted scalar ary hsh arylen star amper sideff
%type <opval> listexpr nexpr texpr iexpr mexpr mnexpr miexpr
-%type <opval> optlistexpr optexpr indirob listop method
+%type <opval> optlistexpr optexpr indirob listop method methbody
%type <opval> formname subname proto subbody cont my_scalar
%type <opval> subattrlist myattrlist myattrterm myterm
-%type <opval> termbinop termunop anonymous termdo
+%type <opval> termbinop termunop anonymous termdo addimplicitshift
%nonassoc <i_tkval> PREC_LOW
%nonassoc LOOPEX
@@ -318,6 +318,27 @@ barestmt: PLUGSTMT
$$ = (OP*)NULL;
#endif
}
+ | METH startsub subname subattrlist methbody
+ {
+ SvREFCNT_inc_simple_void(PL_compcv);
+
+#ifdef MAD
+ {
+ OP* o = newSVOP(OP_ANONCODE, 0,
+ (SV*)newATTRSUB($2, $3, NULL, $4, $5));
+ $$ = newOP(OP_NULL,0);
+ op_getmad(o,$$,'&');
+ op_getmad($3,$$,'n');
+ op_getmad($4,$$,'a');
+ token_getmad($1,$$,'d');
+ append_madprops($5->op_madprop, $$, 0);
+ $5->op_madprop = 0;
+ }
+#else
+ newATTRSUB($2, $3, NULL, $4, $5);
+ $$ = (OP*)NULL;
+#endif
+ }
| MYSUB startsub subname proto subattrlist subbody
{
/* Unimplemented "my sub foo { }" */
@@ -680,6 +701,27 @@ subbody : block { $$ = $1; }
}
;
+methbody : '{' remember addimplicitshift stmtseq '}'
+ {
+ if (PL_parser->copline > (line_t)IVAL($1))
+ PL_parser->copline = (line_t)IVAL($1);
+ $$ = block_end($3, op_append_list(OP_LINESEQ, $3, $4));
+ TOKEN_GETMAD($2,$$,'{');
+ TOKEN_GETMAD($4,$$,'}');
+ }
+ ;
+
+addimplicitshift :
+ { OP *selfsv = newOP(OP_PADSV, 0);
+ OP *rv2av = newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
+ OP *shift = newUNOP(OP_SHIFT, 0, rv2av);
+
+ selfsv->op_targ = (I32)Perl_allocmy(aTHX_ STR_WITH_LEN("$self"), 0);
+ $$ = newSTATEOP(0, NULL,
+ newASSIGNOP(OPf_STACKED, selfsv, 0, shift));
+ }
+ ;
+
/* Ordinary expressions; logical combinations */
expr : expr ANDOP expr
{ $$ = newLOGOP(OP_AND, 0, $1, $3);
diff --git a/regen/keywords.pl b/regen/keywords.pl
index eeed6d4..26dd422 100755
--- a/regen/keywords.pl
+++ b/regen/keywords.pl
@@ -45,6 +45,7 @@ my %feature_kw = (
say => 'say',
state => 'state',
+ method => 'method',
);
my %pos = map { ($_ => 1) } @{$by_strength{'+'}};
@@ -229,6 +230,7 @@ __END__
-lt
+m
+map
++method
-mkdir
-msgctl
-msgget
diff --git a/t/op/method_keyword.t b/t/op/method_keyword.t
new file mode 100644
index 0000000..09506a3
--- /dev/null
+++ b/t/op/method_keyword.t
@@ -0,0 +1,70 @@
+#!./perl
+
+# test use of the method keyword
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+ require 'test.pl';
+}
+
+package SomeClass;
+
+use strict;
+use warnings;
+my ($warning, $line);
+BEGIN { $SIG{__WARN__} = sub { $warning = shift } };
+
+use feature 'method';
+
+sub new {
+ my ($class, $value) = @_;
+ bless \$value, $class;
+}
+
+method get_value {
+ return $$self;
+}
+
+method dup_value
+{
+ return $$self
+ . reverse $$self;
+}
+
+method set_value :lvalue
+{
+ $$self;
+}
+
+method ctor
+{
+ my $value = shift;
+ bless \$value, $self;
+}
+
+method foo
+{
+ BEGIN { $line = __LINE__ }; my $self;
+}
+
+package main;
+
+my $sc = SomeClass->new( 'instance variable' );
+
+can_ok($sc, 'get_value');
+can_ok('SomeClass', 'set_value');
+is($sc->get_value, 'instance variable', 'simple method should work');
+is($sc->dup_value, 'instance variableelbairav ecnatsni',
+ 'method using additional $self should work');
+$sc->set_value = 'foo';
+is($sc->get_value, 'foo', ':lvalue attribute should work');
+
+$sc = SomeClass->ctor( 'method constructor' );
+is($sc->get_value, 'method constructor',
+ 'method should work for constructor too');
+
+like($warning, qr/"my" variable \$self masks earlier.+line $line/,
+ 'added $self should trigger duplicate lexical declaration warnings');
+
+done_testing();
diff --git a/toke.c b/toke.c
index 17152e5..7dc1a5a 100644
--- a/toke.c
+++ b/toke.c
@@ -359,6 +359,7 @@ static struct debug_tokens {
{ LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
{ MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
{ METHOD, TOKENTYPE_OPVAL, "METHOD" },
+ { METH, TOKENTYPE_NONE, "METH" },
{ MULOP, TOKENTYPE_OPNUM, "MULOP" },
{ MY, TOKENTYPE_IVAL, "MY" },
{ MYSUB, TOKENTYPE_NONE, "MYSUB" },
@@ -7455,6 +7456,75 @@ Perl_yylex(pTHX)
case KEY_map:
LOP(OP_MAPSTART, XREF);
+ case KEY_method:
+ {
+ char tmpbuf[sizeof PL_tokenbuf];
+ SSize_t tboffset = 0;
+ expectation attrful;
+ const int key = tmp;
+
+#ifdef PERL_MAD
+ SV *tmpwhite = 0;
+
+ char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ SV *subtoken = newSVpvn(tstart, s - tstart);
+ PL_thistoken = 0;
+
+ d = s;
+ s = SKIPSPACE2(s,tmpwhite);
+#else
+ s = skipspace(s);
+#endif
+
+ if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
+ (*s == ':' && s[1] == ':'))
+ {
+#ifdef PERL_MAD
+ SV *nametoke = NULL;
+#endif
+
+ PL_expect = XBLOCK;
+ attrful = XATTRBLOCK;
+ /* remember buffer pos'n for later force_word */
+ tboffset = s - PL_oldbufptr;
+ d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
+#ifdef PERL_MAD
+ if (PL_madskills)
+ nametoke = newSVpvn(s, d - s);
+#endif
+ if (memchr(tmpbuf, ':', len))
+ sv_setpvn(PL_subname, tmpbuf, len);
+ else {
+ sv_setsv(PL_subname,PL_curstname);
+ sv_catpvs(PL_subname,"::");
+ sv_catpvn(PL_subname,tmpbuf,len);
+ }
+
+#ifdef PERL_MAD
+
+ start_force(0);
+ CURMAD('X', nametoke);
+ CURMAD('_', tmpwhite);
+ (void) force_word(PL_oldbufptr + tboffset, WORD,
+ FALSE, TRUE, TRUE);
+
+ s = SKIPSPACE2(d,tmpwhite);
+#else
+ s = skipspace(d);
+#endif
+ }
+
+ if (*s == ':' && s[1] != ':')
+ PL_expect = attrful;
+
+#ifndef PERL_MAD
+ (void) force_word(PL_oldbufptr + tboffset, WORD,
+ FALSE, TRUE, TRUE);
+#endif
+ /* prepend to PL_linestr */
+ TOKEN(METH);
+ }
+
case KEY_mkdir:
LOP(OP_MKDIR,XTERM);
--
1.7.1