Perl updates:
- Cleaned up initialization and shutdown. - Add support for autocommitted hashes - Wrote preliminary perldocs - Updated sample cgi scripts. - Added new (partial) wiki thing - Added stasis.pl (a simple toplevel)
This commit is contained in:
parent
98e0cb1fab
commit
5d0500dc7a
10 changed files with 617 additions and 63 deletions
|
@ -11,3 +11,6 @@ CREATE_CHECK_PERL(t/01-boostrap.t)
|
||||||
CREATE_CHECK_PERL_OPT(t/02-hash.t ${CMAKE_CURRENT_SOURCE_DIR}/t/02-hash.script)
|
CREATE_CHECK_PERL_OPT(t/02-hash.t ${CMAKE_CURRENT_SOURCE_DIR}/t/02-hash.script)
|
||||||
CREATE_CHECK_PERL(t/03-hash-iterator.t)
|
CREATE_CHECK_PERL(t/03-hash-iterator.t)
|
||||||
CREATE_CHECK_PERL(t/04-hash-in-hash.t)
|
CREATE_CHECK_PERL(t/04-hash-in-hash.t)
|
||||||
|
CREATE_CHECK_PERL(t/05-autoxacts.t)
|
||||||
|
CREATE_CHECK_PERL(t/06-open.t)
|
||||||
|
CREATE_CHECK_PERL(t/07-hash-in-autohash.t)
|
||||||
|
|
|
@ -5,31 +5,28 @@ use strict;
|
||||||
use warnings;
|
use warnings;
|
||||||
|
|
||||||
my $STASIS_DIR;
|
my $STASIS_DIR;
|
||||||
BEGIN {
|
my $initted = 0;
|
||||||
$STASIS_DIR = $INC{"Stasis.pm"};
|
|
||||||
$STASIS_DIR =~ s~/+lang/+perl/+Stasis.pm~~g;
|
|
||||||
$STASIS_DIR =~ s~/+lang/+perl/+apache/+Stasis.pm~~g;
|
|
||||||
1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub import {
|
sub import {
|
||||||
|
my $modname = shift;
|
||||||
my $inline_dir = shift;
|
my $inline_dir = shift;
|
||||||
require Inline;
|
require Inline;
|
||||||
Inline->import (C => Config => (LIBS =>
|
|
||||||
"-L$STASIS_DIR/build/src/stasis/ " .
|
|
||||||
"-lstasis -lpthread",
|
|
||||||
CCFLAGS => "-Wall -pedantic -Werror -std=c99 -DPERL_GCC_PEDANTIC"
|
|
||||||
),
|
|
||||||
ENABLE => 'AUTOWRAP',
|
|
||||||
TYPEMAPS => "$STASIS_DIR/lang/perl/typemap",
|
|
||||||
PREFIX => 'stasis_perl_',
|
|
||||||
DIRECTORY => $ENV{STASIS_INLINE_DIRECTORY});
|
|
||||||
|
|
||||||
Inline->import (C => 'DATA',
|
$STASIS_DIR = $INC{"Stasis.pm"};
|
||||||
INC => "-I $STASIS_DIR -I $STASIS_DIR/build/");
|
$STASIS_DIR =~ s~/+lang/+perl/+Stasis.pm~~g;
|
||||||
|
1;
|
||||||
|
|
||||||
|
Inline->import (C => 'DATA' =>
|
||||||
|
LIBS => "-L$STASIS_DIR/build/src/stasis/ " .
|
||||||
|
"-lstasis -lpthread",
|
||||||
|
CCFLAGS => "-Wall -pedantic -Werror -std=c99 -DPERL_GCC_PEDANTIC",
|
||||||
|
INC => "-I $STASIS_DIR -I $STASIS_DIR/build/",
|
||||||
|
ENABLE => 'AUTOWRAP',
|
||||||
|
TYPEMAPS => "$STASIS_DIR/lang/perl/typemap",
|
||||||
|
PREFIX => 'stasis_perl_',
|
||||||
|
DIRECTORY => $inline_dir ||$ENV{STASIS_INLINE_DIRECTORY}
|
||||||
|
);
|
||||||
Inline->init;
|
Inline->init;
|
||||||
|
|
||||||
}
|
}
|
||||||
sub version {
|
sub version {
|
||||||
return "Stasis 0.1";
|
return "Stasis 0.1";
|
||||||
|
@ -40,6 +37,39 @@ sub ThashCreate {
|
||||||
my $rid = ThashCreateHelper($xid);
|
my $rid = ThashCreateHelper($xid);
|
||||||
return bless $rid, 'Stasis::HashHeader';
|
return bless $rid, 'Stasis::HashHeader';
|
||||||
}
|
}
|
||||||
|
sub Tinit {
|
||||||
|
$initted && die "Called Tinit() when Stasis was initted!\n";
|
||||||
|
$initted = 1;
|
||||||
|
return TinitHelper();
|
||||||
|
}
|
||||||
|
sub Tdeinit {
|
||||||
|
$initted || die "Called Tdeinit() when Stasis was not initted!\n";
|
||||||
|
$initted = 0;
|
||||||
|
return TdeinitHelper();
|
||||||
|
|
||||||
|
}
|
||||||
|
sub TbootstrapHash {
|
||||||
|
my $xid = Tbegin();
|
||||||
|
my $rid = ROOT_RID();
|
||||||
|
if(TrecordType($xid, $rid) == INVALID_SLOT()) {
|
||||||
|
$rid = Stasis::ThashCreate($xid);
|
||||||
|
}
|
||||||
|
Tcommit($xid);
|
||||||
|
return $rid;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub open {
|
||||||
|
my $h = shift;
|
||||||
|
$initted || Tinit();
|
||||||
|
tie %$h, 'Stasis::Hash';
|
||||||
|
}
|
||||||
|
END {
|
||||||
|
if($initted) {
|
||||||
|
print STDERR "Cleanly shutting Stasis down..."; $| = 1;
|
||||||
|
Tdeinit();
|
||||||
|
print STDERR "done.\n";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
package Stasis::Hash;
|
package Stasis::Hash;
|
||||||
require Scalar::Util;
|
require Scalar::Util;
|
||||||
|
@ -50,8 +80,11 @@ our @ISA = qw(Tie::Hash);
|
||||||
|
|
||||||
sub TIEHASH {
|
sub TIEHASH {
|
||||||
my $class = shift;
|
my $class = shift;
|
||||||
my $xid = shift;
|
my $xid = shift ;
|
||||||
my $rid = shift;
|
my $rid = shift || Stasis::ROOT_RID();
|
||||||
|
if(!defined($xid)) {
|
||||||
|
$xid = -1;
|
||||||
|
}
|
||||||
defined ($xid) || die "need xid to tie hash";
|
defined ($xid) || die "need xid to tie hash";
|
||||||
defined ($rid) || die "need rid to tie hash";
|
defined ($rid) || die "need rid to tie hash";
|
||||||
|
|
||||||
|
@ -59,16 +92,46 @@ sub TIEHASH {
|
||||||
xid => $xid,
|
xid => $xid,
|
||||||
rid => $rid,
|
rid => $rid,
|
||||||
};
|
};
|
||||||
|
if($xid == -1) {
|
||||||
|
$this->{autoxact} = 1;
|
||||||
|
$this->{rid} = Stasis::TbootstrapHash();
|
||||||
|
$this->{xid} = Stasis::Tbegin();
|
||||||
|
}
|
||||||
|
|
||||||
return bless $this, $class;
|
return bless $this, $class;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
sub getXid {
|
||||||
|
my $this = shift;
|
||||||
|
my $ret = $$this{xid};
|
||||||
|
defined $ret || ($ret = ${$$this{root}}{xid});
|
||||||
|
#warn "$ret ($$this{xid}) ($$this{root})\n";
|
||||||
|
return $ret;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub setRoot {
|
||||||
|
my $this = shift;
|
||||||
|
my $root = shift;
|
||||||
|
|
||||||
|
#warn "setting root\n";
|
||||||
|
$$this{xid} = undef;
|
||||||
|
$$this{autoxact} = 1;
|
||||||
|
$$this{root} = ($$root{root} || $root);
|
||||||
|
#warn $$this{root}; # = ($$this{root} || $this);
|
||||||
|
#warn $this->getXid();
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
sub FETCH {
|
sub FETCH {
|
||||||
my $this = shift;
|
my $this = shift;
|
||||||
my $key = shift;
|
my $key = shift;
|
||||||
my $sv = Stasis::ThashLookup($$this{xid}, $$this{rid}, $key);
|
my $xid = $this->getXid();
|
||||||
|
my $sv = Stasis::ThashLookup($xid, $$this{rid}, $key);
|
||||||
if(Scalar::Util::blessed($sv)) {
|
if(Scalar::Util::blessed($sv)) {
|
||||||
if($sv->isa('Stasis::HashHeader')) {
|
if($sv->isa('Stasis::HashHeader')) {
|
||||||
my %h;
|
my %h;
|
||||||
tie(%h, 'Stasis::Hash', $$this{xid}, $sv);
|
tie(%h, 'Stasis::Hash', $xid, $sv);
|
||||||
|
tied(%h)->setRoot($this);
|
||||||
return \%h;
|
return \%h;
|
||||||
} else {
|
} else {
|
||||||
die 'ThashLookup returned an object of unknown type';
|
die 'ThashLookup returned an object of unknown type';
|
||||||
|
@ -81,11 +144,12 @@ sub STORE {
|
||||||
my $this = shift;
|
my $this = shift;
|
||||||
my $key = shift;
|
my $key = shift;
|
||||||
my $val = shift;
|
my $val = shift;
|
||||||
|
my $xid = $this->getXid();
|
||||||
if('HASH' eq ref($val)) {
|
if('HASH' eq ref($val)) {
|
||||||
if(Scalar::Util::blessed($val) && $val->isa('Stasis::Hash')) {
|
if(Scalar::Util::blessed($val) && $val->isa('Stasis::Hash')) {
|
||||||
die "untested?";
|
die "untested?";
|
||||||
my $obj = tied ($val); # tied returns the object backing the hash.
|
my $obj = tied ($val); # tied returns the object backing the hash.
|
||||||
Stasis::ThashInsert($$this{xid}, $$this{rid}, $key, $$obj{rid});
|
Stasis::ThashInsert($xid, $$this{rid}, $key, $$obj{rid});
|
||||||
die "untested?";
|
die "untested?";
|
||||||
} else {
|
} else {
|
||||||
# Copy the hash into scratch space
|
# Copy the hash into scratch space
|
||||||
|
@ -95,8 +159,8 @@ sub STORE {
|
||||||
}
|
}
|
||||||
|
|
||||||
# Tie the hash that was passed to us
|
# Tie the hash that was passed to us
|
||||||
my $rid = Stasis::ThashCreate($$this{xid});
|
my $rid = Stasis::ThashCreate($xid);
|
||||||
tie %$val, 'Stasis::Hash', $$this{xid}, $rid;
|
tie %$val, 'Stasis::Hash', $xid, $rid;
|
||||||
|
|
||||||
# Copy the scratch space into the tied hash.
|
# Copy the scratch space into the tied hash.
|
||||||
foreach my $k (keys %h) {
|
foreach my $k (keys %h) {
|
||||||
|
@ -104,48 +168,71 @@ sub STORE {
|
||||||
}
|
}
|
||||||
|
|
||||||
# Insert the populated hashtable
|
# Insert the populated hashtable
|
||||||
Stasis::ThashInsert($$this{xid}, $$this{rid}, $key, $rid);
|
Stasis::ThashInsert($xid, $$this{rid}, $key, $rid);
|
||||||
|
if($$this{autoxact}) {
|
||||||
|
tied(%$val)->setRoot($this);
|
||||||
|
}
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
# XXX assumes the value is a scalar.
|
# XXX assumes the value is a scalar.
|
||||||
Stasis::ThashInsert($$this{xid}, $$this{rid}, $key, $val);
|
Stasis::ThashInsert($xid, $$this{rid}, $key, $val);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
sub DELETE {
|
sub DELETE {
|
||||||
my $this = shift;
|
my $this = shift;
|
||||||
my $key = shift;
|
my $key = shift;
|
||||||
|
my $xid = $this->getXid();
|
||||||
# This will leak hashes that were automatically created. Refcounts?
|
# This will leak hashes that were automatically created. Refcounts?
|
||||||
return Stasis::ThashRemove($$this{xid}, $$this{rid}, $key);
|
return Stasis::ThashRemove($xid, $$this{rid}, $key);
|
||||||
}
|
}
|
||||||
sub FIRSTKEY {
|
sub FIRSTKEY {
|
||||||
my $this = shift;
|
my $this = shift;
|
||||||
$$this{it} = Stasis::ThashIterator($$this{xid}, $$this{rid});
|
my $xid = $this->getXid();
|
||||||
if(Stasis::Titerator_next($$this{xid}, $$this{it})) {
|
$$this{it} = Stasis::ThashIterator($xid, $$this{rid});
|
||||||
return Stasis::Titerator_key($$this{xid}, $$this{it});
|
if(Stasis::Titerator_next($xid, $$this{it})) {
|
||||||
|
return Stasis::Titerator_key($xid, $$this{it});
|
||||||
} else {
|
} else {
|
||||||
Stasis::Titerator_close($$this{xid}, $$this{it});
|
Stasis::Titerator_close($xid, $$this{it});
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
sub NEXTKEY {
|
sub NEXTKEY {
|
||||||
my $this = shift;
|
my $this = shift;
|
||||||
my $lastkey = shift;
|
my $lastkey = shift;
|
||||||
Stasis::Titerator_tupleDone($$this{xid}, $$this{it});
|
my $xid = $this->getXid();
|
||||||
if(Stasis::Titerator_next($$this{xid}, $$this{it})) {
|
Stasis::Titerator_tupleDone($xid, $$this{it});
|
||||||
return Stasis::Titerator_key($$this{xid}, $$this{it});
|
if(Stasis::Titerator_next($xid, $$this{it})) {
|
||||||
|
return Stasis::Titerator_key($xid, $$this{it});
|
||||||
} else {
|
} else {
|
||||||
Stasis::Titerator_close($$this{xid}, $$this{it});
|
Stasis::Titerator_close($xid, $$this{it});
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
sub EXISTS {
|
sub EXISTS {
|
||||||
my $this = shift;
|
my $this = shift;
|
||||||
my $key = shift;
|
my $key = shift;
|
||||||
|
warn "unimplemeted method 'EXISTS' called";
|
||||||
}
|
}
|
||||||
sub CLEAR {
|
sub CLEAR {
|
||||||
my $this = shift;
|
my $this = shift;
|
||||||
|
warn "unimplemeted method 'CLEAR' called";
|
||||||
|
}
|
||||||
|
sub commit {
|
||||||
|
my $this = shift;
|
||||||
|
$this->{autoxact} || die 'commit() called on non-auto hash';
|
||||||
|
$this->{root} && die 'commit() called on non root';
|
||||||
|
Stasis::Tcommit($this->{xid});
|
||||||
|
$this->{xid} = Stasis::Tbegin();
|
||||||
|
}
|
||||||
|
sub abort {
|
||||||
|
my $this = shift;
|
||||||
|
$this->{autoxact} || die 'abort() called on non-auto hash';
|
||||||
|
$this->{root} && die 'abort() called on non root';
|
||||||
|
Stasis::Tabort($this->{xid});
|
||||||
|
$this->{xid} = Stasis::Tbegin();
|
||||||
}
|
}
|
||||||
|
|
||||||
|
package Stasis::Recordid; # Silence warning about "can't locate package Stasis::Recordid for @Stasis::HashHeader::ISA"
|
||||||
package Stasis::HashHeader;
|
package Stasis::HashHeader;
|
||||||
our @ISA = qw(Stasis::Recordid);
|
our @ISA = qw(Stasis::Recordid);
|
||||||
|
|
||||||
|
@ -155,8 +242,12 @@ __DATA__
|
||||||
__C__
|
__C__
|
||||||
#include "stasis/transactional.h"
|
#include "stasis/transactional.h"
|
||||||
|
|
||||||
int Tinit();
|
int TinitHelper() {
|
||||||
int Tdeinit();
|
return Tinit();
|
||||||
|
}
|
||||||
|
int TdeinitHelper() {
|
||||||
|
return Tdeinit();
|
||||||
|
}
|
||||||
int Tbegin();
|
int Tbegin();
|
||||||
int Tcommit(int xid);
|
int Tcommit(int xid);
|
||||||
int TsoftCommit(int xid);
|
int TsoftCommit(int xid);
|
||||||
|
@ -428,3 +519,136 @@ SV* stasis_perl_NULL_RID() {
|
||||||
int stasis_perl_INVALID_SLOT() {
|
int stasis_perl_INVALID_SLOT() {
|
||||||
return INVALID_SLOT;
|
return INVALID_SLOT;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
__END__
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
Stasis - Flexible transactional storage
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
use Stasis;
|
||||||
|
|
||||||
|
my %h;
|
||||||
|
|
||||||
|
Stasis::open(\%h);
|
||||||
|
|
||||||
|
$h{foo} = 'bar';
|
||||||
|
|
||||||
|
# Create an anonymous hash and insert it into h
|
||||||
|
|
||||||
|
$h{bat}{bam} = 'boom';
|
||||||
|
|
||||||
|
tied(%h)->commit();
|
||||||
|
|
||||||
|
$h{bar} = 'bad update';
|
||||||
|
|
||||||
|
tied(%h)->abort();
|
||||||
|
|
||||||
|
defined $h{bar} && die;
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
Stasis is a lightweight transactional storage library. This perl
|
||||||
|
module provides bindings for Stasis' C functions (Tinit(),
|
||||||
|
ThashInsert(), etc), and higher-level interfaces based upon tied perl
|
||||||
|
hashes.
|
||||||
|
|
||||||
|
=head2 Programming Style
|
||||||
|
|
||||||
|
The synopsis describes Stasis.pm's high level interface. Lower-level
|
||||||
|
interactions with Stasis are possible as well:
|
||||||
|
|
||||||
|
use Stasis;
|
||||||
|
|
||||||
|
Stasis::Tinit(); # Initialize Stasis
|
||||||
|
|
||||||
|
Stasis::TbootstrapHash(); # Open or bootstrap a stasis database
|
||||||
|
|
||||||
|
# Bootstrapping arranges for a hash to live in ROOT_RECORD
|
||||||
|
|
||||||
|
my $rid = STASIS::ROOT_RECORD();
|
||||||
|
|
||||||
|
my $xid = Stasis::Tbegin(); # Start new transaction
|
||||||
|
|
||||||
|
# Insert a value into the hash
|
||||||
|
Stasis::ThashInsert($xid, $rid, "foo", "bar");
|
||||||
|
|
||||||
|
# Lookup the value
|
||||||
|
my $bar = Stasis::ThashLookup($xid, $rid, "foo", "bar");
|
||||||
|
|
||||||
|
Stasis::Tcommit($xid);
|
||||||
|
|
||||||
|
$xid = Stasis::Tbegin();
|
||||||
|
|
||||||
|
# This update will not be reflected after abort.
|
||||||
|
Stasis::ThashRemove($xid, $rid, "foo", "bar");
|
||||||
|
|
||||||
|
Stasis::Tabort($xid);
|
||||||
|
|
||||||
|
#Deinitialize Stasis (Called automatically at shutdown if needed)
|
||||||
|
Stasis::Tdeinit();
|
||||||
|
|
||||||
|
Stasis supports a wide range of other data structures (including
|
||||||
|
arrays, records, large objects and trees), which are somewhat
|
||||||
|
supported by Stasis.pm. These bindings are a work in progress;
|
||||||
|
consult the source code for a list of currently implemented methods.
|
||||||
|
|
||||||
|
Note that Stasis (and this module) are thread safe. However, Stasis
|
||||||
|
does not perform lock management. Refer to the Stasis documentation
|
||||||
|
for more information before attempting to make use of concurrent (even
|
||||||
|
if single threaded) transactions.
|
||||||
|
|
||||||
|
|
||||||
|
=head1 CAVEATS AND BUGS
|
||||||
|
|
||||||
|
=head2 No garbage collection
|
||||||
|
|
||||||
|
Nested hashes are not garbage collected. Therefore, the following
|
||||||
|
code leaks storage:
|
||||||
|
|
||||||
|
my %h;
|
||||||
|
Stasis::open(\%h);
|
||||||
|
|
||||||
|
$h{a}{b} = 1; # Automatically instantiates a hash.
|
||||||
|
delete $h{a}; # The automatically created hash is now unreachable.
|
||||||
|
|
||||||
|
tied(%h)->commit(); # However, abort() would have reclaimed the space
|
||||||
|
|
||||||
|
=head2 Small hash performance
|
||||||
|
|
||||||
|
Stasis is currently tuned for small numbers of large hashes.
|
||||||
|
Its hashtable implementation would be more efficient if it included
|
||||||
|
special cases for small indexes, then dynamically switched to the
|
||||||
|
current layout for large data sets.
|
||||||
|
|
||||||
|
=head2 No tied arrays
|
||||||
|
|
||||||
|
Stasis provides an array type, but this module does not export them to
|
||||||
|
perl as tied arrays. Instead, it includes a partial (and untested)
|
||||||
|
set of C-style bindings. Support for push() and pop() should be
|
||||||
|
straightforward. However, Stasis' array implementation does not
|
||||||
|
currently provide anything analogous to shift() and unshift(). Like
|
||||||
|
the hashtables, Stasis' arrays are tuned for large data sets.
|
||||||
|
|
||||||
|
=head2 Type safety / reflection
|
||||||
|
|
||||||
|
Stasis records include a 'type' field that allows 'special' data to be
|
||||||
|
distinguished from 'normal' slots (eg: application data). Hashtables
|
||||||
|
do not use this feature, so it is possible to attempt to access
|
||||||
|
headers as scalar values. This will likely fail by crashing the
|
||||||
|
process. Similarly, the recordids returned by Stasis are blessed
|
||||||
|
arrays. Tampering with their contents, then attempting to dereference
|
||||||
|
them will likely lead to crashes and other trouble. These problems
|
||||||
|
should not affect "well-written" code.
|
||||||
|
|
||||||
|
=head2 This documentation is incomplete
|
||||||
|
|
||||||
|
See the source for a complete list of exported Stasis functions.
|
||||||
|
|
||||||
|
=head2 This module is a work in progress
|
||||||
|
|
||||||
|
Expect API instability. Also, note that many Stasis functions are not
|
||||||
|
yet exported to perl.
|
||||||
|
|
|
@ -15,19 +15,27 @@ sub handler {
|
||||||
my $r = shift;
|
my $r = shift;
|
||||||
$r->content_type('text/html');
|
$r->content_type('text/html');
|
||||||
print "<html><head></head><body><h1>Stasis</h1>" . `pwd`;
|
print "<html><head></head><body><h1>Stasis</h1>" . `pwd`;
|
||||||
my $xid = Stasis::Tbegin();
|
|
||||||
warn "a\n";
|
|
||||||
my %h;
|
|
||||||
tie %h, 'Stasis::Hash', $xid, Stasis::ROOT_RID();
|
|
||||||
|
|
||||||
$h{foo}++;
|
my $output;
|
||||||
|
|
||||||
print ("$xid $h{foo}\n");
|
## XXX This lock acts like a no-op; modapache seems to break perl
|
||||||
|
## threads.
|
||||||
|
{ lock($thelock);
|
||||||
|
my $xid = Stasis::Tbegin();
|
||||||
|
warn "a\n";
|
||||||
|
my %h;
|
||||||
|
tie %h, 'Stasis::Hash', $xid, Stasis::ROOT_RID();
|
||||||
|
|
||||||
Stasis::Tcommit($xid);
|
$h{foo}++;
|
||||||
warn "b\n"; $| = 1;
|
|
||||||
|
|
||||||
print "</body></html>\n";
|
$output = "$xid $h{foo}\n";
|
||||||
|
Stasis::TsoftCommit($xid);
|
||||||
|
warn "b\n"; $| = 1;
|
||||||
|
} # Release lock before commit happens. This is safe, since the output is
|
||||||
|
# deferred, and the commit order safes us from xacts that read uncommitted
|
||||||
|
# data.
|
||||||
|
Stasis::TforceCommits();
|
||||||
|
print "$output</body></html>\n";
|
||||||
|
|
||||||
return Apache2::Const::OK;
|
return Apache2::Const::OK;
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,21 +1,14 @@
|
||||||
use threads;
|
|
||||||
use threads::shared;
|
|
||||||
|
|
||||||
use strict;
|
use strict;
|
||||||
BEGIN {
|
BEGIN {
|
||||||
my $thelock :shared;
|
|
||||||
|
|
||||||
$ENV{STASIS_DIR} = '/home/sears/stasis';
|
$ENV{STASIS_DIR} = '/home/sears/stasis';
|
||||||
|
|
||||||
$ENV{STASIS_LOCK} = $thelock;
|
|
||||||
}
|
}
|
||||||
use lib ($ENV{STASIS_DIR}."/lang/perl/apache/");
|
use lib ($ENV{STASIS_DIR}."/lang/perl/"); # For Stasis.pm
|
||||||
push @INC, "$ENV{STASIS_DIR}/lang/perl/";
|
push @INC, "$ENV{STASIS_DIR}/lang/perl/apache/"; # For StasisWeb::Web.pm
|
||||||
|
|
||||||
use Inline (Config =>
|
#use Inline (Config =>
|
||||||
DIRECTORY => "$ENV{STASIS_DIR}/www-data/",
|
# DIRECTORY => "$ENV{STASIS_DIR}/www-data/",
|
||||||
);
|
# );
|
||||||
use Stasis;
|
use Stasis "$ENV{STASIS_DIR}/www-data/";
|
||||||
|
|
||||||
# XXX Ideally, the rest of this would go in a post_config handler, but
|
# XXX Ideally, the rest of this would go in a post_config handler, but
|
||||||
# I can't get that to work...
|
# I can't get that to work...
|
||||||
|
|
99
lang/perl/bin/stasis.pl
Executable file
99
lang/perl/bin/stasis.pl
Executable file
|
@ -0,0 +1,99 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
|
||||||
|
use Stasis @ARGV;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
my $prompt = "\nstasis: ";
|
||||||
|
|
||||||
|
my %s;
|
||||||
|
Stasis::open(\%s);
|
||||||
|
|
||||||
|
sub print_pad {
|
||||||
|
my $level = shift;
|
||||||
|
for(my $i = 0; $i < $level; $i++) {
|
||||||
|
print ' ';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
sub print_hash {
|
||||||
|
my $h = shift;
|
||||||
|
my $level = shift || 0;
|
||||||
|
my $STEP = 2;
|
||||||
|
if (!defined $h) {
|
||||||
|
print_pad $level;
|
||||||
|
print '%s = ';
|
||||||
|
$h = \%s;
|
||||||
|
}
|
||||||
|
print "{\n";
|
||||||
|
foreach my $k (sort keys %$h) {
|
||||||
|
print_pad $level;
|
||||||
|
if(ref($$h{$k}) eq 'HASH') {
|
||||||
|
print " $k => ";
|
||||||
|
print_hash($$h{$k}, $level+$STEP);
|
||||||
|
} else {
|
||||||
|
print " $k => $$h{$k}\n";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
print_pad $level;
|
||||||
|
print "}\n";
|
||||||
|
"";
|
||||||
|
}
|
||||||
|
sub p { print_hash @_; }
|
||||||
|
sub print_keys {
|
||||||
|
my $h = shift || \%s;
|
||||||
|
print "{ ";
|
||||||
|
print join ", ", sort( keys %$h);
|
||||||
|
print " }\n";
|
||||||
|
"";
|
||||||
|
}
|
||||||
|
sub k { print_keys @_; }
|
||||||
|
sub commit { tied(%s)->commit(); }
|
||||||
|
sub c { commit; }
|
||||||
|
sub abort {tied(%s)->abort(); }
|
||||||
|
sub a { abort; }
|
||||||
|
|
||||||
|
sub help {
|
||||||
|
print
|
||||||
|
qq(This prompt is a perl toplevel.
|
||||||
|
|
||||||
|
The hash %s points to the hash at the root of the datastore.
|
||||||
|
The following helper functions may be useful:
|
||||||
|
|
||||||
|
print_hash [\%hash] (or p [\%hash]) Recursively print database contents
|
||||||
|
print_keys [\%hash] (or k [\%hash]) Print keys non-recursively
|
||||||
|
commit (or c) Commit %s's current transaction
|
||||||
|
abort (or a) Abort the transaction
|
||||||
|
|
||||||
|
help (or h)
|
||||||
|
);
|
||||||
|
"";
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
$| = 1;
|
||||||
|
print "stasis toplevel. 'help' to get started ^D to exit.";
|
||||||
|
print $prompt;
|
||||||
|
|
||||||
|
|
||||||
|
while(my $line = <STDIN>) {
|
||||||
|
print eval($line);
|
||||||
|
print $prompt;
|
||||||
|
}
|
||||||
|
my $done = 0;
|
||||||
|
print "^D\n";
|
||||||
|
while(!$done) {
|
||||||
|
print "Commit any uncommitted data [Y/n]? ";
|
||||||
|
my $line = <STDIN>;
|
||||||
|
if(!defined $line) {
|
||||||
|
print "^D\n";
|
||||||
|
$done = 1;
|
||||||
|
} else {
|
||||||
|
chomp $line;
|
||||||
|
if($line eq "") { $line = "y"; }
|
||||||
|
if($line =~ /^y/i) {
|
||||||
|
tied(%s)->commit();
|
||||||
|
$done = 1;
|
||||||
|
} elsif($line =~ /^n/i) {
|
||||||
|
$done = 1;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
111
lang/perl/cgi-bin/index.fcgi
Executable file
111
lang/perl/cgi-bin/index.fcgi
Executable file
|
@ -0,0 +1,111 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
BEGIN {
|
||||||
|
$ENV{STASIS_INLINE_DIRECTORY} = '/home/sears/stasis/www-data2';
|
||||||
|
$ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
|
||||||
|
chdir '/home/sears/stasis/www-site' || die;
|
||||||
|
push @INC, '/home/sears/stasis/lang/perl';
|
||||||
|
}
|
||||||
|
|
||||||
|
use threads ('stack_size' => 128*1024);
|
||||||
|
use threads::shared;
|
||||||
|
|
||||||
|
use Stasis;
|
||||||
|
|
||||||
|
use IO::Handle;
|
||||||
|
use FCGI;
|
||||||
|
use CGI;
|
||||||
|
|
||||||
|
my $num_procs = 25;
|
||||||
|
|
||||||
|
Stasis::Tinit();
|
||||||
|
|
||||||
|
my @thrs;
|
||||||
|
for(my $i = 0; $i < $num_procs; $i++) {
|
||||||
|
push @thrs, threads->create(\&event_loop);
|
||||||
|
}
|
||||||
|
|
||||||
|
warn "Done spawning worker threads\n";
|
||||||
|
|
||||||
|
foreach my $t (@thrs) {
|
||||||
|
$t->join();
|
||||||
|
}
|
||||||
|
|
||||||
|
warn "Stasis cleanly shut down\n";
|
||||||
|
|
||||||
|
exit;
|
||||||
|
|
||||||
|
sub default_page {
|
||||||
|
my $q = shift;
|
||||||
|
my $page = shift;
|
||||||
|
return $q->p("$page does not exist");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub edit_link {
|
||||||
|
my $q = shift;
|
||||||
|
my $page = shift;
|
||||||
|
my $url = $q->url(-relative=>1);
|
||||||
|
return $q->p("<a href='$url?mode=edit&page=$page'>Click here to edit the page</a>");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub event_loop {
|
||||||
|
# my $in = new IO::Handle;
|
||||||
|
# my $out = new IO::Handle;
|
||||||
|
# my $err = new IO::Handle;
|
||||||
|
*STDIN = new IO::Handle;
|
||||||
|
*STDOUT = new IO::Handle;
|
||||||
|
*STDERR = new IO::Handle;
|
||||||
|
my %E;
|
||||||
|
%ENV = %E;
|
||||||
|
# my %env;
|
||||||
|
my %h;
|
||||||
|
|
||||||
|
# my $request = FCGI::Request($in, $out, $err, \%env);
|
||||||
|
my $request = FCGI::Request();
|
||||||
|
|
||||||
|
Stasis::open(\%h);
|
||||||
|
|
||||||
|
my $contents;
|
||||||
|
|
||||||
|
while($request->Accept() >= 0) {
|
||||||
|
my $q = new CGI(); #$env{QUERY_STRING});
|
||||||
|
|
||||||
|
my $response;
|
||||||
|
|
||||||
|
my $mode = $q->param('mode') || 'view';
|
||||||
|
|
||||||
|
my $page = $q->param('page') || '/';
|
||||||
|
|
||||||
|
if($mode eq 'view') {
|
||||||
|
$contents = ($h{$page} || default_page($q,$page)) . edit_link($q,$page);
|
||||||
|
|
||||||
|
} elsif($mode eq 'edit') {
|
||||||
|
my $page = $q->param('page') || '/';
|
||||||
|
my $a = $q->url(-relative=>1);
|
||||||
|
|
||||||
|
$q->param(-name=>'mode',-value=>'set');
|
||||||
|
$q->param(-name=>'contents',-value=>$h{$page});
|
||||||
|
$contents = $q->start_form()
|
||||||
|
. $q->hidden('mode')
|
||||||
|
. $q->p($q->textarea(-name=>'contents',-cols=>80,-rows=>18))
|
||||||
|
. $q->submit("Save $page")
|
||||||
|
. $q->end_form();
|
||||||
|
} elsif($mode eq 'set') {
|
||||||
|
$h{$page} = $q->param('contents');
|
||||||
|
$contents = $h{$page} . edit_link($q,$page);
|
||||||
|
} else {
|
||||||
|
$contents = "unknown mode $mode";
|
||||||
|
}
|
||||||
|
$response = $q->header()
|
||||||
|
. $q->start_html($page)
|
||||||
|
. $q->h1($page)
|
||||||
|
. $contents
|
||||||
|
. $q->end_html;
|
||||||
|
|
||||||
|
tied(%h)->commit();
|
||||||
|
# print $out $response;
|
||||||
|
print $response;
|
||||||
|
}
|
||||||
|
}
|
|
@ -25,7 +25,7 @@ my $count = 0;
|
||||||
my $tot :shared = 0;
|
my $tot :shared = 0;
|
||||||
my $concurrent :shared = 0;
|
my $concurrent :shared = 0;
|
||||||
|
|
||||||
my $num_procs = 500; #25;
|
my $num_procs = 25;
|
||||||
|
|
||||||
|
|
||||||
Stasis::Tinit();
|
Stasis::Tinit();
|
||||||
|
|
42
lang/perl/t/05-autoxacts.t
Executable file
42
lang/perl/t/05-autoxacts.t
Executable file
|
@ -0,0 +1,42 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
use strict;
|
||||||
|
use Stasis;
|
||||||
|
|
||||||
|
my $checking;
|
||||||
|
|
||||||
|
if(@ARGV && $ARGV[0] eq "--automated-test") {
|
||||||
|
shift @ARGV;
|
||||||
|
system ("rm storefile.txt logfile.txt");
|
||||||
|
$checking = 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
Stasis::Tinit();
|
||||||
|
|
||||||
|
my %hash;
|
||||||
|
|
||||||
|
tie %hash, 'Stasis::Hash';
|
||||||
|
|
||||||
|
for(my $i = 0; $i < 4; $i++) {
|
||||||
|
$hash{$i} = $i * 10;
|
||||||
|
if($i % 2) {
|
||||||
|
tied(%hash)->commit();
|
||||||
|
} else {
|
||||||
|
tied(%hash)->abort();
|
||||||
|
}
|
||||||
|
}
|
||||||
|
Stasis::Tdeinit();
|
||||||
|
Stasis::Tinit();
|
||||||
|
|
||||||
|
tie %hash, 'Stasis::Hash';
|
||||||
|
|
||||||
|
for(my $i = 0; $i < 4; $i++) {
|
||||||
|
if($i % 2) {
|
||||||
|
$hash{$i} == $i * 10 || die;
|
||||||
|
} else {
|
||||||
|
defined($hash{$i}) && die;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
Stasis::Tdeinit();
|
||||||
|
|
||||||
|
print "Passed";
|
33
lang/perl/t/06-open.t
Normal file
33
lang/perl/t/06-open.t
Normal file
|
@ -0,0 +1,33 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
use strict;
|
||||||
|
use Stasis;
|
||||||
|
|
||||||
|
my $checking;
|
||||||
|
|
||||||
|
if(@ARGV && $ARGV[0] eq "--automated-test") {
|
||||||
|
shift @ARGV;
|
||||||
|
system ("rm storefile.txt logfile.txt");
|
||||||
|
$checking = 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
my %hash;
|
||||||
|
|
||||||
|
Stasis::open (\%hash);
|
||||||
|
|
||||||
|
for(my $i = 0; $i < 4; $i++) {
|
||||||
|
$hash{$i} = $i * 10;
|
||||||
|
if($i % 2) {
|
||||||
|
tied(%hash)->commit();
|
||||||
|
} else {
|
||||||
|
tied(%hash)->abort();
|
||||||
|
}
|
||||||
|
}
|
||||||
|
for(my $i = 0; $i < 4; $i++) {
|
||||||
|
if($i % 2) {
|
||||||
|
$hash{$i} == $i * 10 || die;
|
||||||
|
} else {
|
||||||
|
defined($hash{$i}) && die;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
print "Exiting";
|
41
lang/perl/t/07-hash-in-autohash.t
Normal file
41
lang/perl/t/07-hash-in-autohash.t
Normal file
|
@ -0,0 +1,41 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
use strict;
|
||||||
|
use Stasis;
|
||||||
|
|
||||||
|
my $checking;
|
||||||
|
|
||||||
|
if(@ARGV && $ARGV[0] eq "--automated-test") {
|
||||||
|
shift @ARGV;
|
||||||
|
system ("rm storefile.txt logfile.txt");
|
||||||
|
$checking = 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
my %h;
|
||||||
|
Stasis::open(\%h);
|
||||||
|
|
||||||
|
Stasis::Tbegin();
|
||||||
|
|
||||||
|
my %i;
|
||||||
|
|
||||||
|
$h{foo} = \%i;
|
||||||
|
|
||||||
|
tied(%h)->commit();
|
||||||
|
|
||||||
|
$h{foo}{bar} = "x";
|
||||||
|
|
||||||
|
my $i = $h{foo};
|
||||||
|
|
||||||
|
tied(%h)->commit();
|
||||||
|
$$i{baz} = "y";
|
||||||
|
$$i{bat} = "z";
|
||||||
|
|
||||||
|
Stasis::Tdeinit();
|
||||||
|
|
||||||
|
Stasis::open(\%h);
|
||||||
|
|
||||||
|
Stasis::Tbegin();
|
||||||
|
Stasis::Tbegin();
|
||||||
|
|
||||||
|
$h{foo}{baz} = "bat";
|
||||||
|
$h{foo}{bar} == "x" || die;
|
||||||
|
|
Loading…
Reference in a new issue