Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
498 lines (418 sloc) 16.8 KB
;;; bson.el --- Binary JSON serializer/deserializer
;; Copyright (C) 2011-2015 Tomohiro Matsuyama
;; Author: Tomohiro Matsuyama <>
;; Version: 0.1
;; Keywords: convenience
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <>.
;;; Commentary:
;;; Code:
(require 'cl)
(defmacro bson-aif (test then &rest else)
(declare (indent 2))
`(let ((it ,test)) (if it ,then ,@else)))
(defmacro bson-awhen (test &rest body)
(declare (indent 1))
`(let ((it ,test)) (when it ,@body)))
(defmacro bson-with-temp-unibyte-buffer (&rest body)
(declare (indent 0))
`(with-temp-buffer (set-buffer-multibyte nil) ,@body))
(defsubst bson-alist-p (object)
(and (listp object)
(consp (first object))))
(defsubst bson-plist-p (object)
(and (listp object)
(symbolp (first object))))
(defmacro bson-evcase (object &rest clauses)
(declare (indent 1))
(let ((obj (gensym)))
`(let ((,obj ,object))
,@(loop for (value . body) in clauses
collect `((eql ,obj ,value) ,@body))
(t (error "bson-evcase failed: %s, %s"
,obj ',(mapcar 'car clauses)))))))
(defsubst bson-type-of (object)
(or (and (eq object t) 'boolean)
(and (eq object nil) 'boolean)
(and (vectorp object)
(> (length object) 0)
(symbolp (elt object 0))
(let ((name (symbol-name (elt object 0))))
(when (string-match "^cl-struct-\\(.+\\)$" name)
(intern (match-string 1 name)))))
(type-of object)))
(defmacro bson-etypecase (object &rest clauses)
(declare (indent 1))
`(ecase (bson-type-of ,object) ,@clauses))
(defmacro bson-document-dispatch (document &rest clauses)
(declare (indent 1))
,@(loop for (type . body) in clauses
(ecase type
(hash-table `((hash-table-p ,document) ,@body))
(alist `((bson-alist-p ,document) ,@body))
(plist `((bson-plist-p ,document) ,@body))))))
(defun bson-document-size (document)
(bson-document-dispatch document
(hash-table (hash-table-count document))
(alist (length document))
(plist (/ (length document) 2))))
(defun bson-document-get (document key)
(bson-document-dispatch document
(hash-table (gethash key document))
(alist (cdr (assoc key document)))
(plist (plist-get document (intern key)))))
(defun bson-document-put (document key value)
(bson-document-dispatch document
(hash-table (puthash key value document))
(alist (bson-aif (assoc key document)
(setcdr it value)
(push (cons key value) document)))
(plist (setq document (plist-put document (intern key) value))))
(defun bson-document-for (document function)
(bson-document-dispatch document
(hash-table (maphash function document))
(alist (loop for assoc in document
do (funcall function (car assoc) (cdr assoc))))
(plist (loop for key = (pop document)
for value = (pop document)
while key
do (funcall function (symbol-name key) value)))))
(defmacro* bson-document-do ((key value document &optional result) &rest body)
(declare (indent 1))
`(progn (bson-document-for ,document (lambda (,key ,value) ,@body))
(defun bson-document-to-hash-table (document)
(let ((table (make-hash-table :test 'equal)))
(bson-document-do (key value document table)
(puthash key value table))))
(defun* bson-document-to-alist (document &aux alist)
(bson-document-do (key value document alist)
(push (cons key value) alist)))
(defun* bson-document-to-plist (document &aux plist)
(bson-document-do (key value document plist)
(setq plist `(,(intern key) ,value . ,plist))))
(defconst bson-marker-double #x01)
(defconst bson-marker-string #x02)
(defconst bson-marker-document #x03)
(defconst bson-marker-array #x04)
(defconst bson-marker-binary #x05)
(defconst bson-marker-oid #x07)
(defconst bson-marker-boolean #x08)
(defconst bson-marker-datetime #x09)
(defconst bson-marker-null #x0a)
(defconst bson-marker-regexp #x0b)
(defconst bson-marker-jscode #x0d)
(defconst bson-marker-symbol #x0e)
(defconst bson-marker-jscode/scope #x0f)
(defconst bson-marker-int32 #x10)
(defconst bson-marker-timestamp #x11)
(defconst bson-marker-int64 #x12)
(defconst bson-marker-min-key #xff)
(defconst bson-marker-max-key #x7f)
(defstruct bson-oid string)
(defun bson-oid-to-hex-string (oid)
(loop for byte across (bson-oid-string oid)
collect (format "%02x" byte) into hex
finally return (apply 'concat hex)))
(defun bson-oid-of-hex-string (hex-string)
(loop for i from 0 below (length hex-string) by 2
for hex = (substring hex-string i (+ i 2))
collect (string-to-number hex 16) into bytes
finally return (make-bson-oid :string (apply 'unibyte-string bytes))))
(defun bson-datetime-int64-to-time (byte-list)
"Convert a 64 bit int as BYTE-LIST into an Elisp time."
;; Could do with some asserts to check byte-list
(let ((calc-num
(lambda (x) (format "%02X" x))
byte-list ""))))
(defsubst bson-serialize-byte (byte)
(insert-char byte 1))
(defsubst bson-serialize-int32 (int32)
;; TODO bigint
(bson-serialize-byte (logand (lsh int32 -0) #xff))
(bson-serialize-byte (logand (lsh int32 -8) #xff))
(bson-serialize-byte (logand (lsh int32 -16) #xff))
(bson-serialize-byte (logand (lsh int32 -24) #xff)))
(defsubst bson-serialize-int64 (int64)
;; TODO bigint
(bson-serialize-byte (logand (lsh int64 -0) #xff))
(bson-serialize-byte (logand (lsh int64 -8) #xff))
(bson-serialize-byte (logand (lsh int64 -16) #xff))
(bson-serialize-byte (logand (lsh int64 -24) #xff))
(bson-serialize-byte (logand (lsh int64 -32) #xff))
(bson-serialize-byte (logand (lsh int64 -40) #xff))
(bson-serialize-byte (logand (lsh int64 -48) #xff))
(bson-serialize-byte (logand (lsh int64 -56) #xff)))
(defsubst bson-serialize-double (double)
(let (bytes (byte 0) (nbit 0))
(flet ((serialize-bit (bit)
(setq byte (logior (lsh byte 1) bit))
(when (eq (incf nbit) 8)
(push byte bytes)
(setq byte 0
nbit 0)))
(serialize-sign (sign)
(serialize-bit (if (> sign 0) 0 1)))
(serialize-exponent (exponent)
(loop with bits
repeat 11 do
(push (mod exponent 2) bits)
(setq exponent (/ exponent 2))
finally (mapc 'serialize-bit bits)))
(serialize-significand (significand)
(loop repeat 52 do
(setq significand (* significand 2))
(if (< significand 1.0)
(serialize-bit 0)
(serialize-bit 1)
(decf significand)))))
(let ((significand double)
(exponent 0))
(while (> significand 2.0)
(setq significand (/ significand 2))
(incf exponent))
(serialize-sign (if (>= double 0.0) 1 -1))
(serialize-exponent (+ exponent 1023))
(serialize-significand (1- significand))))
(assert (and (eq byte 0) (eq nbit 0)))
(mapc 'bson-serialize-byte bytes)))
(defsubst bson-serialize-string (string)
(bson-serialize-int32 (1+ (string-bytes string)))
(insert string)
(bson-serialize-byte #x00))
(defsubst bson-serialize-cstring (string)
(insert string)
(bson-serialize-byte #x00))
(defsubst bson-serialize-oid (oid)
(insert (bson-oid-string oid)))
(defsubst bson-serialize-array (array)
(loop for i from 0
for element across array
collect `(,i . ,element))))
(defsubst bson-serialize-symbol (symbol)
(bson-serialize-string (symbol-name symbol)))
(defsubst bson-serialize-boolean (boolean)
(bson-serialize-byte (if boolean #x00 #x01)))
(defsubst bson-serialize-name (name)
(cond ((stringp name) name)
((numberp name) (number-to-string name))
((symbolp name) (symbol-name name))
(t (error "invalid element name: %s" name)))))
(defsubst bson-serialize-marker (marker)
(bson-serialize-byte marker))
(defun bson-serialize-element (name object)
(macrolet ((serialize-element (marker function)
(bson-serialize-marker ,marker)
(bson-serialize-name name)
(,function object))))
(bson-etypecase object
(float (serialize-element
bson-marker-double bson-serialize-double))
(string (serialize-element
bson-marker-string bson-serialize-string))
(hash-table (serialize-element
bson-marker-document bson-serialize-document))
(list (serialize-element
bson-marker-document bson-serialize-document))
(bson-oid (serialize-element
bson-marker-oid bson-serialize-oid))
(vector (serialize-element
bson-marker-array bson-serialize-array))
(boolean (serialize-element
bson-marker-boolean bson-serialize-boolean))
(symbol (serialize-element
bson-marker-symbol bson-serialize-symbol))
(integer (serialize-element
bson-marker-int32 bson-serialize-int32)))))
(defun bson-serialize-document-1 (document)
(bson-document-do (key value document)
(bson-serialize-element key value)))
(defun bson-serialize-document (document)
(let ((start (point)))
(bson-serialize-document-1 document)
(bson-serialize-byte #x00)
(let ((end (point)))
(goto-char start)
(bson-serialize-int32 (+ (- end start) 4))))))
(defun* bson-serialize-document-to-buffer (document
&optional (buffer (current-buffer)))
(with-current-buffer buffer
(bson-serialize-document document)))
(defun bson-serialize-document-to-string (document)
(bson-serialize-document document)
(defun* bson-serialize-document-to-stream (document
&optional (stream standard-output))
(let ((standard-output stream))
(princ (bson-serialize-document-to-string document))))
(defun bson-serialize-document-to-process (document process)
(process-send-string process (bson-serialize-document-to-string document)))
(defsubst bson-deserialize-byte ()
(prog1 (char-after) (forward-char)))
(defsubst bson-deserialize-and-check-byte (expected)
(let ((got (bson-deserialize-byte)))
(assert (eq got expected))
(defsubst bson-deserialize-int32 ()
(logior (lsh (bson-deserialize-byte) 0)
(lsh (bson-deserialize-byte) 8)
(lsh (bson-deserialize-byte) 16)
(lsh (bson-deserialize-byte) 24)))
(defsubst bson-deserialize-int64 ()
;; FIXME: this probably needs to be done using calc or bigint
(logior (lsh (bson-deserialize-byte) 0)
(lsh (bson-deserialize-byte) 8)
(lsh (bson-deserialize-byte) 16)
(lsh (bson-deserialize-byte) 24)
(lsh (bson-deserialize-byte) 32)
(lsh (bson-deserialize-byte) 40)
(lsh (bson-deserialize-byte) 48)
(lsh (bson-deserialize-byte) 56)))
(defsubst bson-deserialize-double ()
(let ((bytes (nreverse (loop repeat 8 collect (bson-deserialize-byte))))
(nbit 0))
(flet ((deserialize-bit ()
(prog1 (logand (lsh (car bytes) (- nbit 7)) 1)
(when (eq (incf nbit) 8)
(pop bytes)
(setq nbit 0))))
(deserialize-sign ()
(if (zerop (deserialize-bit)) 1 -1))
(deserialize-exponent ()
(loop for i from 10 downto 0
sum (lsh (deserialize-bit) i)))
(deserialize-significand ()
with bits = (nreverse
(loop repeat 52 collect (deserialize-bit)))
with significand = 0.0
for bit in bits
if (eq bit 1)
do (incf significand)
do (setq significand (/ significand 2))
finally return significand)))
(let* ((sign (deserialize-sign))
(exponent (deserialize-exponent))
(significand (deserialize-significand)))
(* sign
(1+ significand)
(expt 2 (- exponent 1023)))))))
(defsubst bson-deserialize-string ()
(let* ((length (bson-deserialize-int32))
(start (point)))
(forward-char (1- length))
(prog1 (buffer-substring-no-properties start (point))
(bson-deserialize-and-check-byte #x00))))
(defsubst bson-deserialize-cstring ()
(let ((start (point)))
(search-forward (string #x00))
(forward-char -1)
(prog1 (buffer-substring-no-properties start (point))
(bson-deserialize-and-check-byte #x00))))
(defsubst bson-deserialize-datetime ()
(let* ((bytes
(loop repeat 8
collect (bson-deserialize-byte))))
(bson-datetime-int64-to-time (reverse bytes))))
(defsubst bson-deserialize-oid ()
(let* ((bytes (loop repeat 12
collect (bson-deserialize-byte)))
(string (apply 'unibyte-string bytes)))
(make-bson-oid :string string)))
(defsubst bson-deserialize-array ()
(let* ((document (bson-deserialize-document))
(vector (make-vector (bson-document-size document) nil))
(index 0))
(bson-document-do (key value document vector)
(declare (ignore key))
(aset vector index value)
(incf index))))
(defsubst bson-deserialize-binary ()
(let* ((size (bson-deserialize-int32))
(subtype (bson-deserialize-byte))
(start (point)))
(goto-char (+ start size))
(buffer-substring-no-properties start (point)))))
(defsubst bson-deserialize-symbol ()
(intern (bson-deserialize-string)))
(defsubst bson-deserialize-boolean ()
(ecase (bson-deserialize-byte)
(#x00 t)
(#x01 nil)))
(defsubst bson-deserialize-name ()
(defsubst bson-deserialize-marker ()
(defsubst bson-deserialize-and-check-marker (expected)
(let ((got (bson-deserialize-marker)))
(assert (eq got expected))
(defun bson-deserialize-element ()
(let* ((marker (bson-deserialize-marker))
(name (bson-deserialize-name)))
(cons name
(bson-evcase marker
(bson-marker-null nil)
(bson-marker-datetime (bson-deserialize-datetime))
(bson-marker-double (bson-deserialize-double))
(bson-marker-string (bson-deserialize-string))
(bson-marker-binary (bson-deserialize-binary))
(bson-marker-document (bson-deserialize-document))
(bson-marker-array (bson-deserialize-array))
(bson-marker-oid (bson-deserialize-oid))
(bson-marker-boolean (bson-deserialize-boolean))
(bson-marker-symbol (bson-deserialize-symbol))
(bson-marker-int32 (bson-deserialize-int32))))))
(defun bson-deserialize-document-1 (bound)
(do ((document '()))
((or (>= (point) bound)
(eq (char-after) #x00))
(nreverse document))
(destructuring-bind (key . value)
(push (cons key value) document))))
(defun bson-deserialize-document ()
(let ((length (bson-deserialize-int32)))
(prog1 (bson-deserialize-document-1 (+ (point) length -4))
(bson-deserialize-and-check-byte #x00))))
(defun* bson-deserialize-document-from-buffer ((buffer (current-buffer)))
(with-current-buffer buffer
(defun bson-deserialize-document-from-string (string)
(insert string)
(goto-char (point-min))
(provide 'bson)
;;; bson.el ends here
Jump to Line
Something went wrong with that request. Please try again.