Refactor a couple of things
Changes the `:json/class` initarg to just `:json` because it's used so much.
Seems more ergonomic.
Also changes slots without an explicit `:json` to just be standard slots and to
not be serialized. This seems safer and more reasonable anyway — I'd rather
have to be a little more explict that to accidentally serialize a `password`
slot.
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Tue, 28 Jul 2020 21:28:29 -0400 |
| parents |
a2712b3d3b16 |
| children |
(none) |
(in-package :jarl)
;;;; Reading ------------------------------------------------------------------
(defun requires-escape-p (char)
(or (char= #\" char)
(char= #\\ char)
(<= (char-code char) #x1F)))
(defun skip-whitespace (stream)
(loop :while (member (peek-char nil stream nil nil)
'(#\space #\tab #\newline #\linefeed #\return))
:do (read-char stream)))
(defun read-literal (stream literal)
(loop :for next :across literal
:for char = (read-char stream)
:do (assert (char= next char))))
(defun read-integer (stream &optional (allow-leading-zero t))
(loop :with i = 0
:with n = 0
:with has-leading-zero = nil
:for ch = (peek-char nil stream nil #\e)
:for digit = (digit-char-p ch)
:while digit
:do (progn
(when (and (zerop n) (zerop digit))
(setf has-leading-zero t))
(incf n)
(setf i (+ (* 10 i) digit))
(read-char stream))
:finally
(cond
((zerop n) (error "Expected integer"))
((and has-leading-zero (not allow-leading-zero)
(not (and (= n 1) (= i 0))))
(error "Bad leading zero"))
(t (return (values i n))))))
(defun read-exponent (stream)
(read-char stream) ; e
(let* ((char (peek-char nil stream))
(sign (if (member char '(#\+ #\-))
(progn
(read-char stream)
(case char
(#\+ 1)
(#\- -1)))
1)))
(* sign (read-integer stream))))
(defun read-number (stream)
; todo disallow leading zeros in integer part
(let ((sign 1) integer
(fractional 0) (fractional-length 0)
(exponent 0) has-exponent)
(when (char= #\- (peek-char nil stream))
(read-char stream)
(setf sign -1))
(setf integer (read-integer stream nil))
(when (eql #\. (peek-char nil stream nil nil))
(read-char stream)
(setf (values fractional fractional-length) (read-integer stream)))
(when (member (peek-char nil stream nil nil) '(#\e #\E))
(setf exponent (read-exponent stream)
has-exponent t))
(if (and (zerop fractional-length) (not has-exponent))
(* sign integer (expt 10 exponent))
(values
(coerce
(read-from-string (format nil "~A~D.~V,'0Dd~D" ; good enough for reference
(if (= -1 sign) #\- #\+)
integer
fractional-length
fractional
exponent))
'double-float)))))
(defun read-hex-digit (stream)
(or (digit-char-p (read-char stream) 16)
(error "Expected hex digit.")))
(defun read-escaped-char (stream)
(read-char stream) ; \
(ecase (read-char stream)
(#\" #\")
(#\\ #\\)
(#\/ #\/)
(#\b #\backspace)
(#\f (code-char #x0C))
(#\n #\linefeed)
(#\r #\return)
(#\t #\tab)
(#\u (let ((a (read-hex-digit stream)) ; todo handle surrogate pairs
(b (read-hex-digit stream))
(c (read-hex-digit stream))
(d (read-hex-digit stream)))
(code-char (+ (* a (expt 16 3))
(* b (expt 16 2))
(* c (expt 16 1))
(* d (expt 16 0))))))))
(defun read-string (stream)
(assert (char= #\" (read-char stream)))
(coerce (loop :for ch = (peek-char nil stream)
:collect (cond
((char= #\\ ch) (read-escaped-char stream))
((char= #\" ch) (read-char stream) (loop-finish))
((requires-escape-p ch) (error "Bad unescaped char ~S." ch))
(t (read-char stream))))
'string))
(defun read-array (stream)
(assert (char= #\[ (read-char stream)))
(skip-whitespace stream)
(if (char= #\] (peek-char nil stream))
(progn
(read-char stream)
(vector))
(coerce (loop :collect (read-thing stream)
:do (progn
(skip-whitespace stream)
(case (peek-char nil stream)
(#\] (read-char stream) (loop-finish))
(#\, (read-char stream))
(t (error "Expected , or ] while reading array, got ~S."
(peek-char nil stream))))))
'vector)))
(defun read-object (stream)
(assert (char= #\{ (read-char stream)))
(skip-whitespace stream)
(let ((result (make-hash-table :test #'equal)))
(if (char= #\} (peek-char nil stream))
(read-char stream)
(loop :for name = (progn (skip-whitespace stream)
(read-string stream))
:for sep = (progn
(skip-whitespace stream)
(assert (char= #\: (read-char stream))))
:for value = (progn (skip-whitespace stream)
(read-thing stream))
:do (progn
(setf (gethash name result) value)
(skip-whitespace stream)
(case (peek-char nil stream)
(#\} (read-char stream) (loop-finish))
(#\, (read-char stream))
(t (error "Expected , or } while reading object, got ~S."
(peek-char nil stream)))))))
result))
(defun read-thing (stream)
(skip-whitespace stream)
(ecase (peek-char nil stream)
(#\f (read-literal stream "false") :false)
(#\t (read-literal stream "true") :true)
(#\n (read-literal stream "null") nil)
(#\" (read-string stream))
(#\{ (read-object stream))
(#\[ (read-array stream))
((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (read-number stream))))
(defun read-json% (stream eof-error-p eof-value)
(skip-whitespace stream)
(if (peek-char nil stream nil nil)
(prog1
(read-thing stream)
(skip-whitespace stream))
(if eof-error-p
(error "EOF")
eof-value)))
(defun read-json (&optional (stream-or-string *standard-input*) (eof-error-p t) eof-value)
(read-json% (etypecase stream-or-string
(stream stream-or-string)
(string (make-string-input-stream stream-or-string)))
eof-error-p
eof-value))
;;;; Printing -----------------------------------------------------------------
(defun write-escaped-char (char stream)
(case char
((#\newline #\linefeed) (write-string "\\n" stream))
(#\return (write-string "\\r" stream))
(#\\ (write-string "\\\\" stream))
(t (format stream "\\u~4,'0X" (char-code char)))))
(defgeneric print-thing (thing stream))
(defmethod print-thing ((thing null) stream)
(write-string "null" stream))
(defmethod print-thing ((thing string) stream)
(write-char #\" stream)
(loop :for char :across thing
:do (if (requires-escape-p char)
(write-escaped-char char stream)
(write-char char stream)))
(write-char #\" stream))
(defmethod print-thing ((thing vector) stream)
(write-char #\[ stream)
(loop :with first = t
:for object :across thing
:do (progn (if first
(setf first nil)
(write-char #\, stream))
(print-thing object stream)))
(write-char #\] stream))
(defmethod print-thing ((thing hash-table) stream)
(write-char #\{ stream)
(loop :with first = t
:for name :being :the hash-keys :in thing :using (hash-value value)
:do (progn (if first
(setf first nil)
(write-char #\, stream))
(assert (stringp name))
(print-thing name stream)
(write-char #\: stream)
(print-thing value stream)))
(write-char #\} stream))
(defmethod print-thing ((thing double-float) stream)
(princ thing stream))
(defmethod print-thing ((thing integer) stream)
(format stream "~D" thing))
(defmethod print-thing ((thing (eql :false)) stream)
(write-string "false" stream))
(defmethod print-thing ((thing (eql :true)) stream)
(write-string "true" stream))
(defun print-json (object &optional (stream *standard-output*))
(let ((*read-default-float-format* 'double-float)
(*print-base* 10))
(etypecase stream
(stream (print-thing object stream)
(values))
(null (with-output-to-string (s) (print-thing object s))))))
#; Scratch --------------------------------------------------------------------
(read-json " false")
(parse-integer )
(print-json
(read-json
(substitute #\" #\'
"{
'foo': [ 1, 2, 3221098950382094832.0123948904],
'bar': [{'meow': {}, 'woof': null}, {'baz': 1}]
}")))
(with-open-file (s "../JSONTestSuite/test_parsing/i_string_overlong_sequence_2_bytes.json")
(read-json s))
(read-json "[123e1000]")