493 lines
17 KiB
EmacsLisp
493 lines
17 KiB
EmacsLisp
;;; marshal.el --- eieio extension for automatic (un)marshalling
|
|
|
|
;; Copyright (C) 2015 Yann Hodique
|
|
|
|
;; Author: Yann Hodique <hodiquey@vmware.com>
|
|
;; Keywords: eieio
|
|
;; Package-Version: 20160807.1954
|
|
;; Version: 0.7.0
|
|
;; URL: https://github.com/sigma/marshal.el
|
|
;; Package-Requires: ((eieio "1.4") (json "1.3") (ht "2.1"))
|
|
|
|
;; This file 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 2, or (at your option)
|
|
;; any later version.
|
|
|
|
;; This file is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
;; Boston, MA 02111-1307, USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Inspired by Go tagged structs. 'alist, 'plist and 'json drivers are
|
|
;; provided, but implementing others just requires to inherit from
|
|
;; `marshal-driver'.
|
|
|
|
;; Sometimes the types are not enough (for example with lists, whose elements
|
|
;; are not explicitly typed. In those cases, a small extension on top of types
|
|
;; can be used. Like for example :marshal-type (list string)
|
|
|
|
;; Examples:
|
|
|
|
;; 1. Regular use:
|
|
|
|
;; (marshal-defclass plop ()
|
|
;; ((foo :initarg :foo :type string :marshal ((alist . field_foo)))
|
|
;; (bar :initarg :bar :type integer :marshal ((alist . field_bar)))
|
|
;; (baz :initarg :baz :type integer :marshal ((alist . field_baz)))))
|
|
|
|
;; (marshal-defclass plopi ()
|
|
;; ((alpha :marshal ((alist . field_alpha)))
|
|
;; (beta :type plop :marshal ((alist . field_beta)))))
|
|
|
|
;; (marshal (make-instance 'plop :foo "ok" :bar 42) 'alist)
|
|
;; => '((field_bar . 42) (field_foo . "ok"))
|
|
|
|
;; (unmarshal 'plop '((field_foo . "plop") (field_bar . 0) (field_baz . 1)) 'alist)
|
|
;; => '[object plop "plop" "plop" 0 1]
|
|
|
|
;; (marshal
|
|
;; (unmarshal 'plopi '((field_alpha . 42)
|
|
;; (field_beta . ((field_foo . "plop")
|
|
;; (field_bar . 0)
|
|
;; (field_baz . 1)))) 'alist)
|
|
;; 'alist)
|
|
;; => '((field_beta (field_baz . 1) (field_bar . 0) (field_foo . "plop")) (field_alpha . 42))
|
|
|
|
;; 2. Objects involving lists:
|
|
|
|
;; (marshal-defclass foo/tree ()
|
|
;; ((root :initarg :id :marshal ((plist . :root)))
|
|
;; (leaves :initarg :leaves :marshal ((plist . :leaves)) :marshal-type (list foo/tree))))
|
|
|
|
;; (marshal (make-instance 'foo/tree :id 0
|
|
;; :leaves (list (make-instance 'foo/tree :id 1)
|
|
;; (make-instance 'foo/tree :id 2
|
|
;; :leaves (list (make-instance 'foo/tree :id 3)))))
|
|
;; 'plist)
|
|
;; => (:root 0 :leaves ((:root 1) (:root 2 :leaves ((:root 3)))))
|
|
|
|
;; (unmarshal 'foo/tree '(:root 0 :leaves ((:root 1) (:root 2 :leaves ((:root 3))))) 'plist)
|
|
|
|
;; => [object foo/tree "foo/tree" 0
|
|
;; ([object foo/tree "foo/tree" 1 nil]
|
|
;; [object foo/tree "foo/tree" 2
|
|
;; ([object foo/tree "foo/tree" 3 nil])])]
|
|
|
|
;; 3. Json
|
|
|
|
;; (marshal (make-instance 'foo/tree :id 0
|
|
;; :leaves (list (make-instance 'foo/tree :id 1)
|
|
;; (make-instance 'foo/tree :id 2
|
|
;; :leaves (list (make-instance 'foo/tree :id 3)))))
|
|
;; 'json)
|
|
;; => "{\"leaves\":[{\"root\":1},{\"leaves\":[{\"root\":3}],\"root\":2}],\"root\":0}"
|
|
|
|
;; (unmarshal 'foo/tree "{\"leaves\":[{\"root\":1},{\"leaves\":[{\"root\":3}],\"root\":2}],\"root\":0}" 'json)
|
|
;; => [object foo/tree "foo/tree" 0
|
|
;; ([object foo/tree "foo/tree" 1 nil]
|
|
;; [object foo/tree "foo/tree" 2
|
|
;; ([object foo/tree "foo/tree" 3 nil])])]
|
|
|
|
;;; Code:
|
|
|
|
(require 'json)
|
|
(require 'eieio)
|
|
(require 'ht)
|
|
|
|
;;; eieio backward-compatibility
|
|
(dolist (sym '(object-class object-p oref oset))
|
|
(let ((new-sym (intern (concat "eieio-" (symbol-name sym)))))
|
|
(unless (fboundp new-sym)
|
|
(fset new-sym sym))))
|
|
|
|
;;; json hotfix
|
|
(when (json-alist-p '(((foo))))
|
|
(defun json-alist-p (list)
|
|
(while (consp list)
|
|
(setq list (if (and (consp (car list)) (atom (caar list)))
|
|
(cdr list)
|
|
'not-alist)))
|
|
(null list)))
|
|
|
|
;;; Defined drivers
|
|
|
|
(defvar marshal-drivers nil "Alist of drivers")
|
|
|
|
(defun marshal-register-driver (type driver)
|
|
(add-to-list 'marshal-drivers (cons type driver)))
|
|
|
|
;;; Marshalling driver interface
|
|
|
|
(defclass marshal-driver ()
|
|
((input :initarg :input)
|
|
(output :initarg :output)))
|
|
|
|
(defmethod marshal-open ((obj marshal-driver) &optional input)
|
|
(if input
|
|
(oset obj :input input)
|
|
(oset obj :output nil)))
|
|
|
|
(defmethod marshal-write ((obj marshal-driver) path value)
|
|
(unless (slot-boundp obj :output)
|
|
(error "Driver has not been opened in write mode")))
|
|
|
|
(defmethod marshal-read ((obj marshal-driver) path)
|
|
(unless (slot-boundp obj :input)
|
|
(error "Driver has not been opened in read mode")))
|
|
|
|
(defmethod marshal-close ((obj marshal-driver))
|
|
(when (slot-boundp obj :output)
|
|
(oref obj :output)))
|
|
|
|
(defmethod marshal-guess-type :static ((obj marshal-driver) blob)
|
|
(cond ((null blob) nil)
|
|
((booleanp blob) 'bool)
|
|
((stringp blob) 'string)
|
|
((numberp blob) 'number)
|
|
((listp blob) 'list)
|
|
((ht? blob) 'hash)))
|
|
|
|
(defmethod marshal-preprocess ((obj marshal-driver) blob)
|
|
blob)
|
|
|
|
(defmethod marshal-postprocess ((obj marshal-driver) blob)
|
|
blob)
|
|
|
|
(defmethod marshal-unmarshal-null :static ((obj marshal-driver))
|
|
nil)
|
|
|
|
(defmethod marshal-marshal-null :static ((obj marshal-driver))
|
|
nil)
|
|
|
|
(defmethod marshal-unmarshal-string :static ((obj marshal-driver) s)
|
|
(format "%s" s))
|
|
|
|
(defmethod marshal-marshal-string :static ((obj marshal-driver) s)
|
|
s)
|
|
|
|
(defmethod marshal-unmarshal-number :static ((obj marshal-driver) i)
|
|
i)
|
|
|
|
(defmethod marshal-marshal-number :static ((obj marshal-driver) i)
|
|
i)
|
|
|
|
(defmethod marshal-unmarshal-bool :static ((obj marshal-driver) b)
|
|
(equal b t))
|
|
|
|
(defmethod marshal-marshal-bool :static ((obj marshal-driver) b)
|
|
(equal b t))
|
|
|
|
(defmethod marshal-unmarshal-list :static ((obj marshal-driver) l l-type)
|
|
(let ((type (or (and (object-p obj) (eieio-object-class obj))
|
|
obj)))
|
|
(cons (unmarshal-internal (when (consp l-type)
|
|
(cadr l-type))
|
|
(car l) type)
|
|
(unmarshal-internal l-type (cdr l) type))))
|
|
|
|
(defmethod marshal-marshal-list :static ((obj marshal-driver) l)
|
|
(unless (null l)
|
|
(let ((type (or (and (object-p obj) (eieio-object-class obj))
|
|
obj)))
|
|
(cons (marshal-internal (car l) type)
|
|
(marshal-internal (cdr l) type)))))
|
|
|
|
(defmethod marshal-unmarshal-hash :static ((obj marshal-driver) h h-type)
|
|
(let ((type (or (and (object-p obj) (eieio-object-class obj))
|
|
obj))
|
|
(k-type (when (consp h-type) (nth 1 h-type)))
|
|
(v-type (when (consp h-type) (nth 2 h-type))))
|
|
(ht<-alist
|
|
(mapcar (lambda (item)
|
|
(cons (unmarshal-internal k-type (car item) type)
|
|
(unmarshal-internal v-type (cdr item) type))) h))))
|
|
|
|
(defmethod marshal-marshal-hash :static ((obj marshal-driver) h)
|
|
(unless (ht-empty? h)
|
|
(let ((type (or (and (object-p obj) (eieio-object-class obj))
|
|
obj)))
|
|
(mapcar (lambda (item)
|
|
(cons (marshal-internal (car item) type)
|
|
(marshal-internal (cadr item) type)))
|
|
(ht-items h)))))
|
|
|
|
;;; alist-based driver
|
|
|
|
(defclass marshal-driver-alist (marshal-driver)
|
|
())
|
|
|
|
(defmethod marshal-write ((obj marshal-driver-alist) path value)
|
|
(call-next-method)
|
|
(object-add-to-list obj :output (cons path value)))
|
|
|
|
(defmethod marshal-read ((obj marshal-driver-alist) path)
|
|
(call-next-method)
|
|
(cdr (assoc path (oref obj :input))))
|
|
|
|
;;; json driver
|
|
|
|
(defclass marshal-driver-json (marshal-driver-alist)
|
|
())
|
|
|
|
(defmethod marshal-preprocess ((obj marshal-driver-json) blob)
|
|
(let ((json-array-type 'list)
|
|
(json-object-type 'alist))
|
|
(json-read-from-string (call-next-method))))
|
|
|
|
(defmethod marshal-postprocess ((obj marshal-driver-json) blob)
|
|
(json-encode (call-next-method)))
|
|
|
|
(defmethod marshal-unmarshal-bool :static ((obj marshal-driver-json) b)
|
|
(not (eq b json-false)))
|
|
|
|
(defmethod marshal-marshal-bool :static ((obj marshal-driver-json) b)
|
|
(or b json-false))
|
|
|
|
;;; plist-based driver
|
|
|
|
(defclass marshal-driver-plist (marshal-driver)
|
|
())
|
|
|
|
(defmethod marshal-write ((obj marshal-driver-plist) path value)
|
|
(call-next-method)
|
|
(oset obj :output (plist-put (oref obj :output) path value)))
|
|
|
|
(defmethod marshal-read ((obj marshal-driver-plist) path)
|
|
(call-next-method)
|
|
(plist-get (oref obj :input) path))
|
|
|
|
;;; helper functions
|
|
|
|
(defun marshal--alist-add (alist key value &optional append)
|
|
(let ((existing (assoc key alist)))
|
|
(if (not existing)
|
|
(cons (cons key value) alist)
|
|
(setcdr existing (if append
|
|
(append (cdr existing) value)
|
|
value))
|
|
alist)))
|
|
|
|
(defun marshal--alist-merge (alist1 alist2 &optional append)
|
|
(let ((res alist1))
|
|
(if alist2
|
|
(let* ((pair (car alist2))
|
|
(x (car pair))
|
|
(y (cdr pair)))
|
|
(marshal--alist-merge
|
|
(marshal--alist-add alist1 x y append)
|
|
(cdr alist2)))
|
|
alist1)))
|
|
|
|
(defun marshal--transpose-alist2 (l)
|
|
(let (res
|
|
(rows l))
|
|
(while rows
|
|
(let* ((row (car rows))
|
|
(x (car row))
|
|
(cols (cdr row)))
|
|
(while cols
|
|
(let* ((col (car cols))
|
|
(y (car col))
|
|
(z (cdr col))
|
|
(target (or (assoc y res)
|
|
(let ((p (cons y nil)))
|
|
(setq res (push p res))
|
|
p))))
|
|
(setcdr target (cons (cons x z) (cdr target))))
|
|
(setq cols (cdr cols))))
|
|
(setq rows (cdr rows)))
|
|
res))
|
|
|
|
;;; base-class for serializable objects
|
|
|
|
(defclass marshal-base ()
|
|
((-marshal-info :allocation :class :initform nil :protection :protected)
|
|
(-type-info :allocation :class :initform nil :protection :protected)))
|
|
|
|
(defmethod marshal-get-marshal-info :static ((obj marshal-base))
|
|
nil)
|
|
|
|
(defmethod marshal-get-type-info :static ((obj marshal-base))
|
|
nil)
|
|
|
|
(defun marshal-get-driver (type)
|
|
(let ((cls (or (and (class-p type) type)
|
|
(cdr (assoc type marshal-drivers))
|
|
'marshal-driver)))
|
|
(make-instance cls)))
|
|
|
|
(defmethod marshal-internal ((obj marshal-base) type &optional hint)
|
|
(let* ((type (or (and (class-p type)
|
|
(car (rassoc type marshal-drivers)))
|
|
type))
|
|
(driver (marshal-get-driver type))
|
|
(marshal-info (cdr (assoc type (marshal-get-marshal-info obj)))))
|
|
(marshal-open driver)
|
|
(when marshal-info
|
|
(dolist (s (object-slots obj))
|
|
(let ((path (cdr (assoc s marshal-info))))
|
|
(when (and path
|
|
(slot-boundp obj s))
|
|
|
|
(marshal-write driver path
|
|
(marshal-internal
|
|
(eieio-oref obj s)
|
|
type
|
|
(cdr (assoc s (marshal-get-type-info obj)))))))))
|
|
(marshal-close driver)))
|
|
|
|
(defmethod marshal-internal ((obj nil) type &optional hint)
|
|
(let ((driver (marshal-get-driver type)))
|
|
(cond ((and (null hint) (null obj))
|
|
(marshal-marshal-null driver))
|
|
((or (eq obj t)
|
|
(and (null obj) (eq hint 'bool)))
|
|
(marshal-marshal-bool driver obj))
|
|
((stringp obj)
|
|
(marshal-marshal-string driver obj))
|
|
((numberp obj)
|
|
(marshal-marshal-number driver obj))
|
|
((listp obj)
|
|
(marshal-marshal-list driver obj))
|
|
((ht? obj)
|
|
(marshal-marshal-hash driver obj)))))
|
|
|
|
;;;###autoload
|
|
(defun marshal (obj type)
|
|
(let ((driver (marshal-get-driver type)))
|
|
(marshal-postprocess driver
|
|
(marshal-internal obj type))))
|
|
|
|
(defmethod unmarshal--obj ((obj marshal-base) blob type)
|
|
(let ((driver (marshal-get-driver type))
|
|
(marshal-info (cdr (assoc type (marshal-get-marshal-info obj)))))
|
|
(marshal-open driver blob)
|
|
(when (and marshal-info blob)
|
|
(dolist (s (object-slots obj))
|
|
(let ((path (cdr (assoc s marshal-info))))
|
|
(when path
|
|
(eieio-oset obj s
|
|
(unmarshal-internal
|
|
(cdr (assoc s (marshal-get-type-info obj)))
|
|
(marshal-read driver path)
|
|
type))))))
|
|
(marshal-close driver)
|
|
obj))
|
|
|
|
(defun unmarshal-internal (obj blob type)
|
|
(let ((obj (if (class-p obj)
|
|
(make-instance obj)
|
|
obj)))
|
|
(unmarshal--internal obj blob type)))
|
|
|
|
(defmethod unmarshal--internal ((obj nil) blob type)
|
|
(let* ((driver (marshal-get-driver type))
|
|
(obj (or obj (marshal-guess-type driver blob))))
|
|
(cond ((or (null obj) (null blob))
|
|
(marshal-unmarshal-null driver))
|
|
((eq obj 'bool)
|
|
(marshal-unmarshal-bool driver blob))
|
|
((eq obj 'string)
|
|
(marshal-unmarshal-string driver blob))
|
|
((memq obj '(number integer))
|
|
(marshal-unmarshal-number driver blob))
|
|
((or (eq obj 'list)
|
|
(and (consp obj) (eq (car obj) 'list)))
|
|
(marshal-unmarshal-list driver blob obj))
|
|
((or (eq obj 'hash)
|
|
(and (consp obj) (eq (car obj) 'hash)))
|
|
(marshal-unmarshal-hash driver blob obj)))))
|
|
|
|
(defmethod unmarshal--internal ((obj marshal-base) blob type)
|
|
(let ((type (or (and (class-p type)
|
|
(car (rassoc type marshal-drivers)))
|
|
type)))
|
|
(unmarshal--obj obj blob type)))
|
|
|
|
;;;###autoload
|
|
(defun unmarshal (obj blob type)
|
|
(let ((driver (marshal-get-driver type)))
|
|
(unmarshal-internal obj (marshal-preprocess driver blob) type)))
|
|
|
|
;;;###autoload
|
|
(defmacro marshal-defclass (name superclass slots &rest options-and-doc)
|
|
(declare (debug t) (indent 2))
|
|
(let* ((options (if (stringp (car options-and-doc))
|
|
(cdr options-and-doc)
|
|
options-and-doc))
|
|
(default-spec-func (or (plist-get options :marshal-default-spec)
|
|
'ignore))
|
|
(base-cls (or (plist-get options :marshal-base-cls)
|
|
'marshal-base))
|
|
(marshal-info (marshal--transpose-alist2
|
|
(remove nil
|
|
(mapcar
|
|
(lambda (s)
|
|
(let ((name (car s)))
|
|
(let ((marshal
|
|
(or (plist-get (cdr s) :marshal)
|
|
(funcall default-spec-func name))))
|
|
(when marshal
|
|
(cons name
|
|
(mapcar
|
|
(lambda (p)
|
|
(if (consp p)
|
|
p
|
|
(cons p name)))
|
|
marshal))))))
|
|
slots))))
|
|
(type-info (remove nil
|
|
(mapcar (lambda (s)
|
|
(let ((name (car s)))
|
|
(let ((type (or (plist-get (cdr s) :marshal-type)
|
|
(plist-get (cdr s) :type))))
|
|
(when type
|
|
(cons name type)))))
|
|
slots))))
|
|
`(progn
|
|
(defclass ,name (,@superclass ,base-cls)
|
|
(,@slots)
|
|
,@options-and-doc)
|
|
|
|
(defmethod marshal-get-marshal-info :static ((obj ,name))
|
|
(let ((cls (if (eieio-object-p obj)
|
|
(eieio-object-class obj)
|
|
obj)))
|
|
(get cls :marshal-info)))
|
|
|
|
(put ',name :marshal-info ',marshal-info)
|
|
(dolist (cls ',superclass)
|
|
(put ',name :marshal-info
|
|
(marshal--alist-merge (get ',name :marshal-info)
|
|
(marshal-get-marshal-info cls) t)))
|
|
|
|
(defmethod marshal-get-type-info :static ((obj ,name))
|
|
(let ((cls (if (eieio-object-p obj)
|
|
(eieio-object-class obj)
|
|
obj)))
|
|
(get cls :type-info)))
|
|
|
|
(put ',name :type-info ',type-info)
|
|
(dolist (cls ',superclass)
|
|
(put ',name :type-info
|
|
(marshal--alist-merge (get ',name :type-info)
|
|
(marshal-get-type-info cls) t)))
|
|
|
|
,name)))
|
|
|
|
;;; Default drivers
|
|
(marshal-register-driver 'alist 'marshal-driver-alist)
|
|
(marshal-register-driver 'plist 'marshal-driver-plist)
|
|
(marshal-register-driver 'json 'marshal-driver-json)
|
|
|
|
(provide 'marshal)
|
|
;;; marshal.el ends here
|