If file buffer is deleted, just visit file again.
[tinydb.git] / asynq.el
blob7b025d91837f130e240ea646a26765bfe46a88c0
1 ;;;_ tinydb/asynq.el --- Asynchrous queue for use with Elisp
3 ;;;_. Headers
4 ;;;_ , License
5 ;; Copyright (C) 2010 Tom Breton (Tehom)
7 ;; Author: Tom Breton (Tehom) <tehom@panix.com>
8 ;; Keywords: lisp, internal
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.
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.
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.
25 ;;;_ , Commentary:
27 ;; This complements tq transaction queues. Tq is meant for use with
28 ;; processes, and doesn't play nicely with Elisp code.
31 ;;;_ , Requires
32 (eval-when-compile
33 (require 'cl))
35 ;;;_. Body
37 ;;;_ , Transaction management
38 ;;;_ . Struct tinydb-q
39 (defstruct (tinydb-q
40 (:constructor tinydb-make-q
41 (setup get put type-pred
42 &rest args
43 &aux
44 (queue '())
45 (obj (apply setup args))))
46 (:conc-name tinydb-q->)
47 (:copier nil))
48 "A transaction queue that works with native elisp rather than an
49 inferior process."
50 queue
51 obj
52 get
53 put
54 type-pred)
56 ;;;_ . tinydb-q-check-type
57 (defun tinydb-q-check-type (tq obj)
59 (let
60 ((type-pred (tinydb-q->type-pred tq)))
61 (if
62 (or (null type-pred) (funcall type-pred obj))
63 obj
64 (error
65 "In tinydb-q, object %s was wrong type" obj))))
67 ;;;_ . tinydb-check-listlock
68 (defmacro tinydb-check-listlock (sym obj &rest err-args)
70 (declare (debug (symbolp form &rest sexp)))
71 `(when (and
72 (boundp ',sym)
73 (memq ,obj ,sym))
74 (error ,@err-args)))
75 ;;;_ . tinydb-with-listlock
76 (defmacro tinydb-with-listlock (sym obj &rest body)
78 (declare (debug (symbolp form body)))
79 `(let
80 ((,sym
81 (if (boundp ',sym)
82 (cons ,obj ,sym)
83 (list ,obj))))
84 ,@body))
86 ;;;_ . tinydb-q-do-pending
87 (defun tinydb-q-do-pending (tq)
88 "Do all pending operations.
89 If another call to the same tq is active, raise an error."
90 (declare (special persist-*handler-running*))
91 ' ;;$$FIX ME Quoted out because async operations are buggy
92 (tinydb-check-listlock
93 persist-*handler-running* tq
94 "`tinydb-q-do-pending' called while already running.")
95 ' ;;$$FIX ME Quoted out because async operations are buggy
96 (while (tinydb-q->queue tq)
97 (tinydb-with-listlock persist-*handler-running* tq
98 (let*
100 (obj (funcall (tinydb-q->get tq) (tinydb-q->obj tq)))
101 (cell (pop (tinydb-q->queue tq))))
102 (condition-case nil
103 (catch 'tinydb-q-no-change
104 (let
105 ((new-obj
106 (catch 'tinydb-q-new-obj
107 (throw 'tinydb-q-no-change
108 (apply (car cell) obj (cdr cell))))))
109 ;;Check its type. This can raise error. If it
110 ;;does, control just goes to the next iteration
111 ;;without changing obj.
112 (tinydb-q-check-type tq new-obj)
113 ;;Replace the object.
114 (setf
115 (tinydb-q->obj tq)
116 (funcall (tinydb-q->put tq)
117 (tinydb-q->obj tq)
118 new-obj))))
120 ;;On error, just go on to the next one. The obj field
121 ;;has not been changed.
122 (error nil))))))
126 ;;;_ . tinydb-q-will-call
127 (defun tinydb-q-will-call (tq now-p function &rest args)
128 "Schedule FUNCTION to be called on TQ.
129 Function will:
130 * Take TQ's internal object
131 * Take ARGS as the rest of its args
132 * Return value is ignored.
133 * If FUNCTION should set a new value for TQ's internal object, throw
134 that value to `tinydb-q-new-obj'"
135 (check-type tq tinydb-q)
136 (tinydb-check-listlock
137 persist-*handler-running* tq
138 "`tinydb-q-do-pending' called while already running.")
140 ' ;;$$FIX ME Quoted out because async operations are buggy
141 (progn
142 (callf append (tinydb-q->queue tq) (list (list* function args)))
143 (when now-p
144 (tinydb-q-do-pending tq)))
145 (tinydb-with-listlock persist-*handler-running* tq
146 (let*
148 (obj (funcall (tinydb-q->get tq) (tinydb-q->obj tq)))
149 (cell (pop (tinydb-q->queue tq))))
150 ' ;;$$FIX ME Quoted out because async operations are buggy
151 (condition-case nil
154 ;;On error, just go on to the next one. The obj field
155 ;;has not been changed.
156 (error nil))
158 (catch 'tinydb-q-no-change
159 (let
160 ((new-obj
161 (catch 'tinydb-q-new-obj
162 (throw 'tinydb-q-no-change
163 (apply function obj args)))))
164 ;;Check its type. This can raise error. If it does,
165 ;;we exit without changing obj.
166 (tinydb-q-check-type tq new-obj)
167 ;;Replace the object.
168 (setf
169 (tinydb-q->obj tq)
170 (funcall (tinydb-q->put tq)
171 (tinydb-q->obj tq)
172 new-obj))))
176 ;;;_ , Immediate getter
177 ;;;_ . tinydb-get
178 (defun tinydb-get (tq func &rest args)
180 (let ((holder (list nil)))
181 (tinydb-q-will-call tq t
182 #'(lambda (obj holder func args)
183 (setcar holder (apply func obj args)))
184 holder
185 func
186 args)
187 (car holder)))
189 ;;;_ , Some specific handlers
190 ;;;_ . Whole object - Exists mostly for testing
191 ;;;_ , tinydb-set-obj
192 (defun tinydb-set-obj (tq x)
194 (tinydb-q-will-call tq nil
195 #'(lambda (obj x)
196 (throw 'tinydb-q-new-obj x))
199 ;;;_ , tinydb-get-obj
200 (defun tinydb-get-obj (tq)
202 (tinydb-get tq #'identity))
204 ;;;_ . Alist
205 ;;;_ , tinydb-alist-push
206 (defun tinydb-alist-push (tq key obj)
207 "Push X onto an alist managed by TQ."
208 (tinydb-q-will-call tq nil
209 #'(lambda (alist key obj)
210 (throw 'tinydb-q-new-obj (cons (cons key obj) alist)))
211 key obj))
212 ;;;_ , tinydb-alist-pushnew
213 (defun tinydb-alist-pushnew (tq key obj)
214 "Push X onto an alist managed by TQ, unless X's car is already a key on it."
215 (tinydb-q-will-call tq nil
216 #'(lambda (alist key obj)
217 (unless (assoc key alist)
218 (throw 'tinydb-q-new-obj
219 (cons (cons key obj) alist))))
220 key
221 obj))
222 ;;;_ , tinydb-alist-push-replace
223 (defun tinydb-alist-push-replace (tq key obj)
224 "Add a cell of (KEY . OBJ) onto an alist managed by TQ, replacing
225 any previous KEY cell."
226 (tinydb-q-will-call tq nil
227 #'(lambda (alist key obj)
228 (throw 'tinydb-q-new-obj
229 (cons
230 (cons key obj)
231 (tinydb-alist--remove alist key))))
232 key
233 obj))
235 ;;;_ , tinydb-alist-assoc
236 (defun tinydb-alist-assoc (tq key)
237 "Get cell corresponding to KEY from an alist managed by TQ."
238 (tinydb-get tq
239 #'(lambda (alist key)
240 (assoc key alist))
241 key))
242 ;;;_ , persist--alist-remove
243 (defsubst tinydb-alist--remove (alist key)
245 (delete* key alist :key #'car))
247 ;;;_ , tinydb-alist-update
248 (defun tinydb-alist-update (tq key update-f &optional now-p)
249 "Replaces the matching object with an updated version
250 TQ must be an asynq.
251 KEY is a key.
252 UPDATE-F is a function to update the value.
253 * Takes the old object (or nil if none)
254 * Takes a flag, whether there was an old object found.
255 * Takes the KEY.
256 * Returns the new value for the cdr (not including the key)"
258 (tinydb-q-will-call tq now-p
259 #'(lambda (alist key update-f)
260 (let*
261 ((cell
262 (assoc key alist))
263 ;;The new list won't have that cell, it will have
264 ;;another object with that key, so remove the
265 ;;original.
266 (new-list
267 (if cell
268 (tinydb-alist--remove alist key)
269 alist))
271 ;;Get the new cell
272 (new-cell
273 (cons key
274 (if cell
275 (funcall update-f (cdr cell) t key)
276 (funcall update-f nil nil key)))))
278 ;;Write the alist back
279 (throw 'tinydb-q-new-obj (cons new-cell new-list))))
281 update-f))
284 ;;;_. Footers
285 ;;;_ , Provides
287 (provide 'tinydb/asynq)
289 ;;;_ * Local emacs vars.
290 ;;;_ + Local variables:
291 ;;;_ + mode: allout
292 ;;;_ + End:
294 ;;;_ , End
295 ;;; tinydb/asynq.el ends here