initial checkin

db.el

@@ -0,0 +1,256 @@
+;;; db.el --- A database for EmacsLisp  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2012  Nic Ferrier
+
+;; Author: Nic Ferrier <nferrier@ferrier.me.uk>
+;; Maintainer: Nic Ferrier <nferrier@ferrier.me.uk>
+;; Keywords: data, lisp
+;; Created: 23rd September 2012
+;; Package-Requires: ((kv "0.0.7"))
+;; Version: 0.0.1
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is a simple database interface and implementation.
+;;
+;; It should be possible to specify any kind of key/value database
+;; with this interface.
+;;
+;; The supplied implementation is an Emacs hash-table implementation
+;; backed with serializing objects.  It is NOT intended for anything
+;; other than very simple use cases and will not scale very well at
+;; all.
+
+;; However, other implementations (mongodb, redis or PostgreSQL
+;; hstore) would be easy to implement and fit in here.
+
+
+;;; Code:
+
+(eval-when-compile
+  (require 'cl))
+(require 'kv)
+
+(defvar db--types (make-hash-table :test 'eq)
+  "Hash of database type ids against funcs?")
+
+(defun* db-make (reference)
+  "Make a DB based on the REFERENCE."
+  (if (and (listp reference)
+           (eq
+            'db-hash
+            (car reference)))
+      ;; this should be part of what we find when we look it up?
+      (db-hash reference)
+      ;; Otherwise look it up...
+      (let ((db-func (gethash (car reference) db--types)))
+        (if (functionp db-func)
+            (funcall db-func reference)
+            ;; there should be a specific db error
+            (error "no such database implementation")))))
+
+(defun db-get (key db)
+  "Get the value from the DB with the KEY."
+  (funcall (plist-get db :get) key db))
+
+(defun db-put (key value db)
+  "Put a new VALUE into the DB with the specified KEY.
+
+Return the VALUE as it has been put into the DB."
+  (funcall (plist-get db :put) key value db))
+
+(defun db-map (func db &optional query filter)
+  "Call FUNC for every record in DB optionally QUERY filter.
+
+QUERY, if specified, should be a list of query terms.
+
+FUNC should take 2 arguments:
+
+  KEY DB-VALUE
+
+where the DB-VALUE is whatever the DB has attached to the
+specified KEY.
+
+This returns an alist of the KEY and the value the function
+returned.  If FILTER is `t' then only pairs with a value are
+returned."
+  (let (retlist)
+    (funcall (plist-get db :map)
+             (lambda (key value)
+               (when key
+                 (setq
+                  retlist
+                  (cons
+                   (funcall func key value)
+                   retlist))))
+             db query)
+    (if filter
+        (loop for p in retlist
+           if (cdr p)
+           collect p)
+        retlist)))
+
+(defun db-query (db query)
+  "Do QUERY on DB and return the result.
+
+This is `db-map' with an identity function."
+  (db-map 'kvidentity db query))
+
+(defun db-hash (reference)
+  "Make a db-hash database.
+
+REFERENCE comes from the call to `db-make' and should
+include a `:filename' key arg to point to a file:
+
+  '(db-hash :filename \"/var/local/db/auth-db\")
+
+If the filename exists then it is loaded into the database."
+  (let* ((filename (plist-get (cdr reference) :filename))
+         (db (list
+              :db (make-hash-table :test 'equal)
+              :get 'db-hash-get
+              :put 'db-hash-put
+              :map 'db-hash-map
+              :query-equal 'kvassoq=
+              :filename filename)))
+    (when (and filename
+               (file-exists-p (concat filename ".elc")))
+      (db-hash--read db))
+    ;; Return the database
+    db))
+
+(defun db-hash--read (db)
+  "Loads the DB."
+  (let ((filename (plist-get db :filename)))
+    (when filename
+      (load-file (concat filename ".elc"))
+      (plist-put db :db (symbol-value (intern filename))))))
+
+(defvar db-hash-do-not-save nil
+  "If `t' then do not save the database.
+
+This is very useful for testing.")
+
+(defun db-hash--save (db)
+  "Saves the DB."
+  (unless db-hash-do-not-save
+    (let ((filename (plist-get db :filename)))
+      (when filename
+        ;; Make the parent directory for the db if it doesn't exist
+        (let ((dir (file-name-directory filename)))
+          (unless (file-exists-p dir)
+            (make-directory dir t)))
+        ;; Now store the data
+        (with-temp-file (concat filename ".el")
+          (erase-buffer)
+          (let ((fmt-obj (format
+                          "(setq %s (eval-when-compile %S))"
+                          (intern filename)
+                          (plist-get db :db))))
+            (insert fmt-obj)))
+        ;; And compile it and delete the original
+        (byte-compile-file (concat filename ".el"))
+        (delete-file (concat filename ".el"))))))
+
+(defun db-hash-get (key db)
+  (let ((v (gethash key (plist-get db :db))))
+    v))
+
+(defun db-hash-map (func db &optional query)
+  "Run FUNC for every value in DB.
+
+The QUERY is ignored.  We never filter."
+  (let* ((equal-fn (plist-get db :query-equal))
+         (filterfn (kvquery->func query :equal-func equal-fn)))
+    (maphash
+     (lambda (key value)
+       (when (funcall filterfn value)
+         (funcall func key value)))
+     (plist-get db :db))))
+
+(defun db-hash-put (key value db)
+  (let ((v (puthash key value (plist-get db :db))))
+    ;; Instead of saving every time we could simply signal an update
+    ;; and have a timer do the actual save.
+    (db-hash--save db)
+    v))
+
+(defvar db--hash-clear-history nil
+  "History variable for completing read.")
+
+(defun db-hash-clear (db)
+  "Clear the specified DB (a hash-db)."
+  (interactive
+   (list (symbol-value
+          (intern
+           (completing-read
+            "Database: "
+            obarray
+            nil
+            't
+            nil
+            'db--hash-clear-history)))))
+  (clrhash (plist-get db :db))
+  (if (file-exists-p (plist-get db :filename))
+      (delete-file (plist-get db :filename))))
+
+
+;; Filter db - let's you filter another db
+
+(defun db-filter-get (key db)
+  (let* ((filter-func (plist-get db :filter))
+         (origin (plist-get db :source))
+         (value (db-get key origin)))
+    (funcall filter-func key value)))
+
+(defun db-filter-put (key value db)
+  (let* ((filter-func (plist-get db :filter))
+         (origin (plist-get db :source))
+         (ret (db-put key value origin)))
+    (funcall filter-func key ret)))
+
+(defun db-filter-map (key db &optional query)
+  (let* ((filter-func (plist-get db :filter))
+         (origin (plist-get db :source)))
+    (mapcar
+     filter-func
+     (db-map key origin query))))
+
+(defun db-filter (reference)
+  "Make a database object that is a filter around another.
+
+The reference should look something like:
+
+ '(db-filter
+    :source (db-hash :filename ....)
+    :filter (lambda (value) ...)
+
+The `:filter' function takes 2 arguments: KEY and VALUE with
+VALUE being the returned value from the `:source' database."
+  (let* ((ref-plist (cdr reference))
+         (db (list
+              :get 'db-filter-get
+              :put 'db-filter-put
+              :map 'db-filter-map
+              :filter (plist-get ref-plist :filter)
+              :source (plist-get ref-plist :source))))
+    db))
+
+(puthash 'db-filter 'db-filter db--types)
+
+(provide 'db)
+
+;;; db.el ends here

tests.el

@@ -0,0 +1,103 @@
+;;; tests for the emacs db.
+
+(require 'cl)
+(require 'ert)
+(require 'db)
+(require 'kv)
+
+(ert-deftest db-get ()
+  "Test the database interface and the hash implementation."
+  ;; Make a hash-db with no filename
+  (let ((db (db-make '(db-hash))))
+    (should-not (db-get "test-key" db))
+    (db-put "test-key" 321 db)
+    (should
+     (equal
+      321
+      (db-get "test-key" db)))))
+
+(ert-deftest db-put ()
+  "Test the put interface."
+  (let ((db (db-make '(db-hash))))
+    (should-not (db-get "test-key" db))
+    (should
+     (equal
+      '("1" "2" "3")
+      (db-put "test-key" '("1" "2" "3") db)))))
+
+(ert-deftest db-query ()
+  "Test the query interfce."
+  (let ((db (db-make '(db-hash))))
+    (db-put "test001"
+            '(("username" . "test001")
+              ("title" . "Miss")
+              ("surname" . "Test")) db)
+    (db-put "test002"
+            '(("username" . "test002")
+              ("title" . "Mr")
+              ("surname" . "Test")) db)
+    (should
+     (equal
+      '(("test001"
+         ("username" . "test001")
+         ("title" . "Miss")
+         ("surname" . "Test")))
+      (db-map 'kvidentity db '(= "username" "test001"))))))
+
+
+(ert-deftest db-hash--save ()
+  "Test the saving of a hash db."
+  (unwind-protect
+       (progn
+         (let ((db (db-make
+                    ;; You shouldn't use an extension but let elnode deal
+                    ;; with it.
+                    '(db-hash :filename "/tmp/test-db"))))
+           ;; Override the save so it does nothing from put
+           (flet ((db-hash--save (db)
+                    t))
+             (db-put 'test1 "value1" db)
+             (db-put 'test2 "value2" db))
+           ;; And now save
+           (db-hash--save db))
+         ;; And now load in a different scope
+         (let ((db (db-make
+                    '(db-hash :filename "/tmp/test-db"))))
+           (should
+            (equal "value1"
+                   (db-get 'test1 db)))))
+    (delete-file "/tmp/test-db.elc")))
+
+(ert-deftest db-filter ()
+  "Test the filtering."
+  (let ((db (db-make
+             '(db-hash :filename "/tmp/test-db"))))
+    (db-put
+     "test001"
+     '(("uid" . "test001")
+       ("fullname" . "test user 1"))
+     db)
+    (db-put
+     "test002"
+     '(("uid" . "test002")
+       ("fullname" . "test user 2"))
+     db)
+    (db-put
+     "test003"
+     '(("uid" . "test001")
+       ("fullname" . "test user 1"))
+     db)
+    (flet ((filt (key value)
+             (cdr (assoc "fullname" value))))
+      (let ((filtered
+             (db-make
+              `(db-filter
+                :source ,db
+                :filter filt))))
+        (plist-get filtered :source)
+        (should
+         (equal (db-get "test002" filtered) "test user 2"))))))
+
+(provide 'db-tests)
+
+;;; db-tests.el ends here