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

[PATCH] use feature 'method' take two

Thread Previous | Thread Next
From:
chromatic
Date:
January 31, 2011 15:59
Subject:
[PATCH] use feature 'method' take two
Message ID:
201101311559.27032.chromatic@wgz.org
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


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