Implement facility to plug in syntax triggered by keywords
Jesse Vincent [Thu, 5 Nov 2009 16:14:45 +0000 (11:14 -0500)]
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]

25 files changed:
Configure
Cross/config.sh-arm-linux
Cross/config.sh-arm-linux-n770
MANIFEST
NetWare/Makefile
Porting/Maintainers.pl
Porting/config.sh
djgpp/config.over
embed.fnc
ext/XS-APItest-KeywordRPN/KeywordRPN.pm [new file with mode: 0644]
ext/XS-APItest-KeywordRPN/KeywordRPN.xs [new file with mode: 0644]
ext/XS-APItest-KeywordRPN/Makefile.PL [new file with mode: 0644]
ext/XS-APItest-KeywordRPN/README [new file with mode: 0644]
ext/XS-APItest-KeywordRPN/t/keyword_plugin.t [new file with mode: 0644]
perl.h
perlvars.h
perly.y
plan9/config_sh.sample
pod/perl5112delta.pod
pod/perldiag.pod
pod/perlfunc.pod
pod/perlsyn.pod
symbian/install.cfg
toke.c
utils/perlivp.PL

index a4c3397..2c0597f 100755 (executable)
--- a/Configure
+++ b/Configure
@@ -21836,6 +21836,13 @@ for xxx in $known_extensions ; do
                $define) avail_ext="$avail_ext $xxx" ;;
                esac
                ;;
+       XS/APItest/KeywordRPN|xs/apitest/keywordrpn)
+               # This is just for testing.  Skip it unless we have dynamic loading.
+
+               case "$usedl" in
+               $define) avail_ext="$avail_ext $xxx" ;;
+               esac
+               ;;
        XS/Typemap|xs/typemap)
                # This is just for testing.  Skip it unless we have dynamic loading.
                case "$usedl" in
index 4a903a2..61011ab 100644 (file)
@@ -546,7 +546,7 @@ doublesize='8'
 drand01='drand48()'
 drand48_r_proto='0'
 dtrace=''
-dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
 eagain='EAGAIN'
 ebcdic='undef'
 echo='echo'
@@ -561,7 +561,7 @@ endservent_r_proto='0'
 eunicefix=':'
 exe_ext=''
 expr='expr'
-extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared Errno'
+extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared Errno'
 extras=''
 fflushNULL='define'
 fflushall='undef'
@@ -751,7 +751,7 @@ issymlink='/usr/bin/test -h'
 ivdformat='"ld"'
 ivsize='4'
 ivtype='long'
-known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
 ksh=''
 ld='cc'
 lddlflags='-shared -L/usr/local/lib'
index 3e5ebdd..d65aaba 100644 (file)
@@ -531,7 +531,7 @@ dlsrc='dl_dlopen.xs'
 doublesize='8'
 drand01='drand48()'
 drand48_r_proto='0'
-dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
 eagain='EAGAIN'
 ebcdic='undef'
 echo='echo'
@@ -546,7 +546,7 @@ endservent_r_proto='0'
 eunicefix=':'
 exe_ext=''
 expr='expr'
-extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared Errno'
+extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared Errno'
 extras=''
 fflushNULL='define'
 fflushall='undef'
@@ -736,7 +736,7 @@ issymlink='/usr/bin/test -h'
 ivdformat='"ld"'
 ivsize='4'
 ivtype='long'
-known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
 ksh=''
 ld='arm-none-linux-gnueabi-gcc'
 lddlflags='-shared -L/usr/local/lib'
index 44b1bde..e40c344 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3198,6 +3198,11 @@ ext/XS-APItest/APItest.xs        XS::APItest extension
 ext/XS-APItest/core.c          Test API functions when PERL_CORE is defined
 ext/XS-APItest/core_or_not.inc Code common to core.c and notcore.c
 ext/XS-APItest/exception.c     XS::APItest extension
+ext/XS-APItest-KeywordRPN/KeywordRPN.pm        XS::APItest::KeywordRPN extension
+ext/XS-APItest-KeywordRPN/KeywordRPN.xs        XS::APItest::KeywordRPN extension
+ext/XS-APItest-KeywordRPN/Makefile.PL  XS::APItest::KeywordRPN extension
+ext/XS-APItest-KeywordRPN/README       XS::APItest::KeywordRPN extension
+ext/XS-APItest-KeywordRPN/t/keyword_plugin.t   test keyword plugin mechanism
 ext/XS-APItest/Makefile.PL     XS::APItest extension
 ext/XS-APItest/MANIFEST                XS::APItest extension
 ext/XS-APItest/notcore.c       Test API functions when PERL_CORE is not defined
index 20e99ff..2807111 100644 (file)
@@ -326,6 +326,7 @@ STORABLE_NLM                = $(EXTDIR)\Storable\Storable.NLM
 LISTUTIL_NLM           = $(EXTDIR)\List\Util.NLM
 MIMEBASE64_NLM         = $(EXTDIR)\MIME\Base64\Base64.NLM
 XSAPITEST_NLM          = $(EXTDIR)\XS\APItest\APItest.NLM
+XSAPITESTKEYWORDRPN_NLM        = $(EXTDIR)\XS\APItest\KeywordRPN\KeywordRPN.NLM
 XSTYPEMAP_NLM          = $(EXTDIR)\XS\Typemap\Typemap.NLM
 UNICODENORMALIZE_NLM   = $(EXTDIR)\Unicode\Normalize\Normalize.NLM
 
@@ -350,6 +351,7 @@ EXTENSION_NLM       =               \
                $(LISTUTIL_NLM)         \
                $(MIMEBASE64_NLM)       \
                $(XSAPITEST_NLM)        \
+               $(XSAPITESTKEYWORDRPN_NLM)      \
                $(XSTYPEMAP_NLM)        \
                $(UNICODENORMALIZE_NLM)  \
                $(FILTER_NLM)   
@@ -789,7 +791,7 @@ X2P_OBJ             = $(X2P_SRC:.c=.obj)
 
 DYNAMIC_EXT    = Socket IO Fcntl Opcode SDBM_File POSIX attributes B re \
                Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
-               Storable/Storable List/Util MIME/Base64/Base64 XS/APItest/APItest \
+               Storable/Storable List/Util MIME/Base64/Base64 XS/APItest/APItest XS/APItest/KeywordRPN \
                XS/Typemap/Typemap Unicode/Normalize/Normalize Sys/Hostname
 
 STATIC_EXT     = DynaLoader
@@ -817,6 +819,7 @@ STORABLE            = $(EXTDIR)\Storable\Storable
 LISTUTIL               = $(EXTDIR)\List\Util
 MIMEBASE64             = $(EXTDIR)\MIME\Base64\Base64
 XSAPITEST              = $(EXTDIR)\XS\APItest\APItest
+XSAPITESTKEYWORDRPN    = $(EXTDIR)\XS\APItest\KeywordRPN\KeywordRPN
 XSTYPEMAP              = $(EXTDIR)\XS\Typemap\Typemap
 UNICODENORMALIZE       = $(EXTDIR)\Unicode\Normalize\Normalize
 
@@ -843,6 +846,7 @@ EXTENSION_C =               \
                $(LISTUTIL).c   \
                $(MIMEBASE64).c \
                $(XSAPITEST).c  \
+               $(XSAPITESTKEYWORDRPN).c        \
                $(XSTYPEMAP).c  \
                $(UNICODENORMALIZE).c   \
 
@@ -1267,6 +1271,12 @@ $(XSAPITEST_NLM):
        $(MAKE)
        cd ..\..\..\netware
 
+$(XSAPITESTKEYWORDRPN_NLM):
+       cd $(EXTDIR)\XS\$(*B)
+       ..\..\..\miniperl -I..\..\lib Makefile.PL PERL_CORE=1 INSTALLDIRS=perl
+       $(MAKE)
+       cd ..\..\..\netware
+
 $(XSTYPEMAP_NLM):
        cd $(EXTDIR)\XS\$(*B)
        ..\..\..\miniperl -I..\..\lib Makefile.PL PERL_CORE=1 INSTALLDIRS=perl
index f72f3e1..1703d25 100755 (executable)
@@ -1734,6 +1734,14 @@ use File::Glob qw(:case);
        'UPSTREAM'      => 'cpan',
        },
 
+    'XS::APItest::KeywordRPN' =>
+       {
+       'MAINTAINER'    => 'zefram',
+       'FILES'         => q[ext/XS-APItest-KeywordRPN],
+       'CPAN'          => 0,
+       'UPSTREAM'      => 'blead',
+       },
+
     'XSLoader' =>
        {
        'MAINTAINER'    => 'saper',
index b958755..c18faa4 100644 (file)
@@ -560,7 +560,7 @@ doublesize='8'
 drand01='drand48()'
 drand48_r_proto='0'
 dtrace=''
-dynamic_ext='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/Typemap threads/shared Hash/Util/FieldHash'
+dynamic_ext='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash'
 eagain='EAGAIN'
 ebcdic='undef'
 echo='echo'
@@ -575,7 +575,7 @@ endservent_r_proto='0'
 eunicefix=':'
 exe_ext=''
 expr='expr'
-extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/Typemap threads/shared Hash/Util/FieldHash Compress/Zlib Errno IO_Compress_Base IO_Compress_Zlib Module/Pluggable Test/Harness'
+extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash Compress/Zlib Errno IO_Compress_Base IO_Compress_Zlib Module/Pluggable Test/Harness'
 extern_C='extern'
 extras=''
 fflushNULL='define'
@@ -767,7 +767,7 @@ issymlink='test -h'
 ivdformat='"Ld"'
 ivsize='8'
 ivtype='long long'
-known_extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/Typemap threads/shared Hash/Util/FieldHash'
+known_extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash'
 ksh=''
 ld='cc'
 lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector'
index f385f55..5d97c85 100644 (file)
@@ -46,6 +46,7 @@ repair()
      -e 's=cwd=Cwd=' \
      -e 's=perlio/via=PerlIO/via=' \
      -e 's=perlio/encoding=PerlIO/encoding=' \
+     -e 's=xs/apitest/keywordrpn=XS/APItest/KeywordRPN=' \
      -e 's=xs/apitest=XS/APItest=' \
      -e 's=xs/typemap=XS/Typemap=' \
      -e 's=unicode/normaliz=Unicode/Normalize=' \
index 3d07282..47dfa42 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2228,6 +2228,8 @@ ApoM      |const char *|fetch_cop_label|NULLOK struct refcounted_he *const chain \
 xpoM   |struct refcounted_he *|store_cop_label \
                |NULLOK struct refcounted_he *const chain|NN const char *label
 
+xpo    |int    |keyword_plugin_standard|NN char* keyword_ptr|STRLEN keyword_len|NN OP** op_ptr
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:
diff --git a/ext/XS-APItest-KeywordRPN/KeywordRPN.pm b/ext/XS-APItest-KeywordRPN/KeywordRPN.pm
new file mode 100644 (file)
index 0000000..085d3f6
--- /dev/null
@@ -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 (file)
index 0000000..219d6ac
--- /dev/null
@@ -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 (file)
index 0000000..ae2c72a
--- /dev/null
@@ -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 (file)
index 0000000..4caa629
--- /dev/null
@@ -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 (file)
index 0000000..2b705d7
--- /dev/null
@@ -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;
diff --git a/perl.h b/perl.h
index 9f80c5b..45371d6 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -4753,6 +4753,11 @@ typedef void (*XSUBADDR_t) (pTHX_ CV *);
 typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
 typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
 typedef void(CPERLscope(*Perl_ophook_t))(pTHX_ OP*);
+typedef int (CPERLscope(*Perl_keyword_plugin_t))(pTHX_ char*, STRLEN, OP**);
+
+#define KEYWORD_PLUGIN_DECLINE 0
+#define KEYWORD_PLUGIN_STMT    1
+#define KEYWORD_PLUGIN_EXPR    2
 
 /* Interpreter exitlist entry */
 typedef struct exitlistentry {
index 49f4d5e..3639bd6 100644 (file)
@@ -8,9 +8,9 @@
  *
  */
 
-/****************/
-/* Truly global */
-/****************/
+/*
+=head1 Global Variables
+*/
 
 /* Don't forget to re-run embed.pl to propagate changes! */
 
@@ -186,3 +186,65 @@ PERLVARI(Gglobal_struct_size,      U16,    sizeof(struct perl_vars))
 PERLVARI(Ginterp_size_5_10_0, U16,
         PERL_INTERPRETER_SIZE_UPTO_MEMBER(PERL_LAST_5_10_0_INTERP_MEMBER))
 #endif
+
+/*
+=for apidoc AmUx|Perl_keyword_plugin_t|PL_keyword_plugin
+
+Function pointer, pointing at a function used to handle extended keywords.
+The function should be declared as
+
+       int keyword_plugin_function(pTHX_
+               char *keyword_ptr, STRLEN keyword_len,
+               OP **op_ptr)
+
+The function is called from the tokeniser, whenever a possible keyword
+is seen.  C<keyword_ptr> points at the word in the parser's input
+buffer, and C<keyword_len> gives its length; it is not null-terminated.
+The function is expected to examine the word, and possibly other state
+such as L<%^H|perlvar/%^H>, to decide whether it wants to handle it
+as an extended keyword.  If it does not, the function should return
+C<KEYWORD_PLUGIN_DECLINE>, and the normal parser process will continue.
+
+If the function wants to handle the keyword, it first must
+parse anything following the keyword that is part of the syntax
+introduced by the keyword.  The lexer interface is poorly documented.
+Broadly speaking, parsing needs to look at the buffer that extends
+from C<PL_parser-E<gt>bufptr> to C<PL_parser-E<gt>bufend>, and
+C<PL_parser-E<gt>bufptr> must be advanced across whatever text is
+consumed by the parsing process.  The buffer end is not necessarily the
+real end of the input text, but refilling the buffer is too complicated
+to discuss here.  See L<Devel::Declare> for some parsing experience,
+and hope for more core support in a future version of Perl.
+
+When a keyword is being handled, the plugin function must build
+a tree of C<OP> structures, representing the code that was parsed.
+The root of the tree must be stored in C<*op_ptr>.  The function then
+returns a contant indicating the syntactic role of the construct that
+it has parsed: C<KEYWORD_PLUGIN_STMT> if it is a complete statement, or
+C<KEYWORD_PLUGIN_EXPR> if it is an expression.  Note that a statement
+construct cannot be used inside an expression (except via C<do BLOCK>
+and similar), and an expression is not a complete statement (it requires
+at least a terminating semicolon).
+
+When a keyword is handled, the plugin function may also have
+(compile-time) side effects.  It may modify C<%^H>, define functions, and
+so on.  Typically, if side effects are the main purpose of a handler,
+it does not wish to generate any ops to be included in the normal
+compilation.  In this case it is still required to supply an op tree,
+but it suffices to generate a single null op.
+
+That's how the C<*PL_keyword_plugin> function needs to behave overall.
+Conventionally, however, one does not completely replace the existing
+handler function.  Instead, take a copy of C<PL_keyword_plugin> before
+assigning your own function pointer to it.  Your handler function should
+look for keywords that it is interested in and handle those.  Where it
+is not interested, it should call the saved plugin function, passing on
+the arguments it received.  Thus C<PL_keyword_plugin> actually points
+at a chain of handler functions, all of which have an opportunity to
+handle keywords, and only the last function in the chain (built into
+the Perl core) will normally return C<KEYWORD_PLUGIN_DECLINE>.
+
+=cut
+*/
+
+PERLVARI(Gkeyword_plugin, Perl_keyword_plugin_t, MEMBER_TO_FPTR(Perl_keyword_plugin_standard))
diff --git a/perly.y b/perly.y
index 5ec5845..544c2e9 100644 (file)
--- a/perly.y
+++ b/perly.y
@@ -73,6 +73,7 @@
 
 %token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF
 %token <opval> FUNC0SUB UNIOPSUB LSTOPSUB
+%token <opval> PLUGEXPR PLUGSTMT
 %token <p_tkval> LABEL
 %token <i_tkval> FORMAT SUB ANONSUB PACKAGE USE
 %token <i_tkval> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
@@ -241,6 +242,8 @@ line        :       label cond
                              }
                          })
                        }
+       |       label PLUGSTMT
+                       { $$ = newSTATEOP(0, PVAL($1), $2); }
        ;
 
 /* An expression which may have a side-effect */
@@ -1244,6 +1247,7 @@ term      :       termbinop
                                newSVOP(OP_CONST, 0, newSVpvs("Unimplemented")));
                          TOKEN_GETMAD($1,$$,'X');
                        }
+       |       PLUGEXPR
        ;
 
 /* "my" declarations, with optional attributes */
index c116359..763f7aa 100644 (file)
@@ -733,7 +733,7 @@ issymlink='/bin/test -h'
 ivdformat='"ld"'
 ivsize='4'
 ivtype='long'
-known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
 ksh=''
 ld='ld'
 lddlflags=''
index 4d52467..ca8c809 100644 (file)
@@ -52,6 +52,28 @@ boolean, string or number of objects. It is invoked when an object
 appears on the right hand side of the C<=~> operator, or when it is
 interpolated into a regexp. See L<overload>.
 
+=head2 Pluggable keywords
+
+Extension modules can now cleanly hook into the Perl parser to define new
+kinds of keyword-headed expression and compound statement.  The syntax
+following the keyword is defined entirely by the extension.  This allow
+a completely non-Perl sublanguage to be parsed inline, with the right
+ops cleanly generated.
+
+This feature is currently considered experimental, and using it to do
+anything interesting is difficult.  Many necessary supporting facilities,
+such as the lexer and the pad system, can only be accessed through
+unsupported internal interfaces.  It is intended that the Perl 5.13
+development cycle will see the addition of clean, supported interfaces
+for many of these functions.  In Perl 5.12 most uses of pluggable keywords
+will be via L<Devel::Declare>.
+
+See L<perlapi/PL_keyword_plugin> for the mechanism.  The Perl core source
+distribution also includes a new module L<XS::APItest::KeywordRPN>, which
+implements reverse Polish notation arithmetic via pluggable keywords.
+This module is mainly used for test purposes, and is not normally
+installed, but also serves as an example of how to use the new mechanism.
+
 =head1 New Platforms
 
 XXX List any platforms that this version of perl compiles on, that previous
index 3f0a78a..db9a17c 100644 (file)
@@ -373,6 +373,11 @@ is not the same as
     $var = 'myvar';
     $sym = "mypack::$var";
 
+=item Bad plugin affecting keyword '%s'
+
+(F) An extension using the keyword plugin mechanism violated the
+plugin API.
+
 =item Bad realloc() ignored
 
 (S malloc) An internal routine called realloc() on something that had
index c440faa..862e0ba 100644 (file)
@@ -86,6 +86,14 @@ which return C<-1> on failure.  Exceptions to this rule are C<wait>,
 C<waitpid>, and C<syscall>.  System calls also set the special C<$!>
 variable on failure.  Other functions do not, except accidentally.
 
+Extension modules can also hook into the Perl parser to define new
+kinds of keyword-headed expression.  These may look like functions, but
+may also look completely different.  The syntax following the keyword
+is defined entirely by the extension.  If you are an implementor, see
+L<perlapi/PL_keyword_plugin> for the mechanism.  If you are using such
+a module, see the module's documentation for details of the syntax that
+it defines.
+
 =head2 Perl Functions by Category
 X<function>
 
index 5e80901..d5fc4a7 100644 (file)
@@ -272,6 +272,14 @@ conditional is about to be evaluated again.  Thus it can be used to
 increment a loop variable, even when the loop has been continued via
 the C<next> statement.
 
+Extension modules can also hook into the Perl parser to define new
+kinds of compound statement.  These are introduced by a keyword which
+the extension recognises, and the syntax following the keyword is
+defined entirely by the extension.  If you are an implementor, see
+L<perlapi/PL_keyword_plugin> for the mechanism.  If you are using such
+a module, see the module's documentation for details of the syntax that
+it defines.
+
 =head2 Loop Control
 X<loop control> X<loop, control> X<next> X<last> X<redo> X<continue>
 
index 4b86b82..879b361 100644 (file)
@@ -114,5 +114,6 @@ ext XSLoader
 # ext  Unicode/Normalize       nonconst
 # ext  Win32                   USELESS
 # ext  XS/APItest              USELESS
+# ext  XS/APItest/KeywordRPN   USELESS
 # ext  XS/Typemap              nonconst USELESS
 
diff --git a/toke.c b/toke.c
index fa78415..deb3b11 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -343,6 +343,8 @@ static struct debug_tokens {
     { OROP,            TOKENTYPE_IVAL,         "OROP" },
     { OROR,            TOKENTYPE_NONE,         "OROR" },
     { PACKAGE,         TOKENTYPE_NONE,         "PACKAGE" },
+    { PLUGEXPR,                TOKENTYPE_OPVAL,        "PLUGEXPR" },
+    { PLUGSTMT,                TOKENTYPE_OPVAL,        "PLUGSTMT" },
     { PMFUNC,          TOKENTYPE_OPVAL,        "PMFUNC" },
     { POSTDEC,         TOKENTYPE_NONE,         "POSTDEC" },
     { POSTINC,         TOKENTYPE_NONE,         "POSTINC" },
@@ -5220,6 +5222,7 @@ Perl_yylex(pTHX)
     case 'z': case 'Z':
 
       keylookup: {
+       bool anydelim;
        I32 tmp;
 
        orig_keyword = 0;
@@ -5230,34 +5233,19 @@ Perl_yylex(pTHX)
        s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
 
        /* Some keywords can be followed by any delimiter, including ':' */
-       tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
+       anydelim = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
               (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
                             (PL_tokenbuf[0] == 'q' &&
                              strchr("qwxr", PL_tokenbuf[1])))));
 
        /* x::* is just a word, unless x is "CORE" */
-       if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
+       if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
            goto just_a_word;
 
        d = s;
        while (d < PL_bufend && isSPACE(*d))
                d++;    /* no comments skipped here, or s### is misparsed */
 
-       /* Is this a label? */
-       if (!tmp && PL_expect == XSTATE
-             && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
-           tmp = keyword(PL_tokenbuf, len, 0);
-           if (tmp)
-               Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
-           s = d + 1;
-           pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
-           CLINE;
-           TOKEN(LABEL);
-       }
-       else
-           /* Check for keywords */
-           tmp = keyword(PL_tokenbuf, len, 0);
-
        /* Is this a word before a => operator? */
        if (*d == '=' && d[1] == '>') {
            CLINE;
@@ -5268,6 +5256,47 @@ Perl_yylex(pTHX)
            TERM(WORD);
        }
 
+       /* Check for plugged-in keyword */
+       {
+           OP *o;
+           int result;
+           char *saved_bufptr = PL_bufptr;
+           PL_bufptr = s;
+           result = CALL_FPTR(PL_keyword_plugin)(aTHX_ PL_tokenbuf, len, &o);
+           s = PL_bufptr;
+           if (result == KEYWORD_PLUGIN_DECLINE) {
+               /* not a plugged-in keyword */
+               PL_bufptr = saved_bufptr;
+           } else if (result == KEYWORD_PLUGIN_STMT) {
+               pl_yylval.opval = o;
+               CLINE;
+               PL_expect = XSTATE;
+               return REPORT(PLUGSTMT);
+           } else if (result == KEYWORD_PLUGIN_EXPR) {
+               pl_yylval.opval = o;
+               CLINE;
+               PL_expect = XOPERATOR;
+               return REPORT(PLUGEXPR);
+           } else {
+               Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
+                                       PL_tokenbuf);
+           }
+       }
+
+       /* Check for built-in keyword */
+       tmp = keyword(PL_tokenbuf, len, 0);
+
+       /* Is this a label? */
+       if (!anydelim && PL_expect == XSTATE
+             && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
+           if (tmp)
+               Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
+           s = d + 1;
+           pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
+           CLINE;
+           TOKEN(LABEL);
+       }
+
        if (tmp < 0) {                  /* second-class keyword? */
            GV *ogv = NULL;     /* override (winner) */
            GV *hgv = NULL;     /* hidden (loser) */
@@ -13015,6 +13044,18 @@ Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
     return (char *)s;
 }
 
+int
+Perl_keyword_plugin_standard(pTHX_
+       char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
+{
+    PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
+    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(keyword_ptr);
+    PERL_UNUSED_ARG(keyword_len);
+    PERL_UNUSED_ARG(op_ptr);
+    return KEYWORD_PLUGIN_DECLINE;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
index 762b4b3..5986574 100644 (file)
@@ -213,6 +213,7 @@ if (defined($Config{'extensions'})) {
         next if $_ eq 'Devel/DProf'; 
         # test modules
         next if $_ eq 'XS/APItest';
+        next if $_ eq 'XS/APItest/KeywordRPN';
         next if $_ eq 'XS/Typemap';
            # VMS$ perl  -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
            # \NT> perl  -e "eval \"require 'Devel/DProf.pm'\"; print $@"