之前曾写过一次JSON解析，借助了读取器的功能，可惜效果不太令人满意。今天闲来无事，实现原生解析。
本次实现有以下缺限：
1、没有充分优化代码
2、没有考虑转义字符解析（待后续实现）
;JSON 解析 WHJ.V1.20200119
;--------------------------------------------------------------------------------------------
;JSON object
(defclass JSON-OBJECT nil((parent :initarg :parent:accessor parent:initform nil)(object-type :initarg :object-type:accessor object-type)))
;atom
(defclass JSON-ATOM (JSON-OBJECT)((value :initarg :value:accessor value)))
;key:value
(defclass JSON-KV (JSON-OBJECT)((key :initarg :key:accessor key)(value :initarg :value:accessor value)))
;hash object
(defclass JSON-HASH (JSON-OBJECT)((kv-list :initarg :kv-list:accessor kv-list)))
;json array
(defclass JSON-ARRAY (JSON-OBJECT)((value-list :initarg :value-list:accessor value-list)))(defun json-object-p (obj)(member (type-of obj) '(JSON-OBJECT JSON-ATOM JSON-KV JSON-ARRAY JSON-HASH)))
;--------------------------------------------------------------------------------------------
(defgeneric read-json-object (JSON-OBJECT IN-STREAM));从流中读取对象
(defgeneric add-json-object (PARENT CHILD));将child对象添加到parent中
(defgeneric json-object-empty-p (JSON-OBJECT));对象是否为空
(defgeneric json-object-string (JSON-OBJECT));转换为字符串格式
;--------------------------------------------------------------------------------------------
;;;; read until char.
(defun read-until (IN-STREAM CHAR)(let ((char-array (make-array 20 :adjustable t :fill-pointer 0)))(do ((x (read-char IN-STREAM nil nil) (read-char IN-STREAM nil nil)))((or (null x) (char= x CHAR)))(vector-push-extend x char-array))(coerce char-array 'string)))
(defun whitespace-p (char)(member char '(#\tab #\space #\return #\newline)))
;;;; 忽略流中的空白字符
(defun read-skip-whitespace (IN-STREAM)(let ((char-array (make-array 20 :adjustable t :fill-pointer 0))(tmp-char nil))(psetq tmp-char (read-char IN-STREAM nil nil))(do nil((or (null tmp-char) (not (whitespace-p tmp-char))))(vector-push-extend tmp-char char-array)(psetq tmp-char (read-char IN-STREAM nil nil)))(when tmp-char(unread-char tmp-char IN-STREAM))(coerce char-array 'string)))
;;;; 判断下一个读取的值的类型.当 value-p 为t时说明是一个原子类型
(defun next-object-type (IN-STREAM &key (value-p nil))(read-skip-whitespace IN-STREAM); skip whitespace(let ((char (read-char IN-STREAM nil nil)))(prog1(cond((null char) 'JSON-ATOM);读取完毕((char= char #\{) 'JSON-HASH)((char= char #\[) 'JSON-ARRAY)(value-p 'JSON-ATOM)(t 'JSON-KV))(when char (unread-char char IN-STREAM)))))
(defun read-object-value (IN-STREAM)(let ((char-array (make-array 20 :adjustable t :fill-pointer 0))(tmp-char nil))(psetq tmp-char (read-char IN-STREAM nil))(do nil((or (null tmp-char) (member tmp-char '(#\, #\} #\]))))(vector-push-extend tmp-char char-array)(psetq tmp-char (read-char IN-STREAM nil)))(coerce char-array 'string)))
;--------------------------------------------------------------------------------------------
(defmethod initialize-instance :after ((obj JSON-ATOM) &key)(setf (object-type obj) 'JSON-ATOM))
(defmethod initialize-instance :after ((kv JSON-KV) &key)(setf (object-type kv) 'JSON-KV))
(defmethod initialize-instance :after ((hash JSON-HASH) &key)(setf (object-type hash) 'JSON-HASH(kv-list hash) (make-array 10 :adjustable t :fill-pointer 0)))
(defmethod initialize-instance :after ((arr JSON-ARRAY) &key)(setf (object-type arr) 'JSON-ARRAY(value-list arr) (make-array 10 :adjustable t :fill-pointer 0)))
;--------------------------------------------------------------------------------------------
(defmethod json-object-empty-p ((obj JSON-ATOM))(let ((value (value obj)))(or (null value) (string= value ""))))
(defmethod json-object-empty-p ((kv JSON-KV))(let ((key (key kv)))(or (null key) (string= key ""))))
(defmethod json-object-empty-p ((hash JSON-HASH))(= (length (kv-list hash)) 0))
(defmethod json-object-empty-p ((arr JSON-ARRAY))(= (length (value-list arr)) 0))(defmethod read-json-object ((obj JSON-ATOM) IN-STREAM)(setf (value kv) (read-object-value IN-STREAM)))
(defmethod read-json-object ((kv JSON-KV) IN-STREAM)(setf (key kv) (read-until IN-STREAM #\:)(value kv) (read-until IN-STREAM #\,)))(defmethod read-json-object ((arr JSON-ARRAY) IN-STREAM)(read-char IN-STREAM);ignore "["(read-skip-whitespace IN-STREAM); ignore whitespace(do nil(nil)(let ((tmp-item nil))(psetq tmp-item (read-json-object (make-instance (next-object-type IN-STREAM :value-p t) :parent arr) IN-STREAM))(read-skip-whitespace IN-STREAM); ignore whitespace(cond((and (stringp tmp-item) (string= tmp-item ""))(return))((and (json-object-p tmp-item) (json-object-empty-p tmp-item))(return))(t (add-json-object arr tmp-item)))))arr)
(defmethod read-json-object ((hash JSON-HASH) IN-STREAM)(read-char IN-STREAM);ignore "{"(read-skip-whitespace IN-STREAM); ignore whitespace(do nil(nil)(let ((kv (make-instance 'json-kv :parent hash)))(setf (key kv) (read-until IN-STREAM #\:))(when (json-object-empty-p kv) (return))(setf (value kv) (read-json-object (make-instance (next-object-type IN-STREAM :value-p t) :parent hash) IN-STREAM))(add-json-object hash kv))(read-skip-whitespace IN-STREAM) (let ((tmp-char (read-char IN-STREAM nil)))(cond ((null tmp-char) (return))((member tmp-char '(#\, #\] #\})) (return))))); (t (unread-char tmp-char IN-STREAM)))))hash);--------------------------------------------------------------------------------------------
;add child into parent json-hash-object
(defmethod add-json-object ((PARENT JSON-HASH) (CHILD JSON-OBJECT))(setf (parent CHILD) PARENT)(vector-push-extend CHILD (kv-list PARENT)))
(defmethod add-json-object ((PARENT JSON-ARRAY) (CHILD JSON-OBJECT))(setf (parent CHILD) PARENT)(vector-push-extend CHILD (value-list PARENT)))
(defmethod add-json-object ((PARENT JSON-ARRAY) CHILD)(vector-push-extend CHILD (value-list PARENT)))
;--------------------------------------------------------------------------------------------
;for test function
(defmethod json-object-string ((obj JSON-KV))(format nil "<~a ~a ~a ~a>" (object-type obj) (parent obj) (key obj) (value obj)))
(defmethod json-object-string ((obj JSON-ARRAY))(format nil "<~a ~a ~a>" (object-type obj) (parent obj) (value-list obj)))
(defmethod json-object-string ((obj JSON-HASH))(format nil "<~a ~a ~a>" (object-type obj) (parent obj) (kv-list obj)))
;--------------------------------------------------------------------------------------------
;for test examples.
(defun test nil(loop for i from 1 to 9collect (funcall (intern (format nil "TEST-~d" i)))))(defun test-1 nil (let ((in (make-string-input-stream "{\"Wang\":123,\"ok\":\"test\"}")))(unwind-protect(read-json-object (make-instance (next-object-type in) :parent nil) in)(close in))))
(defun test-2 nil(let ((in (make-string-input-stream "{\"Wang\":[1,2,3,4],\"ok\":[\"test\"]}")))(unwind-protect(read-json-object (make-instance (next-object-type in) :parent nil) in)(close in))))(defun test-3 nil(let ((in (make-string-input-stream "[1,2,3,4,\"test\"]")))(unwind-protect(read-json-object (make-instance (next-object-type in) :parent nil) in)(close in))))
(defun test-4 nil(let ((in (make-string-input-stream "[[1,2,3,4,\"test\"]]")))(unwind-protect(read-json-object (make-instance (next-object-type in) :parent nil) in)(close in))))
(defun test-5 nil(let ((in (make-string-input-stream "[[1,2,3,{test:check it},\"test\"]]")))(unwind-protect(read-json-object (make-instance (next-object-type in) :parent nil) in)(close in))))
(defun test-6 nil(let ((in (make-string-input-stream "[1,[2,3],{test:check it},\"test\"]")))(unwind-protect(read-json-object (make-instance (next-object-type in) :parent nil) in)(close in))))
(defun test-7 nil(let ((in (make-string-input-stream "[{test:check it},\"test\"]")))(unwind-protect(read-json-object (make-instance (next-object-type in) :parent nil) in)(close in))))(defun test-8 nil(let ((in (make-string-input-stream "[{ test:[check, it]},\"test\"]")))(unwind-protect(read-json-object (make-instance (next-object-type in) :parent nil) in)(close in))))
(defun test-9 nil(let ((in (make-string-input-stream "{ ok: { test:[check, it]},\"test\":123}")))(unwind-protect(read-json-object (make-instance (next-object-type in) :parent nil) in)(close in))))
;--------------------------------------------------------------------------------------------