389 lines
14 KiB
Common Lisp
389 lines
14 KiB
Common Lisp
|
;; This file is part of yason, a Common Lisp JSON parser/encoder
|
||
|
|
;;
|
||
|
|
;; Copyright (c) 2008-2014 Hans Huebner and contributors
|
||
|
|
;; All rights reserved.
|
||
|
|
;;
|
||
|
|
;; Please see the file LICENSE in the distribution.
|
||
|
|
|
||
|
|
(in-package :yason)
|
||
|
|
|
||
|
|
(defvar *json-output*)
|
||
|
|
|
||
|
|
(defparameter *default-indent* nil
|
||
|
|
"Set to T or an numeric indentation width in order to have YASON
|
||
|
|
indent its output by default.")
|
||
|
|
|
||
|
|
(defparameter *default-indent-width* 2
|
||
|
|
"Default indentation width for output if indentation is selected
|
||
|
|
with no indentation width specified.")
|
||
|
|
|
||
|
|
(defparameter *list-encoder* 'encode-plain-list-to-array
|
||
|
|
"The actual function used to encode a LIST.
|
||
|
|
Can be changed to encode ALISTs or PLISTs as dictionaries by
|
||
|
|
setting it to ENCODE-ALIST or ENCODE-PLIST.")
|
||
|
|
|
||
|
|
(defparameter *symbol-key-encoder* 'encode-symbol-key-error
|
||
|
|
"The actual function used to encode a SYMBOL when seen as a key.
|
||
|
|
You might want ENCODE-SYMBOL-AS-LOWERCASE here.")
|
||
|
|
|
||
|
|
|
||
|
|
(defgeneric encode (object &optional stream)
|
||
|
|
|
||
|
|
(:documentation "Encode OBJECT to STREAM in JSON format. May be
|
||
|
|
specialized by applications to perform specific rendering. STREAM
|
||
|
|
defaults to *STANDARD-OUTPUT*."))
|
||
|
|
|
||
|
|
(defparameter *char-replacements*
|
||
|
|
(alexandria:plist-hash-table
|
||
|
|
'(#\\ "\\\\"
|
||
|
|
#\" "\\\""
|
||
|
|
#\Backspace "\\b"
|
||
|
|
#\Page "\\f"
|
||
|
|
#\Newline "\\n"
|
||
|
|
#\Return "\\r"
|
||
|
|
#\Tab "\\t")))
|
||
|
|
|
||
|
|
(defun unicode-code (char)
|
||
|
|
(char-code char))
|
||
|
|
|
||
|
|
(defun unicode-char (code)
|
||
|
|
(code-char code))
|
||
|
|
|
||
|
|
(defun write-surrogate-pair-escape (code stream)
|
||
|
|
(let ((upper (+ (ldb (byte 10 10) (- code #x10000))
|
||
|
|
#xD800))
|
||
|
|
(lower (+ (ldb (byte 10 0) (- code #x10000))
|
||
|
|
#xDC00)))
|
||
|
|
(format stream "\\u~4,'0X\\u~4,'0X" upper lower)))
|
||
|
|
|
||
|
|
(defmethod encode ((string string) &optional (stream *standard-output*))
|
||
|
|
(write-char #\" stream)
|
||
|
|
(dotimes (i (length string))
|
||
|
|
(let* ((char (aref string i))
|
||
|
|
(replacement (gethash char *char-replacements*)))
|
||
|
|
(cond
|
||
|
|
(replacement (write-string replacement stream))
|
||
|
|
;; Control characters (U+0000 - U+001F) must be escaped.
|
||
|
|
((<= #x0000 (unicode-code char) #x001F)
|
||
|
|
(format stream "\\u~4,'0X" (unicode-code char)))
|
||
|
|
;; Non-BMP characters must be escaped as a UTF-16 surrogate pair.
|
||
|
|
((<= #x010000 (unicode-code char) #x10FFFF)
|
||
|
|
(write-surrogate-pair-escape (unicode-code char) stream))
|
||
|
|
(t (write-char char stream)))))
|
||
|
|
(write-char #\" stream)
|
||
|
|
string)
|
||
|
|
|
||
|
|
(defmethod encode ((object ratio) &optional (stream *standard-output*))
|
||
|
|
(encode (coerce object 'double-float) stream)
|
||
|
|
object)
|
||
|
|
|
||
|
|
(defmethod encode ((object float) &optional (stream *standard-output*))
|
||
|
|
(let ((*read-default-float-format* 'double-float))
|
||
|
|
(format stream "~F" (coerce object 'double-float)))
|
||
|
|
object)
|
||
|
|
|
||
|
|
(defmethod encode ((object integer) &optional (stream *standard-output*))
|
||
|
|
(princ object stream))
|
||
|
|
|
||
|
|
(defmacro with-aggregate/object ((stream opening-char closing-char) &body body)
|
||
|
|
"Set up serialization context for aggregate serialization with the
|
||
|
|
object encoder."
|
||
|
|
(alexandria:with-gensyms (printed)
|
||
|
|
`(progn
|
||
|
|
(write-delimiter ,opening-char ,stream)
|
||
|
|
(change-indentation ,stream #'+)
|
||
|
|
(prog1
|
||
|
|
(let (,printed)
|
||
|
|
(macrolet ((with-element-output (() &body body)
|
||
|
|
`(progn
|
||
|
|
(cond
|
||
|
|
(,',printed
|
||
|
|
(write-delimiter #\, ,',stream))
|
||
|
|
(t
|
||
|
|
(setf ,',printed t)))
|
||
|
|
(write-indentation ,',stream)
|
||
|
|
,@body)))
|
||
|
|
,@body))
|
||
|
|
(change-indentation ,stream #'-)
|
||
|
|
(write-indentation ,stream)
|
||
|
|
(write-delimiter ,closing-char ,stream)))))
|
||
|
|
|
||
|
|
(defun encode-key/value (key value stream)
|
||
|
|
(encode key stream)
|
||
|
|
(write-char #\: stream)
|
||
|
|
(encode value stream))
|
||
|
|
|
||
|
|
(defmethod encode ((object hash-table) &optional (stream *standard-output*))
|
||
|
|
(with-aggregate/object (stream #\{ #\})
|
||
|
|
(maphash (lambda (key value)
|
||
|
|
(with-element-output ()
|
||
|
|
(encode-key/value key value stream)))
|
||
|
|
object)
|
||
|
|
object))
|
||
|
|
|
||
|
|
(defmethod encode ((object vector) &optional (stream *standard-output*))
|
||
|
|
(with-aggregate/object (stream #\[ #\])
|
||
|
|
(loop for value across object
|
||
|
|
do (with-element-output ()
|
||
|
|
(encode value stream)))
|
||
|
|
object))
|
||
|
|
|
||
|
|
(defun encode-plain-list-to-array (object stream)
|
||
|
|
(with-aggregate/object (stream #\[ #\])
|
||
|
|
(dolist (value object)
|
||
|
|
(with-element-output ()
|
||
|
|
(encode value stream)))
|
||
|
|
object))
|
||
|
|
|
||
|
|
(defmethod encode ((object list) &optional (stream *standard-output*))
|
||
|
|
(funcall *list-encoder* object stream))
|
||
|
|
|
||
|
|
|
||
|
|
(defun encode-symbol-key-error (key)
|
||
|
|
(error "No policy for symbols as keys defined. ~
|
||
|
|
Please check YASON:*SYMBOL-KEY-ENCODER*."))
|
||
|
|
|
||
|
|
(defun encode-symbol-as-lowercase (key)
|
||
|
|
"Encodes a symbol KEY as a lowercase string.
|
||
|
|
Ensure that there's no intentional lower-case character lost."
|
||
|
|
(let ((name (symbol-name key)))
|
||
|
|
(assert (notany #'lower-case-p name))
|
||
|
|
(string-downcase name)))
|
||
|
|
|
||
|
|
(defun encode-assoc-key/value (key value stream)
|
||
|
|
;; Checking (EVERY #'UPPER-CASE-P name) breaks with non-alpha characters like #\-
|
||
|
|
(let ((string (if (symbolp key)
|
||
|
|
(funcall *symbol-key-encoder* key)
|
||
|
|
(string key))))
|
||
|
|
(encode-key/value string value stream)))
|
||
|
|
|
||
|
|
(defun encode-alist (object &optional (stream *standard-output*))
|
||
|
|
;; Failsafe in case this here is not an ALIST but a normal list
|
||
|
|
(if (consp (first object))
|
||
|
|
(with-aggregate/object (stream #\{ #\})
|
||
|
|
(loop for (key . value) in object
|
||
|
|
do (with-element-output ()
|
||
|
|
(encode-assoc-key/value key value stream)))
|
||
|
|
object)
|
||
|
|
;; We can't call *LIST-ENCODER* again, that would be an unlimited recursion
|
||
|
|
(encode-plain-list-to-array object stream)))
|
||
|
|
|
||
|
|
(defun encode-plist (object &optional (stream *standard-output*))
|
||
|
|
(with-aggregate/object (stream #\{ #\})
|
||
|
|
(loop for (key value) on object by #'cddr
|
||
|
|
do (with-element-output ()
|
||
|
|
(encode-assoc-key/value key value stream)))
|
||
|
|
object))
|
||
|
|
|
||
|
|
(defmethod encode ((object (eql 'true)) &optional (stream *standard-output*))
|
||
|
|
(write-string "true" stream)
|
||
|
|
object)
|
||
|
|
|
||
|
|
(defmethod encode ((object (eql 'false)) &optional (stream *standard-output*))
|
||
|
|
(write-string "false" stream)
|
||
|
|
object)
|
||
|
|
|
||
|
|
(defmethod encode ((object (eql :null)) &optional (stream *standard-output*))
|
||
|
|
(write-string "null" stream)
|
||
|
|
object)
|
||
|
|
|
||
|
|
(defmethod encode ((object (eql t)) &optional (stream *standard-output*))
|
||
|
|
(write-string "true" stream)
|
||
|
|
object)
|
||
|
|
|
||
|
|
(defmethod encode ((object (eql nil)) &optional (stream *standard-output*))
|
||
|
|
(write-string "null" stream)
|
||
|
|
object)
|
||
|
|
|
||
|
|
(defclass json-output-stream (trivial-gray-streams:fundamental-character-output-stream)
|
||
|
|
((output-stream :reader output-stream
|
||
|
|
:initarg :output-stream)
|
||
|
|
(stack :accessor stack
|
||
|
|
:initform nil)
|
||
|
|
(indent :initarg :indent
|
||
|
|
:reader indent
|
||
|
|
:accessor indent%)
|
||
|
|
(indent-string :initform ""
|
||
|
|
:accessor indent-string))
|
||
|
|
(:default-initargs :indent *default-indent*)
|
||
|
|
(:documentation "Objects of this class capture the state of a JSON stream encoder."))
|
||
|
|
|
||
|
|
(defmethod initialize-instance :after ((stream json-output-stream) &key indent)
|
||
|
|
(when (eq indent t)
|
||
|
|
(setf (indent% stream) *default-indent-width*)))
|
||
|
|
|
||
|
|
(defgeneric make-json-output-stream (stream &key indent))
|
||
|
|
|
||
|
|
(defmethod make-json-output-stream (stream &key (indent t))
|
||
|
|
"Create a JSON output stream with indentation enabled."
|
||
|
|
(if indent
|
||
|
|
(make-instance 'json-output-stream :output-stream stream :indent indent)
|
||
|
|
stream))
|
||
|
|
|
||
|
|
(defmethod trivial-gray-streams:stream-write-char ((stream json-output-stream) char)
|
||
|
|
(write-char char (output-stream stream)))
|
||
|
|
|
||
|
|
(defgeneric write-indentation (stream)
|
||
|
|
(:method ((stream t))
|
||
|
|
nil)
|
||
|
|
(:method ((stream json-output-stream))
|
||
|
|
(when (indent stream)
|
||
|
|
(fresh-line (output-stream stream))
|
||
|
|
(write-string (indent-string stream) (output-stream stream)))))
|
||
|
|
|
||
|
|
(defgeneric write-delimiter (char stream)
|
||
|
|
(:method (char stream)
|
||
|
|
(write-char char stream))
|
||
|
|
(:method (char (stream json-output-stream))
|
||
|
|
(write-char char (output-stream stream))))
|
||
|
|
|
||
|
|
(defgeneric change-indentation (stream operator)
|
||
|
|
(:method ((stream t) (operator t))
|
||
|
|
nil)
|
||
|
|
(:method ((stream json-output-stream) operator)
|
||
|
|
(when (indent stream)
|
||
|
|
(setf (indent-string stream) (make-string (funcall operator (length (indent-string stream))
|
||
|
|
(indent stream))
|
||
|
|
:initial-element #\Space)))))
|
||
|
|
|
||
|
|
(defun next-aggregate-element ()
|
||
|
|
(if (car (stack *json-output*))
|
||
|
|
(write-char (car (stack *json-output*)) (output-stream *json-output*))
|
||
|
|
(setf (car (stack *json-output*)) #\,)))
|
||
|
|
|
||
|
|
(defmacro with-output ((stream &rest args &key indent) &body body)
|
||
|
|
(declare (ignore indent))
|
||
|
|
"Set up a JSON streaming encoder context on STREAM, then evaluate BODY."
|
||
|
|
`(let ((*json-output* (make-instance 'json-output-stream :output-stream ,stream ,@args)))
|
||
|
|
,@body))
|
||
|
|
|
||
|
|
(defmacro with-output-to-string* ((&rest args &key indent stream-symbol) &body body)
|
||
|
|
"Set up a JSON streaming encoder context, then evaluate BODY.
|
||
|
|
Return a string with the generated JSON output."
|
||
|
|
(declare (ignore indent))
|
||
|
|
(let ((stream (or stream-symbol (gensym "STREAM"))))
|
||
|
|
(remf args :stream-symbol)
|
||
|
|
`(with-output-to-string (,stream)
|
||
|
|
(with-output (,stream ,@args)
|
||
|
|
,@body))))
|
||
|
|
|
||
|
|
(define-condition no-json-output-context (error)
|
||
|
|
()
|
||
|
|
(:report "No JSON output context is active")
|
||
|
|
(:documentation "This condition is signalled when one of the stream
|
||
|
|
encoding function is used outside the dynamic context of a
|
||
|
|
WITH-OUTPUT or WITH-OUTPUT-TO-STRING* body."))
|
||
|
|
|
||
|
|
(defmacro with-aggregate/stream ((begin-char end-char) &body body)
|
||
|
|
"Set up context for aggregate serialization for the stream encoder."
|
||
|
|
`(progn
|
||
|
|
(unless (boundp '*json-output*)
|
||
|
|
(error 'no-json-output-context))
|
||
|
|
(when (stack *json-output*)
|
||
|
|
(next-aggregate-element))
|
||
|
|
(write-indentation *json-output*)
|
||
|
|
(write-delimiter ,begin-char *json-output*)
|
||
|
|
(change-indentation *json-output* #'+)
|
||
|
|
(push nil (stack *json-output*))
|
||
|
|
(prog1
|
||
|
|
(progn ,@body)
|
||
|
|
(pop (stack *json-output*))
|
||
|
|
(change-indentation *json-output* #'-)
|
||
|
|
(write-indentation *json-output*)
|
||
|
|
(write-delimiter ,end-char *json-output*))))
|
||
|
|
|
||
|
|
(defmacro with-array (() &body body)
|
||
|
|
"Open a JSON array, then run BODY. Inside the body,
|
||
|
|
ENCODE-ARRAY-ELEMENT must be called to encode elements to the opened
|
||
|
|
array. Must be called within an existing JSON encoder context, see
|
||
|
|
WITH-OUTPUT and WITH-OUTPUT-TO-STRING*."
|
||
|
|
`(with-aggregate/stream (#\[ #\]) ,@body))
|
||
|
|
|
||
|
|
(defmacro with-object (() &body body)
|
||
|
|
"Open a JSON object, then run BODY. Inside the body,
|
||
|
|
ENCODE-OBJECT-ELEMENT or WITH-OBJECT-ELEMENT must be called to encode
|
||
|
|
elements to the object. Must be called within an existing JSON
|
||
|
|
encoder context, see WITH-OUTPUT and WITH-OUTPUT-TO-STRING*."
|
||
|
|
`(with-aggregate/stream (#\{ #\}) ,@body))
|
||
|
|
|
||
|
|
(defun encode-array-element (object)
|
||
|
|
"Encode OBJECT as next array element to the last JSON array opened
|
||
|
|
with WITH-ARRAY in the dynamic context. OBJECT is encoded using the
|
||
|
|
ENCODE generic function, so it must be of a type for which an ENCODE
|
||
|
|
method is defined."
|
||
|
|
(next-aggregate-element)
|
||
|
|
(write-indentation *json-output*)
|
||
|
|
(encode object (output-stream *json-output*)))
|
||
|
|
|
||
|
|
(defun encode-array-elements (&rest objects)
|
||
|
|
"Encode OBJECTS, a list of JSON encodable objects, as array elements."
|
||
|
|
(dolist (object objects)
|
||
|
|
(encode-array-element object)))
|
||
|
|
|
||
|
|
(defun encode-object-element (key value)
|
||
|
|
"Encode KEY and VALUE as object element to the last JSON object
|
||
|
|
opened with WITH-OBJECT in the dynamic context. KEY and VALUE are
|
||
|
|
encoded using the ENCODE generic function, so they both must be of a
|
||
|
|
type for which an ENCODE method is defined."
|
||
|
|
(next-aggregate-element)
|
||
|
|
(write-indentation *json-output*)
|
||
|
|
(encode-key/value key value (output-stream *json-output*))
|
||
|
|
value)
|
||
|
|
|
||
|
|
(defun encode-object-elements (&rest elements)
|
||
|
|
"Encode plist ELEMENTS as object elements."
|
||
|
|
(loop for (key value) on elements by #'cddr
|
||
|
|
do (encode-object-element key value)))
|
||
|
|
|
||
|
|
(defun encode-object-slots (object slots)
|
||
|
|
"For each slot in SLOTS, encode that slot on OBJECT as an object element.
|
||
|
|
Equivalent to calling ENCODE-OBJECT-ELEMENT for each slot where the
|
||
|
|
key is the slot name, and the value is the (SLOT-VALUE OBJECT slot)"
|
||
|
|
(loop for slot in slots
|
||
|
|
do (encode-object-element (string slot)
|
||
|
|
(slot-value object slot))))
|
||
|
|
|
||
|
|
(define-compiler-macro encode-object-slots (&whole form &environment env object raw-slots)
|
||
|
|
"Compiler macro to allow open-coding with encode-object-slots when slots are literal list."
|
||
|
|
(let ((slots (macroexpand raw-slots env)))
|
||
|
|
(cond
|
||
|
|
((null slots) nil)
|
||
|
|
((eq (car slots) 'quote)
|
||
|
|
(setf slots (cadr slots)) ; Get the quoted list
|
||
|
|
`(with-slots ,slots ,object
|
||
|
|
,@(loop for slot in slots
|
||
|
|
collect `(encode-object-element ,(string slot) ,slot))))
|
||
|
|
(t form))))
|
||
|
|
|
||
|
|
(defmacro with-object-element ((key) &body body)
|
||
|
|
"Open a new encoding context to encode a JSON object element. KEY
|
||
|
|
is the key of the element. The value will be whatever BODY
|
||
|
|
serializes to the current JSON output context using one of the
|
||
|
|
stream encoding functions. This can be used to stream out nested
|
||
|
|
object structures."
|
||
|
|
`(progn
|
||
|
|
(next-aggregate-element)
|
||
|
|
(write-indentation *json-output*)
|
||
|
|
(encode ,key (output-stream *json-output*))
|
||
|
|
(setf (car (stack *json-output*)) #\:)
|
||
|
|
(unwind-protect
|
||
|
|
(progn ,@body)
|
||
|
|
(setf (car (stack *json-output*)) #\,))))
|
||
|
|
|
||
|
|
(defgeneric encode-slots (object)
|
||
|
|
(:documentation
|
||
|
|
"Generic function to encode object slots. It should be called in an
|
||
|
|
object encoding context. It uses PROGN combinatation with
|
||
|
|
MOST-SPECIFIC-LAST order, so that base class slots are encoded
|
||
|
|
before derived class slots.")
|
||
|
|
(:method-combination progn :most-specific-last))
|
||
|
|
|
||
|
|
(defgeneric encode-object (object)
|
||
|
|
(:documentation
|
||
|
|
"Generic function to encode an object. The default implementation
|
||
|
|
opens a new object encoding context and calls ENCODE-SLOTS on
|
||
|
|
the argument.")
|
||
|
|
(:method (object)
|
||
|
|
(with-object ()
|
||
|
|
(yason:encode-slots object))))
|