diff --git a/SConstruct b/SConstruct index 81bc849b15e11c8df5875d4cfdc39cb8d0757169..893dd4185b41d7721d1be2294879e4d25f5fa502 100644 --- a/SConstruct +++ b/SConstruct @@ -7,7 +7,7 @@ import sys vars = Variables(None, ARGUMENTS) vars.Add(PathVariable('DESTDIR', "Root directory to install in (useful for packaging scripts)", None, PathVariable.PathIsDirCreate)) vars.Add(PathVariable('prefix', "Where to install in the FHS", "/usr/local", PathVariable.PathAccept)) -vars.Add(ListVariable('bindings', 'Language bindings to build', 'none', ['python'])) +vars.Add(ListVariable('bindings', 'Language bindings to build', 'none', ['python', 'perl'])) env = Environment(ENV = {'PATH' : os.environ['PATH']}, variables = vars, tools=['default', 'scanreplace'], toolpath=['tools']) diff --git a/src/bindings/.gitignore b/src/bindings/.gitignore new file mode 100644 index 0000000000000000000000000000000000000000..8f0fde88f32a382af022bbeed57721e876ea4628 --- /dev/null +++ b/src/bindings/.gitignore @@ -0,0 +1 @@ +hammer_wrap.c diff --git a/src/bindings/perl/.gitignore b/src/bindings/perl/.gitignore new file mode 100644 index 0000000000000000000000000000000000000000..0f12fd2795151775c92ab47a2c10ac232591c8d0 --- /dev/null +++ b/src/bindings/perl/.gitignore @@ -0,0 +1 @@ +hammer.pm diff --git a/src/bindings/perl/SConscript b/src/bindings/perl/SConscript new file mode 100644 index 0000000000000000000000000000000000000000..52bc4bc5602d7d4eb576e1fe171604b23404cc46 --- /dev/null +++ b/src/bindings/perl/SConscript @@ -0,0 +1,19 @@ +# -*- python -*- +Import("env libhammer_shared") + +perlenv = env.Clone() + +perlenv.Append(CCFLAGS=["-fpic", '-DSWIG', '-Wno-all', '-Wno-extra', '-Wno-error', '-DHAMMER_INTERNAL__NO_STDARG_H'], + CPPPATH=["../.."], + LIBS=['hammer'], + LIBPATH=["../.."], + SWIGFLAGS=["-DHAMMER_INTERNAL__NO_STDARG_H", "-Isrc/", "-perl"]) + +perlenv.ParseConfig("perl -MConfig -e 'print(qq[-I$$Config{archlib}/CORE\n]);'") +perlenv.ParseConfig("perl -MConfig -e 'print($$Config{ccflags} . \"\n\");'") + +swig = ['hammer.i'] + +libhammer_perl = perlenv.SharedLibrary('hammer', swig, SHLIBPREFIX='') + +print "Reading perl sconscript" diff --git a/src/bindings/perl/hammer.i b/src/bindings/perl/hammer.i new file mode 100644 index 0000000000000000000000000000000000000000..5103a98c38d4eae35e7bc1ba4a9aa69887954058 --- /dev/null +++ b/src/bindings/perl/hammer.i @@ -0,0 +1,156 @@ +%module hammer; +%begin %{ +#include <unistd.h> +#include <stdint.h> +%} + +%inline %{ + static int h_tt_perl; + %} +%init %{ + h_tt_perl = h_allocate_token_type("com.upstandinghackers.hammer.perl"); + %} + + +%apply (char *STRING, size_t LENGTH) {(uint8_t* str, size_t len)} +%apply (uint8_t* str, size_t len) {(const uint8_t* input, size_t length)} +%apply (uint8_t* str, size_t len) {(const uint8_t* str, const size_t len)} +%apply (uint8_t* str, size_t len) {(const uint8_t* charset, size_t length)} + +%typemap(out) struct HParseResult_* { + SV* hpt_to_perl(const struct HParsedToken_ *token); + if ($1 == NULL) { + // TODO: raise parse failure + $result = newSV(0); + } else { + $result = hpt_to_perl($1->ast); + //hpt_to_perl($1->ast); + } + } + +%typemap(in) uint8_t { + if (SvIOKp($input)) { + $1 = SvIV($input); + } else if (SvPOKp($input)) { + IV len; + uint8_t* ival = SvPV($input, len); + if (len < 1) { + %type_error("Expected string with at least one character"); + SWIG_fail; + } + $1 = ival[0]; + } else { + %type_error("Expected int or string"); + SWIG_fail; + } + } + + +%typemap(newfree) struct HParseResult_* { + h_parse_result_free($input); + } + +%rename("token") h_token; +%rename("%(regex:/^h_(.*)/\\1/)s", regextarget=1) "^h_u?int(64|32|16|8)"; +%rename("int_range") h_int_range; +%include "../swig/hammer.i"; + + +%{ + SV* hpt_to_perl(const HParsedToken *token) { + // All values that this function returns have a refcount of exactly 1. + SV *ret; + if (token == NULL) { + return newSV(0); // TODO: croak. + } + switch (token->token_type) { + case TT_NONE: + return newSV(0); + break; + case TT_BYTES: + return newSVpvn((char*)token->token_data.bytes.token, token->token_data.bytes.len); + case TT_SINT: + // TODO: return PyINT if appropriate + return newSViv(token->token_data.sint); + case TT_UINT: + // TODO: return PyINT if appropriate + return newSVuv(token->token_data.uint); + case TT_SEQUENCE: { + AV* aret; + 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])); + } + return newRV_noinc((SV*)aret); + } + default: + if (token->token_type == h_tt_perl) { + return (SV*)token->token_data.user; + + return SvREFCNT_inc(ret); + } else { + return SWIG_NewPointerObj((void*)token, SWIGTYPE_p_HParsedToken_, 0 | 0); + // TODO: support registry + } + + } + + } + /* + HParser* ch(uint8_t chr) { + return h_action(h_ch(chr), h__to_dual_char, NULL); + } + HParser* in(const uint8_t *charset, size_t length) { + return h_action(h_in(charset, length), h__to_dual_char, NULL); + } + HParser* not_in(const uint8_t *charset, size_t length) { + return h_action(h_not_in(charset, length), h__to_dual_char, NULL); + } + */ + HParsedToken* h__to_char(const HParseResult* result, void* user_data) { + assert(result != NULL); + assert(result->ast != NULL); + assert(result->ast->token_type == TT_UINT); + + uint8_t buf = result->ast->token_data.uint; + SV *sv = newSVpvn(&buf, 1); + // This was a failed experiment; for now, you'll have to use ord yourself. + //sv_setuv(sv, buf); + //SvPOK_on(sv); + + HParsedToken *res = h_arena_malloc(result->arena, sizeof(HParsedToken)); + res->token_type = h_tt_perl; + res->token_data.user = sv; + return res; + } + +%} +%inline { + HParser* ch(uint8_t chr) { + return h_action(h_ch(chr), h__to_char, NULL); + } + 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) { + return h_action(h_in(charset, length), h__to_char, NULL); + } + HParser* not_in(const uint8_t *charset, size_t length) { + return h_action(h_not_in(charset, length), h__to_char, NULL); + } + } + +%extend HParser_ { + SV* parse(const uint8_t* input, size_t length) { + SV* hpt_to_perl(const struct HParsedToken_ *token); + HParseResult *res = h_parse($self, input, length); + if (res) { + return hpt_to_perl(res->ast); + } else { + croak("Parse failure"); + } + } + bool compile(HParserBackend backend) { + return h_compile($self, backend, NULL) == 0; + } +} diff --git a/src/bindings/perl/t/hammer.t b/src/bindings/perl/t/hammer.t new file mode 100644 index 0000000000000000000000000000000000000000..81e441076560fc482e73eab2aa9e2caa851ba23e --- /dev/null +++ b/src/bindings/perl/t/hammer.t @@ -0,0 +1,115 @@ +# -*- cperl -*- +use warnings; +use Test::More tests => 12; +use hammer; + +sub check_parse_eq { + my ($parser, $input, $expected) = @_; + my $actual; + eval { + $actual = $parser->parse($input); + }; + if ($@) { + ok($@ eq ""); + } else { + is_deeply($actual, $expected); + } +} + +sub check_parse_failed { + my ($parser, $input) = @_; + eval { + my $actual = $parser->parse($input); + }; + ok($@ ne ""); +} + +subtest "token" => sub { + my $parser = hammer::token("95\xa2"); + + check_parse_eq($parser, "95\xa2", "95\xa2"); + check_parse_failed($parser, "95"); +}; + +subtest "ch" => sub { + my $parser = hammer::ch("\xa2"); + #check_parse_eq($parser, "\xa2", 0xa2); + check_parse_eq($parser, "\xa2", "\xa2"); + check_parse_failed($parser, "\xa3"); +}; + +subtest "ch_range" => sub { + # ch_range doesn't need to be part of hammer-perl; the equivalent + # effect can be achieved with hammer::in('a'..'z') + # + # However, the function is provided just in case. + my $parser = hammer::ch_range('a','c'); + check_parse_eq($parser, 'b', 'b'); + #check_parse_eq($parser, 'b', 0x62); + check_parse_failed($parser, 'd'); +}; + +SKIP: { + use integer; + 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(); + check_parse_eq($parser, "\xff\xff\xff\xfe\x00\x00\x00\x00", -0x200000000); + check_parse_failed($parser, "\xff\xff\xff\xfe\x00\x00\x00"); + }; + subtest "uint64" => sub { + my $parser = hammer::uint64(); + check_parse_eq($parser, "\x00\x00\x00\x02\x00\x00\x00\x00", 0x200000000); + check_parse_failed($parser, "\x00\x00\x00\x02\x00\x00\x00"); + }; +} + +subtest "int32" => sub { + my $parser = hammer::int32(); + check_parse_eq($parser, "\xff\xfe\x00\x00", -0x20000); + check_parse_eq($parser, "\x00\x02\x00\x00", 0x20000); + check_parse_failed($parser, "\xff\xfe\x00"); + check_parse_failed($parser, "\x00\x02\x00"); +}; + +subtest "uint32" => sub { + my $parser = hammer::uint32(); + check_parse_eq($parser, "\x00\x02\x00\x00", 0x20000); + check_parse_failed($parser, "\x00\x02\x00") +}; + +subtest "int16" => sub { + my $parser = hammer::int16(); + check_parse_eq($parser, "\xfe\x00", -0x200); + check_parse_eq($parser, "\x02\x00", 0x200); + check_parse_failed($parser, "\xfe"); + check_parse_failed($parser, "\x02"); +}; + +subtest "uint16" => sub { + my $parser = hammer::uint16(); + check_parse_eq($parser, "\x02\x00", 0x200); + check_parse_failed($parser, "\x02"); +}; + +subtest "int8" => sub { + my $parser = hammer::int8(); + check_parse_eq($parser, "\x88", -0x78); + check_parse_failed($parser, ""); +}; + +subtest "uint8" => sub { + my $parser = hammer::uint8(); + check_parse_eq($parser, "\x78", 0x78); + check_parse_failed($parser, ""); +}; + +subtest "int_range" => sub { # test 12 + my $parser = hammer::int_range(hammer::uint8(), 3, 10); + check_parse_eq($parser, "\x05", 5); + check_parse_failed($parser, "\x0b"); +}; + +1; + + diff --git a/src/bindings/swig/hammer.i b/src/bindings/swig/hammer.i index 5ac8c3767b2c639e2a5444de532ca1e59c8a450a..13c30a4dee457d6c3fdd2112bf92fb652d7c99d0 100644 --- a/src/bindings/swig/hammer.i +++ b/src/bindings/swig/hammer.i @@ -135,7 +135,10 @@ %{ #include "allocator.h" #include "hammer.h" +#ifndef SWIGPERL +// Perl's embed.h conflicts with err.h, which internal.h includes. Ugh. #include "internal.h" +#endif #include "glue.h" %} %include "allocator.h"