Got perl bindings started

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'])
 

src/bindings/.gitignore

@@ -0,0 +1 @@
+hammer_wrap.c

src/bindings/perl/.gitignore

@@ -0,0 +1 @@
+hammer.pm

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"

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;
+    }
+}

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;
+
+

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"