394 lines
11 KiB
EmacsLisp
Executable file
394 lines
11 KiB
EmacsLisp
Executable file
;;; erlext.el --- Encoding and decoding of Erlang external term format
|
|
|
|
;; Copyleft (]) 2000-2002 Luke Gorrie <luke@bluetail.com>
|
|
;; Version: $Id: erlext.el,v 1.1 2004/10/25 19:55:57 lukeg Exp $
|
|
;; Keywords: erlang
|
|
|
|
;;; Commentary:
|
|
;;
|
|
;; Library for encoding/decoding elisp terms into erlang's external
|
|
;; term format. For format details see erts/emulator/internal_doc/ in
|
|
;; the Erlang/OTP sources.
|
|
;;
|
|
;; Supported mappings from/to erlext to elisp:
|
|
;; atom -> symbol
|
|
;; string -> string
|
|
;; integer -> integer
|
|
;; list -> list
|
|
;; tuple -> (vector ...)
|
|
;; pid -> (vector ERL-TAG 'pid node id serial creation)
|
|
;; binary -> string
|
|
;; Not mapped/supported yet:
|
|
;; ref, port, float, bignum, function, ...
|
|
;;
|
|
;; ----------------------------------------------------------------------
|
|
;; Revision history:
|
|
;;
|
|
;; Originally written some time in 2000, borrowing lots of code that I
|
|
;; didn't understand from Lennart Staflin's nice elisp CORBA client.
|
|
;;
|
|
;; May 2001: Added asynchronous networking support for the "shbuf"
|
|
;; program that shares emacs buffers on the network via an erlang
|
|
;; server.
|
|
;;
|
|
;; March 2002: Big cleanup for use in distributed erlang. Removed the
|
|
;; old networking code.
|
|
|
|
(eval-when-compile (require 'cl))
|
|
(eval-when-compile (load "cl-extra"))
|
|
|
|
;; type tags
|
|
|
|
(defconst erlext-tag-alist
|
|
'((smallInt . 97)
|
|
(int . 98)
|
|
(float . 99)
|
|
(atom . 100)
|
|
(cached . 67)
|
|
(ref . 101)
|
|
(port . 102)
|
|
(pid . 103)
|
|
(smallTuple . 104)
|
|
(largeTuple . 105)
|
|
(null . 106)
|
|
(string . 107)
|
|
(list . 108)
|
|
(bin . 109)
|
|
(smallBig . 110)
|
|
(largeBig . 111)
|
|
(newRef . 114)))
|
|
|
|
(defconst erlext-max-atom-length 255 "The maximum length of an erlang atom.")
|
|
(defconst erlext-protocol-version 131)
|
|
|
|
(defconst empty-symbol (intern "")
|
|
"The zero-length lisp symbol.")
|
|
|
|
(defvar erl-tag (make-symbol "TYPE")
|
|
"Tag placed in the first element of a vector to indicate a non-tuple type.")
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Encoding / decoding interface
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun erlext-binary-to-term (string)
|
|
"Decode and return the elisp representation of `string'."
|
|
(assert (stringp string))
|
|
(let (default-enable-multibyte-characters)
|
|
(with-temp-buffer
|
|
(insert string)
|
|
(goto-char (point-min))
|
|
(erlext-read-whole-obj))))
|
|
|
|
(defun erlext-term-to-binary (term)
|
|
"Encode `term' as erlext and return the result as a string."
|
|
(let (default-enable-multibyte-characters)
|
|
(with-temp-buffer
|
|
(insert erlext-protocol-version)
|
|
(erlext-write-obj term)
|
|
(buffer-string))))
|
|
|
|
;; Tuple datatype: (tuple X Y Z) => [X Y Z]
|
|
|
|
(defun tuple (&rest elems)
|
|
(apply #'vector elems))
|
|
|
|
(defun tuple-to-list (x)
|
|
(assert (tuplep x))
|
|
(mapcar #'identity x))
|
|
|
|
(defun tuplep (x)
|
|
(and (vectorp x)
|
|
(or (zerop (length x))
|
|
(not (eq (elt x 0) erl-tag)))))
|
|
|
|
(defun tuple-arity (tuple)
|
|
(1- (length tuple)))
|
|
|
|
(defmacro tuple-elt (tuple index)
|
|
"Return element INDEX from TUPLE. Index starts from 1."
|
|
;; Defined as a macro just so that we get the setf of `elt' for free
|
|
`(elt ,tuple (1- ,index)))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Encoding
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun erlext-write-obj (obj)
|
|
(cond ((listp obj) ; lists at top since (symbolp '()) => t
|
|
(erlext-write-list obj))
|
|
((stringp obj)
|
|
(erlext-write-string obj))
|
|
((symbolp obj)
|
|
(erlext-write-atom obj))
|
|
((vectorp obj)
|
|
(if (tuplep obj)
|
|
(erlext-write-tuple (tuple-to-list obj))
|
|
(let* ((list (mapcar #'identity obj))
|
|
(type (cadr list))
|
|
(elts (cddr list)))
|
|
(ecase type
|
|
((erl-pid)
|
|
(apply #'erlext-write-pid elts))
|
|
((erl-port)
|
|
(apply #'erlext-write-port elts))
|
|
((erl-ref)
|
|
(apply #'erlext-write-ref elts))
|
|
((erl-new-ref)
|
|
(apply #'erlext-write-new-ref elts))
|
|
((erl-binary)
|
|
(erlext-write-binary (car elts)))))))
|
|
((integerp obj)
|
|
(erlext-write-int obj))
|
|
(t
|
|
(error "erlext can't marshal %S" obj))))
|
|
|
|
(defun erlext-write1 (n)
|
|
(assert (integerp n))
|
|
(insert n))
|
|
(defun erlext-write2 (n)
|
|
(assert (integerp n))
|
|
(insert (logand (ash n -8) 255)
|
|
(logand n 255)))
|
|
(defun erlext-write4 (n)
|
|
(assert (integerp n))
|
|
(insert (logand (ash n -24) 255)
|
|
(logand (ash n -16) 255)
|
|
(logand (ash n -8) 255)
|
|
(logand n 255)))
|
|
(defun erlext-writen (bytes)
|
|
(assert (stringp bytes))
|
|
(insert bytes))
|
|
(defun erlext-insert4 (n offset)
|
|
(goto-char offset)
|
|
(erlext-write4 n)
|
|
(goto-char (point-max)))
|
|
|
|
(defun erlext-write-atom (atom)
|
|
(assert (symbolp atom))
|
|
(let* ((string (symbol-name atom))
|
|
(len (length string)))
|
|
(assert (<= len erlext-max-atom-length))
|
|
(erlext-write1 (erlext-get-code 'atom))
|
|
(erlext-write2 (length string))
|
|
(erlext-writen string)))
|
|
(defun erlext-write-int (n)
|
|
(assert (integerp n))
|
|
(cond ((= n (logand n 255))
|
|
(erlext-write1 (erlext-get-code 'smallInt))
|
|
(erlext-write1 n))
|
|
;; elisp has small numbers so 32bit on the wire is as far as
|
|
;; we need bother supporting
|
|
(t
|
|
(erlext-write1 (erlext-get-code 'int))
|
|
(erlext-write4 n))))
|
|
(defun erlext-write-list (lst)
|
|
(assert (listp lst))
|
|
(if (null lst)
|
|
(erlext-write-null)
|
|
(progn (erlext-write-list-head (length lst))
|
|
(mapc 'erlext-write-obj lst)
|
|
(erlext-write-null))))
|
|
(defun erlext-write-string (str)
|
|
(assert (stringp str))
|
|
(erlext-write1 (erlext-get-code 'string))
|
|
(erlext-write2 (length str))
|
|
(erlext-writen str))
|
|
(defun erlext-write-binary (str)
|
|
(assert (stringp str))
|
|
(erlext-write1 (erlext-get-code 'bin))
|
|
(erlext-write4 (length str))
|
|
(erlext-writen str))
|
|
(defun erlext-write-null ()
|
|
(erlext-write1 (erlext-get-code 'null)))
|
|
(defun erlext-write-list-head (arity)
|
|
(assert (> arity 0))
|
|
(erlext-write1 (erlext-get-code 'list))
|
|
(erlext-write4 arity))
|
|
(defun erlext-write-tuple (elts)
|
|
(assert (listp elts))
|
|
(let ((arity (length elts)))
|
|
(if (< arity 256)
|
|
(progn (erlext-write1 (erlext-get-code 'smallTuple))
|
|
(erlext-write1 arity))
|
|
(progn (erlext-write1 (erlext-get-code 'largeTuple))
|
|
(erlext-write4 arity))))
|
|
(mapc 'erlext-write-obj elts))
|
|
(defun erlext-write-pid (node id serial creation)
|
|
(erlext-write1 (erlext-get-code 'pid))
|
|
(erlext-write-obj node)
|
|
(erlext-write4 id)
|
|
(erlext-write4 serial)
|
|
(erlext-write1 creation))
|
|
(defun erlext-write-port (node id creation)
|
|
(erlext-write1 (erlext-get-code 'port))
|
|
(erlext-write-obj node)
|
|
(erlext-write4 id)
|
|
(erlext-write1 creation))
|
|
(defun erlext-write-ref (node id creation)
|
|
(erlext-write1 (erlext-get-code 'ref))
|
|
(erlext-write-obj node)
|
|
(erlext-write4 id)
|
|
(erlext-write1 creation))
|
|
(defun erlext-write-new-ref (node creation id)
|
|
(erlext-write1 (erlext-get-code 'newRef))
|
|
(erlext-write2 (/ (length id) 4))
|
|
(erlext-write-obj node)
|
|
(erlext-write1 creation)
|
|
(erlext-writen id))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Decoding
|
|
;; ------------------------------------------------------------
|
|
|
|
(eval-and-compile
|
|
(if (fboundp 'char-int)
|
|
;; convert character to string
|
|
(defsubst erlext-read1 ()
|
|
(prog1 (char-int (following-char))
|
|
(forward-char 1)))
|
|
(defsubst erlext-read1 ()
|
|
(prog1 (following-char)
|
|
(forward-char 1)))))
|
|
|
|
(defun erlext-read-whole-obj ()
|
|
(let ((version (erlext-read1)))
|
|
(assert (= version erlext-protocol-version))
|
|
(erlext-read-obj)))
|
|
|
|
(defun erlext-read-obj ()
|
|
(let ((tag (erlext-get-tag (erlext-read1))))
|
|
(case tag
|
|
((smallInt) (erlext-read1))
|
|
((int) (erlext-read4))
|
|
((atom) (erlext-read-atom))
|
|
((smallTuple) (erlext-read-small-tuple))
|
|
((largeTuple) (erlext-read-large-tuple))
|
|
((list) (erlext-read-list))
|
|
((string) (erlext-read-string))
|
|
((bin) (erlext-read-binary))
|
|
((null) nil)
|
|
((nil) nil)
|
|
((pid) (vector erl-tag
|
|
'erl-pid
|
|
(erlext-read-obj) ; node
|
|
(erlext-read4) ; id
|
|
(erlext-read4) ; serial
|
|
(erlext-read1))); creation
|
|
((port) (vector erl-tag
|
|
'erl-port
|
|
(erlext-read-obj) ; node
|
|
(erlext-read4) ; id
|
|
(erlext-read1))) ; creation
|
|
((ref) (vector erl-tag
|
|
'erl-ref
|
|
(erlext-read-obj) ; node
|
|
(erlext-read4) ;id
|
|
(erlext-read1))) ; creation
|
|
((newRef) (erlext-read-newref))
|
|
((smallBig) (erlext-read-small-bignum))
|
|
((largeBig) (erlext-read-large-bignum))
|
|
(t
|
|
(error "Unknown tag: %S" tag)))))
|
|
|
|
(defun erlext-read (size)
|
|
(case size
|
|
((1) (erlext-read1))
|
|
((2) (erlext-read2))
|
|
((4) (erlext-read4))))
|
|
;; read1 moved above so that it can be inlined
|
|
(defun erlext-read2 ()
|
|
(logior (ash (erlext-read1) 8)
|
|
(erlext-read1)))
|
|
(defun erlext-read4 ()
|
|
(logior (ash (erlext-read1) 24)
|
|
(ash (erlext-read1) 16)
|
|
(ash (erlext-read1) 8)
|
|
(erlext-read1)))
|
|
(defun erlext-readn (n)
|
|
(assert (integerp n))
|
|
(let ((start (point))
|
|
(end (+ (point) n)))
|
|
(prog1 (let ((string (buffer-substring start end)))
|
|
(if (featurep 'xemacs)
|
|
string
|
|
(string-as-unibyte string))) ; fixme: should be
|
|
; string-make-unibyte?
|
|
; Why is it necessary
|
|
; anyhow?
|
|
(goto-char end))))
|
|
(defun erlext-read-atom ()
|
|
(let ((length (erlext-read2)))
|
|
(intern (erlext-readn length))))
|
|
(defun erlext-read-small-tuple ()
|
|
(erlext-read-tuple (erlext-read1)))
|
|
(defun erlext-read-large-tuple ()
|
|
(erlext-read-tuple (erlext-read4)))
|
|
(defun erlext-read-list ()
|
|
(let ((arity (erlext-read4)))
|
|
(prog1 (loop for x from 1 to arity
|
|
collect (erlext-read-obj))
|
|
;; This seems fishy, I find nil's at the end of lists, not
|
|
;; included as elements, and no mention of how it works in the
|
|
;; erl_ext_dist.txt
|
|
(assert (eq (erlext-get-code 'null) (erlext-read1))))))
|
|
(defun erlext-read-tuple (arity)
|
|
(apply #'vector (loop for x from 1 to arity
|
|
collect (erlext-read-obj))))
|
|
|
|
(defun erlext-read-string ()
|
|
(erlext-readn (erlext-read2)))
|
|
|
|
(defun erlext-read-binary ()
|
|
(erlext-readn (erlext-read4)))
|
|
|
|
(defun erlext-read-newref ()
|
|
(let* ((len (erlext-read2))
|
|
(node (erlext-read-obj))
|
|
(creation (erlext-read1))
|
|
(id (erlext-readn (* 4 len))))
|
|
(vector erl-tag 'erl-new-ref node creation id)))
|
|
|
|
;; We don't actually support bignums. When we get one, we skip over it
|
|
;; and return the symbol {SMALL|LARGE}-BIGNUM.
|
|
|
|
(defun erlext-read-small-bignum ()
|
|
(erlext-read (erlext-read1))
|
|
'SMALL-BIGNUM)
|
|
|
|
(defun erlext-read-large-bignum ()
|
|
(erlext-read (erlext-read4))
|
|
'LARGE-BIGNUM)
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Helpers
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun erlext-get-tag (number)
|
|
(car (rassq number erlext-tag-alist)))
|
|
(defun erlext-get-code (tag)
|
|
(cdr (assq tag erlext-tag-alist)))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Testing
|
|
;; ------------------------------------------------------------
|
|
|
|
(defvar erlext-test-cases
|
|
`(1 foo "bar" [bar baz] [,erl-tag erl-pid someone@somehost 0 0 0] (1 foo ())
|
|
[,erl-tag erl-port someone@somehost 0 0]
|
|
(([1 2]) ([1 2]))))
|
|
|
|
(defun erlext-test ()
|
|
"Test each term in `erlext-test-cases' by encoding it and decoding
|
|
it and making sure that it's unchanged."
|
|
(interactive)
|
|
(mapc #'erlext-test-case erlext-test-cases)
|
|
(message "Smooth sailing"))
|
|
|
|
(defun erlext-test-case (term)
|
|
(condition-case x
|
|
(assert (equal term (erlext-binary-to-term (erlext-term-to-binary term))))
|
|
(error (error "test failed for %S: %S" term (error-message-string x)))))
|
|
|
|
(provide 'erlext)
|