emacs/jelly.el

   1 ;;;; Jelly -- portable serialisation for network communication.
   2 ;;;; by Allen Short <washort@twistedmatrix.com>
   3 ;;;; This file is in the public domain.
   4
   5 "'Get into a rut early: Do the same processes the same way. Accumulate idioms. Standardize. The only difference(!) between Shakespeare and you was the size of his idiom list -- not the size of his vocabulary.' -- Alan Perlis,  Programming Epigram #10"
   6
   7 (provide 'jelly)
   8
   9 (defvar jelly-debug 0)
  10 (defstruct (jelly)
  11   (preserved (make-hash-table))
  12   (cooked (make-hash-table))
  13   (ref-id 0))
  14
  15 (defun jelly-cook (obj j)
  16 (if jelly-debug (print (list "cook" obj j) (get-buffer "*jelly-trace*")))
  17   (let* ((sexp (gethash obj (jelly-preserved j)))
  18          (new-list (copy-list sexp)))
  19     (incf (jelly-ref-id j))
  20     (setf (car sexp) 'reference)
  21     (setf (cdr sexp) (list (jelly-ref-id j) new-list))
  22     (setf (gethash obj (jelly-cooked j)) (list 'dereference (jelly-ref-id j)))
  23     sexp))
  24
  25
  26 (defun jelly-prepare (obj j)
  27 (if jelly-debug (print (list "prepare" obj j) (get-buffer "*jelly-trace*")))
  28   (setf (gethash obj (jelly-preserved j)) (cons 'empty 'pair)))
  29
  30 (defun jelly-preserve (obj sexp j)
  31 (if jelly-debug (print (list "preserve" obj sexp j) (get-buffer "*jelly-trace*")))
  32   (if (not (eq (gethash obj (jelly-cooked j) 'empty) 'empty))
  33       (progn (setf (third (gethash obj (jelly-preserved j))) sexp)
  34              (gethash obj (jelly-preserved j)))
  35     (setf (gethash obj (jelly-preserved j)) sexp)
  36     sexp))
  37
  38 (defun jelly-serialize (obj j)
  39   (if jelly-debug (print (list "jelly-serialize" obj j) (get-buffer "*jelly-trace*")))
  40   "(jelly-serialise OBJECT JAR)
  41     Serialises OBJECT with state JAR."
  42   (if (not (eq (gethash obj (jelly-cooked j) 'empty) 'empty))
  43       (gethash obj (jelly-cooked j))
  44     (if (not (eq (gethash obj (jelly-preserved j) 'empty) 'empty))
  45         (progn (jelly-cook obj j)
  46                (gethash obj (jelly-cooked j)))
  47       (cond
  48        ((or
  49          (integerp obj)
  50          (stringp obj)
  51          (floatp obj))
  52         obj)
  53        ((or (eq obj 'None) (null obj))
  54         'None)
  55        ((hash-table-p obj)
  56         (jelly-prepare obj j)
  57         (let ((jhash '(dictionary)))
  58           (maphash
  59            (lambda (k v)
  60              (setf jhash (append jhash (list (list (jelly-serialize k j) (jelly-serialize v j))))))
  61              obj)
  62           (jelly-preserve obj jhash j)))
  63
  64        ((listp obj)
  65         (jelly-prepare obj j)
  66         (let ((jlist (cons 'list
  67                            (mapcar
  68                             (lambda (e)
  69                               (jelly-serialize e j))
  70                             obj))))
  71            (jelly-preserve obj jlist j)))
  72        (t (error "Unpersistable object: %s" obj))))))
  73
  74 (defun jelly-serialize-alist (alist j)
  75   "elisp wont tell you when a list is an alist, and it doesn't have keyword args, so i have to do something silly like this. If you use this for anything but a single top-level non-circular alist, you deserve to lose. "
  76   (let ((jhash '(dictionary)))
  77     (jelly-prepare alist j)
  78     (mapcar
  79      (lambda (pair)
  80        (setf jhash (append jhash (list (list (jelly-serialize (car pair) j) (jelly-serialize (cdr pair) j))))))
  81      alist)
  82     (jelly-preserve alist jhash j)))
  83
  84 (defun jelly-unserialize (jelly)
  85   (let ((refs (make-hash-table)))
  86     (jelly-fixup-refs (jelly-unserialize-internal jelly))))
  87
  88
  89
  90 (defun jelly-unserialize-internal (jelly)
  91   ;; time to make dynamic scoping work for me, not against me :)
  92   (if (or (integerp jelly) (stringp jelly) (floatp jelly))
  93       jelly
  94     (ecase (intern (car jelly))
  95       ((list tuple)
  96        (mapcar (lambda (i) (jelly-unserialize-internal i)) (cdr jelly)))
  97       (dictionary
  98        (let ((ht (make-hash-table)))
  99          (mapc
 100           (lambda (pair)
 101             (let ((k (car pair)) (v (second pair))) ; hi glyph!
 102               (setf (gethash k ht) (jelly-unserialize-internal v))))
 103           (cdr jelly))
 104          ht))
 105       ((integer string float)
 106        (lambda () (cdr jelly)))
 107       (reference
 108        (let ((val  (jelly-unserialize-internal (third jelly))))
 109          (setf (gethash (second jelly) refs) val)
 110          val))
 111       (dereference
 112        (lexical-let ((-ref-num- (cadr jelly)))
 113          (lambda () (gethash -ref-num- refs)))))))
 114
 115 (defun jelly-fixup-refs (obj)
 116   (cond
 117    ((functionp obj)
 118     obj)
 119    ((or
 120      (integerp obj)
 121      (stringp obj)
 122      (floatp obj))
 123     obj)
 124    ((hash-table-p obj)
 125     (maphash
 126      (lambda (k v)
 127        (if (functionp v)
 128            (puthash k (funcall v) obj)
 129          (jelly-fixup-refs v)))
 130      obj)
 131     obj)
 132    ((listp obj)
 133     (mapl
 134      (lambda (list)
 135        (if (and (functionp (car list)) (not (compiled-function-p (car list))) (not (cadar list)))
 136            (setf (car list) (funcall (car list)))
 137          (unless (eq obj (car list)) (jelly-fixup-refs (car list)))))
 138      obj)
 139     obj)
 140    (t (error "it's broke"))))
 141
 142
 143