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    '  ;;$$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*
  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    '  ;;$$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*
 147          (
 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
 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 (defun tinydb-get (tq func &rest args)
 179    ""
 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)))
 188
 189 ;;;_ , Some specific handlers
 190 ;;;_  . Whole object - Exists mostly for testing
 191 ;;;_   , tinydb-set-obj
 192 (defun tinydb-set-obj (tq x)
 193    ""
 194    (tinydb-q-will-call tq nil
 195       #'(lambda (obj x)
 196            (throw 'tinydb-q-new-obj x))
 197       x))
 198
 199 ;;;_   , tinydb-get-obj
 200 (defun tinydb-get-obj (tq)
 201    ""
 202    (tinydb-get tq #'identity))
 203
 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))
 234
 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)
 244    ""
 245    (delete* key alist :key #'car))
 246
 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)"
 257
 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))
 270
 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)))))
 277
 278               ;;Write the alist back
 279               (throw 'tinydb-q-new-obj (cons new-cell new-list))))
 280       key
 281       update-f))
 282
 283
 284 ;;;_. Footers
 285 ;;;_ , Provides
 286
 287 (provide 'tinydb/asynq)
 288
 289 ;;;_ * Local emacs vars.
 290 ;;;_  + Local variables:
 291 ;;;_  + mode: allout
 292 ;;;_  + End:
 293
 294 ;;;_ , End
 295 ;;; tinydb/asynq.el ends here