6c1bac83e3c9

--- 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

--- 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)))))
 

--- 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
 
     ))

--- 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-_,'[]{}+=")