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