# HG changeset patch # User Steve Losh # Date 1598743327 14400 # Node ID af3ef34fe3baf1424854a7d7c9f392751added15 # Parent 6d74e7ab0fc07a4e7c59604e18540a5733a28664 Add extra key preservation diff -r 6d74e7ab0fc0 -r af3ef34fe3ba .TODO.done --- 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 diff -r 6d74e7ab0fc0 -r af3ef34fe3ba TODO --- 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 diff -r 6d74e7ab0fc0 -r af3ef34fe3ba src/mop.lisp --- 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)))) diff -r 6d74e7ab0fc0 -r af3ef34fe3ba src/wrappers.lisp --- 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)))) diff -r 6d74e7ab0fc0 -r af3ef34fe3ba test/tests.lisp --- 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-_,'[]{}+=")