initial checkin of perl bindings

lang/perl/Stasis.pm

@@ -0,0 +1,264 @@
+package Stasis;
+require Inline;
+
+my $STASIS_DIR;
+BEGIN {
+ $STASIS_DIR = $ENV{STASIS_DIR}
+   || die "\nNeed STASIS_DIR environment variable!!\n\n";
+#'/home/sears/stasis4';
+}
+use Inline C => Config => LIBS =>
+    "-L$STASIS_DIR/build/src/stasis/ " .
+    "-L$STASIS_DIR/build/src/libdfa/ " .
+    "-lstasis -lrw",
+  ENABLE => AUTOWRAP,
+  TYPEMAPS => "$STASIS_DIR/lang/perl/typemap",
+  PREFIX => 'stasis_perl_';
+use Inline ( C => 'DATA',
+             INC  => "-I $STASIS_DIR"
+    );
+
+sub version {
+   return "Stasis 0.1";
+}
+
+__DATA__
+__C__
+#include "stasis/transactional.h"
+
+static int initted;
+
+int Tinit();
+int Tdeinit();
+int Tbegin();
+int Tcommit(int xid);
+int Tabort(int xid);
+int Tprepare(int xid);
+recordid Talloc(int xid, unsigned long size);
+
+int TrecordType(int xid, recordid rid);
+int TrecordSize(int xid, recordid rid);
+
+static recordid recordid_SV(SV* sv) {
+   if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)) {
+     abort();
+   }
+   if (!(sv_isobject(sv) && sv_derived_from(sv, "Stasis::Recordid"))) {
+     abort();
+   }
+   AV * av = (AV*)SvRV(sv);
+   if(av_len(av)+1 != 2) {
+     abort();
+   }
+   SV ** pageSV = av_fetch(av, 0, 0);
+   SV ** slotSV = av_fetch(av, 1, 0);
+   if(!(pageSV  &&  slotSV &&
+        *pageSV && *slotSV &&
+        SvIOK(*pageSV) && SvIOK(*slotSV))) {
+     abort();
+   }
+   recordid rid = {
+     (pageid_t) SvUV(*pageSV),
+     (slotid_t) SvUV(*slotSV)
+   };
+
+   return rid;
+}
+static SV* SV_recordid(recordid rid) {
+   SV* sv;
+   if(!memcmp(&rid, &NULLRID, sizeof(NULLRID))) {
+     sv = newSV(0);
+   } else {
+     AV* arry = newAV();
+     av_push(arry, newSVuv((UV) rid.page));
+     av_push(arry, newSVuv((UV) rid.slot));
+     sv = newRV_noinc((SV*)arry);
+   }
+   return sv_bless(sv, gv_stashpv("Stasis::Recordid", GV_ADD));
+}
+
+static byte * bytes_SV(SV* sv, STRLEN * sz) {
+  byte * ret = 0;
+  IV valI;
+  NV valN;
+  char* valP;
+  byte * tmp;
+  recordid valR;
+  char code;
+  if(SvIOK(sv)) {
+    // signed int, machine length
+    valI = SvIV(sv);
+    *sz = sizeof(IV);
+    tmp = (byte*)&valI;
+    code = 'I';
+  } else if (SvNOK(sv)) {
+    valN = SvNV(sv); // double
+    *sz = sizeof(NV);
+    tmp = (byte*)&valN;
+    code = 'N';
+  } else if (SvPOK(sv)) {
+    valP = (byte*)SvPV(sv,*sz); // string
+    tmp = valP;
+    code = 'P';
+  } else if (sv_isobject(sv) && sv_derived_from(sv, "Stasis::Recordid")) {
+    valR = recordid_SV(sv);
+    *sz = sizeof(recordid);
+    tmp = (byte*)&valR;
+    code = 'R';
+  } else {
+    abort();
+  }
+  // make room for code byte
+  *sz = *sz+1;
+  if(code == 'P') {
+    // append null
+    (*sz)++;
+    ret = malloc(*sz);
+    memcpy(ret,tmp, (*sz)-2);
+    ret[(*sz)-2] = '\0';
+    ret[(*sz)-1] = code;
+  } else {
+    ret = malloc(*sz);
+    memcpy(ret, tmp, (*sz)-1);
+    ret[(*sz)-1] = code;
+  }
+  return ret;
+}
+static SV * SV_bytes(byte* bytes, STRLEN sz) {
+  SV * ret;
+  char code = bytes[sz-1];
+  switch(code) {
+  case 'I': {
+    assert(sz-1 == sizeof(IV));
+    ret = newSViv(*(IV*)bytes);
+  } break;
+  case 'N': {
+    assert(sz-1 == sizeof(NV));
+    ret = newSVnv(*(NV*)bytes);
+  } break;
+  case 'P': {
+    ret = newSVpvn(bytes,sz-2);
+  } break;
+  case 'R': {
+    assert(sz-1 == sizeof(recordid));
+    ret = SV_recordid(*(recordid*)bytes);
+  } break;
+  default: {
+    abort();
+  }
+  }
+  return ret;
+}
+
+recordid TallocScalar(int xid, SV* sv) {
+  STRLEN sz;
+  byte * buf = bytes_SV(sv, &sz);
+  free(buf);
+  return Talloc(xid, sz);
+}
+
+int stasis_perl_Tset(int xid, recordid rid, SV * sv) {
+  STRLEN sz;
+  byte * buf = bytes_SV(sv, &sz);
+  rid.size = sz;
+  int ret = Tset(xid, rid, buf);
+  free(buf);
+  return ret;
+}
+SV* stasis_perl_Tread(int xid, recordid rid) {
+  rid.size = TrecordSize(xid, rid);
+  char * buf = malloc(rid.size);
+  Tread(xid, rid, buf);
+  SV* ret = SV_bytes(buf, rid.size);
+  free(buf);
+  return ret;
+}
+
+int stasis_perl_TsetRecordid(int xid, recordid rid, recordid buf) {
+  rid.size = sizeof(buf);
+  return Tset(xid, rid, &buf);
+}
+
+recordid stasis_perl_TreadRecordid(int xid, recordid rid) {
+  recordid buf;
+  Tread(xid, rid, &buf);
+  return buf;
+}
+
+recordid stasis_perl_ThashCreate(int xid) {
+  return ThashCreate(xid, VARIABLE_LENGTH, VARIABLE_LENGTH);
+}
+
+int stasis_perl_ThashInsert(int xid, recordid hash, SV * key, SV * val) {
+  STRLEN key_len, val_len;
+  byte * keyb = bytes_SV(key,&key_len);
+  byte * valb = bytes_SV(val,&val_len);
+  int ret = ThashInsert(xid, hash, keyb, key_len, valb, val_len);
+  free(keyb);
+  free(valb);
+  return ret;
+}
+
+int stasis_perl_ThashRemove(int xid, recordid hash, SV * key) {
+  STRLEN key_len;
+  byte * keyb = bytes_SV(key,&key_len);
+  int ret = ThashRemove(xid, hash, keyb, key_len);
+  free(keyb);
+  return ret;
+}
+
+SV* stasis_perl_ThashLookup(int xid, recordid hash, SV * key) {
+  STRLEN key_len;
+  byte* keyb = bytes_SV(key, &key_len);
+
+  byte* valb;
+  int val_len = ThashLookup(xid, hash, keyb, key_len, &valb);
+  free(keyb);
+  if(val_len != -1) {
+    SV* ret = SV_bytes(valb, val_len);
+    free(valb);
+    return ret;
+  } else {
+    return 0;
+  }
+}
+
+SV* stasis_perl_ROOT_RID() {
+  return SV_recordid(ROOT_RECORD);
+}
+
+SV* stasis_perl_NULL_RID() {
+  return SV_recordid(NULLRID);
+}
+
+int stasis_perl_INVALID_SLOT() {
+  return INVALID_SLOT;
+}
+
+/*SV* new() {
+  void * session = 0;
+  Tinit();
+
+  SV*    obj_ref = newSViv(0);
+  SV*    obj = newSVrv(obj_ref, "Stasis");
+
+  sv_setiv(obj, (IV)session);
+  SvREADONLY_on(obj);
+  return obj_ref;
+}
+
+int begin_xact(SV* obj) {
+  return Tbegin();
+}
+
+void commit_xact(SV* obj, int xid) {
+  Tcommit(xid);
+}
+void abort_xact(SV* obj, int xid) {
+  Tabort(xid);
+}
+
+void DESTROY(SV* obj) {
+  Tdeinit();
+}
+*/

lang/perl/t/gen-script.pl

@@ -0,0 +1,26 @@
+#!/usr/bin/perl -w
+use strict;
+
+sub walk {
+    my $mid =shift;
+    my $low = shift;
+    my $hi = shift;
+    my $depth = (shift)-1;
+
+    $depth || return;
+
+    my $lmid = $mid + ($low - $mid) / 2;
+    my $rmid = $mid + ($hi  - $mid) / 2;
+
+    $lmid < $rmid || die;
+
+    print "c $mid $lmid,$rmid\n";
+
+    walk($lmid, $low, $mid, $depth);
+    walk($rmid, $mid, $hi, $depth);
+}
+
+my $depth = $ARGV[0];
+
+walk 0, -16, 16, $depth;
+

lang/perl/t/test.pl

@@ -0,0 +1,62 @@
+#!/usr/bin/perl -w
+#use diagnostics -verbose;
+use strict;
+use Stasis;
+
+Stasis::Tinit();
+my $x=Stasis::Tbegin();
+print("$x\n");
+
+my $rid1 = Stasis::TallocScalar($x, "thequickbrown"); #14);
+print "rid is $$rid1[0] $$rid1[1]\n";
+defined ($rid1) || die;
+
+Stasis::Tset($x, $rid1, "thequickbrown");
+
+my $thequickbrown = Stasis::Tread($x, $rid1);
+print "$thequickbrown\n";
+
+$rid1 = Stasis::TallocScalar($x, 3.14159); #14);
+print "rid is $$rid1[0] $$rid1[1]\n";
+defined ($rid1) || die;
+
+Stasis::Tset($x, $rid1, 3.14159);
+
+$thequickbrown = Stasis::Tread($x, $rid1);
+print "->$thequickbrown\n";
+
+my $rid2 = Stasis::TallocScalar($x, 42);
+Stasis::Tset($x, $rid2, 42);
+
+$thequickbrown = Stasis::Tread($x, $rid2);
+print "$thequickbrown\n";
+
+$thequickbrown == 42 || die;
+
+Stasis::Tcommit($x);
+
+$x = Stasis::Tbegin();
+
+Stasis::Tset($x, $rid2, 13);
+$thequickbrown = Stasis::Tread($x, $rid2);
+print "$thequickbrown\n";
+
+$thequickbrown == 13 || die;
+
+Stasis::Tabort($x);
+$x = Stasis::Tbegin();
+$thequickbrown = Stasis::Tread($x, $rid2);
+print "$thequickbrown\n";
+
+$thequickbrown == 42 || die;
+
+my $rid3 = Stasis::TallocScalar($x, $rid2);
+Stasis::Tset($x,$rid3,$rid2);
+
+my $rid2cpy = Stasis::Tread($x,$rid3);
+
+($$rid2cpy[0] == $$rid2[0] && $$rid2cpy[1]==$$rid2[1]) || die;
+
+Stasis::Tcommit($x);
+
+Stasis::Tdeinit(); 

lang/perl/t/test2.pl

@@ -0,0 +1,48 @@
+#!/usr/bin/perl -w
+use strict;
+use Stasis;
+
+Stasis::Tinit();
+
+my $xid = Stasis::Tbegin();
+my $rid;
+
+sub walk {
+    my $from = shift;
+    my $level  = shift || 0;
+    my $to = Stasis::ThashLookup($xid, $rid, $from);
+    print $from;
+    $level += (length($from) + 4);
+
+    if(defined $to) {
+        my @tok = split ',', $to;
+        my $first = 1;
+        foreach my $f (@tok) {
+            if($first) { print " => "; } else { my $n = $level; while($n--) {print " ";} }
+            $first = 0;
+            walk($f,$level);
+        }
+    } else {
+        print "\n";
+    }
+}
+
+if(Stasis::TrecordType($xid, Stasis::ROOT_RID()) == Stasis::INVALID_SLOT()) {
+    $rid = Stasis::ThashCreate($xid);
+} else {
+    $rid = Stasis::ROOT_RID();
+}
+
+while(my $line = <>) {
+    chomp $line;
+    my @tok = split '\s+', $line;
+    if($tok[0] eq "c") {
+        Stasis::ThashInsert($xid, $rid, $tok[1], $tok[2]);
+    } elsif($tok[0] eq "q") {
+        walk $tok[1];
+    }
+
+}
+
+Stasis::Tcommit($xid);
+Stasis::Tdeinit();

lang/perl/t/test2.script

@@ -0,0 +1,16 @@
+c ! +,-
+c + y,z
+c - @,#
+c y q,r
+c z s,t
+c @ u,v
+c # w,x
+c q a,b
+c r c,d
+c s e,f
+c t g,h
+c u i,j
+c v k,l
+c w m,n
+c x o,p
+q !

lang/perl/typemap

@@ -0,0 +1,11 @@
+TYPEMAP
+recordid        T_RECORDID
+byte*           T_BYTEARRAY
+
+INPUT
+T_RECORDID
+   $var = recordid_SV($arg);
+
+OUTPUT
+T_RECORDID
+   $arg = SV_recordid($var);