Permalink
Browse files

Moved out BERT to it's own library.

  • Loading branch information...
1 parent 733980a commit fb6521c381c1bb20da083db95e5c77513811c94f @flambard committed Nov 17, 2012
Showing with 1 addition and 233 deletions.
  1. +0 −2 README.md
  2. +0 −16 bert.asd
  3. +0 −214 src/bert.lisp
  4. +1 −1 src/packages.lisp
View
2 README.md
@@ -4,8 +4,6 @@ CLERIC - Common Lisp Erlang Interface
CLERIC is an implementation of the Erlang distribution protocol, comparable with
erl_interface and jinterface.
-CLERIC also includes a [BERT](http://bert-rpc.org/) serializer.
-
Homepage: <http://common-lisp.net/project/cleric/>
Please see the `doc/` directory for further documentation. The latest documentation is available [online](http://common-lisp.net/project/cleric/doc/).
View
16 bert.asd
@@ -1,16 +0,0 @@
-(defpackage :bert-system
- (:use :cl))
-
-(in-package :bert-system)
-
-(asdf:defsystem :bert
- :description "BERT serializer."
- :author "Markus Flambard <mflambard@common-lisp.net>"
- :version "0.1.2"
- :license "MIT License"
- :depends-on (:cleric :alexandria)
- :components
- ((:module :src
- :components
- ((:file "bert"))
- )))
View
214 src/bert.lisp
@@ -1,214 +0,0 @@
-;; BERT (Binary ERlang Term)
-;;
-;; See http://bert-rpc.org/
-;;
-
-(defpackage #:bert
- (:documentation "BERT (Binary ERlang Term).")
- (:use #:cl #:cleric-bops #:cleric-etf #:alexandria)
- (:shadow #:encode #:decode)
- (:export
-
- ;; Classes
- #:erlang-binary
- #:erlang-tuple
- #:bert-time
- #:bert-regex
-
- ;; Functions and methods
- #:encode
- #:decode
- #:binary
- #:bytes
- #:size
- #:string-to-binary
- #:bytes-to-binary
- #:binary-to-string
- #:tuple
- #:elements
- #:arity
- #:bool
-
- ;; Special variables
- #:*atom-symbol-package*
- #:*lisp-string-is-erlang-binary*
- #:true
- #:false
-
- ;; Conditions
- #:untranslatable-lisp-object-error
- #:unexpected-message-length-error
- #:unexpected-message-tag-error
- ))
-
-
-(in-package :bert)
-
-(defconstant +protocol-version+ 131)
-
-(defgeneric translate-complex-type (object)
- (:documentation "Translates tuples with the 'bert' tag to corresponding Lisp objects."))
-
-(defgeneric encode (object &key berp-header)
- (:documentation "Encodes the BERT-translatable object to a vector of bytes."))
-
-
-(define-constant true (tuple '|bert| '|true|)
- :test #'match-p
- :documentation "BERT boolean true term.")
-
-(define-constant false (tuple '|bert| '|false|)
- :test #'match-p
- :documentation "BERT boolean false term.")
-
-(defun bool (value)
- (if value true false))
-
-
-(defclass bert-time ()
- ((megaseconds :reader megaseconds :initarg :megaseconds)
- (seconds :reader seconds :initarg :seconds)
- (microseconds :reader microseconds :initarg :microseconds))
- (:documentation "BERT time data type"))
-
-(defmethod translate-complex-type ((time bert-time))
- (with-slots (megaseconds seconds microseconds) time
- (tuple '|bert| '|time| megaseconds seconds microseconds)))
-
-
-(defclass bert-regex ()
- ((source :reader regex-source :initarg :source)
- (options :reader regex-options :initarg :options))
- (:documentation "BERT regex data type"))
-
-(defmethod translate-complex-type ((regex bert-regex))
- (with-slots (source options) regex
- (tuple '|bert| '|regex| (string-to-binary source) options)))
-
-
-(defmethod translate-complex-type ((dict hash-table))
- (tuple '|bert| '|dict|
- (loop
- for key being the hash-keys in dict using (hash-value value)
- collect (tuple (translate-complex-type key)
- (translate-complex-type value))) ))
-
-
-(defmethod translate-complex-type ((nil-symbol (eql nil)))
- (declare (ignorable nil-symbol))
- (tuple '|bert| '|nil|))
-
-
-(defmethod translate-complex-type ((tuple erlang-tuple))
- (with-slots (elements) tuple
- (make-instance 'erlang-tuple
- :elements (map 'vector #'translate-complex-type elements))))
-
-
-(defmethod translate-complex-type ((lst list))
- (mapcar #'translate-complex-type lst))
-
-
-(defmethod translate-complex-type (object)
- object)
-
-
-(defmethod encode (object &key berp-header)
- (let ((bytes (cleric:encode (translate-complex-type object)
- :version-tag +protocol-version+)))
- (if berp-header
- (concatenate '(vector (unsigned-byte 8))
- (uint32-to-bytes (length bytes))
- bytes)
- bytes)))
-
-
-(deftype bert-translatable ()
- "A type that encompasses all types of Lisp objects that can be translated to BERT objects."
- '(satisfies bert-translatable-p))
-
-(defun bert-translatable-p (object)
- "Returns true if OBJECT is translatable to an Erlang object."
- (typecase object
- ((or integer float symbol string hash-table erlang-tuple erlang-binary bert-time bert-regex)
- t)
- (list
- (every #'bert-translatable-p object))
- (t
- nil)))
-
-
-(defun simple-bert-term-p (bert-term)
- (typep bert-term '(or integer float symbol string erlang-binary)))
-
-(defun compound-bert-term-p (bert-term)
- (typep bert-term '(or list erlang-tuple)))
-
-(defun complex-bert-term-p (bert-term)
- (when (and (typep bert-term 'erlang-tuple) (< 0 (arity bert-term)))
- (let ((first-element (aref (elements bert-term) 0)))
- (and (symbolp first-element)
- (string= "bert" (symbol-name first-element))))))
-
-
-(defun translate-complex-terms (term)
- (cond
- ((simple-bert-term-p term)
- term)
- ((listp term)
- (mapcar #'translate-complex-terms term))
- ((complex-bert-term-p term)
- (translate-complex-term term))
- ((typep term 'erlang-tuple)
- (with-slots (elements) term
- (make-instance
- 'erlang-tuple
- :elements (map 'vector #'translate-complex-terms elements))))
- (t
- (error "~a is not a BERT term." term)) ))
-
-(defun translate-complex-term (term)
- (assert (typep term 'erlang-tuple))
- (with-slots (elements) term
- (assert (string= "bert" (symbol-name (aref elements 0))))
- (eswitch ((aref elements 1) :test #'string= :key #'symbol-name)
- ("nil" nil)
- ("true" t)
- ("false" nil)
- ("dict"
- (translate-dict-term (aref elements 2)))
- ("time"
- (translate-time-term (aref elements 2)
- (aref elements 3)
- (aref elements 4)))
- ("regex"
- (translate-regex-term (aref elements 2)
- (aref elements 3))) )))
-
-(defun translate-dict-term (dict)
- (loop
- with hash = (make-hash-table)
- for tuple in dict
- do (let* ((elements (elements tuple))
- (key (aref elements 0))
- (value (aref elements 1)))
- (setf (gethash key hash) value))
- finally (return hash)))
-
-(defun translate-time-term (megaseconds seconds microseconds)
- (make-instance 'bert-time
- :megaseconds megaseconds
- :seconds seconds
- :microseconds microseconds))
-
-(defun translate-regex-term (source options)
- (make-instance 'bert-regex
- :source source
- :options options))
-
-
-(defun decode (bytes)
- (multiple-value-bind (term pos)
- (cleric:decode bytes :version-tag +protocol-version+)
- (values (translate-complex-terms term) pos)))
-
View
2 src/packages.lisp
@@ -1,5 +1,5 @@
(defpackage #:cleric-bops
- (:documentation "Common byte operations used internally by CLERIC and BERT.")
+ (:documentation "Common byte operations used internally by CLERIC.")
(:use #:cl #:etf-bops)
(:export

0 comments on commit fb6521c

Please sign in to comment.