From 6ec65ec2d276c359fab11d079536e47f31052647 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 14 Nov 2011 21:37:55 +0100
Subject: Implement a Berkeley-DB-based persistence layer.

---
 src/mulk/benki/db.clj | 90 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 90 insertions(+)
 create mode 100644 src/mulk/benki/db.clj

diff --git a/src/mulk/benki/db.clj b/src/mulk/benki/db.clj
new file mode 100644
index 0000000..d0f922a
--- /dev/null
+++ b/src/mulk/benki/db.clj
@@ -0,0 +1,90 @@
+(ns mulk.benki.db
+  (:refer-clojure)
+  (:use mulk.benki.util
+        clojure.java.io)
+  (:import [com.sleepycat.je
+            Database DatabaseConfig DatabaseEntry Environment EnvironmentConfig
+            OperationStatus]))
+
+(def ^{:dynamic true :private true} *txn*)
+(def ^{:dynamic true :private true} *db*)
+
+(defn- db-directory []
+  ;; FIXME: This is a hack.
+  ;;(file (.getParent (first (clojure.java.classpath/classpath))) "db")
+  (file "db"))
+
+(defn- make-db-env []
+  (let [envconfig (doto (EnvironmentConfig.)
+                    (.setTransactional            true)
+                    (.setAllowCreate              true)
+                    (.setTxnSerializableIsolation true))]
+    (Environment. (db-directory) envconfig)))
+
+(defonce dbenv (make-db-env))
+
+(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 state-vars (atom {}))
+
+
+(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 %))))))
-- 
cgit v1.2.3