From 068b1376463f865c2beade84eb71e1ae590edc42 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 21 Feb 2012 20:34:48 +0100
Subject: Initial checkin.

---
 src/eu/mulk/instadump.clj | 100 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 100 insertions(+)
 create mode 100644 src/eu/mulk/instadump.clj

(limited to 'src')

diff --git a/src/eu/mulk/instadump.clj b/src/eu/mulk/instadump.clj
new file mode 100644
index 0000000..5ad56ce
--- /dev/null
+++ b/src/eu/mulk/instadump.clj
@@ -0,0 +1,100 @@
+;; Copyright 2012, Matthias Andreas Benkard.
+;; See file COPYING for license details.
+
+(ns eu.mulk.instadump
+  (:refer-clojure)
+  (:use clojure.java.io)
+  (:import [com.sleepycat.je
+            Database DatabaseConfig DatabaseEntry Environment EnvironmentConfig
+            OperationStatus]))
+
+
+;;;; * Internal stuff
+(def ^{:dynamic true :private true} *txn*)
+(def ^{:dynamic true :private true} *db*)
+
+(declare ^{:private true} dbenv)
+
+
+(defn- make-db-env [db-directory-name]
+  (let [envconfig (doto (EnvironmentConfig.)
+                    (.setTransactional            true)
+                    (.setAllowCreate              true)
+                    (.setTxnSerializableIsolation true))]
+    (Environment. (file db-directory-name) envconfig)))
+
+(defn- call-with-transaction [thunk]
+  (binding [*txn* (.beginTransaction @dbenv nil nil)]
+    (try (let [result (thunk)]
+           (.commit *txn*)
+           result)
+      (finally (.abort *txn*)))))
+
+(defn- call-with-db [thunk]
+  (let [dbconfig (doto (DatabaseConfig.)
+                   (.setTransactional            true)
+                   (.setAllowCreate              true)
+                   (.setSortedDuplicates         false))]
+    (call-with-transaction
+      (fn []
+        (binding [*db* (.openDatabase @dbenv *txn* "benki" dbconfig)]
+          (thunk))))))
+
+(defmacro with-db [& body]
+  `(call-with-db (fn [] ~@body)))
+
+(defn- dump-str-for-db [x]
+  (binding [*print-dup*  true
+            *print-meta* true]
+    (pr-str x)))
+
+(defn- getkey [key default]
+  (let [entry (DatabaseEntry.)]
+    (if (= (.get *db* *txn* (DatabaseEntry. (.getBytes key)) entry nil)
+           OperationStatus/SUCCESS)
+      (-> entry
+          (.getData)
+          (String.)
+          (read-string))
+      default)))
+
+(defn- putkey [key val]
+  (let [bdbkey key]
+    (.put *db*
+          *txn*
+          (DatabaseEntry. (.getBytes bdbkey))
+          (DatabaseEntry. (.getBytes (dump-str-for-db val))))))
+
+
+(defonce ^{:private true} dbenv (atom nil))
+(defonce ^{:private true} state-vars (atom {}))
+
+
+;;;; * Public API
+(defn setup-instadump! [dirname]
+  (reset! dbenv (make-db-env dirname)))
+
+(defmacro defstate [sym default]
+  (let [dbkey (str *ns* "/" (name sym))]
+    `(defonce ~sym
+       (let [r# (ref (with-db (getkey ~dbkey ~default)))]
+         (swap! state-vars #(assoc % ~dbkey r#))
+         r#))))
+
+
+(defn save-all-global-state! []
+  (with-db
+    (dosync
+      (doseq [[key r] @state-vars]
+        (putkey key (ensure r))))))
+
+(defn reload-all-global-state! []
+  (with-db
+    (dosync
+      (doseq [[key r] @state-vars]
+        (alter r #(getkey key %))))))
+
+(comment
+  (setup-instadump! "db")
+  (defstate testvar1 150)
+  (defstate testvar2 "abc"))
-- 
cgit v1.2.3