asynq.el

   1 ;;;_ tinydb/asynq.el --- Asynchrous queue for use with Elisp
   2
   3 ;;;_. Headers
   4 ;;;_ , License
   5 ;; Copyright (C) 2010  Tom Breton (Tehom)
   6
   7 ;; Author: Tom Breton (Tehom) <tehom@panix.com>
   8 ;; Keywords: lisp, internal
   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 complements tq transaction queues.  Tq is meant for use with
  28 ;; processes, and doesn't play nicely with Elisp code.
  29
  30
  31 ;;;_ , Requires
  32 (eval-when-compile
  33    (require 'cl))
  34
  35 ;;;_. Body
  36
  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)
  55
  56 ;;;_  . tinydb-q-check-type
  57 (defun tinydb-q-check-type (tq obj)
  58    ""
  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))))
  66
  67 ;;;_  . tinydb-check-listlock
  68 (defmacro tinydb-check-listlock (sym obj &rest err-args)
  69    ""
  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)
  77    ""
  78    (declare (debug (symbolp form body)))
  79    `(let
  80        ((,sym
  81            (if (boundp ',sym)
  82               (cons ,obj ,sym)
  83               (list ,obj))))
  84        ,@body))
  85
  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    '
  92    (tinydb-check-listlock
  93       persist-*handler-running* tq
  94       "`tinydb-q-do-pending' called while already running.")
  95    '
  96    (while (tinydb-q->queue tq)
  97       (tinydb-with-listlock persist-*handler-running* tq
  98          (let*
  99             (
 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))))
 119
 120                ;;On error, just go on to the next one.  The obj field
 121                ;;has not been changed.
 122                (error nil))))))
 123
 124
 125
 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.")
 139
 140    '
 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*
 147          (
 148             (obj (funcall (tinydb-q->get tq) (tinydb-q->obj tq)))
 149             (cell (pop (tinydb-q->queue tq))))
 150          '
 151          (condition-case nil
 152             t
 153
 154             ;;On error, just go on to the next one.  The obj field
 155             ;;has not been changed.
 156             (error nil))
 157
 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))))
 173          ))
 174    )
 175
 176 ;;;_ , Immediate getter
 177 ;;;_  . tinydb-get
 178 ;;Can make this more sensible now.
 179 (defun tinydb-get (tq func &rest args)
 180    ""
 181    (let ((holder (list nil)))
 182       (tinydb-q-will-call tq t
 183          #'(lambda (obj holder func args)
 184               (setcar holder (apply func obj args)))
 185          holder
 186          func
 187          args)
 188       (car holder)))
 189
 190 ;;;_ , Some specific handlers
 191 ;;;_  . Whole object - Exists mostly for testing
 192 ;;;_   , tinydb-set-obj
 193 (defun tinydb-set-obj (tq x)
 194    ""
 195    (tinydb-q-will-call tq nil
 196       #'(lambda (obj x)
 197            (throw 'tinydb-q-new-obj x))
 198       x))
 199
 200 ;;;_   , tinydb-get-obj
 201 (defun tinydb-get-obj (tq)
 202    ""
 203    (tinydb-get tq #'identity))
 204
 205 ;;;_  . Alist
 206 ;;;_   , tinydb-alist-push
 207 (defun tinydb-alist-push (tq key obj)
 208    "Push X onto an alist managed by TQ."
 209    (tinydb-q-will-call tq nil
 210       #'(lambda (alist key obj)
 211            (throw 'tinydb-q-new-obj (cons (cons key obj) alist)))
 212       key obj))
 213 ;;;_   , tinydb-alist-pushnew
 214 (defun tinydb-alist-pushnew (tq key obj)
 215    "Push X onto an alist managed by TQ, unless X's car is already a key on it."
 216    (tinydb-q-will-call tq nil
 217       #'(lambda (alist key obj)
 218            (unless (assoc key alist)
 219               (throw 'tinydb-q-new-obj
 220                  (cons (cons key obj) alist))))
 221       key
 222       obj))
 223 ;;;_   , tinydb-alist-push-replace
 224 (defun tinydb-alist-push-replace (tq key obj)
 225    "Add a cell of (KEY . OBJ) onto an alist managed by TQ, replacing
 226 any previous KEY cell."
 227    (tinydb-q-will-call tq nil
 228       #'(lambda (alist key obj)
 229            (throw 'tinydb-q-new-obj
 230               (cons
 231                  (cons key obj)
 232                  (tinydb-alist--remove alist key))))
 233       key
 234       obj))
 235
 236 ;;;_   , tinydb-alist-assoc
 237 (defun tinydb-alist-assoc (tq key)
 238    "Get cell corresponding to KEY from an alist managed by TQ."
 239    (tinydb-get tq
 240       #'(lambda (alist key)
 241            (assoc key alist))
 242       key))
 243 ;;;_   , persist--alist-remove
 244 (defsubst tinydb-alist--remove (alist key)
 245    ""
 246    (delete* key alist :key #'car))
 247
 248 ;;;_   , tinydb-alist-update
 249 (defun tinydb-alist-update (tq key update-f &optional now-p)
 250    "Replaces the matching object with an updated version
 251 TQ must be an asynq.
 252 KEY is a key.
 253 UPDATE-F is a function to update the value.
 254  * Takes the old object (or nil if none)
 255  * Takes a flag, whether there was an old object found.
 256  * Takes the KEY.
 257  * Returns the new value for the cdr (not including the key)"
 258
 259    (tinydb-q-will-call tq now-p
 260       #'(lambda (alist key update-f)
 261            (let*
 262               ((cell
 263                   (assoc key alist))
 264                  ;;The new list won't have that cell, it will have
 265                  ;;another object with that key, so remove the
 266                  ;;original.
 267                  (new-list
 268                     (if cell
 269                        (tinydb-alist--remove alist key)
 270                        alist))
 271
 272                  ;;Get the new cell
 273                  (new-cell
 274                     (cons key
 275                        (if cell
 276                           (funcall update-f (cdr cell) t   key)
 277                           (funcall update-f nil        nil key)))))
 278
 279               ;;Write the alist back
 280               (throw 'tinydb-q-new-obj (cons new-cell new-list))))
 281       key
 282       update-f))
 283
 284
 285 ;;;_. Footers
 286 ;;;_ , Provides
 287
 288 (provide 'tinydb/asynq)
 289
 290 ;;;_ * Local emacs vars.
 291 ;;;_  + Local variables:
 292 ;;;_  + mode: allout
 293 ;;;_  + End:
 294
 295 ;;;_ , End
 296 ;;; tinydb/asynq.el ends here