lib/distel/elisp/erlext.el

   1 ;;; erlext.el --- Encoding and decoding of Erlang external term format
   2
   3 ;; Copyleft (]) 2000-2002 Luke Gorrie <luke@bluetail.com>
   4 ;; Version: $Id$
   5 ;; Keywords: erlang
   6
   7 ;;; Commentary:
   8 ;;
   9 ;; Library for encoding/decoding elisp terms into erlang's external
  10 ;; term format.  For format details see erts/emulator/internal_doc/ in
  11 ;; the Erlang/OTP sources.
  12 ;;
  13 ;; Supported mappings from/to erlext to elisp:
  14 ;;   atom    -> symbol
  15 ;;   string  -> string
  16 ;;   integer -> integer
  17 ;;   list    -> list
  18 ;;   tuple   -> (vector ...)
  19 ;;   pid     -> (vector ERL-TAG 'pid node id serial creation)
  20 ;;   binary  -> string
  21 ;; Not mapped/supported yet:
  22 ;;   ref, port, float, bignum, function, ...
  23 ;;
  24 ;; ----------------------------------------------------------------------
  25 ;; Revision history:
  26 ;;
  27 ;; Originally written some time in 2000, borrowing lots of code that I
  28 ;; didn't understand from Lennart Staflin's nice elisp CORBA client.
  29 ;;
  30 ;; May 2001: Added asynchronous networking support for the "shbuf"
  31 ;; program that shares emacs buffers on the network via an erlang
  32 ;; server.
  33 ;;
  34 ;; March 2002: Big cleanup for use in distributed erlang. Removed the
  35 ;; old networking code.
  36
  37 (eval-when-compile (require 'cl))
  38 (eval-when-compile (load "cl-extra"))
  39
  40 ;; type tags
  41
  42 (defconst erlext-tag-alist
  43   '((smallInt   . 97)
  44     (int        . 98)
  45     (float      . 99)
  46     (atom       . 100)
  47     (cached     . 67)
  48     (ref        . 101)
  49     (port       . 102)
  50     (pid        . 103)
  51     (smallTuple . 104)
  52     (largeTuple . 105)
  53     (null       . 106)
  54     (string     . 107)
  55     (list       . 108)
  56     (bin        . 109)
  57     (smallBig   . 110)
  58     (largeBig   . 111)
  59     (newRef     . 114)))
  60
  61 (defconst erlext-max-atom-length 255 "The maximum length of an erlang atom.")
  62 (defconst erlext-protocol-version 131)
  63
  64 (defconst empty-symbol (intern "")
  65   "The zero-length lisp symbol.")
  66
  67 (defconst erl-tag (make-symbol "TYPE")
  68   "Tag placed in the first element of a vector to indicate a non-tuple type.
  69 This is an uninterned symbol, which is only eq/eqv/equal/equalp to
  70 itself.")
  71
  72 ;; ------------------------------------------------------------
  73 ;; Encoding / decoding interface
  74 ;; ------------------------------------------------------------
  75
  76 (defun erlext-binary-to-term (string)
  77   "Decode and return the elisp representation of `string'."
  78   (assert (stringp string))
  79   (let (default-enable-multibyte-characters)
  80     (with-temp-buffer
  81       (insert string)
  82       (goto-char (point-min))
  83       (erlext-read-whole-obj))))
  84
  85 (defun erlext-term-to-binary (term)
  86   "Encode `term' as erlext and return the result as a string."
  87   (let (default-enable-multibyte-characters)
  88     (with-temp-buffer
  89       (insert erlext-protocol-version)
  90       (erlext-write-obj term)
  91       (buffer-string))))
  92
  93 ;; Tuple datatype: (tuple X Y Z) => [X Y Z]
  94
  95 (defun tuple (&rest elems)
  96   (apply #'vector elems))
  97
  98 (defun tuple-to-list (x)
  99   (assert (tuplep x))
 100   (mapcar #'identity x))
 101
 102 (defun tuplep (x)
 103   (and (vectorp x)
 104        (or (zerop (length x))
 105            (not (eq (elt x 0) erl-tag)))))
 106
 107 (defun tuple-arity (tuple)
 108   (1- (length tuple)))
 109
 110 (defmacro tuple-elt (tuple index)
 111   "Return element INDEX from TUPLE. Index starts from 1."
 112   ;; Defined as a macro just so that we get the setf of `elt' for free
 113   `(elt ,tuple (1- ,index)))
 114
 115 ;; ------------------------------------------------------------
 116 ;; Encoding
 117 ;; ------------------------------------------------------------
 118
 119 (defun erlext-write-obj (obj)
 120   (cond ((listp obj)                    ; lists at top since (symbolp '()) => t
 121          (erlext-write-list obj))
 122         ((stringp obj)
 123          (erlext-write-string obj))
 124         ((symbolp obj)
 125          (erlext-write-atom obj))
 126         ((vectorp obj)
 127          (if (tuplep obj)
 128              (erlext-write-tuple (tuple-to-list obj))
 129            (let* ((list (mapcar #'identity obj))
 130                   (type (cadr list))
 131                   (elts (cddr list)))
 132              (ecase type
 133                ((erl-pid)
 134                 (apply #'erlext-write-pid elts))
 135                ((erl-port)
 136                 (apply #'erlext-write-port elts))
 137                ((erl-ref)
 138                 (apply #'erlext-write-ref elts))
 139                ((erl-new-ref)
 140                 (apply #'erlext-write-new-ref elts))))))
 141         ((integerp obj)
 142          (erlext-write-int obj))
 143         (t
 144          (error "erlext can't marshal %S" obj))))
 145
 146 (defun erlext-write1 (n)
 147   (assert (integerp n))
 148   (insert n))
 149 (defun erlext-write2 (n)
 150   (assert (integerp n))
 151   (insert (logand (ash n -8) 255)
 152           (logand n 255)))
 153 (defun erlext-write4 (n)
 154   (assert (integerp n))
 155   (insert (logand (ash n -24) 255)
 156           (logand (ash n -16) 255)
 157           (logand (ash n -8) 255)
 158           (logand n 255)))
 159 (defun erlext-writen (bytes)
 160   (assert (stringp bytes))
 161   (insert bytes))
 162 (defun erlext-insert4 (n offset)
 163   (goto-char offset)
 164   (erlext-write4 n)
 165   (goto-char (point-max)))
 166
 167 (defun erlext-write-atom (atom)
 168   (assert (symbolp atom))
 169   (let* ((string (symbol-name atom))
 170          (len    (length string)))
 171     (assert (<= len erlext-max-atom-length))
 172     (erlext-write1 (erlext-get-code 'atom))
 173     (erlext-write2 (length string))
 174     (erlext-writen string)))
 175 (defun erlext-write-int (n)
 176   (assert (integerp n))
 177   (cond ((= n (logand n 255))
 178          (erlext-write1 (erlext-get-code 'smallInt))
 179          (erlext-write1 n))
 180         ;; elisp has small numbers so 32bit on the wire is as far as
 181         ;; we need bother supporting
 182         (t
 183          (erlext-write1 (erlext-get-code 'int))
 184          (erlext-write4 n))))
 185 (defun erlext-write-list (lst)
 186   (assert (listp lst))
 187   (if (null lst)
 188       (erlext-write-null)
 189     (progn (erlext-write-list-head (length lst))
 190            (mapc 'erlext-write-obj lst)
 191            (erlext-write-null))))
 192 (defun erlext-write-string (str)
 193   (assert (stringp str))
 194   (erlext-write1 (erlext-get-code 'string))
 195   (erlext-write2 (length str))
 196   (erlext-writen str))
 197 (defun erlext-write-binary (str)
 198   (assert (stringp str))
 199   (erlext-write1 (erlext-get-code 'bin))
 200   (erlext-write4 (length str))
 201   (erlext-writen str))
 202 (defun erlext-write-null ()
 203   (erlext-write1 (erlext-get-code 'null)))
 204 (defun erlext-write-list-head (arity)
 205   (assert (> arity 0))
 206   (erlext-write1 (erlext-get-code 'list))
 207   (erlext-write4 arity))
 208 (defun erlext-write-tuple (elts)
 209   (assert (listp elts))
 210   (let ((arity (length elts)))
 211     (if (< arity 256)
 212         (progn (erlext-write1 (erlext-get-code 'smallTuple))
 213                (erlext-write1 arity))
 214       (progn (erlext-write1 (erlext-get-code 'largeTuple))
 215              (erlext-write4 arity))))
 216   (mapc 'erlext-write-obj elts))
 217 (defun erlext-write-pid (node id serial creation)
 218   (erlext-write1 (erlext-get-code 'pid))
 219   (erlext-write-obj node)
 220   (erlext-write4 id)
 221   (erlext-write4 serial)
 222   (erlext-write1 creation))
 223 (defun erlext-write-port (node id creation)
 224   (erlext-write1 (erlext-get-code 'port))
 225   (erlext-write-obj node)
 226   (erlext-write4 id)
 227   (erlext-write1 creation))
 228 (defun erlext-write-ref (node id creation)
 229   (erlext-write1 (erlext-get-code 'ref))
 230   (erlext-write-obj node)
 231   (erlext-write4 id)
 232   (erlext-write1 creation))
 233 (defun erlext-write-new-ref (node creation id)
 234   (erlext-write1 (erlext-get-code 'newRef))
 235   (erlext-write2 (/ (length id) 4))
 236   (erlext-write-obj node)
 237   (erlext-write1 creation)
 238   (erlext-writen id))
 239
 240 ;; ------------------------------------------------------------
 241 ;; Decoding
 242 ;; ------------------------------------------------------------
 243
 244 (eval-and-compile
 245   (if (fboundp 'char-int)
 246       ;; convert character to string
 247       (defsubst erlext-read1 ()
 248         (prog1 (char-int (following-char))
 249           (forward-char 1)))
 250     (defsubst erlext-read1 ()
 251       (prog1 (following-char)
 252         (forward-char 1)))))
 253
 254 (defun erlext-read-whole-obj ()
 255   (let ((version (erlext-read1)))
 256     (assert (= version erlext-protocol-version))
 257     (erlext-read-obj)))
 258
 259 (defun erlext-read-obj ()
 260   (let ((tag (erlext-get-tag (erlext-read1))))
 261     (case tag
 262       ((smallInt)   (erlext-read1))
 263       ((int)        (erlext-read4))
 264       ((atom)       (erlext-read-atom))
 265       ((smallTuple) (erlext-read-small-tuple))
 266       ((largeTuple) (erlext-read-large-tuple))
 267       ((list)       (erlext-read-list))
 268       ((string)     (erlext-read-string))
 269       ((bin)        (erlext-read-binary))
 270       ((null)       nil)
 271       ((pid)        (vector erl-tag
 272                             'erl-pid
 273                             (erlext-read-obj) ; node
 274                             (erlext-read4) ; id
 275                             (erlext-read4) ; serial
 276                             (erlext-read1))); creation
 277       ((port)       (vector erl-tag
 278                             'erl-port
 279                             (erlext-read-obj) ; node
 280                             (erlext-read4) ; id
 281                             (erlext-read1))) ; creation
 282       ((ref)        (vector erl-tag
 283                             'erl-ref
 284                             (erlext-read-obj) ; node
 285                             (erlext-read4) ;id
 286                             (erlext-read1))) ; creation
 287       ((newRef)     (erlext-read-newref))
 288       ((smallBig)   (erlext-read-small-bignum))
 289       ((largeBig)   (erlext-read-large-bignum))
 290      (t
 291       (error "Unknown tag: %S" tag)))))
 292
 293 (defun erlext-read (size)
 294   (case size
 295     ((1) (erlext-read1))
 296     ((2) (erlext-read2))
 297     ((4) (erlext-read4))))
 298 ;; read1 moved above so that it can be inlined
 299 (defun erlext-read2 ()
 300   (logior (ash (erlext-read1) 8)
 301           (erlext-read1)))
 302 (defun erlext-read4 ()
 303   (logior (ash (erlext-read1) 24)
 304           (ash (erlext-read1) 16)
 305           (ash (erlext-read1) 8)
 306           (erlext-read1)))
 307 (defun erlext-readn (n)
 308   (assert (integerp n))
 309   (let ((start (point))
 310         (end   (+ (point) n)))
 311     (prog1 (let ((string (buffer-substring start end)))
 312              (if (featurep 'xemacs)
 313                  string
 314                (string-as-unibyte string))) ; fixme: should be
 315                                             ; string-make-unibyte?
 316                                             ; Why is it necessary
 317                                             ; anyhow?
 318       (goto-char end))))
 319 (defun erlext-read-atom ()
 320   (let ((length (erlext-read2)))
 321     (intern (erlext-readn length))))
 322 (defun erlext-read-small-tuple ()
 323   (erlext-read-tuple (erlext-read1)))
 324 (defun erlext-read-large-tuple ()
 325   (erlext-read-tuple (erlext-read4)))
 326 (defun erlext-read-list ()
 327   (let ((arity (erlext-read4)))
 328     (prog1 (loop for x from 1 to arity
 329                  collect (erlext-read-obj))
 330       ;; This seems fishy, I find nil's at the end of lists, not
 331       ;; included as elements, and no mention of how it works in the
 332       ;; erl_ext_dist.txt
 333       (assert (eq (erlext-get-code 'null) (erlext-read1))))))
 334 (defun erlext-read-tuple (arity)
 335   (apply #'vector (loop for x from 1 to arity
 336                         collect (erlext-read-obj))))
 337
 338 (defun erlext-read-string ()
 339   (erlext-readn (erlext-read2)))
 340
 341 (defun erlext-read-binary ()
 342   (erlext-readn (erlext-read4)))
 343
 344 (defun erlext-read-newref ()
 345   (let* ((len (erlext-read2))
 346          (node (erlext-read-obj))
 347          (creation (erlext-read1))
 348          (id (erlext-readn (* 4 len))))
 349     (vector erl-tag 'erl-new-ref node creation id)))
 350
 351 ;; We don't actually support bignums. When we get one, we skip over it
 352 ;; and return the symbol {SMALL|LARGE}-BIGNUM.
 353
 354 (defun erlext-read-small-bignum ()
 355   (erlext-read (erlext-read1))
 356   'SMALL-BIGNUM)
 357
 358 (defun erlext-read-large-bignum ()
 359   (erlext-read (erlext-read4))
 360   'LARGE-BIGNUM)
 361
 362 ;; ------------------------------------------------------------
 363 ;; Helpers
 364 ;; ------------------------------------------------------------
 365
 366 (defun erlext-get-tag (number)
 367   (car (rassq number erlext-tag-alist)))
 368 (defun erlext-get-code (tag)
 369   (cdr (assq tag erlext-tag-alist)))
 370
 371 ;; ------------------------------------------------------------
 372 ;; Testing
 373 ;; ------------------------------------------------------------
 374
 375 (defvar erlext-test-cases
 376   `(1 foo "bar" [bar baz] [,erl-tag erl-pid someone@somehost 0 0 0] (1 foo ())
 377       [,erl-tag erl-port someone@somehost 0 0]
 378       (([1 2]) ([1 2]))))
 379
 380 (defun erlext-test ()
 381   "Test each term in `erlext-test-cases' by encoding it and decoding
 382 it and making sure that it's unchanged."
 383   (interactive)
 384   (mapc #'erlext-test-case erlext-test-cases)
 385   (message "Smooth sailing"))
 386
 387 (defun erlext-test-case (term)
 388   (condition-case x
 389       (assert (equal term (erlext-binary-to-term (erlext-term-to-binary term))))
 390     (error (error "test failed for %S: %S" term (error-message-string x)))))
 391
 392 (provide 'erlext)