--- a/.TODO.done Fri Aug 28 00:24:06 2020 -0400
+++ b/.TODO.done Sat Aug 29 19:22:07 2020 -0400
@@ -6,5 +6,6 @@
Add opaque-json type | id:a1a380eb9782d088693dfb75402b99c2b30cf039
Add size and depth limits | id:ab9b49ec993f1e46c34b9d627549f41cad80609d
Add fuzz tests against other implementations | id:cd53968480f72453ee820d65a180efe6da0fef71
+Add extra key preservation | id:cfb63b37d87893083fc98477ec3d488fb909a984
Fix `Undefined function (SETF CCL:SLOT-DEFINITION-INITARGS)` in CCL | id:e834dd6749849e10669a643019337533e87f5cdd
Add basic unit tests | id:ed372a368fce619ce8230043635de5258212f607
--- a/TODO Fri Aug 28 00:24:06 2020 -0400
+++ b/TODO Sat Aug 29 19:22:07 2020 -0400
@@ -1,4 +1,7 @@
+Indentation. | id:0184922ad2c249da5361f439f6449fadcb27d43c
Clean up error hierarchy | id:3d3efa4af649474151661a9d294080ab24e22ff7
-Add extra key preservation | id:cfb63b37d87893083fc98477ec3d488fb909a984
+Input wrapping. | id:7bc7f71a7dd85e13efde40b5ea2a5b6bfe13cf58
+Fuzz against other JSON implementations | id:ccfe488e219c9454228a0510c61f8c59946e5875
Test reading explicit types, not just t. | id:d2def699c46f12c02d49c01c869fc9b927bda72d
+Ensure slots are coalesced properly. | id:d800e6516a5bf5f8ce843f442956078e7a1b672e
Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772
--- a/src/mop.lisp Fri Aug 28 00:24:06 2020 -0400
+++ b/src/mop.lisp Sat Aug 29 19:22:07 2020 -0400
@@ -5,6 +5,10 @@
"Convert a Lisp-cased string designator `\"FOO-BAR\"` into snake cased `\"foo_bar\"`."
(substitute #\_ #\- (string-downcase string)))
+
+(defclass json-object ()
+ ((preserved :accessor preserved :initarg preserved)))
+
(defclass json-class (standard-class)
((slot-name-to-json-name :accessor slot-name-to-json-name
:initarg :slot-name-to-json-name
@@ -118,14 +122,30 @@
(before-print slot))))
(json-slots class)))
-(defmethod shared-initialize ((class json-class) slot-names
- &rest initargs
- &key slot-name-to-json-name unknown-slots allow-print allow-read
- &allow-other-keys)
+(defun patch-direct-superclasses (direct-superclasses)
+ "Patch `direct-superclasses` to ensure `json-object` will be a superclass.
+
+ If one of the superclasses is already a `json-class` then `json-object` will
+ already be an indirect superclass, so nothing needs to be done. Otherwise add
+ `json-object` to the list of direct superclasses.
+
+ "
+ (let ((meta (find-class 'json-class))
+ (super (find-class 'json-object)))
+ (if (find meta direct-superclasses :key #'class-of)
+ direct-superclasses
+ (append direct-superclasses (list super)))))
+
+(defmethod shared-initialize :around
+ ((class json-class) slot-names
+ &rest initargs
+ &key slot-name-to-json-name unknown-slots allow-print allow-read direct-superclasses
+ &allow-other-keys)
(flet ((arg (initarg args)
(when args ; todo assert length = 1
(list initarg (first args)))))
(apply #'call-next-method class slot-names
+ :direct-superclasses (patch-direct-superclasses direct-superclasses)
(append (arg :slot-name-to-json-name slot-name-to-json-name)
(arg :unknown-slots unknown-slots)
(arg :allow-read (or allow-read '(t)))
@@ -151,6 +171,7 @@
(decf-depth input)
(make-instance class))
(loop
+ :with preserved = nil
:with unknown = (unknown-slots class)
:with map = (slot-map class)
:with init = (list)
@@ -160,7 +181,9 @@
:do (progn
(if (null initarg)
(ecase unknown
- (:discard (read% t nil input))
+ (:preserve (setf (gethash name (or preserved (setf preserved (make-hash-table :test #'equal))))
+ (read% t nil input)))
+ (:discard (read% nil nil input))
(:error (e class-name input "got unknown object attribute ~S" name)))
(let ((value (read% c cc input)))
(push (if after-read (funcall after-read value) value) init)
@@ -171,7 +194,10 @@
(#\} (decf-depth input) (loop-finish))
(#\, (skip-whitespace input))
(t (e class-name input "expected ~S or ~S but got ~S." #\} #\, ch)))))
- :finally (return (apply #'make-instance class init)))))
+ :finally (progn (when preserved
+ (push preserved init)
+ (push 'preserved init))
+ (return (apply #'make-instance class init))))))
(defmethod read% ((class-name symbol) (contained-class null) (input input))
(let ((wrapper (find-wrapper class-name)))
@@ -188,31 +214,27 @@
;;;; Printing -----------------------------------------------------------------
-(defun render-json-class (class thing stream)
+(defun print-json-class (class thing stream &aux (first t))
(write-char #\{ stream)
- (loop :with first = t
- :for (slot name before-print) :in (slot-alist class)
- :when (slot-boundp thing slot)
- :do (let ((value (slot-value thing slot)))
- (if first
- (setf first nil)
- (write-char #\, stream))
- (print% name stream)
- (write-char #\: stream)
- (print% (if before-print
- (funcall before-print value)
- value)
- stream)))
+ (flet ((print-pair (k v)
+ (if first
+ (setf first nil)
+ (write-char #\, stream))
+ (print% k stream)
+ (write-char #\: stream)
+ (print% v stream)))
+ (loop :for (slot name before-print) :in (slot-alist class)
+ :when (slot-boundp thing slot)
+ :do (let ((value (slot-value thing slot)))
+ (print-pair name (if before-print
+ (funcall before-print value)
+ value)))
+ :finally (when (slot-boundp thing 'preserved)
+ (maphash #'print-pair (slot-value thing 'preserved)))))
(write-char #\} stream))
-(defmethod print% (thing stream)
- (let* ((class (class-of thing))
- (wrapper (find-wrapper (class-name class))))
- (cond
- (wrapper (print-with-wrapper wrapper thing stream))
- ((not (typep class 'json-class))
- (error "Don't know how to print object ~S of class ~S as JSON." thing class))
- ((not (allow-print class))
- (error "Class ~S does not allow printing." class))
- (t (render-json-class class thing stream)))))
-
+(defmethod print% ((thing json-object) stream)
+ (let ((class (class-of thing)))
+ (if (allow-print class)
+ (print-json-class class thing stream)
+ (error "Class ~S does not allow printing." class))))
--- a/src/wrappers.lisp Fri Aug 28 00:24:06 2020 -0400
+++ b/src/wrappers.lisp Sat Aug 29 19:22:07 2020 -0400
@@ -45,3 +45,12 @@
(defun print-with-wrapper (wrapper thing stream)
(print% (funcall (wrapper-print wrapper) thing) stream))
+
+(defmethod print% (thing stream)
+ (let* ((class (class-of thing))
+ (wrapper (find-wrapper (class-name class))))
+ (if wrapper
+ (print-with-wrapper wrapper thing stream)
+ (error "Don't know how to print object ~S of class ~S as JSON, ~
+ because it's not a JSON class and doesn't have any wrapper(s)."
+ thing class))))
--- a/test/tests.lisp Fri Aug 28 00:24:06 2020 -0400
+++ b/test/tests.lisp Sat Aug 29 19:22:07 2020 -0400
@@ -77,6 +77,9 @@
(is (same object (jarl:read t (jarl:print oj nil)))))
(signals end-of-file (jarl:read t s))))
+(defun roundtrip-string (class-designator string)
+ (jarl:print (jarl:read class-designator (json string)) nil))
+
(defun check-roundtrips (object)
(is (same object (jarl:read t (jarl:print object nil)))))
@@ -524,6 +527,46 @@
(signals validation-error (jarl:read 'arbp (json "{'i':999}"))))
+;;;; Unknown Slots ------------------------------------------------------------
+(defclass us-pres ()
+ ((id :json number))
+ (:metaclass jarl:json-class)
+ (:unknown-slots :preserve))
+
+(defclass us-disc ()
+ ((id :json number))
+ (:metaclass jarl:json-class)
+ (:unknown-slots :discard))
+
+(defclass us-err ()
+ ((id :json number))
+ (:metaclass jarl:json-class)
+ (:unknown-slots :error))
+
+
+(define-test preserve-unknown-slots
+ (is (string= (json "{'id':1}")
+ (roundtrip-string 'us-pres "{'id':1}")))
+ (is (string= (json "{'foo':10}")
+ (roundtrip-string 'us-pres "{'foo':10}")))
+ (is (same (h "id" 1 "foo" "bar" "meow" "wow")
+ (jarl:read t (roundtrip-string 'us-pres "{'id':1, 'foo': 'bar', 'meow': 'wow'}")))))
+
+(define-test discard-unknown-slots
+ (is (string= (json "{'id':1}")
+ (roundtrip-string 'us-disc "{'id':1}")))
+ (is (string= (json "{}")
+ (roundtrip-string 'us-disc "{'foo':10}")))
+ (is (string= (json "{'id':1}")
+ (roundtrip-string 'us-disc "{'id':1, 'foo': 'bar', 'meow': 'wow'}"))))
+
+(define-test error-on-unknown-slots
+ (is (string= (json "{'id':1}")
+ (roundtrip-string 'us-err "{'id':1}")))
+ (signals error (jarl:read 'us-err "{'foo':10}"))
+ (signals error (jarl:read 'us-err "{'id':1, 'foo': 'bar', 'meow': 'wow'}")))
+
+
;;;; Fuzz Utilities -----------------------------------------------------------
(defparameter *basic-chars*
" abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_,'[]{}+=")