clisp 之 JSON解析 V1
时间：2023-09-09 20:37:02
简单实现json字符串 解析为lisp 对象。
调用：
(whj.json:parse-json-string json-string)
(defpackage :whj.json (:use :cl :ext) (:export :parse-json-string)) ;------------------------------------------------------------------------------- (in-package :whj.json) ;------------------------------------------------------------------------------- (defun object-begin-char-p (ch) (if (member ch (list #\{ #\[)) t nil)) (defun object-end-char-p (ch) (if (member ch (list #\} #\])) t nil)) (defun whitespace-p (char) (member char '(#\tab #\space #\return #\newline))) (defun pair-chars-p (ch1 ch2) (or (and (char= ch1 #\{) (char= ch2 #\})) (and (char= ch1 #\[) (char= ch2 #\])))) (defun next-object-start-index (json-string start-index stop-index) (loop for i from start-index to stop-index for ch = (char json-string i) if (object-begin-char-p ch) do (return-from next-object-start-index i)) nil) (defun next-object-stop-index (json-string start-index stop-index) (loop for i from start-index to stop-index for ch = (char json-string i) if (object-end-char-p ch) do (return-from next-object-stop-index i)) nil) (defun nvl? (v default-value) (if v v default-value)) (defun trim-value (str) (when (char= (char str 0) #\") (setq str (subseq str 1 (1- (length str))))) str) (defun as-json-array (json-string object-index-list) (let ((arr (make-array 2 :adjustable t :fill-pointer 0)) (s 1) (e 1) (flag nil);t:标识在字段内；nil:字符开始或结束 ) (loop for i from s below (length json-string) do (progn (let ((prev-char (char json-string (1- i))) (cur-char (char json-string i))) (cond ((and (null flag) (= s e) (whitespace-p cur-char)) ;前导空白字符的忽略值 (setf s (1 i) e s)) ((and (null flag) (char= cur-char #\") (char/= prev-char #\\)) ;字符串值开始 (setf flag t s i)) ((and flag (char= cur-char #\") (char/= prev-char #\\));字符串双引号匹配结束 (setf flag nil e (1 i))) ((or (and (null flag) (char= cur-char #\,)) ;值结束 (and (null flag) (char= cur-char #\]))) (unless (= s e) (let ((val (subseq json-string s e))) (setq val (trim-value val)) (vector-push-extend val arr))) (setf s (1 i) e s)) (flag (setq e (1 i)));在值的内部，不管是不是空白字符，都需要 ((and (null flag) (not (whitespace-p cur-char))) ;值开始 (incf e) (let ((obj-index-pair (find i object-index-list :key 'car))) (when obj-index-pair ;更新下一轮循环变量 (setf flag nil s (cdr obj-index-pair) e s i s) (let ((sub-json-string (subseq json-string (car obj-index-pair) (cdr obj-index-pair)))) (vector-push-extend (parse-json-string sub-json-string) arr))))) ) ))) arr)) (defun as-json-hash (json-string object-index-list) (let ((dict (make-hash-table :test #'equal)) (s 1) (e 1) (flag nil);t:标识在字段内；nil:字符开始或结束 (key nil)) (loop for i from s below (length json-string) do (let ((prev-char (char json-string (1- i))) (cur-char (char json-string i))) (cond ((and (null flag) (= s e) (whitespace-p cur-char)) ;前导空白字符的忽略值 (setf s (1 i) e s)) ((and (null flag) (char= cur-char #\") (char/= prev-char #\\)) ;字符串值开始 (setf flag t s i)) ((and flag (char= cur-char #\") (char/= prev-char #\\));字符串双引号匹配结束 (setf flag nil e (1 i))) ((or (and (null flag) (char= cur-char #\,)) ;值结束 (and (null flag) (char= cur-char #\})) (and (null flag) (char= cur-char #\:) (char/= prev-char #\\))) (unless (= s e) (let ((val (subseq json-string s e))) (setq val (trim-value val)) (if (char= cur-char #\:) (setf key val) (setf (gethash key dict) val key nil)))) (setf s (1 i) e s)) (flag (setq e (1 i)));在值的内部，不管是不是空白字符，都需要 ((and (null flag) (not (whitespace-p cur-char))) ;值开始 (incf e) (let ((obj-index-pair (find i object-index-list :key 'car))) (when obj-index-pair ;更新下一轮循环变量 (setf flag nil s (cdr obj-index-pair) e s i s) (let ((sub-json-string (subseq json-string (car obj-index-pair) (cdr obj-index-pair)))) (setf (gethash key dict) (parse-json-string sub-json-string) key nil) )))));end cond ));end loop dict)) (defun do-prepare-json-string (json-string) (let ((result-list nil) (stack nil) (max-index (1- (length json-string)))) (do* ((s (next-object-start-index json-sting 0 max-index) (next-object-start-index json-string (1+ e) max-index))
(e (next-object-stop-index json-string (1+ s) max-index) (next-object-stop-index json-string (1+ (nvl? e max-index)) max-index)))
((null e))
(when s
(setf stack (cons (cons s (char json-string s)) stack))
;---------------------------------------------------------------
;若 s+1 和 e-1 之前还存在对象开始标志
(tagbody
next
(setf s (next-object-start-index json-string (1+ s) (1- e)))
(when s
(setf stack (cons (cons s (char json-string s)) stack))
(go next))))
;---------------------------------------------------------------
(when e
(let* ((stack-first (car stack))
(si (car stack-first))
(si-char (cdr stack-first))
(ei (1+ e)))
(when (pair-chars-p si-char (char json-string e))
(setf result-list (cons (cons (car (car stack)) (1+ e)) result-list))
(setf stack (cdr stack))
(unless (car stack)
(return-from do-prepare-json-string result-list))))))))
(defun parse-json-string (json-string)
(let ((result-list (do-prepare-json-string json-string)))
(let ((ch (char json-string (caar result-list))))
(cond
((char= ch #\[) (as-json-array json-string result-list))
((char= ch #\{) (as-json-hash json-string result-list))
(t (error "not impl.~a" ch))))))
;-------------------------------------------------------------------------------
;#(" tenis " "football" "1" "4")
(defun test-01 nil
(setf str "[\" tenis \" , \"football\",1, , 4 ]")
(let ((result-list (do-prepare-json-string str)))
(as-json-array str result-list)))
;((0 . 48) (32 . 39))
(defun test-02 nil
(setf str02 "[\" tenis \" , \"football\",1, , [1,5,9] ]")
(do-prepare-json-string str02))
;array
;#(" tenis " "football" "1" #("1" "5" "9"))
(defun test-03 nil
(setf str03 "[\" tenis \" , \"football\",1, ,[1,5,9] ]")
(let ((result-list (do-prepare-json-string str03)))
(as-json-array str03 result-list)))
;hash
;#S(HASH-TABLE :TEST FASTHASH-EQUAL ("age" . "24") ("name" . "jxj"))
(defun test-04 nil
(setf str04 "{\"name\":\"jxj\",\"age\":24}")
(parse-json-string str04))
;#S(HASH-TABLE :TEST FASTHASH-EQUAL ("hobb" . #("tenis" "football")) ("score" . #S(HASH-TABLE :TEST FASTHASH-EQUAL ("eng" . "A") ("math" . "99"))) ("age" . "24") ("name" . "jxj"))
(defun test-05 nil
(setf str "{\"name\":\"jxj\",\"age\":24,\"score\":{\"math\":99,\"eng\":\"A\"},\"hobb\":[\"tenis\",\"football\"]}")
(parse-json-string str))
;-------------------------------------------------------------------------------
(setf (ext:package-lock :whj.json) t)
;-------------------------------------------------------------------------------
