Mercurial > core / lisp/lib/dat/json.lisp
changeset 395: |
d876b572b5b9 |
parent: |
58d7c3925687
|
child: |
ea4f008ad13f |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sun, 02 Jun 2024 02:30:54 -0400 |
permissions: |
-rw-r--r-- |
description: |
updates |
1 ;;; lib/dat/json.lisp --- JSON format 3 ;; JSON parser generator 5 ;; There are quite a few json libraries in the CL ecosystem. This 6 ;; particular implementation is based on the JSON package here: 7 ;; https://github.com/massung/json 9 ;; It's object-based (like CL-JSON) instead of using a 13 (in-package :dat/json) 15 (defclass json-object () 16 ((members :initform nil 18 :accessor json-object-members)) 19 (:documentation "An associative list of key/value pairs.")) 21 (defmethod print-object ((obj json-object) stream) 22 "Output a JSON object to a stream in readable form." 23 (print-unreadable-object (obj stream :type t) 24 (let ((*print-level* 1)) 25 (json-encode obj stream)))) 27 (defun json-getf (object key &optional value) 28 "Find an member's value in a JSON object." 29 (let ((place (assoc key (json-object-members object) :test 'string=))) 32 (values (second place) t)))) 34 (defun json-setf (object key value) 35 "Assign a value to a key in a JSON object." 36 (let ((place (assoc key (json-object-members object) :test 'string=))) 39 (let ((k (if (stringp key) 41 (princ-to-string key)))) 42 (push (list k value) (json-object-members object))) 43 (rplacd place (list value)))))) 45 (defsetf json-getf json-setf) 47 (defun json-decode (string &key (start 0) end) 48 "Convert a JSON string into a Lisp object." 49 (with-input-from-string (stream string :start start :end end) 50 (values (json-read stream) 51 (file-position stream)))) 53 (defmethod deserialize ((obj string) (format (eql :json)) &key (start 0) end) 54 (declare (ignore format)) 55 (json-decode obj :start start :end end)) 57 (defun json-encode (value &optional stream) 58 "Encodes a Lisp value into a stream." 59 (json-write value stream)) 61 (defmethod serialize (obj (format (eql :json)) &key stream) 62 (declare (ignore format)) 64 (json-encode obj stream) 65 (with-output-to-string (s) 69 (defun json-enable-reader-macro () 70 "Set the #{ dispatch macro character for reading JSON objects." 71 (flet ((json-object-reader (stream char n) 72 (declare (ignorable char n)) 73 (let ((xs (read-delimited-list #\} stream t))) 78 ;; stop when nothing is left 79 unless (or xs key value) 80 return (make-instance 'json-object :members pairs) 82 ;; build associative list of key/value pairs 83 collect (list (princ-to-string key) value) 85 (set-dispatch-macro-character #\# #\{ #'json-object-reader) 86 (set-macro-character #\} (get-macro-character #\) nil)))) 88 (defun json-read (stream &optional (eof-error-p t) eof-value) 89 "Read a JSON object from a stream." 90 (let ((c (peek-char t stream eof-error-p :eof))) 94 ;; constants, objects, lists, and strings 95 (#\t (json-read-true stream)) 96 (#\f (json-read-false stream)) 97 (#\n (json-read-null stream)) 98 (#\{ (json-read-object stream)) 99 (#\[ (json-read-list stream)) 100 (#\" (json-read-string stream)) 102 (otherwise (json-read-number stream))))) 104 (defun json-peek-char (stream expected &key skip-ws) 105 "Peek at the next character or token and optionally error if unexpected." 106 (declare (optimize (speed 3) (debug 0))) 107 (when (equal (peek-char skip-ws stream) expected) 110 (defun json-read-char (stream expected &key skip-ws) 111 "Read the next, expected character in the stream." 112 (declare (optimize (speed 3) (debug 0))) 113 (if (json-peek-char stream expected :skip-ws skip-ws) 115 (error "JSON error: unexpected ~s" (read-char stream)))) 117 (defun json-read-true (stream) 118 "Read true from a JSON stream." 119 (json-read-char stream #\t :skip-ws t) 120 (json-read-char stream #\r) 121 (json-read-char stream #\u) 122 (json-read-char stream #\e)) 124 (defun json-read-false (stream) 125 "Read false from a JSON stream." 127 (json-read-char stream #\f :skip-ws t) 128 (json-read-char stream #\a) 129 (json-read-char stream #\l) 130 (json-read-char stream #\s) 131 (json-read-char stream #\e))) 133 (defun json-read-null (stream) 134 "Read null from a JSON stream." 136 (json-read-char stream #\n :skip-ws t) 137 (json-read-char stream #\u) 138 (json-read-char stream #\l) 139 (json-read-char stream #\l))) 141 (defun json-read-number (stream) 142 "Read a number from a JSON stream." 143 (declare (optimize (speed 3) (debug 0))) 144 (let ((s (with-output-to-string (s) 145 (when (equal (peek-char t stream) #\-) 146 (write-char (read-char stream) s)) 148 ;; read base-10 digits, fraction, and exponent 149 (labels ((read-digits () 150 (let ((c (read-char stream))) 151 (unless (digit-char-p c) 152 (error "JSON error: unexpected ~s" c)) 158 ;; next digit, test for eof 159 (unless (setf c (read-char stream nil)) 163 (unless (digit-char-p c) 164 (return (unread-char c stream)))))) 166 ;; fractional component 168 (when (equal (peek-char nil stream nil) #\.) 169 (write-char (read-char stream) s) 174 (when (equalp (peek-char nil stream nil) #\e) 175 (write-char (read-char stream) s) 178 (case (peek-char nil stream) 179 (#\- (write-char (read-char stream) s)) 180 (#\+ (write-char (read-char stream) s))) 185 ;; read each component; numbers beginning with 0 are a special case 186 (if (equalp (peek-char nil stream) #\0) 187 (write-char (read-char stream) s) 192 (read-from-string s)))) 194 (defun json-read-string (stream) 195 "Read a string from a JSON stream." 196 (declare (optimize (speed 3) (debug 0))) 198 ;; read the expected quote 199 (json-read-char stream #\" :skip-ws t) 201 ;; read into an output buffer 202 (with-output-to-string (s) 204 for c = (read-char stream) 206 ;; stop at closing quote 209 ;; write character to output 210 do (if (char/= c #\\) 212 (let ((c (case (read-char stream) 219 ;; read unicode character 220 (#\u (let ((x1 (digit-char-p (read-char stream) 16)) 221 (x2 (digit-char-p (read-char stream) 16)) 222 (x3 (digit-char-p (read-char stream) 16)) 223 (x4 (digit-char-p (read-char stream) 16))) 224 (code-char (logior (ash x1 12) 229 ;; verbatim character 231 (write-char c s)))))) 233 (defun json-read-list (stream) 234 "Read a list of JSON values." 235 (declare (optimize (speed 3) (debug 0))) 237 ;; read the expected open bracket 238 (json-read-char stream #\[ :skip-ws t) 240 ;; check for an empty list 241 (if (json-peek-char stream #\] :skip-ws t) 244 for x = (json-read stream) 248 ;; check for another element 249 while (json-peek-char stream #\, :skip-ws t) 251 ;; return the final list 252 finally (return (prog1 xs 253 (json-read-char stream #\] :skip-ws t)))))) 255 (defun json-read-object (stream) 256 "Read an associative list of key/value pairs into a JSON object." 257 (declare (optimize (speed 3) (debug 0))) 259 ;; read the expected open brace 260 (json-read-char stream #\{ :skip-ws t) 262 ;; check for an empty object 263 (if (json-peek-char stream #\} :skip-ws t) 264 (make-instance 'json-object) 266 for key = (json-read-string stream) 268 (json-read-char stream #\: :skip-ws t) 271 ;; build the associative list of members 272 collect (list key value) 275 ;; check for another element 276 while (json-peek-char stream #\, :skip-ws t) 278 ;; return the final list 279 finally (return (prog1 (make-instance 'json-object :members xs) 280 (json-read-char stream #\} :skip-ws t)))))) 282 (defmethod json-write ((value (eql t)) &optional stream) 283 "Encode the true value." 284 (declare (ignore value)) 285 (format stream "~<true~>")) 287 (defmethod json-write ((value (eql nil)) &optional stream) 288 "Encode the null constant." 289 (declare (ignore value)) 290 (format stream "~<null~>")) 292 (defmethod json-write ((value symbol) &optional stream) 293 "Encode a symbol to a stream." 294 (json-write (symbol-name value) stream)) 296 (defmethod json-write ((value number) &optional stream) 297 "Encode a number to a stream." 298 (format stream "~<~a~>" value)) 300 (defmethod json-write ((value ratio) &optional stream) 301 "Encode a ratio to a stream." 302 (format stream "~<~a~>" (float value))) 304 (defmethod json-write ((value string) &optional stream) 305 "Encode a string as a stream." 306 (flet ((encode-char (c) 308 ((char= c #\\) "\\\\") 309 ((char= c #\") "\\\"") 310 ((char= c #\newline) "\\n") 311 ((char= c #\tab) "\\t") 312 ((char= c #\formfeed) "\\f") 313 ((char= c #\backspace) "\\b") 314 ((char= c #\return) "\\r") 316 (format nil "\\u~16,4,'0r" (char-code c))) 319 (format stream "~<\"~{~a~}\"~>" (map 'list #'encode-char value)))) 321 (defmethod json-write ((value pathname) &optional stream) 322 "Encode a pathname as a stream." 323 (json-write (namestring value) stream)) 325 (defmethod json-write ((value vector) &optional stream) 326 "Encode an array to a stream." 327 (let ((*print-pretty* t) 330 (*print-right-margin* 72)) 331 (pprint-logical-block (stream nil :prefix "[" :suffix "]") 332 (when (plusp (length value)) 333 (json-write (aref value 0))) 335 for i from 1 below (length value) 337 (write-char #\, stream) 338 (pprint-newline :fill) 339 (pprint-indent :block 0) 340 (json-write (aref value i) stream)))))) 342 (defmethod json-write ((value list) &optional stream) 343 "Encode a list to a stream." 344 (let ((*print-pretty* t) 347 (*print-right-margin* 72)) 348 (pprint-logical-block (stream value :prefix "[" :suffix "]") 349 (pprint-exit-if-list-exhausted) 351 (json-write (pprint-pop) stream) 352 (pprint-exit-if-list-exhausted) 353 (write-char #\, stream) 354 (pprint-newline :fill) 355 (pprint-indent :block 0))))) 357 (defmethod json-write ((value hash-table) &optional stream) 358 "Encode a hash-table to a stream." 359 (let ((*print-pretty* t) 362 (*print-right-margin* 72)) 363 (let ((keys (loop for key being each hash-keys in value collect key))) 364 (pprint-logical-block (stream keys :prefix "{" :suffix "}") 365 (pprint-exit-if-list-exhausted) 367 (let ((key (pprint-pop))) 368 (if (not (stringp key)) 370 (warn "~s is not a valid JSON key; skipping...~%" key) 371 (pprint-exit-if-list-exhausted)) 373 (json-write key stream) 374 (write-char #\: stream) 375 (json-write (gethash key value) stream) 376 (pprint-exit-if-list-exhausted) 377 (write-char #\, stream) 378 (pprint-newline :mandatory) 379 (pprint-indent :current 0))))))))) 381 (defmethod json-write ((value json-object) &optional stream) 382 "Encode a JSON object with an associative list of members to a stream." 383 (let ((*print-pretty* t) 386 (*print-right-margin* 72)) 387 (pprint-logical-block (stream (json-object-members value) 390 (pprint-exit-if-list-exhausted) 392 (let ((kv-pair (pprint-pop))) 393 (destructuring-bind (k v) 395 (if (not (stringp k)) 397 (warn "~s is not a valid JSON key; skipping...~%" k) 398 (pprint-exit-if-list-exhausted)) 400 (json-write k stream) 401 (write-char #\: stream) 402 (json-write v stream) 403 (pprint-exit-if-list-exhausted) 404 (write-char #\, stream) 405 (pprint-newline :mandatory) 406 (pprint-indent :current 0)))))))))