# HG changeset patch # User Steve Losh # Date 1597980061 14400 # Node ID 6c1bac83e3c9047e27422d84568d698ce267036f # Parent c9eb52bb4d0ab89244a52ac6a41354e8607a8298 Add :json/before-print and :json/after-read wrappers diff -r c9eb52bb4d0a -r 6c1bac83e3c9 TODO --- a/TODO Wed Aug 19 00:10:39 2020 -0400 +++ b/TODO Thu Aug 20 23:21:01 2020 -0400 @@ -1,6 +1,8 @@ +Fix :allow-print and :allow-read to set t when removing them during class redef. | id:21cce1bed829a138de33b33e3ad3219f7888be04 Clean up error hierarchy | id:3d3efa4af649474151661a9d294080ab24e22ff7 Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732 Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8 Add extra key preservation | id:cfb63b37d87893083fc98477ec3d488fb909a984 Test reading explicit types, not just t. | id:d2def699c46f12c02d49c01c869fc9b927bda72d Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772 +Fix `Undefined function (SETF CCL:SLOT-DEFINITION-INITARGS)` in CCL | id:e834dd6749849e10669a643019337533e87f5cdd diff -r c9eb52bb4d0a -r 6c1bac83e3c9 src/mop.lisp --- a/src/mop.lisp Wed Aug 19 00:10:39 2020 -0400 +++ b/src/mop.lisp Thu Aug 20 23:21:01 2020 -0400 @@ -12,8 +12,8 @@ (unknown-slots :accessor unknown-slots :initarg :unknown-slots :initform :discard) - (name-initarg-map :accessor name-initarg-map) - (slot-name-alist :accessor slot-name-alist) + (slot-map :accessor slot-map) + (slot-alist :accessor slot-alist) (allow-print :accessor allow-print :initarg :allow-print :initform t) (allow-read :accessor allow-read :initarg :allow-read :initform t))) @@ -23,12 +23,16 @@ (defclass json-direct-slot-definition (c2mop:standard-direct-slot-definition) ((json-class :initarg :json :accessor json-class) - (json-name :initarg :json/name :accessor json-name))) + (json-name :initarg :json/name :accessor json-name) + (before-print :initarg :json/before-print :accessor before-print) + (after-read :initarg :json/after-read :accessor after-read))) (defclass json-effective-slot-definition (c2mop:standard-effective-slot-definition) ((json-class :initarg :json :accessor json-class) (json-name :initarg :json/name :accessor json-name) - (json-initarg :accessor json-initarg))) + (json-initarg :accessor json-initarg) + (before-print :initarg :json/before-print :accessor before-print :initform nil) + (after-read :initarg :json/after-read :accessor after-read :initform nil))) (defmethod c2mop:direct-slot-definition-class ((class json-class) &rest initargs) (if (getf initargs :json) @@ -60,7 +64,13 @@ (json-class eslot) (if (slot-boundp dslot 'json-class) (canonicalize-class-designator (json-class dslot)) '(t)) - (json-initarg eslot) initarg) ; todo nicer name + (json-initarg eslot) initarg ; todo nicer name + (after-read eslot) (if (slot-boundp dslot 'after-read) + (after-read dslot) + nil) + (before-print eslot) (if (slot-boundp dslot 'before-print) + (before-print dslot) + nil)) (push initarg (c2mop:slot-definition-initargs eslot)) eslot))) @@ -69,10 +79,11 @@ (remove-if-not (lambda (slot) (typep slot 'json-effective-slot-definition)) (c2mop:class-slots class))) -(defun make-name-initarg-map (class) - "Return a name/initarg map for the JSON slots of `class`. +(defun make-slot-map (class) + "Return a slot map for the JSON slots of `class`, used when reading. - The result will be a hash table of `{name: (initarg class contained-class)}`. + The result will be a hash table of `{name: (initarg class contained-class + after-read)}`. " (let* ((slots (json-slots class)) @@ -80,13 +91,19 @@ (dolist (slot slots) (destructuring-bind (c &optional cc) (json-class slot) (setf (gethash (json-name slot) result) - (list (json-initarg slot) c cc)))) + (list (json-initarg slot) c cc (after-read slot))))) result)) -(defun make-slot-name-alist (class) +(defun make-slot-alist (class) + "Return a slot alist for the JSON slots of `class`, used when printing. + + The result will be an alist of `((slot . (\"name\" before-print)))`. + + " (mapcar (lambda (slot) (cons (c2mop:slot-definition-name slot) - (json-name slot))) + (list (json-name slot) + (before-print slot)))) (json-slots class))) (defmethod shared-initialize ((class json-class) slot-names @@ -104,8 +121,8 @@ initargs)))) (defmethod c2mop:finalize-inheritance :after ((class json-class)) - (setf (name-initarg-map class) (make-name-initarg-map class) - (slot-name-alist class) (make-slot-name-alist class))) + (setf (slot-map class) (make-slot-map class) + (slot-alist class) (make-slot-alist class))) ;;;; Read --------------------------------------------------------------------- @@ -123,18 +140,18 @@ (make-instance class)) (loop :with unknown = (unknown-slots class) - :with map = (name-initarg-map class) + :with map = (slot-map class) :with init = (list) :for name = (read% 'string nil input) :for sep = (parse-kv-separator class-name input) - :for (initarg c cc) = (gethash name map) + :for (initarg c cc after-read) = (gethash name map) :do (progn (if (null initarg) (ecase unknown (:discard (read% t nil input)) (:error (e class-name input "got unknown object attribute ~S" name))) - (progn - (push (read% c cc input) init) + (let ((value (read% c cc input))) + (push (if after-read (funcall after-read value) value) init) (push initarg init))) (skip-whitespace input) (let ((ch (r input))) @@ -166,13 +183,17 @@ (t (write-char #\{ stream) (loop :with first = t - :for (slot . name) :in (slot-name-alist class) + :for (slot name before-print) :in (slot-alist class) :when (slot-boundp thing slot) - :do (progn (if first - (setf first nil) - (write-char #\, stream)) - (print% name stream) - (write-char #\: stream) - (print% (slot-value thing slot) stream))) + :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))) (write-char #\} stream))))) diff -r c9eb52bb4d0a -r 6c1bac83e3c9 src/package.lisp --- a/src/package.lisp Wed Aug 19 00:10:39 2020 -0400 +++ b/src/package.lisp Thu Aug 20 23:21:01 2020 -0400 @@ -7,5 +7,6 @@ :json-parsing-error :line :column :json-class + :lisp-case-to-snake-case )) diff -r c9eb52bb4d0a -r 6c1bac83e3c9 test/tests.lisp --- a/test/tests.lisp Wed Aug 19 00:10:39 2020 -0400 +++ b/test/tests.lisp Thu Aug 20 23:21:01 2020 -0400 @@ -411,6 +411,33 @@ (signals error (jarl:print (make-instance 'apr/deny-print :id 1) nil))) +;;;; After Read/Before Print -------------------------------------------------- +(define-condition validation-error (error) ()) + +(defun validate-small (i) + (if (> (abs i) 10) + (error 'validation-error) + i)) + +(defclass arbp () + ((i :json number :initarg :i + :json/after-read validate-small) + (s :json string :initarg :s + :json/after-read string-upcase + :json/before-print string-downcase)) + (:metaclass jarl:json-class)) + + +(define-test before-print + (is (string= (json "{'s':'hello'}") + (jarl:print (make-instance 'arbp :s "Hello") nil)))) + +(define-test after-read + (is (string= "HELLO" (slot-value (jarl:read 'arbp (json "{'s':'Hello'}")) 's))) + (is (= 5 (slot-value (jarl:read 'arbp (json "{'i':5}")) 'i))) + (signals validation-error (jarl:read 'arbp (json "{'i':999}")))) + + ;;;; Fuzz Utilities ----------------------------------------------------------- (defparameter *basic-chars* " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_,'[]{}+=")