summaryrefslogtreecommitdiff
path: root/ext/XS-APItest
diff options
context:
space:
mode:
Diffstat (limited to 'ext/XS-APItest')
-rw-r--r--ext/XS-APItest/APItest.pm98
-rw-r--r--ext/XS-APItest/APItest.xs228
-rw-r--r--ext/XS-APItest/Makefile.PL2
-rw-r--r--ext/XS-APItest/t/keyword_multiline.t27
-rw-r--r--ext/XS-APItest/t/keyword_plugin.t76
-rw-r--r--ext/XS-APItest/t/stuff_svcur_bug.t12
-rw-r--r--ext/XS-APItest/t/swaptwostmts.t158
7 files changed, 597 insertions, 4 deletions
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index ca121adcc9..474d528fb4 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -1,6 +1,6 @@
package XS::APItest;
-use 5.008;
+{ use 5.011001; }
use strict;
use warnings;
use Carp;
@@ -35,6 +35,11 @@ sub import {
}
}
}
+ foreach (keys %{$exports||{}}) {
+ next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts)\z/;
+ $^H{"XS::APItest/$_"} = 1;
+ delete $exports->{$_};
+ }
if ($exports) {
my @carp = keys %$exports;
if (@carp) {
@@ -45,7 +50,7 @@ sub import {
}
}
-our $VERSION = '0.22';
+our $VERSION = '0.23';
use vars '$WARNINGS_ON_BOOTSTRAP';
use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);
@@ -101,6 +106,10 @@ XS::APItest - Test the perl C API
use XS::APItest;
print_double(4);
+ use XS::APItest qw(rpn calcrpn);
+ $triangle = rpn($n $n 1 + * 2 /);
+ calcrpn $triangle { $n $n 1 + * 2 / }
+
=head1 ABSTRACT
This module tests the perl C API. Also exposes various bit of the perl
@@ -226,6 +235,86 @@ Exercises the C function of the same name. Returns nothing.
=back
+=head1 KEYWORDS
+
+These are not supplied by default, but must be explicitly imported.
+They are lexically scoped.
+
+=over
+
+=item rpn(EXPRESSION)
+
+This construct is a Perl expression. I<EXPRESSION> must be an RPN
+arithmetic expression, as described below. 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 below. The RPN expression is evaluated, and its value is
+assigned to the variable.
+
+=back
+
+=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.
+
=head1 SEE ALSO
L<XS::Typemap>, L<perlapi>.
@@ -234,13 +323,16 @@ L<XS::Typemap>, L<perlapi>.
Tim Jenness, E<lt>t.jenness@jach.hawaii.eduE<gt>,
Christian Soeller, E<lt>csoelle@mph.auckland.ac.nzE<gt>,
-Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt>
+Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt>,
+Andrew Main (Zefram) <zefram@fysh.org>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2002,2004 Tim Jenness, Christian Soeller, Hugo van der Sanden.
All Rights Reserved.
+Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org>
+
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 48542dd6d0..67c27380dc 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -372,6 +372,224 @@ my_rpeep (pTHX_ OP *o)
}
}
+/** RPN keyword parser **/
+
+#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, *hintkey_stufftest_sv;
+static SV *hintkey_swaptwostmts_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)
+
+/* RPN parser */
+
+#define parse_var() THX_parse_var(aTHX)
+static OP *THX_parse_var(pTHX)
+{
+ char *s = PL_bufptr;
+ char *start = s;
+ PADOFFSET varpos;
+ OP *padop;
+ if(*s != '$') croak("RPN syntax error");
+ while(1) {
+ char c = *++s;
+ if(!isALNUM(c)) break;
+ }
+ if(s-start < 2) croak("RPN syntax error");
+ lex_read_to(s);
+ {
+ /* because pad_findmy() doesn't really use length yet */
+ SV *namesv = sv_2mortal(newSVpvn(start, s-start));
+ varpos = pad_findmy(SvPVX(namesv), s-start, 0);
+ }
+ if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
+ croak("RPN only supports \"my\" variables");
+ padop = newOP(OP_PADSV, 0);
+ padop->op_targ = varpos;
+ return padop;
+}
+
+#define push_rpn_item(o) \
+ (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
+#define pop_rpn_item() \
+ (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
+ (tmpop = stack, stack = stack->op_sibling, \
+ tmpop->op_sibling = NULL, tmpop))
+
+#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
+static OP *THX_parse_rpn_expr(pTHX)
+{
+ OP *stack = NULL, *tmpop;
+ while(1) {
+ I32 c;
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ switch(c) {
+ case /*(*/')': case /*{*/'}': {
+ OP *result = pop_rpn_item();
+ if(stack) croak("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 {
+ lex_read_unichar(0);
+ val = 10*val + (c - '0');
+ c = lex_peek_unichar(0);
+ } 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();
+ lex_read_unichar(0);
+ push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
+ } break;
+ case '-': {
+ OP *b = pop_rpn_item();
+ OP *a = pop_rpn_item();
+ lex_read_unichar(0);
+ push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
+ } break;
+ case '*': {
+ OP *b = pop_rpn_item();
+ OP *a = pop_rpn_item();
+ lex_read_unichar(0);
+ push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
+ } break;
+ case '/': {
+ OP *b = pop_rpn_item();
+ OP *a = pop_rpn_item();
+ lex_read_unichar(0);
+ push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
+ } break;
+ case '%': {
+ OP *b = pop_rpn_item();
+ OP *a = pop_rpn_item();
+ lex_read_unichar(0);
+ push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
+ } break;
+ default: {
+ croak("RPN syntax error");
+ } break;
+ }
+ }
+}
+
+#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
+static OP *THX_parse_keyword_rpn(pTHX)
+{
+ OP *op;
+ lex_read_space(0);
+ if(lex_peek_unichar(0) != '('/*)*/)
+ croak("RPN expression must be parenthesised");
+ lex_read_unichar(0);
+ op = parse_rpn_expr();
+ if(lex_peek_unichar(0) != /*(*/')')
+ croak("RPN expression must be parenthesised");
+ lex_read_unichar(0);
+ return op;
+}
+
+#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
+static OP *THX_parse_keyword_calcrpn(pTHX)
+{
+ OP *varop, *exprop;
+ lex_read_space(0);
+ varop = parse_var();
+ lex_read_space(0);
+ if(lex_peek_unichar(0) != '{'/*}*/)
+ croak("RPN expression must be braced");
+ lex_read_unichar(0);
+ exprop = parse_rpn_expr();
+ if(lex_peek_unichar(0) != /*{*/'}')
+ croak("RPN expression must be braced");
+ lex_read_unichar(0);
+ return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
+}
+
+#define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
+static OP *THX_parse_keyword_stufftest(pTHX)
+{
+ I32 c;
+ bool do_stuff;
+ lex_read_space(0);
+ do_stuff = lex_peek_unichar(0) == '+';
+ if(do_stuff) {
+ lex_read_unichar(0);
+ lex_read_space(0);
+ }
+ c = lex_peek_unichar(0);
+ if(c == ';') {
+ lex_read_unichar(0);
+ } else if(c != /*{*/'}') {
+ croak("syntax error");
+ }
+ if(do_stuff) lex_stuff_pvs(" ", 0);
+ return newOP(OP_NULL, 0);
+}
+
+#define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
+static OP *THX_parse_keyword_swaptwostmts(pTHX)
+{
+ OP *a, *b;
+ a = parse_fullstmt(0);
+ b = parse_fullstmt(0);
+ if(a && b)
+ PL_hints |= HINT_BLOCK_SCOPE;
+ /* should use append_list(), but that's not part of the public API */
+ return !a ? b : !b ? a : newLISTOP(OP_LINESEQ, 0, b, a);
+}
+
+/* plugin glue */
+
+#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
+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));
+}
+
+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 if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
+ keyword_active(hintkey_stufftest_sv)) {
+ *op_ptr = parse_keyword_stufftest();
+ return KEYWORD_PLUGIN_STMT;
+ } else if(keyword_len == 12 &&
+ strnEQ(keyword_ptr, "swaptwostmts", 12) &&
+ keyword_active(hintkey_swaptwostmts_sv)) {
+ *op_ptr = parse_keyword_swaptwostmts();
+ return KEYWORD_PLUGIN_STMT;
+ } else {
+ return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
+ }
+}
+
#include "const-c.inc"
MODULE = XS::APItest PACKAGE = XS::APItest
@@ -1319,3 +1537,13 @@ BOOT:
cv = GvCV(*meth);
CvLVALUE_on(cv);
}
+
+BOOT:
+{
+ hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
+ hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
+ hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
+ hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
+ next_keyword_plugin = PL_keyword_plugin;
+ PL_keyword_plugin = my_keyword_plugin;
+}
diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL
index 340fc7e910..3af0eb4f96 100644
--- a/ext/XS-APItest/Makefile.PL
+++ b/ext/XS-APItest/Makefile.PL
@@ -8,7 +8,7 @@ WriteMakefile(
'VERSION_FROM' => 'APItest.pm', # finds $VERSION
'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
ABSTRACT_FROM => 'APItest.pm', # retrieve abstract from module
- AUTHOR => 'Tim Jenness <t.jenness@jach.hawaii.edu>, Christian Soeller <csoelle@mph.auckland.ac.nz>, Hugo van der Sanden <hv@crypt.compulink.co.uk>',
+ AUTHOR => 'Tim Jenness <t.jenness@jach.hawaii.edu>, Christian Soeller <csoelle@mph.auckland.ac.nz>, Hugo van der Sanden <hv@crypt.compulink.co.uk>, Andrew Main (Zefram) <zefram@fysh.org>',
'C' => ['exception.c', 'core.c', 'notcore.c'],
'OBJECT' => '$(BASEEXT)$(OBJ_EXT) $(O_FILES)',
realclean => {FILES => 'const-c.inc const-xs.inc'},
diff --git a/ext/XS-APItest/t/keyword_multiline.t b/ext/XS-APItest/t/keyword_multiline.t
new file mode 100644
index 0000000000..e2cbdb87cb
--- /dev/null
+++ b/ext/XS-APItest/t/keyword_multiline.t
@@ -0,0 +1,27 @@
+use warnings;
+use strict;
+
+use Test::More tests => 4;
+
+my($t, $n);
+$n = 5;
+
+use XS::APItest qw(rpn);
+$t = rpn($n
+ $n 1 +
+ * #wibble
+#wobble
+2
+ /
+);
+is $t, 15;
+is __LINE__, 18;
+
+$t = 0;
+$t = rpn($n $n 1 + *
+#line 100
+ 2 /);
+is $t, 15;
+is __LINE__, 102;
+
+1;
diff --git a/ext/XS-APItest/t/keyword_plugin.t b/ext/XS-APItest/t/keyword_plugin.t
new file mode 100644
index 0000000000..a20c952dcb
--- /dev/null
+++ b/ext/XS-APItest/t/keyword_plugin.t
@@ -0,0 +1,76 @@
+use warnings;
+use strict;
+
+use Test::More tests => 13;
+
+BEGIN { $^H |= 0x20000; }
+no warnings;
+
+my($triangle, $num);
+$num = 5;
+
+$triangle = undef;
+eval q{
+ use XS::APItest ();
+ $triangle = rpn($num $num 1 + * 2 /);
+};
+isnt $@, "";
+
+$triangle = undef;
+eval q{
+ use XS::APItest qw(rpn);
+ $triangle = rpn($num $num 1 + * 2 /);
+};
+is $@, "";
+is $triangle, 15;
+
+$triangle = undef;
+eval q{
+ use XS::APItest qw(rpn);
+ $triangle = join(":", "x", rpn($num $num 1 + * 2 /), "y");
+};
+is $@, "";
+is $triangle, "x:15:y";
+
+$triangle = undef;
+eval q{
+ use XS::APItest qw(rpn);
+ $triangle = 1 + rpn($num $num 1 + * 2 /) * 10;
+};
+is $@, "";
+is $triangle, 151;
+
+$triangle = undef;
+eval q{
+ use XS::APItest qw(rpn);
+ $triangle = rpn($num $num 1 + * 2 /);
+ $triangle++;
+};
+is $@, "";
+is $triangle, 16;
+
+$triangle = undef;
+eval q{
+ use XS::APItest qw(rpn);
+ $triangle = rpn($num $num 1 + * 2 /)
+ $triangle++;
+};
+isnt $@, "";
+
+$triangle = undef;
+eval q{
+ use XS::APItest qw(calcrpn);
+ calcrpn $triangle { $num $num 1 + * 2 / }
+ $triangle++;
+};
+is $@, "";
+is $triangle, 16;
+
+$triangle = undef;
+eval q{
+ use XS::APItest qw(calcrpn);
+ 123 + calcrpn $triangle { $num $num 1 + * 2 / } ;
+};
+isnt $@, "";
+
+1;
diff --git a/ext/XS-APItest/t/stuff_svcur_bug.t b/ext/XS-APItest/t/stuff_svcur_bug.t
new file mode 100644
index 0000000000..6d0544cc87
--- /dev/null
+++ b/ext/XS-APItest/t/stuff_svcur_bug.t
@@ -0,0 +1,12 @@
+use warnings;
+use strict;
+
+use Test::More tests => 1;
+ok 1;
+
+use XS::APItest qw(stufftest);
+
+# In the buggy case, a syntax error occurs at EOF.
+# Adding a semicolon, any following statements, or anything else
+# causes the bug not to show itself.
+stufftest+;()
diff --git a/ext/XS-APItest/t/swaptwostmts.t b/ext/XS-APItest/t/swaptwostmts.t
new file mode 100644
index 0000000000..c11d650962
--- /dev/null
+++ b/ext/XS-APItest/t/swaptwostmts.t
@@ -0,0 +1,158 @@
+use warnings;
+use strict;
+
+use Test::More tests => 22;
+
+BEGIN { $^H |= 0x20000; }
+
+my $t;
+
+$t = "";
+eval q{
+ use XS::APItest ();
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ $t .= "c";
+ $t .= "d";
+};
+isnt $@, "";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ $t .= "c";
+ $t .= "d";
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ if(1) { $t .= "b"; }
+ $t .= "c";
+ $t .= "d";
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ if(1) { $t .= "c"; }
+ $t .= "d";
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ foreach(1..3) {
+ $t .= "c";
+ swaptwostmts
+ $t .= "d";
+ $t .= "e";
+ $t .= "f";
+ }
+ $t .= "g";
+};
+is $@, "";
+is $t, "acedfcedfcedfbg";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ $t .= "c";
+};
+is $@, "";
+is $t, "acb";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ $t .= "c"
+};
+is $@, "";
+is $t, "acb";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b"
+};
+isnt $@, "";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ $_ = $t;
+ $_ .= "a";
+ swaptwostmts
+ if(1) { $_ .= "b"; }
+ tr/a-z/A-Z/;
+ $_ .= "d";
+ $t = $_;
+};
+is $@, "";
+is $t, "Abd";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ sub add_to_t { $t .= $_[0]; }
+ add_to_t "a";
+ swaptwostmts
+ if(1) { add_to_t "b"; }
+ add_to_t "c";
+ add_to_t "d";
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ { $t .= "a"; }
+ swaptwostmts
+ if(1) { { $t .= "b"; } }
+ { $t .= "c"; }
+ { $t .= "d"; }
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest qw(swaptwostmts);
+ no warnings "void";
+ "@{[ $t .= 'a' ]}";
+ swaptwostmts
+ if(1) { "@{[ $t .= 'b' ]}"; }
+ "@{[ $t .= 'c' ]}";
+ "@{[ $t .= 'd' ]}";
+};
+is $@, "";
+is $t, "acbd";
+
+1;
View Lorry Controller Status