Implement facility to plug in syntax triggered by keywords

Date: Tue, 27 Oct 2009 01:29:40 +0000
From: Zefram <zefram@fysh.org>
To: perl5-porters@perl.org
Subject: bareword sub lookups

Attached is a patch that changes how the tokeniser looks up subroutines,
when they're referenced by a bareword, for prototype and const-sub
purposes.  Formerly, it has looked up bareword subs directly in the
package, which is contrary to the way the generated op tree looks up
the sub, via an rv2cv op.  The patch makes the tokeniser generate the
rv2cv op earlier, and dig around in that.

The motivation for this is to allow modules to hook the rv2cv op
creation, to affect the name->subroutine lookup process.  Currently,
such hooking affects op execution as intended, but everything goes wrong
with a bareword ref where the tokeniser looks at some unrelated CV,
or a blank space, in the package.  With the patch in place, an rv2cv
hook correctly affects the tokeniser and therefore the prototype-based
aspects of parsing.

The patch also changes ck_subr (which applies the argument context and
checking parts of prototype behaviour) to handle subs referenced by an
RV const op inside the rv2cv, where formerly it would only handle a gv
op inside the rv2cv.  This is to support the most likely kind of modified
rv2cv op.

[This commit includes the Makefile.PL for XS-APITest-KeywordRPN missing
from the original patch, as well as updates to perldiag.pod and a
MANIFEST sort]

5 files changed, 547 insertions, 0 deletions

diff --git a/ext/XS-APItest-KeywordRPN/KeywordRPN.pm b/ext/XS-APItest-KeywordRPN/KeywordRPN.pm
new file mode 100644
index 0000000000..085d3f68b2
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/KeywordRPN.pm
@@ -0,0 +1,146 @@
+=head1 NAME
+
+XS::APItest::KeywordRPN - write arithmetic expressions in RPN
+
+=head1 SYNOPSIS
+
+	use XS::APItest::KeywordRPN qw(rpn calcrpn);
+
+	$triangle = rpn($n $n 1 + * 2 /);
+
+	calcrpn $triangle { $n $n 1 + * 2 / }
+
+=head1 DESCRIPTION
+
+This module supplies plugged-in keywords, using the new mechanism in Perl
+5.11.2, that allow arithmetic to be expressed in reverse Polish notation,
+in an otherwise Perl program.  This module has serious limitations and
+is not intended for real use: its purpose is only to test the keyword
+plugin mechanism.  For that purpose it is part of the Perl core source
+distribution, and is not meant to be installed.
+
+=head2 RPN expression syntax
+
+Tokens of an RPN expression may be separated by whitespace, but such
+separation is usually not required.  It is required only where unseparated
+tokens would look like a longer token.  For example, C<12 34 +> can be
+written as C<12 34+>, but not as C<1234 +>.
+
+An RPN expression may be any of:
+
+=over
+
+=item C<1234>
+
+A sequence of digits is an unsigned decimal literal number.
+
+=item C<$foo>
+
+An alphanumeric name preceded by dollar sign refers to a Perl scalar
+variable.  Only variables declared with C<my> or C<state> are supported.
+If the variable's value is not a native integer, it will be converted
+to an integer, by Perl's usual mechanisms, at the time it is evaluated.
+
+=item I<A> I<B> C<+>
+
+Sum of I<A> and I<B>.
+
+=item I<A> I<B> C<->
+
+Difference of I<A> and I<B>, the result of subtracting I<B> from I<A>.
+
+=item I<A> I<B> C<*>
+
+Product of I<A> and I<B>.
+
+=item I<A> I<B> C</>
+
+Quotient when I<A> is divided by I<B>, rounded towards zero.
+Division by zero generates an exception.
+
+=item I<A> I<B> C<%>
+
+Remainder when I<A> is divided by I<B> with the quotient rounded towards zero.
+Division by zero generates an exception.
+
+=back
+
+Because the arithmetic operators all have fixed arity and are postfixed,
+there is no need for operator precedence, nor for a grouping operator
+to override precedence.  This is half of the point of RPN.
+
+An RPN expression can also be interpreted in another way, as a sequence
+of operations on a stack, one operation per token.  A literal or variable
+token pushes a value onto the stack.  A binary operator pulls two items
+off the stack, performs a calculation with them, and pushes the result
+back onto the stack.  The stack starts out empty, and at the end of the
+expression there must be exactly one value left on the stack.
+
+=cut
+
+package XS::APItest::KeywordRPN;
+
+{ use 5.011001; }
+use warnings;
+use strict;
+
+our $VERSION = "0.000";
+
+require XSLoader;
+XSLoader::load(__PACKAGE__, $VERSION);
+
+=head1 OPERATORS
+
+These are the operators being added to the Perl language.
+
+=over
+
+=item rpn(EXPRESSION)
+
+This construct is a Perl expression.  I<EXPRESSION> must be an RPN
+arithmetic expression, as described above.  The RPN expression is
+evaluated, and its value is returned as the value of the Perl expression.
+
+=item calcrpn VARIABLE { EXPRESSION }
+
+This construct is a complete Perl statement.  (No semicolon should
+follow the closing brace.)  I<VARIABLE> must be a Perl scalar C<my>
+variable, and I<EXPRESSION> must be an RPN arithmetic expression as
+described above.  The RPN expression is evaluated, and its value is
+assigned to the variable.
+
+=back
+
+=head1 BUGS
+
+This module only performs arithmetic on native integers, and only a
+small subset of the arithmetic operations that Perl offers.  This is
+due to it being intended only for demonstration and test purposes.
+
+The RPN parser is liable to leak memory when a parse error occurs.
+It doesn't leak on success, however.
+
+The linkage with Perl's lexer is liable to fail when an RPN expression
+is spread across multiple lines.
+
+=head1 SEE ALSO
+
+L<Devel::Declare>,
+L<perlapi/PL_keyword_plugin>
+
+=head1 AUTHOR
+
+Andrew Main (Zefram) <zefram@fysh.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org>
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/ext/XS-APItest-KeywordRPN/KeywordRPN.xs b/ext/XS-APItest-KeywordRPN/KeywordRPN.xs
new file mode 100644
index 0000000000..219d6ac1d9
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/KeywordRPN.xs
@@ -0,0 +1,283 @@
+#define PERL_CORE 1   /* for pad_findmy() */
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
+#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
+#define sv_is_string(sv) \
+	(!sv_is_glob(sv) && !sv_is_regexp(sv) && \
+	 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
+
+static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv;
+static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
+
+/* low-level parser helpers */
+
+#define PL_bufptr (PL_parser->bufptr)
+#define PL_bufend (PL_parser->bufend)
+
+static char THX_peek_char(pTHX)
+{
+	if(PL_bufptr == PL_bufend)
+		Perl_croak(aTHX_
+			"unexpected EOF "
+			"(or you were unlucky about buffer position, FIXME)");
+	return *PL_bufptr;
+}
+#define peek_char() THX_peek_char(aTHX)
+
+static char THX_read_char(pTHX)
+{
+	char c = peek_char();
+	PL_bufptr++;
+	if(c == '\n') CopLINE_inc(PL_curcop);
+	return c;
+}
+#define read_char() THX_read_char(aTHX)
+
+static void THX_skip_opt_ws(pTHX)
+{
+	while(1) {
+		switch(peek_char()) {
+			case '\t': case '\n': case '\v': case '\f': case ' ':
+				read_char();
+				break;
+			default:
+				return;
+		}
+	}
+}
+#define skip_opt_ws() THX_skip_opt_ws(aTHX)
+
+/* RPN parser */
+
+static OP *THX_parse_var(pTHX)
+{
+	SV *varname = sv_2mortal(newSVpvs("$"));
+	PADOFFSET varpos;
+	OP *padop;
+	if(peek_char() != '$') Perl_croak(aTHX_ "RPN syntax error");
+	read_char();
+	while(1) {
+		char c = peek_char();
+		if(!isALNUM(c)) break;
+		read_char();
+		sv_catpvn_nomg(varname, &c, 1);
+	}
+	if(SvCUR(varname) < 2) Perl_croak(aTHX_ "RPN syntax error");
+	varpos = pad_findmy(SvPVX(varname));
+	if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
+		Perl_croak(aTHX_ "RPN only supports \"my\" variables");
+	padop = newOP(OP_PADSV, 0);
+	padop->op_targ = varpos;
+	return padop;
+}
+#define parse_var() THX_parse_var(aTHX)
+
+#define push_rpn_item(o) \
+	(tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
+#define pop_rpn_item() \
+	(!stack ? (Perl_croak(aTHX_ "RPN stack underflow"), (OP*)NULL) : \
+	 (tmpop = stack, stack = stack->op_sibling, \
+	  tmpop->op_sibling = NULL, tmpop))
+
+static OP *THX_parse_rpn_expr(pTHX)
+{
+	OP *stack = NULL, *tmpop;
+	while(1) {
+		char c;
+		skip_opt_ws();
+		c = peek_char();
+		switch(c) {
+			case /*(*/')': case /*{*/'}': {
+				OP *result = pop_rpn_item();
+				if(stack)
+					Perl_croak(aTHX_
+						"RPN expression must return "
+						"a single value");
+				return result;
+			} break;
+			case '0': case '1': case '2': case '3': case '4':
+			case '5': case '6': case '7': case '8': case '9': {
+				UV val = 0;
+				do {
+					read_char();
+					val = 10*val + (c - '0');
+					c = peek_char();
+				} while(c >= '0' && c <= '9');
+				push_rpn_item(newSVOP(OP_CONST, 0,
+					newSVuv(val)));
+			} break;
+			case '$': {
+				push_rpn_item(parse_var());
+			} break;
+			case '+': {
+				OP *b = pop_rpn_item();
+				OP *a = pop_rpn_item();
+				read_char();
+				push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
+			} break;
+			case '-': {
+				OP *b = pop_rpn_item();
+				OP *a = pop_rpn_item();
+				read_char();
+				push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
+			} break;
+			case '*': {
+				OP *b = pop_rpn_item();
+				OP *a = pop_rpn_item();
+				read_char();
+				push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
+			} break;
+			case '/': {
+				OP *b = pop_rpn_item();
+				OP *a = pop_rpn_item();
+				read_char();
+				push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
+			} break;
+			case '%': {
+				OP *b = pop_rpn_item();
+				OP *a = pop_rpn_item();
+				read_char();
+				push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
+			} break;
+			default: {
+				Perl_croak(aTHX_ "RPN syntax error");
+			} break;
+		}
+	}
+}
+#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
+
+static OP *THX_parse_keyword_rpn(pTHX)
+{
+	OP *op;
+	skip_opt_ws();
+	if(peek_char() != '('/*)*/)
+		Perl_croak(aTHX_ "RPN expression must be parenthesised");
+	read_char();
+	op = parse_rpn_expr();
+	if(peek_char() != /*(*/')')
+		Perl_croak(aTHX_ "RPN expression must be parenthesised");
+	read_char();
+	return op;
+}
+#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
+
+static OP *THX_parse_keyword_calcrpn(pTHX)
+{
+	OP *varop, *exprop;
+	skip_opt_ws();
+	varop = parse_var();
+	skip_opt_ws();
+	if(peek_char() != '{'/*}*/)
+		Perl_croak(aTHX_ "RPN expression must be braced");
+	read_char();
+	exprop = parse_rpn_expr();
+	if(peek_char() != /*{*/'}')
+		Perl_croak(aTHX_ "RPN expression must be braced");
+	read_char();
+	return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
+}
+#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
+
+/* plugin glue */
+
+static int THX_keyword_active(pTHX_ SV *hintkey_sv)
+{
+	HE *he;
+	if(!GvHV(PL_hintgv)) return 0;
+	he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
+				SvSHARED_HASH(hintkey_sv));
+	return he && SvTRUE(HeVAL(he));
+}
+#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
+
+static void THX_keyword_enable(pTHX_ SV *hintkey_sv)
+{
+	SV *val_sv = newSViv(1);
+	HE *he;
+	PL_hints |= HINT_LOCALIZE_HH;
+	gv_HVadd(PL_hintgv);
+	he = hv_store_ent(GvHV(PL_hintgv),
+		hintkey_sv, val_sv, SvSHARED_HASH(hintkey_sv));
+	if(he) {
+		SV *val = HeVAL(he);
+		SvSETMAGIC(val);
+	} else {
+		SvREFCNT_dec(val_sv);
+	}
+}
+#define keyword_enable(hintkey_sv) THX_keyword_enable(aTHX_ hintkey_sv)
+
+static void THX_keyword_disable(pTHX_ SV *hintkey_sv)
+{
+	if(GvHV(PL_hintgv)) {
+		PL_hints |= HINT_LOCALIZE_HH;
+		hv_delete_ent(GvHV(PL_hintgv),
+			hintkey_sv, G_DISCARD, SvSHARED_HASH(hintkey_sv));
+	}
+}
+#define keyword_disable(hintkey_sv) THX_keyword_disable(aTHX_ hintkey_sv)
+
+static int my_keyword_plugin(pTHX_
+	char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
+{
+	if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
+			keyword_active(hintkey_rpn_sv)) {
+		*op_ptr = parse_keyword_rpn();
+		return KEYWORD_PLUGIN_EXPR;
+	} else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
+			keyword_active(hintkey_calcrpn_sv)) {
+		*op_ptr = parse_keyword_calcrpn();
+		return KEYWORD_PLUGIN_STMT;
+	} else {
+		return next_keyword_plugin(aTHX_
+				keyword_ptr, keyword_len, op_ptr);
+	}
+}
+
+MODULE = XS::APItest::KeywordRPN PACKAGE = XS::APItest::KeywordRPN
+
+BOOT:
+	hintkey_rpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/rpn");
+	hintkey_calcrpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/calcrpn");
+	next_keyword_plugin = PL_keyword_plugin;
+	PL_keyword_plugin = my_keyword_plugin;
+
+void
+import(SV *class, ...)
+PREINIT:
+	int i;
+PPCODE:
+	for(i = 1; i != items; i++) {
+		SV *item = ST(i);
+		if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) {
+			keyword_enable(hintkey_rpn_sv);
+		} else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) {
+			keyword_enable(hintkey_calcrpn_sv);
+		} else {
+			Perl_croak(aTHX_
+				"\"%s\" is not exported by the %s module",
+				SvPV_nolen(item), SvPV_nolen(ST(0)));
+		}
+	}
+
+void
+unimport(SV *class, ...)
+PREINIT:
+	int i;
+PPCODE:
+	for(i = 1; i != items; i++) {
+		SV *item = ST(i);
+		if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) {
+			keyword_disable(hintkey_rpn_sv);
+		} else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) {
+			keyword_disable(hintkey_calcrpn_sv);
+		} else {
+			Perl_croak(aTHX_
+				"\"%s\" is not exported by the %s module",
+				SvPV_nolen(item), SvPV_nolen(ST(0)));
+		}
+	}
diff --git a/ext/XS-APItest-KeywordRPN/Makefile.PL b/ext/XS-APItest-KeywordRPN/Makefile.PL
new file mode 100644
index 0000000000..ae2c72a40c
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/Makefile.PL
@@ -0,0 +1,17 @@
+{ use 5.006; }
+use warnings;
+use strict;
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME => "XS::APItest::KeywordRPN",
+    VERSION_FROM => "KeywordRPN.pm",
+    PREREQ_PM => {},
+    ABSTRACT_FROM => "KeywordRPN.pm",
+    AUTHOR => "Andrew Main (Zefram) <zefram\@fysh.org>",
+);
+
+sub MY::install { "install ::\n" }
+
+1;
diff --git a/ext/XS-APItest-KeywordRPN/README b/ext/XS-APItest-KeywordRPN/README
new file mode 100644
index 0000000000..4caa629af1
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/README
@@ -0,0 +1,25 @@
+NAME
+
+XS::APItest::KeywordRPN - write arithmetic expressions in RPN
+
+DESCRIPTION
+
+This module supplies plugged-in keywords, using the new mechanism in Perl
+5.11.2, that allow arithmetic to be expressed in reverse Polish notation,
+in an otherwise Perl program.  This module has serious limitations and
+is not intended for real use: its purpose is only to test the keyword
+plugin mechanism.  For that purpose it is part of the Perl core source
+distribution, and is not meant to be installed.
+
+AUTHOR
+
+Andrew Main (Zefram) <zefram@fysh.org>
+
+COPYRIGHT
+
+Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org>
+
+LICENSE
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
diff --git a/ext/XS-APItest-KeywordRPN/t/keyword_plugin.t b/ext/XS-APItest-KeywordRPN/t/keyword_plugin.t
new file mode 100644
index 0000000000..2b705d733a
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/t/keyword_plugin.t
@@ -0,0 +1,76 @@
+use warnings;
+use strict;
+
+use Test::More tests => 13;
+
+BEGIN { $^H |= 0x20000; }
+no warnings;
+
+my($t, $n);
+$n = 5;
+
+$t = undef;
+eval q{
+	use XS::APItest::KeywordRPN ();
+	$t = rpn($n $n 1 + * 2 /);
+};
+isnt $@, "";
+
+$t = undef;
+eval q{
+	use XS::APItest::KeywordRPN qw(rpn);
+	$t = rpn($n $n 1 + * 2 /);
+};
+is $@, "";
+is $t, 15;
+
+$t = undef;
+eval q{
+	use XS::APItest::KeywordRPN qw(rpn);
+	$t = join(":", "x", rpn($n $n 1 + * 2 /), "y");
+};
+is $@, "";
+is $t, "x:15:y";
+
+$t = undef;
+eval q{
+	use XS::APItest::KeywordRPN qw(rpn);
+	$t = 1 + rpn($n $n 1 + * 2 /) * 10;
+};
+is $@, "";
+is $t, 151;
+
+$t = undef;
+eval q{
+	use XS::APItest::KeywordRPN qw(rpn);
+	$t = rpn($n $n 1 + * 2 /);
+	$t++;
+};
+is $@, "";
+is $t, 16;
+
+$t = undef;
+eval q{
+	use XS::APItest::KeywordRPN qw(rpn);
+	$t = rpn($n $n 1 + * 2 /)
+	$t++;
+};
+isnt $@, "";
+
+$t = undef;
+eval q{
+	use XS::APItest::KeywordRPN qw(calcrpn);
+	calcrpn $t { $n $n 1 + * 2 / }
+	$t++;
+};
+is $@, "";
+is $t, 16;
+
+$t = undef;
+eval q{
+	use XS::APItest::KeywordRPN qw(calcrpn);
+	123 + calcrpn $t { $n $n 1 + * 2 / } ;
+};
+isnt $@, "";
+
+1;