persist.el

   1 ;;;_ tinydb/persist.el --- Create persisting data
   2
   3 ;;;_. Headers
   4 ;;;_ , License
   5 ;; Copyright (C) 2007,2010  Tom Breton (Tehom)
   6
   7 ;; Author: Tom Breton (Tehom) <tehom@panix.com>
   8 ;; Keywords:
   9
  10 ;; This file is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This file is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;;_ , Commentary:
  26
  27 ;; This was originally part of my `password' library.  I separated it
  28 ;; so that it could be re-used.
  29
  30 ;;Drawbacks: It only makes one object persist per buffer.  This could
  31 ;;be remedied with a major rewrite.  Even so, it would probably be
  32 ;;less safe.
  33
  34 ;;;_ , Requires
  35 (require 'pp)
  36 (require 'tinydb/asynq)
  37
  38
  39 ;;;_. Code:
  40
  41 ;;;_ , Internal:
  42
  43 ;;;_  . tinydb-persist--write-obj
  44 (defun tinydb-persist--write-obj (obj &optional force-save)
  45    ""
  46
  47    (let
  48       ((old-str (buffer-string)))
  49       (erase-buffer)
  50       (insert (pp-to-string obj))
  51       ;;If it can't be read back, it's an error
  52       (condition-case err
  53          (progn
  54             (goto-char (point-min))
  55             (read (current-buffer)))
  56          (error
  57             (erase-buffer)
  58             (insert old-str)
  59             (apply #'signal (car err) (cdr err)))))
  60
  61    (when force-save
  62       ;;Save, forcing backups to exist.
  63       (let
  64          ((file-precious-flag t))
  65          (save-buffer 64))))
  66
  67
  68 ;;;_ , File-buffer instantiation of asynq
  69
  70 ;;;_  . tinydb-persist-make-q
  71 (defun tinydb-persist-make-q
  72    (filename initial-obj &optional eager-save type-pred)
  73    "Make a file-based persisting queue"
  74    (tinydb-make-q
  75       ;;This is the setup for file-based asynq
  76       #'(lambda (filename initial-object eager-save)
  77            (with-current-buffer
  78               (find-file-noselect filename eager-save)
  79               (declare (special persist-eager-save))
  80               (set
  81                  (make-local-variable
  82                     'persist-eager-save)
  83                  eager-save)
  84               (when
  85                  (= (buffer-size) 0)
  86                  (tinydb-persist--write-obj initial-object eager-save))
  87               (current-buffer)))
  88
  89       ;;get
  90       #'(lambda (buffer)
  91            (with-current-buffer buffer
  92               (condition-case err
  93                  (progn
  94                     (goto-char (point-min))
  95                     (read (current-buffer)))
  96                  (error
  97                     (error
  98                        "In persist buffer %s, contents could not be read"
  99                        (current-buffer))
 100                     '()))))
 101
 102       ;;put
 103       #'(lambda (buffer obj)
 104            (with-current-buffer buffer
 105               (declare (special persist-eager-save))
 106               (tinydb-persist--write-obj obj persist-eager-save)
 107               buffer))
 108       type-pred
 109       filename initial-obj eager-save))
 110 ;;;_  . Associating files to objects
 111 ;;;_  . tinydb:filename-alist
 112 ;;$$IMPROVE ME Detect and restart deleted buffers.
 113 (defvar tinydb:filename-alist
 114    '()
 115    "Alist from absolute filenames to tinydb objects" )
 116
 117 ;;;_  . tinydb:filename->tinydb
 118 (defun tinydb:filename->tinydb (filename)
 119    "Return a tinydb object visiting FILENAME."
 120    (or
 121       (let*
 122          ((cell (assoc filename tinydb:filename-alist))
 123             (buf (second cell)))
 124          (when (buffer-live-p buf)
 125             buf))
 126       (let
 127          ((filetq
 128              (tinydb-persist-make-q filename '() nil #'listp)))
 129          (push (list filename filetq) tinydb:filename-alist)
 130          filetq)))
 131
 132
 133 ;;;_: Footers
 134
 135 ;;;_ * Local emacs vars.
 136 ;;;_  + Local variables:
 137 ;;;_  + mode: allout
 138 ;;;_  + End:
 139
 140 (provide 'tinydb/persist)
 141 ;;; tinydb/persist.el ends here