implemented support for tied perl hashes
This commit is contained in:
parent
ed1ed5fcf2
commit
ac0d623d32
4 changed files with 175 additions and 6 deletions
|
@ -11,6 +11,7 @@ ENDMACRO(CREATE_CHECK_PERL_OPT)
|
||||||
|
|
||||||
CREATE_CHECK_PERL(t/test.pl)
|
CREATE_CHECK_PERL(t/test.pl)
|
||||||
CREATE_CHECK_PERL_OPT(t/test2.pl ${CMAKE_CURRENT_SOURCE_DIR}/t/test2.script)
|
CREATE_CHECK_PERL_OPT(t/test2.pl ${CMAKE_CURRENT_SOURCE_DIR}/t/test2.script)
|
||||||
|
CREATE_CHECK_PERL(t/test3.pl)
|
||||||
|
|
||||||
#ADD_TEST(perl/test.pl perl -I${CMAKE_HOME_DIRECTORY}/lang/perl ${CMAKE_CURRENT_SOURCE_DIR}/t/test.pl)
|
#ADD_TEST(perl/test.pl perl -I${CMAKE_HOME_DIRECTORY}/lang/perl ${CMAKE_CURRENT_SOURCE_DIR}/t/test.pl)
|
||||||
#ADD_TEST(perl/t/test2.pl ${CMAKE_CURRENT_SOURCE_DIR}/t/test.pl STASIS_DIR=${CMAKE_HOME_DIRECTORY})
|
#ADD_TEST(perl/t/test2.pl ${CMAKE_CURRENT_SOURCE_DIR}/t/test.pl STASIS_DIR=${CMAKE_HOME_DIRECTORY})
|
||||||
|
|
|
@ -7,10 +7,8 @@ BEGIN {
|
||||||
if(!defined($STASIS_DIR)) {
|
if(!defined($STASIS_DIR)) {
|
||||||
$STASIS_DIR = $INC{"Stasis.pm"};
|
$STASIS_DIR = $INC{"Stasis.pm"};
|
||||||
$STASIS_DIR =~ s~/lang/perl/Stasis.pm~~g;
|
$STASIS_DIR =~ s~/lang/perl/Stasis.pm~~g;
|
||||||
print $STASIS_DIR;
|
|
||||||
}
|
}
|
||||||
1;
|
1;
|
||||||
#die "\nNeed STASIS_DIR environment variable!!\n\n";
|
|
||||||
}
|
}
|
||||||
use Inline C => Config => LIBS =>
|
use Inline C => Config => LIBS =>
|
||||||
"-L$STASIS_DIR/build/src/stasis/ " .
|
"-L$STASIS_DIR/build/src/stasis/ " .
|
||||||
|
@ -26,6 +24,76 @@ sub version {
|
||||||
return "Stasis 0.1";
|
return "Stasis 0.1";
|
||||||
}
|
}
|
||||||
|
|
||||||
|
package Stasis::Hash;
|
||||||
|
|
||||||
|
require Tie::Hash;
|
||||||
|
|
||||||
|
@ISA = qw(Tie::Hash);
|
||||||
|
|
||||||
|
sub TIEHASH {
|
||||||
|
my $class = shift;
|
||||||
|
my $xid = shift;
|
||||||
|
my $rid = shift;
|
||||||
|
defined ($xid) || die "need xid to tie hash";
|
||||||
|
defined ($rid) || die "need rid to tie hash";
|
||||||
|
|
||||||
|
my $this = {
|
||||||
|
xid => $xid,
|
||||||
|
rid => $rid,
|
||||||
|
};
|
||||||
|
|
||||||
|
return bless $this, $class;
|
||||||
|
}
|
||||||
|
sub FETCH {
|
||||||
|
my $this = shift;
|
||||||
|
my $key = shift;
|
||||||
|
my $ret = Stasis::ThashLookup($$this{xid}, $$this{rid}, $key);
|
||||||
|
## Oddly, returning without the defined() check leads to a segfault(??)
|
||||||
|
if(defined($ret)) { return $ret; } else { return; }
|
||||||
|
}
|
||||||
|
sub STORE {
|
||||||
|
my $this = shift;
|
||||||
|
my $key = shift;
|
||||||
|
my $val = shift;
|
||||||
|
Stasis::ThashInsert($$this{xid}, $$this{rid}, $key, $val);
|
||||||
|
}
|
||||||
|
sub DELETE {
|
||||||
|
my $this = shift;
|
||||||
|
my $key = shift;
|
||||||
|
return Stasis::ThashRemove($$this{xid}, $$this{rid}, $key);
|
||||||
|
}
|
||||||
|
sub FIRSTKEY {
|
||||||
|
my $this = shift;
|
||||||
|
$$this{it} = Stasis::ThashIterator($$this{xid}, $$this{rid});
|
||||||
|
if(Stasis::Titerator_next($$this{xid}, $$this{it})) {
|
||||||
|
return Stasis::Titerator_key($$this{xid}, $$this{it});
|
||||||
|
} else {
|
||||||
|
Stasis::Titerator_close($$this{xid}, $$this{it});
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
sub NEXTKEY {
|
||||||
|
my $this = shift;
|
||||||
|
my $lastkey = shift;
|
||||||
|
print("."); $|=1;
|
||||||
|
Stasis::Titerator_tupleDone($$this{xid}, $$this{it});
|
||||||
|
if(Stasis::Titerator_next($$this{xid}, $$this{it})) {
|
||||||
|
return Stasis::Titerator_key($$this{xid}, $$this{it});
|
||||||
|
} else {
|
||||||
|
Stasis::Titerator_close($$this{xid}, $$this{it});
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
sub EXISTS {
|
||||||
|
my $this = shift;
|
||||||
|
my $key = shift;
|
||||||
|
}
|
||||||
|
sub CLEAR {
|
||||||
|
my $this = shift;
|
||||||
|
}
|
||||||
|
|
||||||
|
package Stasis;
|
||||||
|
|
||||||
__DATA__
|
__DATA__
|
||||||
__C__
|
__C__
|
||||||
#include "stasis/transactional.h"
|
#include "stasis/transactional.h"
|
||||||
|
@ -227,6 +295,29 @@ SV* stasis_perl_ThashLookup(int xid, recordid hash, SV * key) {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
void * stasis_perl_ThashIterator(int xid, recordid hash) {
|
||||||
|
return ThashGenericIterator(xid, hash);
|
||||||
|
}
|
||||||
|
|
||||||
|
int stasis_perl_Titerator_next(int xid, void *it) {
|
||||||
|
return Titerator_next(xid, it);
|
||||||
|
}
|
||||||
|
SV* stasis_perl_Titerator_key(int xid, void *it) {
|
||||||
|
byte * bytes;
|
||||||
|
STRLEN sz = Titerator_key(xid, it, &bytes);
|
||||||
|
return SV_bytes(bytes, sz);
|
||||||
|
}
|
||||||
|
SV* stasis_perl_Titerator_value(int xid, void *it) {
|
||||||
|
byte * bytes;
|
||||||
|
STRLEN sz = Titerator_value(xid, it, &bytes);
|
||||||
|
return SV_bytes(bytes, sz);
|
||||||
|
}
|
||||||
|
void stasis_perl_Titerator_tupleDone(int xid, void *it) {
|
||||||
|
Titerator_tupleDone(xid, it);
|
||||||
|
}
|
||||||
|
void stasis_perl_Titerator_close(int xid, void *it) {
|
||||||
|
Titerator_close(xid, it);
|
||||||
|
}
|
||||||
SV* stasis_perl_ROOT_RID() {
|
SV* stasis_perl_ROOT_RID() {
|
||||||
return SV_recordid(ROOT_RECORD);
|
return SV_recordid(ROOT_RECORD);
|
||||||
}
|
}
|
||||||
|
|
|
@ -43,8 +43,9 @@ my $rid;
|
||||||
|
|
||||||
sub walk {
|
sub walk {
|
||||||
my $from = shift;
|
my $from = shift;
|
||||||
|
my $h = shift;
|
||||||
my $level = shift || 0;
|
my $level = shift || 0;
|
||||||
my $to = Stasis::ThashLookup($xid, $rid, $from);
|
my $to = $h->{$from};
|
||||||
myprint $from;
|
myprint $from;
|
||||||
$level += (length($from) + 4);
|
$level += (length($from) + 4);
|
||||||
|
|
||||||
|
@ -54,7 +55,7 @@ sub walk {
|
||||||
foreach my $f (@tok) {
|
foreach my $f (@tok) {
|
||||||
if($first) { myprint " => "; } else { my $n = $level; while($n--) {myprint " ";} }
|
if($first) { myprint " => "; } else { my $n = $level; while($n--) {myprint " ";} }
|
||||||
$first = 0;
|
$first = 0;
|
||||||
walk($f,$level);
|
walk($f,$h,$level);
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
myprint "\n";
|
myprint "\n";
|
||||||
|
@ -67,13 +68,18 @@ if(Stasis::TrecordType($xid, Stasis::ROOT_RID()) == Stasis::INVALID_SLOT()) {
|
||||||
$rid = Stasis::ROOT_RID();
|
$rid = Stasis::ROOT_RID();
|
||||||
}
|
}
|
||||||
|
|
||||||
|
my %hash;
|
||||||
|
tie(%hash, 'Stasis::Hash', $xid, $rid);
|
||||||
|
|
||||||
|
|
||||||
while(my $line = <>) {
|
while(my $line = <>) {
|
||||||
chomp $line;
|
chomp $line;
|
||||||
my @tok = split '\s+', $line;
|
my @tok = split '\s+', $line;
|
||||||
if($tok[0] eq "c") {
|
if($tok[0] eq "c") {
|
||||||
Stasis::ThashInsert($xid, $rid, $tok[1], $tok[2]);
|
#Stasis::ThashInsert($xid, $rid, $tok[1], $tok[2]);
|
||||||
|
$hash{$tok[1]} = $tok[2];
|
||||||
} elsif($tok[0] eq "q") {
|
} elsif($tok[0] eq "q") {
|
||||||
walk $tok[1];
|
walk $tok[1], \%hash;
|
||||||
}
|
}
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
71
lang/perl/t/test3.pl
Normal file
71
lang/perl/t/test3.pl
Normal file
|
@ -0,0 +1,71 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
use strict;
|
||||||
|
use Stasis;
|
||||||
|
|
||||||
|
my $expected =
|
||||||
|
"a1 b2 c3 d4 e5 f6 g7 h8 i9 j10 \n" .
|
||||||
|
"k1 l2 m3 n4 o5 p6 q7 r8 s9 t10 \n";
|
||||||
|
|
||||||
|
my $checking = 0;
|
||||||
|
my $out = "";
|
||||||
|
|
||||||
|
sub myprint {
|
||||||
|
my $a = shift;
|
||||||
|
if($checking) {
|
||||||
|
$out .= $a;
|
||||||
|
} else {
|
||||||
|
print $a;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if($ARGV[0] eq "--automated-test") {
|
||||||
|
shift @ARGV;
|
||||||
|
system ("rm storefile.txt logfile.txt");
|
||||||
|
$checking = 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
Stasis::Tinit();
|
||||||
|
my $xid = Stasis::Tbegin();
|
||||||
|
my $rid = Stasis::ThashCreate($xid);
|
||||||
|
Stasis::Tcommit($xid);
|
||||||
|
$xid = Stasis::Tbegin();
|
||||||
|
my %h;
|
||||||
|
tie %h, 'Stasis::Hash', $xid, $rid;
|
||||||
|
|
||||||
|
my $i = 0;
|
||||||
|
foreach my $x (qw(a b c d e f g h i j)) {
|
||||||
|
$i++;
|
||||||
|
$h{$x}=$i;
|
||||||
|
}
|
||||||
|
my @keys = sort keys %h;
|
||||||
|
|
||||||
|
for my $k (@keys) {
|
||||||
|
myprint "$k$h{$k} ";
|
||||||
|
}
|
||||||
|
myprint "\n";
|
||||||
|
|
||||||
|
Stasis::Tabort($xid);
|
||||||
|
|
||||||
|
$xid = Stasis::Tbegin();
|
||||||
|
tie %h, 'Stasis::Hash', $xid, $rid;
|
||||||
|
|
||||||
|
my $i = 0;
|
||||||
|
foreach my $x (qw(k l m n o p q r s t)) {
|
||||||
|
$i++;
|
||||||
|
$h{$x}=$i;
|
||||||
|
}
|
||||||
|
|
||||||
|
@keys = sort keys %h;
|
||||||
|
|
||||||
|
for my $k (@keys) {
|
||||||
|
# does not output the aborted pairs.
|
||||||
|
myprint "$k$h{$k} ";
|
||||||
|
}
|
||||||
|
myprint "\n";
|
||||||
|
Stasis::Tcommit($xid);
|
||||||
|
Stasis::Tdeinit();
|
||||||
|
|
||||||
|
if($checking) {
|
||||||
|
$out eq $expected || die "\nFAIL: Output did not match. Expected\n{$expected}\nGot\n{$out}\n";
|
||||||
|
print "\nPASS: Produced expected output:\n$out";
|
||||||
|
}
|
Loading…
Reference in a new issue