diff --git a/src/bindings/perl/hammer.i b/src/bindings/perl/hammer.i
index 5103a98c38d4eae35e7bc1ba4a9aa69887954058..49036574003f299aa85d72b6b762f66e67b6df2c 100644
--- a/src/bindings/perl/hammer.i
+++ b/src/bindings/perl/hammer.i
@@ -28,6 +28,26 @@
}
}
+%typemap(in) void*[] {
+ if (!SvROK($input))
+ SWIG_exception_fail(SWIG_TypeError, "Expected array ref");
+
+ if (SvTYPE(SvRV($input)) != SVt_PVAV)
+ SWIG_exception_fail(SWIG_TypeError, "Expected array ref");
+
+ AV* av = (AV*) SvRV($input);
+ size_t amax = av_top_index(av) + 1; // I want the length, not the top index...
+ // TODO: is this array copied?
+ $1 = malloc(amax * sizeof(*$1));
+ $1[amax] = NULL;
+ for (int i = 0; i < amax; i++) {
+ int res = SWIG_ConvertPtr(*av_fetch(av, i, 0), &($1[i]), SWIGTYPE_p_HParser_, 0|0);
+ if (!SWIG_IsOK(res)) {
+ SWIG_exception_fail(SWIG_ArgError(res), "Expected a list of parsers and only parsers");
+ }
+ }
+ }
+
%typemap(in) uint8_t {
if (SvIOKp($input)) {
$1 = SvIV($input);
@@ -52,7 +72,12 @@
%rename("token") h_token;
%rename("%(regex:/^h_(.*)/\\1/)s", regextarget=1) "^h_u?int(64|32|16|8)";
+%rename("end_p") h_end_p;
+%rename("left") h_left;
+%rename("middle") h_middle;
+%rename("right") h_right;
%rename("int_range") h_int_range;
+%rename("whitespace") h_whitespace;
%include "../swig/hammer.i";
@@ -76,7 +101,7 @@
// TODO: return PyINT if appropriate
return newSVuv(token->token_data.uint);
case TT_SEQUENCE: {
- AV* aret;
+ AV* aret = newAV();
av_extend(aret, token->token_data.seq->used);
for (int i = 0; i < token->token_data.seq->used; i++) {
av_store(aret, i, hpt_to_perl(token->token_data.seq->elements[i]));
@@ -85,9 +110,7 @@
}
default:
if (token->token_type == h_tt_perl) {
- return (SV*)token->token_data.user;
-
- return SvREFCNT_inc(ret);
+ return SvREFCNT_inc((SV*)token->token_data.user);
} else {
return SWIG_NewPointerObj((void*)token, SWIGTYPE_p_HParsedToken_, 0 | 0);
// TODO: support registry
@@ -124,6 +147,41 @@
return res;
}
+ static HParsedToken* call_action(const HParseResult *p, void* user_data ) {
+ SV *func = (SV*)user_data;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ if (p->ast != NULL) {
+ mXPUSHs(hpt_to_perl(p->ast));
+ } else {
+ mXPUSHs(newSV(0));
+ }
+ PUTBACK;
+
+ int nret = call_sv(func, G_SCALAR);
+
+ SPAGAIN;
+ if (nret != 1)
+ croak("Expected 1 return value, got %d", nret);
+
+ HParsedToken *ret = h_arena_malloc(p->arena, sizeof(*ret));
+ memset(ret, 0, sizeof(*ret));
+ ret->token_type = h_tt_perl;
+ ret->token_data.user = SvREFCNT_inc(POPs);
+ if (p->ast != NULL) {
+ ret->index = p->ast->index;
+ ret->bit_offset = p->ast->bit_offset;
+ }
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return ret;
+ }
+
%}
%inline {
HParser* ch(uint8_t chr) {
@@ -132,12 +190,15 @@
HParser* ch_range(uint8_t c0, uint8_t c1) {
return h_action(h_ch_range(c0,c1), h__to_char, NULL);
}
- HParser* in(const uint8_t *charset, size_t length) {
+ HParser* h__in(const uint8_t *charset, size_t length) {
return h_action(h_in(charset, length), h__to_char, NULL);
}
- HParser* not_in(const uint8_t *charset, size_t length) {
+ HParser* h__not_in(const uint8_t *charset, size_t length) {
return h_action(h_not_in(charset, length), h__to_char, NULL);
}
+ HParser* action(HParser *parser, SV* sub) {
+ return h_action(parser, call_action, SvREFCNT_inc(sub));
+ }
}
%extend HParser_ {
@@ -154,3 +215,19 @@
return h_compile($self, backend, NULL) == 0;
}
}
+
+%perlcode %{
+ sub sequence {
+ return hammerc::h_sequence__a([@_]);
+ }
+ sub choice {
+ return hammerc::h_choice__a([@_]);
+ }
+ sub in {
+ return h__in(join('',@_));
+ }
+ sub not_in {
+ return h__not_in(join('',@_));
+ }
+
+ %}
diff --git a/src/bindings/perl/t/hammer.t b/src/bindings/perl/t/hammer.t
index 81e441076560fc482e73eab2aa9e2caa851ba23e..424aa9c03e9b4b033311a76209b484440da2afa9 100644
--- a/src/bindings/perl/t/hammer.t
+++ b/src/bindings/perl/t/hammer.t
@@ -1,8 +1,10 @@
# -*- cperl -*-
use warnings;
-use Test::More tests => 12;
+use strict;
+use Test::More tests => 21;
use hammer;
+
sub check_parse_eq {
my ($parser, $input, $expected) = @_;
my $actual;
@@ -10,6 +12,7 @@ sub check_parse_eq {
$actual = $parser->parse($input);
};
if ($@) {
+ diag($@);
ok($@ eq "");
} else {
is_deeply($actual, $expected);
@@ -51,6 +54,7 @@ subtest "ch_range" => sub {
SKIP: {
use integer;
+ no warnings 'portable'; # I know the hex constants are not portable. that's why this test is skipped on <64 bit systems.
skip "Needs 64-bit support", 2 if 0x4000000 * 2 eq -1; # TODO: Not sure if this works; may need $Config{ivsize} >= 8
subtest "int64" => sub {
my $parser = hammer::int64();
@@ -110,6 +114,78 @@ subtest "int_range" => sub { # test 12
check_parse_failed($parser, "\x0b");
};
-1;
+subtest "whitespace" => sub {
+ my $parser = hammer::whitespace(hammer::ch('a'));
+ check_parse_eq($parser, "a", "a");
+ check_parse_eq($parser, " a", "a");
+ check_parse_eq($parser, " a", "a");
+ check_parse_eq($parser, "\t\n\ra", "a");
+};
+
+subtest "whitespace-end" => sub {
+ my $parser = hammer::whitespace(hammer::end_p());
+ check_parse_eq($parser, "", undef);
+ check_parse_eq($parser, " ", undef);
+ check_parse_failed($parser, " x", undef)
+};
+
+subtest "left" => sub { # test 15
+ my $parser = hammer::left(hammer::ch('a'),
+ hammer::ch(' '));
+ check_parse_eq($parser, "a ", "a");
+ check_parse_failed($parser, "a");
+ check_parse_failed($parser, " ");
+};
+
+subtest "right" => sub {
+ my $parser = hammer::right(hammer::ch(' '),
+ hammer::ch('a'));
+ check_parse_eq($parser, " a", "a");
+ check_parse_failed($parser, "a");
+ check_parse_failed($parser, " ");
+};
+
+subtest "middle" => sub {
+ my $parser = hammer::middle(hammer::ch(' '),
+ hammer::ch('a'),
+ hammer::ch(' '));
+ check_parse_eq($parser, " a ", "a");
+ for my $test_string (split('/', "a/ / a/a / b /ba / ab")) {
+ check_parse_failed($parser, $test_string);
+ }
+};
+
+subtest "action" => sub {
+ my $parser = hammer::action(hammer::sequence(hammer::choice(hammer::ch('a'),
+ hammer::ch('A')),
+ hammer::choice(hammer::ch('b'),
+ hammer::ch('B'))),
+ sub { [map(uc, @{+shift})]; });
+ check_parse_eq($parser, "ab", ['A', 'B']);
+ check_parse_eq($parser, "AB", ['A', 'B']);
+ check_parse_eq($parser, 'Ab', ['A', 'B']);
+ check_parse_failed($parser, "XX");
+};
+
+
+subtest "in" => sub {
+ my $parser = hammer::in('a'..'c');
+ check_parse_eq($parser, 'a', 'a');
+ check_parse_eq($parser, 'b', 'b');
+ check_parse_eq($parser, 'c', 'c');
+ check_parse_failed($parser, 'd');
+};
+subtest "not_in" => sub { # test 20
+ my $parser = hammer::not_in('a'..'c');
+ check_parse_failed($parser, 'a');
+ check_parse_failed($parser, 'b');
+ check_parse_failed($parser, 'c');
+ check_parse_eq($parser, 'd', 'd');
+};
+subtest "end_p" => sub {
+ my $parser = hammer::sequence(hammer::ch('a'), hammer::end_p());
+ check_parse_eq($parser, 'a', ['a']);
+ check_parse_failed($parser, 'aa');
+};