develooper Front page | perl.perl5.porters | Postings from January 2011

[PATCH] use feature 'method'; (was Re: Proposal: "$->" for implicit invocant)

Thread Previous | Thread Next
From:
chromatic
Date:
January 20, 2011 10:27
Subject:
[PATCH] use feature 'method'; (was Re: Proposal: "$->" for implicit invocant)
Message ID:
201101201027.20293.chromatic@wgz.org
From d8fad4de0a35342abbae6d2263130073f31e2789 Mon Sep 17 00:00:00 2001
From: chromatic <chromatic@wgz.org>
Date: Thu, 20 Jan 2011 10:20:02 -0800
Subject: [PATCH] Added use feature 'method' and tests.

---
 MANIFEST              |    1 +
 keywords.h            |  255 +++++++++++++++++++++++++------------------------
 lib/feature.pm        |   11 ++-
 perl_keyword.pl       |    7 +-
 perly.y               |   45 ++++++++-
 regen/keywords.pl     |    3 +-
 t/op/method_keyword.t |   60 ++++++++++++
 toke.c                |  161 ++++++++++++++++++++++++-------
 8 files changed, 370 insertions(+), 173 deletions(-)
 create mode 100644 t/op/method_keyword.t

diff --git a/MANIFEST b/MANIFEST
index aaf7227..1deaef6 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4845,6 +4845,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/keywords.h b/keywords.h
index 526f3e4..2a4f70c 100644
--- a/keywords.h
+++ b/keywords.h
@@ -138,132 +138,133 @@
 #define KEY_lt			123
 #define KEY_m			124
 #define KEY_map			125
-#define KEY_mkdir		126
-#define KEY_msgctl		127
-#define KEY_msgget		128
-#define KEY_msgrcv		129
-#define KEY_msgsnd		130
-#define KEY_my			131
-#define KEY_ne			132
-#define KEY_next		133
-#define KEY_no			134
-#define KEY_not			135
-#define KEY_oct			136
-#define KEY_open		137
-#define KEY_opendir		138
-#define KEY_or			139
-#define KEY_ord			140
-#define KEY_our			141
-#define KEY_pack		142
-#define KEY_package		143
-#define KEY_pipe		144
-#define KEY_pop			145
-#define KEY_pos			146
-#define KEY_print		147
-#define KEY_printf		148
-#define KEY_prototype		149
-#define KEY_push		150
-#define KEY_q			151
-#define KEY_qq			152
-#define KEY_qr			153
-#define KEY_quotemeta		154
-#define KEY_qw			155
-#define KEY_qx			156
-#define KEY_rand		157
-#define KEY_read		158
-#define KEY_readdir		159
-#define KEY_readline		160
-#define KEY_readlink		161
-#define KEY_readpipe		162
-#define KEY_recv		163
-#define KEY_redo		164
-#define KEY_ref			165
-#define KEY_rename		166
-#define KEY_require		167
-#define KEY_reset		168
-#define KEY_return		169
-#define KEY_reverse		170
-#define KEY_rewinddir		171
-#define KEY_rindex		172
-#define KEY_rmdir		173
-#define KEY_s			174
-#define KEY_say			175
-#define KEY_scalar		176
-#define KEY_seek		177
-#define KEY_seekdir		178
-#define KEY_select		179
-#define KEY_semctl		180
-#define KEY_semget		181
-#define KEY_semop		182
-#define KEY_send		183
-#define KEY_setgrent		184
-#define KEY_sethostent		185
-#define KEY_setnetent		186
-#define KEY_setpgrp		187
-#define KEY_setpriority		188
-#define KEY_setprotoent		189
-#define KEY_setpwent		190
-#define KEY_setservent		191
-#define KEY_setsockopt		192
-#define KEY_shift		193
-#define KEY_shmctl		194
-#define KEY_shmget		195
-#define KEY_shmread		196
-#define KEY_shmwrite		197
-#define KEY_shutdown		198
-#define KEY_sin			199
-#define KEY_sleep		200
-#define KEY_socket		201
-#define KEY_socketpair		202
-#define KEY_sort		203
-#define KEY_splice		204
-#define KEY_split		205
-#define KEY_sprintf		206
-#define KEY_sqrt		207
-#define KEY_srand		208
-#define KEY_stat		209
-#define KEY_state		210
-#define KEY_study		211
-#define KEY_sub			212
-#define KEY_substr		213
-#define KEY_symlink		214
-#define KEY_syscall		215
-#define KEY_sysopen		216
-#define KEY_sysread		217
-#define KEY_sysseek		218
-#define KEY_system		219
-#define KEY_syswrite		220
-#define KEY_tell		221
-#define KEY_telldir		222
-#define KEY_tie			223
-#define KEY_tied		224
-#define KEY_time		225
-#define KEY_times		226
-#define KEY_tr			227
-#define KEY_truncate		228
-#define KEY_uc			229
-#define KEY_ucfirst		230
-#define KEY_umask		231
-#define KEY_undef		232
-#define KEY_unless		233
-#define KEY_unlink		234
-#define KEY_unpack		235
-#define KEY_unshift		236
-#define KEY_untie		237
-#define KEY_until		238
-#define KEY_use			239
-#define KEY_utime		240
-#define KEY_values		241
-#define KEY_vec			242
-#define KEY_wait		243
-#define KEY_waitpid		244
-#define KEY_wantarray		245
-#define KEY_warn		246
-#define KEY_when		247
-#define KEY_while		248
-#define KEY_write		249
-#define KEY_x			250
-#define KEY_xor			251
-#define KEY_y			252
+#define KEY_method		126
+#define KEY_mkdir		127
+#define KEY_msgctl		128
+#define KEY_msgget		129
+#define KEY_msgrcv		130
+#define KEY_msgsnd		131
+#define KEY_my			132
+#define KEY_ne			133
+#define KEY_next		134
+#define KEY_no			135
+#define KEY_not			136
+#define KEY_oct			137
+#define KEY_open		138
+#define KEY_opendir		139
+#define KEY_or			140
+#define KEY_ord			141
+#define KEY_our			142
+#define KEY_pack		143
+#define KEY_package		144
+#define KEY_pipe		145
+#define KEY_pop			146
+#define KEY_pos			147
+#define KEY_print		148
+#define KEY_printf		149
+#define KEY_prototype		150
+#define KEY_push		151
+#define KEY_q			152
+#define KEY_qq			153
+#define KEY_qr			154
+#define KEY_quotemeta		155
+#define KEY_qw			156
+#define KEY_qx			157
+#define KEY_rand		158
+#define KEY_read		159
+#define KEY_readdir		160
+#define KEY_readline		161
+#define KEY_readlink		162
+#define KEY_readpipe		163
+#define KEY_recv		164
+#define KEY_redo		165
+#define KEY_ref			166
+#define KEY_rename		167
+#define KEY_require		168
+#define KEY_reset		169
+#define KEY_return		170
+#define KEY_reverse		171
+#define KEY_rewinddir		172
+#define KEY_rindex		173
+#define KEY_rmdir		174
+#define KEY_s			175
+#define KEY_say			176
+#define KEY_scalar		177
+#define KEY_seek		178
+#define KEY_seekdir		179
+#define KEY_select		180
+#define KEY_semctl		181
+#define KEY_semget		182
+#define KEY_semop		183
+#define KEY_send		184
+#define KEY_setgrent		185
+#define KEY_sethostent		186
+#define KEY_setnetent		187
+#define KEY_setpgrp		188
+#define KEY_setpriority		189
+#define KEY_setprotoent		190
+#define KEY_setpwent		191
+#define KEY_setservent		192
+#define KEY_setsockopt		193
+#define KEY_shift		194
+#define KEY_shmctl		195
+#define KEY_shmget		196
+#define KEY_shmread		197
+#define KEY_shmwrite		198
+#define KEY_shutdown		199
+#define KEY_sin			200
+#define KEY_sleep		201
+#define KEY_socket		202
+#define KEY_socketpair		203
+#define KEY_sort		204
+#define KEY_splice		205
+#define KEY_split		206
+#define KEY_sprintf		207
+#define KEY_sqrt		208
+#define KEY_srand		209
+#define KEY_stat		210
+#define KEY_state		211
+#define KEY_study		212
+#define KEY_sub			213
+#define KEY_substr		214
+#define KEY_symlink		215
+#define KEY_syscall		216
+#define KEY_sysopen		217
+#define KEY_sysread		218
+#define KEY_sysseek		219
+#define KEY_system		220
+#define KEY_syswrite		221
+#define KEY_tell		222
+#define KEY_telldir		223
+#define KEY_tie			224
+#define KEY_tied		225
+#define KEY_time		226
+#define KEY_times		227
+#define KEY_tr			228
+#define KEY_truncate		229
+#define KEY_uc			230
+#define KEY_ucfirst		231
+#define KEY_umask		232
+#define KEY_undef		233
+#define KEY_unless		234
+#define KEY_unlink		235
+#define KEY_unpack		236
+#define KEY_unshift		237
+#define KEY_untie		238
+#define KEY_until		239
+#define KEY_use			240
+#define KEY_utime		241
+#define KEY_values		242
+#define KEY_vec			243
+#define KEY_wait		244
+#define KEY_waitpid		245
+#define KEY_wantarray		246
+#define KEY_warn		247
+#define KEY_when		248
+#define KEY_while		249
+#define KEY_write		250
+#define KEY_x			251
+#define KEY_xor			252
+#define KEY_y			253
 
 /* ex: set ro: */
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/perl_keyword.pl b/perl_keyword.pl
index 73128c3..5edd293 100644
--- a/perl_keyword.pl
+++ b/perl_keyword.pl
@@ -7,9 +7,9 @@ use warnings;
 
 my @pos = qw(__DATA__ __END__ AUTOLOAD BEGIN CHECK DESTROY default defined
 	    delete do END else eval elsif exists for format foreach given grep
-	    goto glob INIT if last local m my map next no our pos print printf
-	    package prototype q qr qq qw qx redo return require s say scalar sort
-	    split state study sub tr use undef UNITCHECK until
+	    goto glob INIT if last local m my map method next no our pos print
+	    printf package prototype q qr qq qw qx redo return require s say scalar 
+	    sort split state study sub tr use undef UNITCHECK until
 	    unless when while y);
 
 my @neg = qw(__FILE__ __LINE__ __PACKAGE__ and abs alarm atan2 accept bless
@@ -46,6 +46,7 @@ my %feature_kw = (
 	say     => 'say',
 
 	state	=> 'state',
+	method  => 'method',
 	);
 
 my %pos = map { ($_ => 1) } @pos;
diff --git a/perly.y b/perly.y
index 596426f..1269d95 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
@@ -89,7 +89,7 @@
 
 %type <i_tkval> lpar_or_qw
 
-%type <ival> grammar remember mremember
+%type <ival> grammar remember mremember addimplicitshift
 %type <ival>  startsub startanonsub startformsub
 /* FIXME for MAD - are these two ival? */
 %type <ival> mydefsv mintro
@@ -97,7 +97,7 @@
 %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
@@ -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,24 @@ subbody	:	block	{ $$ = $1; }
 			}
 	;
 
+methbody : '{' addimplicitshift remember stmtseq '}'
+			{ 
+                if (PL_parser->copline > (line_t)IVAL($1))
+			      PL_parser->copline = (line_t)IVAL($1);
+
+			  $$ = block_end($3, $4);
+			  TOKEN_GETMAD($2,$$,'{');
+			  TOKEN_GETMAD($4,$$,'}');
+			}
+	;
+
+addimplicitshift :
+	{
+        lex_stuff_pvs("my $self = shift;", 0);
+        $$ = PL_savestack_ix;
+     }
+    ;
+
 /* 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 381e098..dfb1ce2 100755
--- a/regen/keywords.pl
+++ b/regen/keywords.pl
@@ -1,5 +1,5 @@
 #!/usr/bin/perl -w
-# 
+#
 # Regenerate (overwriting only if changed):
 #
 #    keywords.h
@@ -186,6 +186,7 @@ lstat
 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..0c5fd76
--- /dev/null
+++ b/t/op/method_keyword.t
@@ -0,0 +1,60 @@
+#!./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;
+
+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;
+}
+
+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');
+
+done_testing();
diff --git a/toke.c b/toke.c
index cb096e9..41445dc 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" },
@@ -7459,6 +7460,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);
 
@@ -9987,61 +10057,78 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
           }
 
         case 'm':
-          if (name[1] == 's' &&
-              name[2] == 'g')
+          switch (name[1])
           {
-            switch (name[3])
-            {
-              case 'c':
-                if (name[4] == 't' &&
-                    name[5] == 'l')
-                {                                 /* msgctl     */
-                  return -KEY_msgctl;
-                }
+            case 'e':
+              if (name[2] == 't' &&
+                  name[3] == 'h' &&
+                  name[4] == 'o' &&
+                  name[5] == 'd')
+              {                                   /* method           */
+                return (all_keywords || FEATURE_IS_ENABLED("method") ? KEY_method : 0);
+              }
 
-                goto unknown;
+              goto unknown;
 
-              case 'g':
-                if (name[4] == 'e' &&
-                    name[5] == 't')
-                {                                 /* msgget     */
-                  return -KEY_msgget;
-                }
+            case 's':
+              if (name[2] == 'g')
+              {
+                switch (name[3])
+                {
+                  case 'c':
+                    if (name[4] == 't' &&
+                        name[5] == 'l')
+                    {                             /* msgctl           */
+                      return -KEY_msgctl;
+                    }
 
-                goto unknown;
+                    goto unknown;
 
-              case 'r':
-                if (name[4] == 'c' &&
-                    name[5] == 'v')
-                {                                 /* msgrcv     */
-                  return -KEY_msgrcv;
-                }
+                  case 'g':
+                    if (name[4] == 'e' &&
+                        name[5] == 't')
+                    {                             /* msgget           */
+                      return -KEY_msgget;
+                    }
 
-                goto unknown;
+                    goto unknown;
 
-              case 's':
-                if (name[4] == 'n' &&
-                    name[5] == 'd')
-                {                                 /* msgsnd     */
-                  return -KEY_msgsnd;
+                  case 'r':
+                    if (name[4] == 'c' &&
+                        name[5] == 'v')
+                    {                             /* msgrcv           */
+                      return -KEY_msgrcv;
+                    }
+
+                    goto unknown;
+
+                  case 's':
+                    if (name[4] == 'n' &&
+                        name[5] == 'd')
+                    {                             /* msgsnd           */
+                      return -KEY_msgsnd;
+                    }
+
+                    goto unknown;
+
+                  default:
+                    goto unknown;
                 }
+              }
 
-                goto unknown;
+              goto unknown;
 
-              default:
-                goto unknown;
-            }
+            default:
+              goto unknown;
           }
 
-          goto unknown;
-
         case 'p':
           if (name[1] == 'r' &&
               name[2] == 'i' &&
               name[3] == 'n' &&
               name[4] == 't' &&
               name[5] == 'f')
-          {                                       /* printf     */
+          {                                       /* printf           */
             return KEY_printf;
           }
 
-- 
1.7.1



Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About