├── test ├── package.lisp ├── test-top-page.lisp ├── test0.lisp ├── test2.lisp ├── util.lisp ├── reader.lisp ├── test-trivial-json-codec.lisp ├── test3.lisp ├── test4.lisp ├── test1.lisp └── test-utils.lisp ├── src ├── support.lisp ├── support_json-lib.lisp ├── support_com-inuoe-jzon.lisp ├── support_shasht.lisp ├── support_yason.lisp ├── support_jonathan.lisp ├── support_com-gigamonkeys-json.lisp ├── package.lisp ├── support_cl-json.lisp ├── support_st-json.lisp ├── support_jsown.lisp ├── support_boost-json.lisp ├── condition.lisp ├── support_json-streams.lisp ├── support_trivial-json-codec.lisp ├── util.lisp ├── interface.lisp ├── parser.lisp └── traversal.lisp ├── .gitignore ├── LICENSE ├── .github ├── workflows │ ├── macos-load.yml │ ├── linux-load.yml │ └── linux-sbcl-testSystem.yml └── disabled-workflows │ └── windows-load.yml ├── synonyms └── synonyms.lisp ├── cl-json-pointer-test.asd ├── cl-json-pointer.asd └── README.md /test/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :cl-json-pointer/test 4 | (:use :cl :cl-json-pointer) 5 | (:use :alexandria :named-readtables) 6 | (:export 7 | #:run)) 8 | -------------------------------------------------------------------------------- /src/support.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (defvar *cl-json-pointer-supported-json-flavors* nil 4 | "Holds symbols acceptable by `*json-object-flavor*' and :FLAVOR keyword argument (except `T')") 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | *.dfsl 5 | *.pfsl 6 | *.d64fsl 7 | *.p64fsl 8 | *.lx64fsl 9 | *.lx32fsl 10 | *.dx64fsl 11 | *.dx32fsl 12 | *.fx64fsl 13 | *.fx32fsl 14 | *.sx64fsl 15 | *.sx32fsl 16 | *.wx64fsl 17 | *.wx32fsl 18 | -------------------------------------------------------------------------------- /src/support_json-lib.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | ;;; json-lib does not use lists for objects nor arrays by default. 4 | ;;; I don't need to customize list traversal methods. 5 | 6 | (pushnew :json-lib *cl-json-pointer-supported-json-flavors*) 7 | -------------------------------------------------------------------------------- /src/support_com-inuoe-jzon.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | ;;; com.inuoe.jzon does not use lists for objects nor arrays. So I 4 | ;;; don't need to customize list traversal methods. 5 | 6 | (pushnew :com.inuoe.jzon *cl-json-pointer-supported-json-flavors*) 7 | -------------------------------------------------------------------------------- /src/support_shasht.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | ;;; shasht does not use lists for objects nor arrays by default. 4 | ;;; 5 | ;;; And shasht can be use lists by changing the mappings. I think the 6 | ;;; default traversal methods in cl-json-pointer can treat them. 7 | 8 | (pushnew :shasht *cl-json-pointer-supported-json-flavors*) 9 | -------------------------------------------------------------------------------- /src/support_yason.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (defmethod traverse-by-reference-token 4 | ((flavor (eql :yason)) (obj list) (rtoken string) set-method next-setter) 5 | ;; An optimization -- don't consider plist. 6 | (list-try-traverse '(:alist) flavor obj rtoken set-method next-setter)) 7 | 8 | (pushnew :yason *cl-json-pointer-supported-json-flavors*) 9 | -------------------------------------------------------------------------------- /src/support_jonathan.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | ;;; TODO: support :AS flavors 4 | (defmethod traverse-by-reference-token 5 | ((flavor (eql :jonathan)) (obj null) rtoken set-method next-setter) 6 | (declare (ignorable rtoken set-method next-setter)) 7 | (let ((*traverse-nil-set-to-name-method* :plist)) ; default plist one. 8 | (call-next-method))) 9 | 10 | (defmethod intern-object-key ((flavor (eql :jonathan)) rtoken) 11 | (intern rtoken (find-package :keyword))) 12 | 13 | (pushnew :jonathan *cl-json-pointer-supported-json-flavors*) 14 | -------------------------------------------------------------------------------- /src/support_com-gigamonkeys-json.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (defmethod traverse-by-reference-token 4 | ((flavor (eql :com.gigamonkeys.json)) (obj list) (rtoken string) set-method next-setter) 5 | ;; An optimization -- don't consider alist. 6 | (list-try-traverse '(:plist) flavor obj rtoken set-method next-setter)) 7 | 8 | (defmethod traverse-by-reference-token 9 | ((flavor (eql :com.gigamonkeys.json)) (obj null) rtoken set-method next-setter) 10 | (declare (ignorable rtoken set-method next-setter)) 11 | (let ((*traverse-nil-set-to-name-method* :plist)) 12 | (call-next-method))) 13 | 14 | (pushnew :com.gigamonkeys.json *cl-json-pointer-supported-json-flavors*) 15 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage #:cl-json-pointer 4 | (:use :cl) 5 | (:use #:alexandria) 6 | (:import-from #:closer-mop 7 | #:class-slots 8 | #:slot-definition-name 9 | #:slot-boundp-using-class 10 | #:slot-value-using-class 11 | #:slot-makunbound-using-class) 12 | (:export 13 | #:json-pointer-error 14 | #:*json-object-flavor* 15 | #:*cl-json-pointer-supported-json-flavors* 16 | #:parse-json-pointer 17 | #:get-by-json-pointer 18 | #:exists-p-by-json-pointer 19 | #:set-by-json-pointer 20 | #:add-by-json-pointer 21 | #:delete-by-json-pointer 22 | #:remove-by-json-pointer 23 | #:update-by-json-pointer 24 | #:deletef-by-json-pointer)) 25 | -------------------------------------------------------------------------------- /src/support_cl-json.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (define-constant +identifier-name-to-key-name+ 4 | (symbol-name '*identifier-name-to-key*) 5 | :test #'equal) 6 | 7 | (define-constant +json-identifier-name-to-lisp-name+ 8 | (symbol-name '*json-identifier-name-to-lisp*) 9 | :test #'equal) 10 | 11 | (defmethod intern-object-key ((flavor (eql :cl-json)) rtoken) 12 | ;; Do Like: 13 | ;; (funcall cl-json:*identifier-name-to-key* 14 | ;; (funcall cl-json:*json-identifier-name-to-lisp* rtoken))) 15 | (when-let* ((cl-json-package (find-package :cl-json)) 16 | (i-n-t-k-symbol (find-symbol +identifier-name-to-key-name+ 17 | cl-json-package)) 18 | (j-i-n-t-l-symbol (find-symbol +json-identifier-name-to-lisp-name+ 19 | cl-json-package))) 20 | (return-from intern-object-key 21 | (funcall (symbol-value i-n-t-k-symbol) 22 | (funcall (symbol-value j-i-n-t-l-symbol) rtoken)))) 23 | (call-next-method)) 24 | 25 | (pushnew :cl-json *cl-json-pointer-supported-json-flavors*) 26 | -------------------------------------------------------------------------------- /src/support_st-json.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (defmethod traverse-by-reference-token 4 | (flavor 5 | (obj st-json:jso) ; ST-JSON support is separated, for hooking the structure here. 6 | rtoken set-method next-setter) 7 | (declare (ignorable flavor)) 8 | (multiple-value-bind (val exists) 9 | (st-json:getjso rtoken obj) 10 | (values val exists 11 | (ecase set-method 12 | ((nil) nil) 13 | ((:update :add) 14 | (chained-setter-lambda (x) (next-setter obj) 15 | (setf (st-json:getjso rtoken obj) x))) 16 | ((:delete :remove) 17 | (chained-setter-lambda () (next-setter obj) 18 | ;; FIXME: This code uses internal symbol.. 19 | (let* ((internal-alist (st-json::jso-alist obj)) 20 | (alist-setter 21 | (nth-value 2 (traverse-by-reference-token 22 | :alist internal-alist rtoken set-method 23 | (lambda (x) 24 | (setf (st-json::jso-alist obj) x)))))) 25 | (funcall alist-setter)))))))) 26 | 27 | (pushnew :st-json *cl-json-pointer-supported-json-flavors*) 28 | -------------------------------------------------------------------------------- /src/support_jsown.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (defmethod traverse-by-reference-token ((flavor (eql :jsown)) (obj list) 4 | (rtoken string) set-method next-setter) 5 | (if (eq (car obj) :OBJ) 6 | (traverse-by-reference-token :alist (cdr obj) 7 | (intern-object-key flavor rtoken) 8 | set-method 9 | (chained-setter-lambda (x) (next-setter obj) 10 | (setf (cdr obj) x))) 11 | (call-next-method))) 12 | 13 | (defmethod traverse-by-reference-token ((flavor (eql :jsown)) (obj null) 14 | rtoken set-method next-setter) 15 | (cond ((null set-method) 16 | (values nil nil nil)) 17 | ((read-reference-token-as-index rtoken nil) 18 | (call-next-method)) 19 | (t 20 | (values nil nil 21 | (ecase set-method 22 | ((:delete :remove) 23 | (thunk-lambda 24 | (bad-deleter-error obj rtoken))) 25 | ((:update :add) 26 | (chained-setter-lambda (x) (next-setter) 27 | `(:OBJ (,(intern-object-key flavor rtoken) . ,x))))))))) 28 | 29 | (pushnew :jsown *cl-json-pointer-supported-json-flavors*) 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 YOKOTA Yuki 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/support_boost-json.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | ;; boost-json has its own CLOS class to handle JSON objects. 4 | 5 | (defmethod traverse-by-reference-token (flavor (obj boost-json:json-object) 6 | rtoken set-method next-setter) 7 | (declare (ignorable flavor)) 8 | (multiple-value-bind (val exists) 9 | (boost-json:json-getf obj rtoken) 10 | (values val exists 11 | (ecase set-method 12 | ((nil) nil) 13 | ((:update :add) 14 | (chained-setter-lambda (x) (next-setter obj) 15 | (boost-json:json-setf obj rtoken x))) 16 | ((:delete :remove) 17 | (chained-setter-lambda () (next-setter obj) 18 | ;; This code potion is almost same with ST-JSON support. 19 | (let* ((internal-alist (boost-json:json-object-members obj)) 20 | (alist-setter 21 | (nth-value 2 (traverse-by-reference-token 22 | :alist internal-alist rtoken set-method 23 | (lambda (updated-alist) 24 | (setf (boost-json:json-object-members obj) updated-alist)))))) 25 | (funcall alist-setter)))))))) 26 | 27 | (pushnew :st-json *cl-json-pointer-supported-json-flavors*) 28 | -------------------------------------------------------------------------------- /src/condition.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (define-condition json-pointer-error (simple-error) 4 | () 5 | (:documentation "The root object of all errors related to cl-json-pointer")) 6 | 7 | (define-condition json-pointer-parse-error (json-pointer-error) 8 | () 9 | (:documentation "Thrown by `parse-json-pointer'")) 10 | 11 | (define-condition json-pointer-bad-reference-token-error (json-pointer-error) 12 | ((rtoken :initarg :reference-token :initform nil)) 13 | (:report (lambda (c stream) 14 | (format stream (simple-condition-format-control c) 15 | (slot-value c 'rtoken)))) 16 | (:documentation "Errors related to the json-pointer syntax") 17 | (:default-initargs 18 | :format-control "Bad reference token (~A)")) 19 | 20 | (define-condition json-pointer-bad-reference-token-0-used-error (json-pointer-bad-reference-token-error) 21 | () 22 | (:default-initargs 23 | :format-control "reference token (~A) must not start with '0' when used as an index")) 24 | 25 | (define-condition json-pointer-bad-reference-token-not-numeric-error (json-pointer-bad-reference-token-error) 26 | () 27 | (:default-initargs 28 | :format-control "reference token (~A) cannot be read as index")) 29 | 30 | (define-condition json-pointer-access-error (json-pointer-error) 31 | () 32 | (:documentation "Errors at traversing an object")) 33 | -------------------------------------------------------------------------------- /test/test-top-page.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer/test) 2 | 3 | ;;; my top page 4 | (defparameter *rfc6901-example* 5 | "{ 6 | \"foo\": [\"bar\", \"baz\"], 7 | \"\": 0, 8 | \"a/b\": 1, 9 | \"c%d\": 2, 10 | \"e^f\": 3, 11 | \"g|h\": 4, 12 | \"i\\\\j\": 5, 13 | \"k\\\"l\": 6, 14 | \" \": 7, 15 | \"m~n\": 8 16 | }") 17 | 18 | ;; This test is intended only for `cl-json'. 19 | (defun test-top-page () 20 | (let ((obj (cl-json:decode-json-from-string *rfc6901-example*))) 21 | (1am:is (eql obj (get-by-json-pointer obj ""))) 22 | (1am:is (equalp (get-by-json-pointer obj "/foo") '("bar" "baz"))) 23 | (1am:is (equal (get-by-json-pointer obj "/foo/0") "bar")) 24 | (1am:is (equal (get-by-json-pointer obj "/") 0)) 25 | (1am:is (equal (get-by-json-pointer obj "/a~1b") 1)) 26 | (1am:is (equal (get-by-json-pointer obj "/c%d") 2)) 27 | (1am:is (equal (get-by-json-pointer obj "/e^f") 3)) 28 | (1am:is (equal (get-by-json-pointer obj "/g|h") 4)) 29 | (1am:is (equal (get-by-json-pointer obj "/i\\j") 5)) 30 | (1am:is (equal (get-by-json-pointer obj "/k\"l") 6)) 31 | (1am:is (equal (get-by-json-pointer obj "/ ") 7)) 32 | (1am:is (equal (get-by-json-pointer obj "/m~0n") 8)))) 33 | 34 | (1am:test test-top-page-runner 35 | (when (eq *current-json-reader* 'cl-json:decode-json-from-string) 36 | (test-top-page))) 37 | -------------------------------------------------------------------------------- /.github/workflows/macos-load.yml: -------------------------------------------------------------------------------- 1 | name: macos-load 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | name: ${{ matrix.lisp }} 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | lisp: [sbcl-bin, ccl] 16 | 17 | runs-on: macos-latest 18 | 19 | steps: 20 | - uses: actions/checkout@v2 21 | 22 | - name: install roswell 23 | shell: bash 24 | env: 25 | LISP: ${{ matrix.lisp }} 26 | run: curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh -x 27 | 28 | - name: run lisp 29 | continue-on-error: true 30 | shell: bash 31 | run: | 32 | ros -e '(format t "~a:~a on ~a~%...~%~%" (lisp-implementation-type) (lisp-implementation-version) (machine-type))' 33 | 34 | - name: update ql dist if we have one cached 35 | shell: bash 36 | run: ros -e "(ql:update-all-dists :prompt nil)" 37 | 38 | - name: Load trivial-backtrace to cache it 39 | shell: sh 40 | run: ros -e "(ql:quickload :trivial-backtrace)" 41 | 42 | - name: Quickload and run asdf:test-system 43 | shell: sh 44 | run: | 45 | ros -e '(ql:quickload :trivial-backtrace)' -e '(handler-bind ((error (lambda (e) (format t "Caught error ~a" e) (trivial-backtrace:print-backtrace e) (uiop:quit 123)))) (asdf:load-asd "cl-json-pointer.asd") (ql:quickload :cl-json-pointer))' 46 | -------------------------------------------------------------------------------- /.github/workflows/linux-load.yml: -------------------------------------------------------------------------------- 1 | name: linux-load 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | name: ${{ matrix.lisp }} 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | lisp: [sbcl-bin, ccl, allegro, cmucl, ecl ] 16 | # clisp, abcl -- Roswell cannot install them. 17 | 18 | runs-on: ubuntu-latest 19 | 20 | steps: 21 | - uses: actions/checkout@v2 22 | 23 | - name: install roswell 24 | shell: sh 25 | env: 26 | LISP: ${{ matrix.lisp }} 27 | run: curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh -x 28 | 29 | - name: run lisp 30 | continue-on-error: true 31 | shell: sh 32 | run: | 33 | ros -e '(format t "~a:~a on ~a~%...~%~%" (lisp-implementation-type) (lisp-implementation-version) (machine-type)) ' 34 | 35 | - name: update ql dist if we have one cached 36 | shell: sh 37 | run: ros -e "(ql:update-all-dists :prompt nil)" 38 | 39 | - name: Load trivial-backtrace to cache it 40 | shell: sh 41 | run: ros -e "(ql:quickload :trivial-backtrace)" 42 | 43 | - name: Quickload and run asdf:test-system 44 | shell: sh 45 | run: | 46 | ros -e '(ql:quickload :trivial-backtrace)' -e '(handler-bind ((error (lambda (e) (format t "Caught error ~a" e) (trivial-backtrace:print-backtrace e) (uiop:quit 123)))) (asdf:load-asd "cl-json-pointer.asd") (ql:quickload :cl-json-pointer))' 47 | -------------------------------------------------------------------------------- /src/support_json-streams.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (defmethod traverse-by-reference-token ((flavor (eql :json-streams)) (obj list) 4 | (rtoken string) set-method next-setter) 5 | (case (car obj) 6 | (:object 7 | (traverse-by-reference-token :alist (cdr obj) 8 | (intern-object-key flavor rtoken) 9 | set-method 10 | (chained-setter-lambda (x) (next-setter obj) 11 | (setf (cdr obj) x)))) 12 | (:array 13 | (traverse-by-reference-token :list (cdr obj) 14 | rtoken set-method 15 | (chained-setter-lambda (x) (next-setter obj) 16 | (setf (cdr obj) x)))) 17 | (t 18 | (call-next-method)))) 19 | 20 | (defmethod traverse-by-reference-token ((flavor (eql :json-streams)) (obj null) 21 | rtoken set-method next-setter) 22 | (cond ((null set-method) 23 | (values nil nil nil)) 24 | ((member set-method '(:delete :remove)) 25 | (values nil nil 26 | (thunk-lambda 27 | (bad-deleter-error obj rtoken)))) 28 | (t 29 | (if-let ((index (read-reference-token-as-index rtoken nil))) 30 | (values nil nil 31 | (lambda (x) 32 | (let* ((tmp nil) 33 | (internal-setter 34 | (nth-value 2 (traverse-by-reference-token 35 | :list nil index set-method 36 | (lambda (x) 37 | (setf tmp x)))))) 38 | (funcall internal-setter x) ; TMP gains the newly created list. 39 | (funcall next-setter (list* :array tmp))))) 40 | (values nil nil 41 | (chained-setter-lambda (x) (next-setter) 42 | `(:object (,(intern-object-key flavor rtoken) . ,x)))))))) 43 | 44 | (pushnew :json-streams *cl-json-pointer-supported-json-flavors*) 45 | -------------------------------------------------------------------------------- /.github/workflows/linux-sbcl-testSystem.yml: -------------------------------------------------------------------------------- 1 | # Test for all branches -- try SBCL on Linux, which is required to be in Quicklisp repo. 2 | 3 | name: linux-sbcl-testSystem 4 | 5 | on: 6 | push: 7 | pull_request: 8 | branches: [ master ] 9 | 10 | jobs: 11 | build: 12 | name: ${{ matrix.lisp }} 13 | strategy: 14 | fail-fast: false 15 | matrix: 16 | # 'sbcl-bin/2.0.5' and 'sbcl-bin/2.2.3' are for Quicklisp build. 17 | lisp: [sbcl-bin/2.0.5, sbcl-bin/2.2.3] 18 | 19 | runs-on: ubuntu-latest 20 | 21 | steps: 22 | - uses: actions/checkout@v2 23 | 24 | - name: install roswell 25 | shell: sh 26 | env: 27 | LISP: ${{ matrix.lisp }} 28 | run: curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh -x 29 | 30 | - name: run lisp 31 | continue-on-error: true 32 | shell: sh 33 | run: | 34 | ros -e '(format t "~a:~a on ~a~%...~%~%" (lisp-implementation-type) (lisp-implementation-version) (machine-type)) ' 35 | 36 | - name: update ql dist if we have one cached 37 | shell: sh 38 | run: ros -e "(ql:update-all-dists :prompt nil)" 39 | 40 | - name: Load some libs to cache it 41 | shell: sh 42 | run: ros -e "(ql:quickload :trivial-backtrace) (ql:quickload :st-json)" 43 | 44 | - name: Quickload and run asdf:test-system 45 | shell: sh 46 | run: | 47 | ros -e '(ql:quickload :trivial-backtrace)' -e '(handler-bind ((error (lambda (e) (format t "Caught error ~a" e) (trivial-backtrace:print-backtrace e) (uiop:quit 123)))) (asdf:load-asd "cl-json-pointer.asd") (ql:quickload :cl-json-pointer) (asdf:load-asd "cl-json-pointer-test.asd") (ql:quickload :cl-json-pointer/test) (asdf:test-system :cl-json-pointer))' 48 | -------------------------------------------------------------------------------- /.github/disabled-workflows/windows-load.yml: -------------------------------------------------------------------------------- 1 | name: windows-load 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | name: ${{ matrix.lisp }} 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | lisp: [sbcl-bin, ccl] 16 | 17 | runs-on: windows-latest 18 | 19 | steps: 20 | - name: windows specific settings 21 | # https://dev.classmethod.jp/articles/replace-deprecated-method-on-actions/ 22 | run: | 23 | git config --global core.autocrlf false 24 | echo "ROSWELL_INSTALL_DIR=~/ros" >> $GITHUB_ENV 25 | echo "~/ros/bin" >> $GITHUB_PATH 26 | 27 | - uses: actions/checkout@v2 28 | 29 | - name: install roswell 30 | shell: sh 31 | env: 32 | LISP: ${{ matrix.lisp }} 33 | run: curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh -x 34 | 35 | - name: run lisp 36 | continue-on-error: true 37 | shell: sh 38 | run: | 39 | ros -e '(format t "~a:~a on ~a~%...~%~%" (lisp-implementation-type) (lisp-implementation-version) (machine-type)) ' 40 | 41 | - name: update ql dist if we have one cached 42 | shell: sh 43 | run: ros -e "(ql:update-all-dists :prompt nil)" 44 | 45 | - name: Load trivial-backtrace to cache it 46 | shell: sh 47 | run: ros -e "(ql:quickload :trivial-backtrace)" 48 | 49 | - name: Quickload and run asdf:test-system 50 | shell: sh 51 | run: | 52 | ros -e '(ql:quickload :trivial-backtrace)' -e '(handler-bind ((error (lambda (e) (format t "Caught error ~a" e) (trivial-backtrace:print-backtrace e) (uiop:quit 123)))) (asdf:load-asd "cl-json-pointer.asd") (ql:quickload :cl-json-pointer))' 53 | -------------------------------------------------------------------------------- /synonyms/synonyms.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:cl-json-pointer/synonyms 2 | (:nicknames :cljsp) ; I worry about name conflict... 3 | (:documentation "Provide synonyms of cl-json-pointer package, for convenience.") 4 | (:use :cl #:cl-json-pointer) 5 | (:shadow #:get #:set #:delete #:remove) 6 | (:export 7 | #:json-pointer-error 8 | #:parse #:get #:exists-p #:set #:add #:delete #:remove #:update #:deletef)) 9 | 10 | (in-package :cl-json-pointer/synonyms) 11 | 12 | (defmacro defsynonym-cljsp-func (name (func &rest required-args)) 13 | "Defines a function named by NAME as a synonym of FUNC. 14 | REQUIRED-ARGS are required arguments of FUNC. 15 | (The reason why this is required is mainly for 'slime-autodoc'.)" 16 | `(progn (declaim (inline ,name)) 17 | (defun ,name (,@required-args &rest keyargs &key &allow-other-keys) 18 | (apply #',func ,@required-args keyargs)))) 19 | 20 | (defsynonym-cljsp-func parse (parse-json-pointer obj)) 21 | 22 | (defsynonym-cljsp-func get (get-by-json-pointer obj pointer)) 23 | 24 | (defsynonym-cljsp-func exists-p (exists-p-by-json-pointer obj pointer)) 25 | 26 | (defsynonym-cljsp-func set (set-by-json-pointer obj pointer value)) 27 | 28 | (defsynonym-cljsp-func add (add-by-json-pointer obj pointer value)) 29 | 30 | (defsynonym-cljsp-func delete (delete-by-json-pointer obj pointer)) 31 | 32 | (defsynonym-cljsp-func remove (remove-by-json-pointer obj pointer)) 33 | 34 | (define-setf-expander get (obj pointer &rest args &key &allow-other-keys &environment env) 35 | (get-setf-expansion `(get-by-json-pointer ,obj ,pointer ,@args) env)) 36 | 37 | (defmacro update (obj pointer value &rest keyargs &key &allow-other-keys) 38 | `(update-by-json-pointer ,obj ,pointer ,value ,@keyargs)) 39 | 40 | (defmacro deletef (obj pointer &rest keyargs &key &allow-other-keys) 41 | `(deletef-by-json-pointer ,obj ,pointer ,@keyargs)) 42 | -------------------------------------------------------------------------------- /cl-json-pointer-test.asd: -------------------------------------------------------------------------------- 1 | ;;; Some libs are not in Quicklisp. 2 | (eval-when (:compile-toplevel :load-toplevel :execute) 3 | (when (find-system :com.inuoe.jzon nil) 4 | (pushnew :cl-json-pointer/test/com.inuoe.jzon *features*)) 5 | (when (find-system :json-lib nil) 6 | (pushnew :cl-json-pointer/test/json-lib *features*))) 7 | 8 | (defsystem #:cl-json-pointer/test 9 | :description "Tests for cl-json-pointer." 10 | :licence "MIT" 11 | :author "YOKOTA Yuki " 12 | :depends-on (#:cl-json-pointer 13 | #:cl-json-pointer/synonyms 14 | ;; test libs 15 | #:named-readtables #:1am 16 | ;; All Json libs and platform supports (alphabetical order) 17 | (:feature :cl-json-pointer/boost-json-support #:cl-json-pointer/boost-json-support) ; not in Quicklisp. 18 | #:cl-json 19 | #:com.gigamonkeys.json 20 | (:feature :cl-json-pointer/test/com.inuoe.jzon #:com.inuoe.jzon) ; not in Quicklisp. 21 | #:jonathan ; I surprised this lib has 8 dependencies. 22 | (:feature :cl-json-pointer/test/json-lib #:json-lib) ; not in Quicklisp. 23 | #:json-streams 24 | #:jsown 25 | #:shasht 26 | #:cl-json-pointer/st-json-support ; st-json 27 | #:trivial-json-codec 28 | #:yason 29 | ;; Not supported 30 | ;; #:define-json-expander #:json-mop 31 | ) 32 | :serial t 33 | :components 34 | ((:module "test" 35 | :serial t 36 | :components 37 | ((:file "package") 38 | (:file "util") 39 | ;; 40 | (:file "reader") 41 | ;; 42 | (:file "test-utils") 43 | (:file "test0") 44 | (:file "test1") 45 | (:file "test2") 46 | (:file "test3") 47 | (:file "test4") 48 | (:file "test-top-page") 49 | (:file "test-trivial-json-codec")))) 50 | :perform (prepare-op :before (o c) 51 | (set (find-symbol* :*tests* :1am) '() )) 52 | :perform (test-op (o s) (symbol-call '#:cl-json-pointer/test '#:run))) 53 | -------------------------------------------------------------------------------- /test/test0.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer/test) 2 | (in-readtable cjp-test-syntax) 3 | 4 | (define-constant +rfc6901-example+ 5 | #{ 6 | "foo": ["bar", "baz"], 7 | "": 0, 8 | "a/b": 1, 9 | "c%d": 2, 10 | "e^f": 3, 11 | "g|h": 4, 12 | "i\\j": 5, 13 | "k\"l": 6, 14 | " ": 7, 15 | "m~n": 8 16 | } 17 | :test 'equal) 18 | 19 | (define-constant +rfc6901-example-keys+ 20 | '("" 21 | "/foo" 22 | "/foo/0" 23 | "/" 24 | "/a~1b" 25 | "/c%d" 26 | "/e^f" 27 | "/g|h" 28 | "/i\\j" 29 | "/k\"l" 30 | "/ " 31 | "/m~0n") 32 | :test 'equal) 33 | 34 | 35 | (1am:test test0-parse-json-pointer 36 | (1am:is (equal (mapcar #'parse-json-pointer +rfc6901-example-keys+) 37 | '(() 38 | ("foo") 39 | ("foo" "0") 40 | ("") 41 | ("a/b") 42 | ("c%d") 43 | ("e^f") 44 | ("g|h") 45 | ("i\\j") 46 | ("k\"l") 47 | (" ") 48 | ("m~n"))))) 49 | 50 | (1am:test test0-traverse-json 51 | (let ((json (read-json-string +rfc6901-example+))) 52 | (loop for cas in +rfc6901-example-keys+ 53 | as obj = (get-by-json-pointer json cas) 54 | for expected in `(,json 55 | #("bar" "baz") "bar" 56 | 0 1 2 3 4 5 6 7 8) 57 | always (1am:is (equalp obj expected))))) 58 | 59 | (defclass test-class () 60 | ((hoge :initform 'hoge-value))) 61 | 62 | (1am:test test0-traverse-json-2 63 | (let ((obj (make-instance 'test-class)) 64 | (ptr (ecase (readtable-case *readtable*) 65 | (:upcase "/HOGE") 66 | (:downcase "/hoge") 67 | (:preserve "/hoge") 68 | (:invert "/HOGE")))) 69 | ;; This test is dependent from json libs.. 70 | (1am:is (equal (get-by-json-pointer obj ptr :flavor t) 71 | 'hoge-value)))) 72 | 73 | (1am:test test0-traverse-json-3 () 74 | (let ((obj (read-json-string #{ "a": 1, "b": 2} ))) 75 | (1am:is (equal (get-by-json-pointer obj "/a") 1)) 76 | (1am:is (equal (get-by-json-pointer obj "/b") 2)) 77 | (let ((setf-ed-obj obj)) 78 | (setf (get-by-json-pointer setf-ed-obj "/c") 3) 79 | ;; some flavors which directly uses lists may update `setf-ed-obj' 80 | (when (member *current-json-reader* 81 | '(read-json-string/cl-json-crafted 82 | cl-json:decode-json-from-string 83 | jonathan:parse 84 | com.gigamonkeys.json:parse-json)) 85 | (1am:is (not (equal obj setf-ed-obj)))) 86 | (1am:is (equal (get-by-json-pointer setf-ed-obj "/c") 3))))) 87 | -------------------------------------------------------------------------------- /test/test2.lisp: -------------------------------------------------------------------------------- 1 | ;;; Test codes by: 2 | ;;; https://github.com/alexeykuzmin/jsonpointer.js 3 | 4 | (in-package :cl-json-pointer/test) 5 | (in-readtable cjp-test-syntax) 6 | 7 | (define-constant +test2-array+ 8 | #[ 9 | { "foo": "bar", "baz": [1, 2, 3] } , 10 | { "foo": "foobar"} 11 | ] 12 | :test 'equal) 13 | 14 | (defmethod json-object-equal-p (obj1 obj2) 15 | (equalp obj1 obj2)) 16 | 17 | #+cl-json-pointer/boost-json-support 18 | (defmethod json-object-equal-p ((obj1 boost-json:json-object) (obj2 boost-json:json-object)) 19 | "Currently, boost-json only has its own class for JSON object. 20 | (st-json has its own type, but it is a structure, which `cl:equalp' works." 21 | (equalp (boost-json:json-object-members obj1) 22 | (boost-json:json-object-members obj2))) 23 | 24 | (1am:test test2-array 25 | (let ((obj (read-json-string +test2-array+))) 26 | (1am:is (equal (get-by-json-pointer obj "/0/foo") "bar")) 27 | (1am:is (equal (get-by-json-pointer obj "/0/baz/1") 2)) 28 | (1am:is (json-object-equal-p (get-by-json-pointer obj "/1") 29 | (read-json-string #{ "foo": "foobar" }))))) 30 | 31 | 32 | (define-constant +test2-undefined+ 33 | #{ 34 | "foo": "bar", 35 | "baz": [1, 2, 3] 36 | } 37 | :test 'equal) 38 | 39 | (1am:test test2-undefined 40 | (let ((obj (read-json-string +test2-undefined+))) 41 | (1am:is (not (exists-p-by-json-pointer obj "/oof"))) 42 | (1am:is (not (exists-p-by-json-pointer obj "/baz/4"))) 43 | (1am:is (not (exists-p-by-json-pointer obj "/foo/bar"))) 44 | (1am:is (not (exists-p-by-json-pointer obj "/foo/bar/baz"))))) 45 | 46 | 47 | (define-constant +test2-bad-pointer+ 48 | #{ 49 | "foo": "bar", 50 | "baz": [1, 2, 3], 51 | "-": "valid" 52 | } 53 | :test 'equal) 54 | 55 | (1am:test test2-bad-pointer 56 | (let ((obj (read-json-string +test2-bad-pointer+))) 57 | (1am:signals cl-json-pointer:json-pointer-error 58 | (parse-json-pointer "a")) 59 | (1am:signals cl-json-pointer:json-pointer-error 60 | (get-by-json-pointer obj "/baz/01")) ; My impl does not report error at parsing. 61 | ;; this case is curious. I think this is valid. 62 | #+() 63 | (1am:signals cl-json-pointer:json-pointer-error 64 | (get-by-json-pointer obj "/baz/-")) 65 | (1am:signals cl-json-pointer:json-pointer-error 66 | (parse-json-pointer "-")))) 67 | 68 | 69 | (1am:test test2-valid-pointer () 70 | (1am:is (null (parse-json-pointer ""))) ; In my impl, this returns nil. 71 | (1am:is (parse-json-pointer "/")) 72 | (1am:is (parse-json-pointer "//")) 73 | (1am:is (parse-json-pointer "/a")) 74 | (1am:is (parse-json-pointer "/0")) 75 | (1am:is (parse-json-pointer "/10")) 76 | (1am:is (parse-json-pointer "/a/0")) 77 | (1am:is (parse-json-pointer "/1/a")) 78 | (1am:is (parse-json-pointer "/-"))) 79 | -------------------------------------------------------------------------------- /test/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer/test) 2 | 3 | ;;; This code does not consider escaped parens. 4 | (defun parens-reader (stream start-char n) 5 | (declare (ignore n)) 6 | (let ((end-char 7 | (ecase start-char 8 | (#\{ #\}) 9 | (#\[ #\])))) 10 | (with-output-to-string (out) 11 | (write-char start-char out) 12 | (loop with nest-level = 1 13 | for c = (read-char stream t :eof t) 14 | do (write-char c out) 15 | (cond ((eql c start-char) 16 | (incf nest-level)) 17 | ((eql c end-char) 18 | (decf nest-level) 19 | (when (zerop nest-level) 20 | (loop-finish)))))))) 21 | 22 | (defreadtable cjp-test-syntax 23 | (:merge :standard) 24 | (:dispatch-macro-char #\# #\{ 'parens-reader) 25 | (:dispatch-macro-char #\# #\[ 'parens-reader)) 26 | 27 | ;;; for multiple json libraries 28 | 29 | (defvar *json-reader-alist* nil 30 | "See `run'") 31 | 32 | (defvar *current-json-reader* nil 33 | "See `with-current-json-reader'") 34 | 35 | (defvar *current-array-type* nil 36 | "See `with-current-json-reader'") 37 | 38 | (defun read-json-string (string) 39 | "Reads STRING using `*current-json-reader*'." 40 | (check-type *current-json-reader* (or symbol function)) 41 | (funcall *current-json-reader* string)) 42 | 43 | (define-constant +array-type-check+ 44 | "[1]" 45 | :test #'equal 46 | :documentation "Used for checking how JSON libs treat arrays. See `with-current-json-reader'.") 47 | 48 | (defmacro esubtypecase ((type-var) &body clauses) 49 | "Like `etypecase', but uses `subtypep' for type comparison." 50 | (loop with current-type = (gensym) 51 | for (type . body) in clauses 52 | collect `((subtypep ,current-type ',type) ,@body) into ex-clauses 53 | finally 54 | (return `(let ((,current-type ,type-var)) 55 | (cond ,@ex-clauses 56 | (t 57 | (error "Unexpected type ~A for 'esubtypecase'" 58 | ,current-type))))))) 59 | 60 | (defmacro with-current-json-reader ((flavor reader-func) &body body) 61 | "Binds `*current-json-reader*', `*current-array-type*', and 62 | `*json-object-flavor*' referring READER-FUNC, and runs BODY." 63 | (let () 64 | `(let* ((*current-json-reader* ,reader-func) 65 | (*current-array-type* (type-of (read-json-string +array-type-check+))) 66 | (*json-object-flavor* ,flavor)) 67 | ,@body))) 68 | 69 | (defun print-test-heading () 70 | (format t "~&testing on ~A:~A~& JSON object flavor ~A~& JSON array = ~A~%" 71 | (package-name (symbol-package *current-json-reader*)) 72 | *current-json-reader* 73 | *json-object-flavor* *current-array-type*)) 74 | 75 | (defun run (&optional (reader-alist *json-reader-alist*)) ; test entry point 76 | "Runs `1am:run' with changing JSON backend based on `*json-reader-alist*'" 77 | (loop with shuffled = (alexandria:shuffle (copy-list reader-alist)) 78 | for (flavor . func) in shuffled 79 | do (with-current-json-reader (flavor func) 80 | (print-test-heading) 81 | (1am:run)))) 82 | -------------------------------------------------------------------------------- /src/support_trivial-json-codec.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | ;;; `trivial-json-codec:deserialize' works well. See test/test-trivial-json-codec.lisp file. 4 | ;;; `trivial-json-codec:deserialize-raw' requires special handlings. 5 | 6 | (defmethod intern-object-key ((flavor (eql :trivial-json-codec)) (rtoken string)) 7 | "It seems trivial-json-codec ignores escape characters (backslashes). 8 | 9 | For example, the result of 10 | (trivial-json-codec:deserialize-raw cl-json-pointer/test::+test1-example+) 11 | contains (:I\\\\J 5). I think this should be (:I\\J 5) 12 | 13 | But, this method treats it in that way." 14 | (loop with tmpstr = (make-array (length rtoken) :element-type 'character 15 | :adjustable t :fill-pointer 0) 16 | for c across rtoken 17 | if (or (char= c #\\) (char= c #\")) 18 | do (vector-push-extend #\\ tmpstr) 19 | (vector-push-extend c tmpstr) 20 | else 21 | do (vector-push-extend (char-upcase c) tmpstr) 22 | finally 23 | (return (intern tmpstr :keyword)))) 24 | 25 | (defmethod traverse-by-reference-token ((flavor (eql :trivial-json-codec-alist)) (alist list) 26 | rtoken set-method next-setter) 27 | "The result of `trivial-json-codec:deserialize-raw' looks like an 28 | alist, but its cdr is wrapped by a cons: 29 | 30 | (trivial-json-codec:deserialize-raw \"{ \\\"a\\\": 1, \\\"b\\\": 2}\" ) 31 | ; => ((:A 1) (:B 2)) 32 | 33 | This method treats them specially." 34 | (flet ((add-to-head (x) 35 | (acons rtoken (list x) alist))) ; assumes RTOKEN is interned. 36 | (if-let ((entry (assoc rtoken alist :test #'compare-string-by-readtable-case))) 37 | (values (cadr entry) entry 38 | (ecase set-method 39 | ((nil) nil) 40 | (:update 41 | (chained-setter-lambda (x) (next-setter alist) 42 | (setf (cadr entry) x))) 43 | (:add 44 | (chained-setter-lambda (x) (next-setter) 45 | (add-to-head x))) 46 | (:delete 47 | (chained-setter-lambda () (next-setter) 48 | (delete entry alist))) 49 | (:remove 50 | (chained-setter-lambda () (next-setter) 51 | (remove entry alist))))) 52 | (values nil nil 53 | (ecase set-method 54 | ((nil) nil) 55 | ((:add :update) 56 | (chained-setter-lambda (x) (next-setter) 57 | (add-to-head x))) 58 | ((:delete :remove) 59 | (thunk-lambda 60 | (bad-deleter-error alist rtoken)))))))) 61 | 62 | (defmethod traverse-by-reference-token 63 | ((flavor (eql :trivial-json-codec)) (obj list) (rtoken string) set-method next-setter) 64 | (list-try-traverse '(:trivial-json-codec-alist) 65 | flavor obj rtoken set-method next-setter)) 66 | 67 | (defmethod traverse-by-reference-token :around 68 | ((flavor (eql :trivial-json-codec)) (obj null) rtoken set-method next-setter) 69 | (declare (ignorable rtoken set-method next-setter)) 70 | (let ((*traverse-nil-set-to-last-method* :array)) 71 | (call-next-method))) 72 | 73 | (pushnew :trivial-json-codec *cl-json-pointer-supported-json-flavors*) 74 | -------------------------------------------------------------------------------- /src/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | ;;; Lists 4 | 5 | (defun clone-and-replace-on-cons (list cons value) 6 | "Makes a fresh list whose contents is same as LIST except the car of 7 | CONS is replaced with VALUE. If CONS is not contained in LIST, 8 | returns a new list by appending LIST, (list VALUE) and the cdr of CONS to the LIST." 9 | (nconc (ldiff list cons) (list value) (cdr cons))) 10 | 11 | (defun remove-cons (list cons &optional (count 1)) 12 | "Makes a fresh list whose contents is same as LIST except the CONS 13 | and successive COUNT conses. If CONS is not contained in LIST, 14 | returns a new list by appending LIST and (nthcdr COUNT CONS)." 15 | (nconc (ldiff list cons) (nthcdr count cons))) 16 | 17 | (defun delete-cons (list cons &optional (count 1)) 18 | "Destructively modifies LIST to exclude the CONS and successive 19 | COUNT conses. If CONS is not contained in LIST, returns a list by 20 | `nconc'ing LIST and (nthcdr COUNT CONS)." 21 | (when (or (eq list cons) 22 | (null list)) 23 | (return-from delete-cons (nthcdr count cons))) 24 | (loop for c on list 25 | as cdr-c = (cdr c) 26 | until (or (eq cdr-c cons) ; found 27 | (null cdr-c) ; proper list tail (not contained) 28 | (not (consp cdr-c))) ; dotted list tail 29 | finally 30 | (setf (cdr c) (nthcdr count cons)) 31 | (return list))) 32 | 33 | (defun extend-list (list n &key initial-element) 34 | "Destructively extends LIST to size N." 35 | (declare (type integer n)) 36 | (let ((tmp-cons (cons :placeholder list))) 37 | (declare (dynamic-extent tmp-cons)) 38 | (loop for prev = tmp-cons then c 39 | for rest-length downfrom n 40 | for c on list 41 | while (plusp rest-length) 42 | finally 43 | (when (plusp rest-length) 44 | (setf (cdr prev) 45 | (make-list rest-length :initial-element initial-element))) 46 | (return (cdr tmp-cons))))) 47 | 48 | ;;; Arrays 49 | 50 | (defun array-try-push (array x) 51 | (let ((adjustable? (adjustable-array-p array)) 52 | (has-fill-pointer? (array-has-fill-pointer-p array))) 53 | (if has-fill-pointer? 54 | (if adjustable? 55 | (vector-push-extend x array) 56 | (vector-push x array)) ; uses `vector-push' result as condition. 57 | nil))) 58 | 59 | (defun extend-array (array new-length fill-pointer) 60 | "Makes a new adjustable fill-pointered array having same contents as ARRAY." 61 | (if (adjustable-array-p array) 62 | (adjust-array array new-length :initial-element nil 63 | :fill-pointer fill-pointer) 64 | (let ((new-array (make-array new-length :adjustable t :initial-element nil 65 | :fill-pointer fill-pointer))) 66 | (replace new-array array) 67 | new-array))) 68 | 69 | ;;; Others 70 | 71 | (defun compare-string-by-readtable-case (a b &key (case (readtable-case *readtable*))) 72 | ;; TODO: For removing this, I require 'try-intern' like one! 73 | ;; TODO: should I use `ignore-errors' for alist (or plist) ? 74 | (ecase case 75 | ((:upcase :downcase) (string-equal a b)) 76 | ((:preserve :invert) (string= a b)))) 77 | 78 | (defmacro thunk-lambda (&body form) 79 | "Used for making thunks." 80 | (with-gensyms (_) 81 | `(lambda (&rest ,_) 82 | (declare (ignore ,_)) 83 | ,@form))) 84 | -------------------------------------------------------------------------------- /cl-json-pointer.asd: -------------------------------------------------------------------------------- 1 | ;;; The core package. (includes cl-json, yason, etc.) 2 | (defsystem #:cl-json-pointer/core 3 | :description "cl-json-pointer core files." 4 | :licence "MIT" 5 | :author "YOKOTA Yuki " 6 | :depends-on (#:alexandria #:closer-mop) 7 | :components 8 | ((:module "src" 9 | :components 10 | ((:file "package") 11 | (:file "util" :depends-on ("package")) 12 | (:file "condition" :depends-on ("package")) 13 | (:file "parser" :depends-on ("condition")) 14 | (:file "traversal" :depends-on ("util" "condition" "parser")) 15 | (:file "interface" :depends-on ("traversal")) 16 | (:file "support" :depends-on ("traversal")) 17 | ;; alphabetical order 18 | (:file "support_cl-json" :depends-on ("support")) 19 | (:file "support_com-gigamonkeys-json" :depends-on ("support")) 20 | (:file "support_com-inuoe-jzon" :depends-on ("support")) 21 | (:file "support_jonathan" :depends-on ("support")) 22 | (:file "support_json-lib" :depends-on ("support")) 23 | (:file "support_json-streams" :depends-on ("support")) 24 | (:file "support_jsown" :depends-on ("support")) 25 | (:file "support_shasht" :depends-on ("support")) 26 | (:file "support_trivial-json-codec" :depends-on ("support")) 27 | (:file "support_yason" :depends-on ("support")) 28 | ;; Supporting st-json has its own defsystem because it 29 | ;; requires the real dependency. See below. 30 | )))) 31 | 32 | ;;; Some library support. 33 | (defsystem #:cl-json-pointer/st-json-support 34 | :description "cl-json-pointer st-json support." 35 | :licence "MIT" 36 | :author "YOKOTA Yuki " 37 | :depends-on (#:cl-json-pointer/core #:st-json) 38 | :components ((:module "src" :components ((:file "support_st-json"))))) 39 | 40 | (eval-when (:compile-toplevel :load-toplevel :execute) 41 | (when (find-system :st-json nil) 42 | (pushnew :cl-json-pointer/st-json-support *features*))) 43 | 44 | (defsystem #:cl-json-pointer/boost-json-support 45 | :description "cl-json-pointer boost-json support." 46 | :licence "MIT" 47 | :author "YOKOTA Yuki " 48 | :depends-on (#:cl-json-pointer/core #:boost-json) 49 | :components ((:module "src" :components ((:file "support_boost-json"))))) 50 | 51 | (eval-when (:compile-toplevel :load-toplevel :execute) 52 | (when (find-system :boost-json nil) 53 | (pushnew :cl-json-pointer/boost-json-support *features*))) 54 | 55 | ;;; The main defsystem. 56 | (defsystem #:cl-json-pointer 57 | :description "A JSON Pointer (RFC6901) implementation for Common Lisp." 58 | :licence "MIT" 59 | :author "YOKOTA Yuki " 60 | :depends-on (#:cl-json-pointer/core 61 | (:feature :cl-json-pointer/st-json-support 62 | #:cl-json-pointer/st-json-support) 63 | (:feature :cl-json-pointer/boost-json-support 64 | #:cl-json-pointer/boost-json-support)) 65 | :in-order-to ((test-op (test-op #:cl-json-pointer/test)))) 66 | 67 | ;;; For convenience. 68 | (defsystem #:cl-json-pointer/synonyms 69 | :description "Extra functions for cl-json-pointer." 70 | :licence "MIT" 71 | :author "YOKOTA Yuki " 72 | :depends-on (#:cl-json-pointer) 73 | :components 74 | ((:module "synonyms" :components ((:file "synonyms"))))) 75 | -------------------------------------------------------------------------------- /test/reader.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer/test) 2 | 3 | (defmacro push-json-reader-alist (json-object-flavor-keyword function) 4 | `(eval-when (:compile-toplevel :load-toplevel :execute) 5 | (pushnew (cons ,json-object-flavor-keyword ,function) 6 | *json-reader-alist* :test #'equal))) 7 | 8 | ;;; cl-json 9 | ;; TODO: use fluid-object 10 | 11 | ;; specially crafted cl-json's one. I make it default. 12 | (defun read-json-string/cl-json-crafted (string) 13 | (cl-json:bind-custom-vars (:array-type 'vector) 14 | (let ((cl-json:*json-identifier-name-to-lisp* #'identity)) 15 | (cl-json:decode-json-from-string string)))) 16 | 17 | (unless *current-json-reader* 18 | (setf *current-json-reader* 'read-json-string/cl-json-crafted)) 19 | 20 | (push-json-reader-alist t 'read-json-string/cl-json-crafted) 21 | (push-json-reader-alist :cl-json 'cl-json:decode-json-from-string) 22 | 23 | ;;; st-json 24 | (push-json-reader-alist :st-json 'st-json:read-json-from-string) 25 | 26 | ;;; yason 27 | (push-json-reader-alist :yason 'yason:parse) 28 | 29 | ;; TODO: use variables 30 | ;; (*parse-json-arrays-as-vectors*) 31 | ;; (*parse-json-booleans-as-symbols*) 32 | ;; (*parse-json-null-as-keyword*) 33 | ;; (*parse-object-key-fn*) 34 | 35 | ;;; jsown 36 | (push-json-reader-alist :jsown 'jsown:parse) 37 | 38 | ;;; jonathan 39 | (push-json-reader-alist :jonathan 'jonathan:parse) 40 | 41 | ;; TODO: `:as' variants: alist, array, hash-table 42 | 43 | ;;; json-streams 44 | (push-json-reader-alist :json-streams 'json-streams:json-parse) 45 | 46 | (defmacro json-streams-array-pop-prefix (js-array) 47 | `(when (eq *current-json-reader* 'json-streams:json-parse) 48 | (check-type ,js-array list) 49 | (assert (eq (pop ,js-array) :array)))) 50 | 51 | ;;; com.gigamonkeys.json 52 | (push-json-reader-alist :com.gigamonkeys.json 'com.gigamonkeys.json:parse-json) 53 | 54 | ;;; com.inuoe.jzon (not in Quicklisp) 55 | (alexandria:if-let (jzon-package (find-package '#:com.inuoe.jzon)) 56 | (push-json-reader-alist :com.inuoe.jzon (find-symbol "PARSE" jzon-package)) 57 | (warn "cl-json-pointer test does not run on 'com.inuoe.jzon'.")) 58 | 59 | ;;; shasht 60 | (push-json-reader-alist :shasht 'shasht:read-json) 61 | 62 | (defun shasht-read-json-crafted-alist (&rest args) 63 | (let ((shasht:*read-default-false-value* :false) 64 | (shasht:*read-default-array-format* :list) 65 | (shasht:*write-false-values* '(:false)) 66 | (shasht:*read-default-object-format* :alist) 67 | (shasht:*write-alist-as-object* t)) 68 | (apply 'shasht:read-json args))) 69 | 70 | (defun shasht-read-json-crafted-plist (&rest args) 71 | (let ((shasht:*read-default-object-format* :plist) 72 | (shasht:*write-plist-as-object* t) 73 | (shasht:*read-default-false-value* :false) 74 | (shasht:*write-false-values* '(:false))) 75 | (apply 'shasht:read-json args))) 76 | 77 | (push-json-reader-alist :shasht 'shasht-read-json-crafted-alist) 78 | (push-json-reader-alist :shasht 'shasht-read-json-crafted-plist) 79 | 80 | ;;; trivial-json-codec 81 | (push-json-reader-alist :trivial-json-codec 'trivial-json-codec:deserialize-raw) 82 | 83 | ;;; boost-json 84 | (alexandria:if-let (boost-json-package (find-package '#:boost-json)) 85 | (push-json-reader-alist :boost-json (find-symbol "JSON-DECODE" boost-json-package)) 86 | (warn "cl-json-pointer test does not run on 'boost-json'.")) 87 | 88 | ;;; json-lib 89 | (alexandria:if-let (json-lib-package (find-package '#:json-lib)) 90 | (push-json-reader-alist :json-lib (find-symbol "PARSE" json-lib-package)) 91 | (warn "cl-json-pointer test does not run on 'json-lib'.")) 92 | -------------------------------------------------------------------------------- /src/interface.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (defvar *json-object-flavor* t 4 | "Default flavor of JSON library currently used. 5 | This value is used for :FLAVOR argument of exported functions. 6 | Currently acceptable values are held by `*cl-json-pointer-supported-json-flavors*' 7 | 8 | Default is `t', behaves as well as possible without any knowledge about JSON libs.") 9 | 10 | ;;; Getter family 11 | 12 | (defun get-by-json-pointer (obj pointer &key (flavor *json-object-flavor*)) 13 | "Traverses OBJ with POINTER and returns three values: 14 | the found value (`nil' if not found), a generalized boolean saying the existence of the place pointed by POINTER, and NIL." 15 | (let ((parsed-ptr (parse-json-pointer pointer))) 16 | (traverse-by-json-pointer obj flavor parsed-ptr nil))) 17 | 18 | (defun exists-p-by-json-pointer (obj pointer &key (flavor *json-object-flavor*)) 19 | "Traverses OBJ with POINTER and returns the existence of the place pointed by POINTER." 20 | (nth-value 1 (get-by-json-pointer obj pointer :flavor flavor))) 21 | 22 | ;;; Setter family 23 | 24 | (defun make-setter-by-json-pointer (obj obj-flavor pointer set-method) 25 | "Updating functions (`set-by-json-pointer', `delete-by-json-pointer', etc) 26 | calls this for making a setter function." 27 | (let ((parsed-ptr (parse-json-pointer pointer))) 28 | (nth-value 2 (traverse-by-json-pointer obj obj-flavor parsed-ptr set-method)))) 29 | 30 | (defun set-by-json-pointer (obj pointer value &key (flavor *json-object-flavor*)) 31 | "Traverses OBJ with POINTER, sets VALUE into the pointed 32 | place, and returns the modified OBJ" 33 | (funcall (make-setter-by-json-pointer obj flavor pointer :update) value)) 34 | 35 | (defun add-by-json-pointer (obj pointer value &key (flavor *json-object-flavor*)) 36 | "Works same as `set-by-json-pointer', except this try to make a new 37 | list when setting to lists." 38 | (funcall (make-setter-by-json-pointer obj flavor pointer :add) value)) 39 | 40 | (defun delete-by-json-pointer (obj pointer &key (flavor *json-object-flavor*)) 41 | "Traverses OBJ with POINTER, deletes the pointed place, and 42 | returns the modified OBJ" 43 | (funcall (make-setter-by-json-pointer obj flavor pointer :delete))) 44 | 45 | (defun remove-by-json-pointer (obj pointer &key (flavor *json-object-flavor*)) 46 | "Works same as `delete-by-json-pointer', except this try to make a new 47 | list when deleting from lists." 48 | (funcall (make-setter-by-json-pointer obj flavor pointer :remove))) 49 | 50 | 51 | (define-setf-expander get-by-json-pointer (obj pointer &key (flavor '*json-object-flavor*) &environment env) 52 | "A setf expansion for allowing `setf' to `(get-by-json-pointer ...)' forms." 53 | (multiple-value-bind (o-tmps o-vals o-newval o-setter o-getter) 54 | (get-setf-expansion obj env) 55 | (unless (length= 1 o-newval) 56 | (error "setf to get-by-json-pointer requires the first arg is one value.")) 57 | (with-gensyms (p-tmp flavor-tmp store) 58 | (values (list* p-tmp flavor-tmp o-tmps) 59 | (list* pointer flavor o-vals) 60 | (list store) 61 | `(let ((,(first o-newval) ; this binding influences O-SETTER. 62 | (set-by-json-pointer ,o-getter ,p-tmp ,store :flavor ,flavor-tmp))) 63 | ,o-setter 64 | ,store) 65 | `(get-by-json-pointer ,o-getter ,p-tmp :flavor ,flavor-tmp))))) 66 | 67 | (define-modify-macro update-by-json-pointer (pointer value &rest keyargs) 68 | set-by-json-pointer 69 | "Modify macro of `set-by-json-pointer'. This sets results of 70 | `set-by-json-pointer' to the referred place. ") 71 | 72 | (define-modify-macro deletef-by-json-pointer (pointer &rest keyargs) 73 | delete-by-json-pointer 74 | "Modify macro of `delete-by-json-pointer'. This sets results of 75 | `delete-by-json-pointer' to the referred place. ") 76 | -------------------------------------------------------------------------------- /test/test-trivial-json-codec.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-json-pointer/test-trivial-json-codec 2 | (:use :cl) 3 | (:export #:Payload 4 | #:Message)) 5 | 6 | (in-package :cl-json-pointer/test-trivial-json-codec) 7 | 8 | ;;; Copied from https://gitlab.com/ediethelm/trivial-json-codec/-/blob/master/README.md 9 | 10 | (defclass Payload () 11 | ()) 12 | 13 | (defclass SimplePayload (Payload) 14 | ((value :type integer 15 | :initarg :value))) 16 | 17 | (defclass ComplicatedPayload (Payload) 18 | ((value :type string 19 | :initarg :value) 20 | (additional-info :type string 21 | :initarg :additional-info) 22 | (message-id :type trivial-utilities:positive-fixnum 23 | :initarg :message-id))) 24 | 25 | (defclass DifferentPayload (Payload) 26 | ((cargo :type fixnum 27 | :initarg :cargo))) 28 | 29 | (defclass Message () 30 | ((uid :initarg :uid 31 | :initform nil 32 | :accessor uid) 33 | (payload :type (or null Payload) 34 | :initarg :payload 35 | :accessor payload))) 36 | 37 | (c2mop:ensure-finalized (find-class 'Payload)) 38 | (c2mop:ensure-finalized (find-class 'SimplePayload)) 39 | (c2mop:ensure-finalized (find-class 'ComplicatedPayload)) 40 | (c2mop:ensure-finalized (find-class 'DifferentPayload)) 41 | (c2mop:ensure-finalized (find-class 'Message)) 42 | 43 | 44 | (in-package :cl-json-pointer/test) 45 | 46 | (defun test-trivial-json-codec () 47 | ;; Copied from https://gitlab.com/ediethelm/trivial-json-codec/-/blob/master/README.md 48 | (let ((obj (trivial-json-codec:deserialize-json 49 | "{ \"UID\" : 1, \"PAYLOAD\" : { \"VALUE\" : 12345}}" 50 | :class (find-class 'cl-json-pointer/test-trivial-json-codec:Message)))) 51 | (1am:is (typep obj 'cl-json-pointer/test-trivial-json-codec:Message)) 52 | (1am:is (equal (get-by-json-pointer obj "/UID") 1)) 53 | (1am:is (equal (get-by-json-pointer obj "/PAYLOAD/VALUE") 12345)) 54 | (1am:is (typep (get-by-json-pointer obj "/PAYLOAD") 'cl-json-pointer/test-trivial-json-codec:Payload))) 55 | (let ((obj (trivial-json-codec:deserialize-json 56 | "{ \"UID\" : 2, \"PAYLOAD\" : { \"VALUE\" : \"abc\", \"ADDITIONAL-INFO\" : \"1234\", \"MESSAGE-ID\" : 17}}" 57 | :class (find-class 'cl-json-pointer/test-trivial-json-codec:Message)))) 58 | (1am:is (typep obj 'cl-json-pointer/test-trivial-json-codec:Message)) 59 | (1am:is (equal (get-by-json-pointer obj "/UID") 2)) 60 | (1am:is (equal (get-by-json-pointer obj "/PAYLOAD/VALUE") "abc")) 61 | (1am:is (equal (get-by-json-pointer obj "/PAYLOAD/ADDITIONAL-INFO") "1234")) 62 | (1am:is (equal (get-by-json-pointer obj "/PAYLOAD/MESSAGE-ID") 17)) 63 | (let ((payload (get-by-json-pointer obj "/PAYLOAD"))) 64 | (1am:is (typep payload 'cl-json-pointer/test-trivial-json-codec:Payload)) 65 | (1am:is (eq (get-by-json-pointer obj "/PAYLOAD/VALUE") (get-by-json-pointer payload "/VALUE"))) 66 | (1am:is (eq (get-by-json-pointer obj "/PAYLOAD/ADDITIONAL-INFO") (get-by-json-pointer payload "/ADDITIONAL-INFO"))) 67 | (1am:is (eq (get-by-json-pointer obj "/PAYLOAD/MESSAGE-ID") (get-by-json-pointer payload "/MESSAGE-ID"))))) 68 | (let ((obj (trivial-json-codec:deserialize-json 69 | "{ \"UID\" : 2, \"PAYLOAD\" : { \"CARGO\" : -147}}" 70 | :class (find-class 'cl-json-pointer/test-trivial-json-codec:Message)))) 71 | (1am:is (typep obj 'cl-json-pointer/test-trivial-json-codec:Message)) 72 | (1am:is (equal (get-by-json-pointer obj "/UID") 2)) 73 | (1am:is (equal (get-by-json-pointer obj "/PAYLOAD/CARGO") -147))) 74 | ;; 75 | t) 76 | 77 | (1am:test test-trivial-json-codec-1am 78 | (unless (eq *json-object-flavor* :trivial-json-codec) 79 | (return-from test-trivial-json-codec-1am t)) 80 | (format t "~&trivial-json-codec test runs only on :trivial-json-codec flavor.") 81 | (test-trivial-json-codec)) 82 | -------------------------------------------------------------------------------- /test/test3.lisp: -------------------------------------------------------------------------------- 1 | ;;; Test codes by: 2 | ;;; https://github.com/manuelstofer/json-pointer/blob/master/test/test.js 3 | 4 | (in-package :cl-json-pointer/test) 5 | (in-readtable cjp-test-syntax) 6 | 7 | (1am:test test3-get 8 | (let ((obj (make-instance 'standard-object))) 9 | (1am:is (eq obj (cljsp:get obj ""))))) 10 | 11 | (1am:test test3-set 12 | ;; If set to root, my impl simply sets into the root! 13 | (let ((obj nil)) 14 | (setf (cljsp:get obj "") 'foo) 15 | (1am:is (eq obj 'foo))) 16 | (let ((obj (read-json-string #{ "existing": "bla"} ))) 17 | (setf (cljsp:get obj "/new-value/bla") :expected) 18 | (1am:is (eql (cljsp:get obj "/new-value/bla") :expected)) 19 | (setf (cljsp:get obj "/first-level") :expected) 20 | (1am:is (eql (cljsp:get obj "/first-level") :expected))) 21 | (let ((obj nil)) 22 | (setf (cljsp:get obj "/0/test/0") :expected) 23 | ;; intermediate structures 24 | (1am:is (cljsp:exists-p obj "")) 25 | (1am:is (cljsp:exists-p obj "/0")) 26 | (1am:is (cljsp:exists-p obj "/0/test")) 27 | ;; TODO: Types depend on nil-handling method. 28 | ;; (1am:is (arrayp (cljsp:get obj ""))) 29 | ;; (1am:is (not (arrayp (cljsp:get obj "/0")))) 30 | ;; (1am:is (arrayp (cljsp:get obj "/0/test"))) 31 | (1am:is (equal (cljsp:get obj "/0/test/0") :expected))) 32 | (let ((obj (list "foo"))) 33 | (setf (cljsp:get obj "/-/test/-") :expected) 34 | ;; intermediate structures 35 | (1am:is (cljsp:exists-p obj "")) 36 | (1am:is (cljsp:exists-p obj "/1")) 37 | (1am:is (cljsp:exists-p obj "/1/test")) 38 | ;; TODO: Types depend on nil-handling method. 39 | ;; (1am:is (arrayp (cljsp:get obj "/"))) 40 | (1am:is (length= 2 (cljsp:get obj ""))) 41 | ;; (1am:is (not (arrayp (cljsp:get obj "/1")))) 42 | ;; (1am:is (arrayp (cljsp:get obj "/1/test"))) 43 | (1am:is (equal (cljsp:get obj "/1/test/0") :expected)))) 44 | 45 | (1am:test test3-delete 46 | (esubtypecase (*current-array-type*) 47 | (list 48 | ;; This is the JS's original test. In my impl, this requires 'list' semantics! 49 | (let ((obj (read-json-string +rfc6901-example+))) ; see test0.lisp 50 | (1am:is (cljsp:delete obj "/foo/0")) 51 | (1am:is (equal (cljsp:get obj "/foo/0") "baz"))) 52 | (let ((obj (read-json-string +rfc6901-example+))) 53 | (1am:is (cljsp:delete obj "/foo/1")) 54 | (1am:is (not (cljsp:exists-p obj "/foo/1"))))) 55 | (array 56 | ;; My impl does not shrink arrays. 57 | (let* ((obj (read-json-string +rfc6901-example+)) 58 | (len (length (cljsp:get obj "/foo"))) 59 | (old1 (cljsp:get obj "/foo/1"))) 60 | (1am:is (cljsp:delete obj "/foo/0")) 61 | (1am:is (eq (cljsp:get obj "/foo/0") nil)) ; TODO: FIXME: This is depend on deleting op. 62 | (1am:is (eq (cljsp:get obj "/foo/1") old1)) 63 | (1am:is (length= len (cljsp:get obj "/foo")))) 64 | (let* ((obj (read-json-string +rfc6901-example+)) 65 | (len (length (cljsp:get obj "/foo"))) 66 | (old0 (cljsp:get obj "/foo/0"))) 67 | (1am:is (cljsp:delete obj "/foo/1")) 68 | (1am:is (eq (cljsp:get obj "/foo/0") old0)) 69 | (1am:is (eq (cljsp:get obj "/foo/1") nil)) ; TODO: FIXME: This is depend on deleting op. 70 | (1am:is (length= len (cljsp:get obj "/foo"))))))) 71 | 72 | ;;; nothing for 'dict' 73 | 74 | (define-constant +test3-has-obj+ 75 | #{ 76 | "bla": { 77 | "test": "expected" 78 | }, 79 | "foo": [["hello"]], 80 | "abc": "bla" 81 | } 82 | :test 'equal) 83 | 84 | (1am:test test3-has 85 | (let ((obj (read-json-string +test3-has-obj+))) 86 | (1am:is (cljsp:exists-p obj "/bla")) 87 | (1am:is (cljsp:exists-p obj "/abc")) 88 | (1am:is (cljsp:exists-p obj "/foo/0/0")) 89 | (1am:is (cljsp:exists-p obj "/bla/test")) 90 | (1am:is (not (cljsp:exists-p obj "/not-existing"))) 91 | (1am:is (not (cljsp:exists-p obj "/not-existing/bla"))) 92 | (1am:is (not (cljsp:exists-p obj "/test/1/bla"))) 93 | (1am:is (not (cljsp:exists-p obj "/bla/test1"))))) 94 | 95 | ;;; nothing for 'walk' 96 | 97 | (1am:test test3-parse 98 | ;; FIXME: too fragile 99 | (1am:is (equal (cljsp:parse "/bla") 100 | '("bla"))) 101 | (1am:is (equal (cljsp:parse "/hello~0bla/test~1bla") 102 | '("hello~bla" "test/bla")))) 103 | 104 | ;;; nothing for 'compile' 105 | 106 | ;;; nothing for the 'convenience api'. 107 | -------------------------------------------------------------------------------- /test/test4.lisp: -------------------------------------------------------------------------------- 1 | ;;; Test codes by: 2 | ;;; https://github.com/WHenderson/json-pointer-rfc6901/tree/master/test 3 | 4 | (in-package :cl-json-pointer/test) 5 | (in-readtable cjp-test-syntax) 6 | 7 | ;;; nothing for 'escape', 'escapeFragment', 'unescape' 'unescapeFragment' 8 | 9 | (1am:test test4-parse 10 | (1am:is (null (cljsp:parse ""))) ; my impl returns nil. 11 | (1am:signals cl-json-pointer:json-pointer-error 12 | (cljsp:parse "a")) 13 | (1am:is (equal (cljsp:parse "/a/b") '("a" "b"))) 14 | (1am:is (equal (cljsp:parse "/~0/~1") '("~" "/")))) 15 | 16 | (1am:test test4-parse-fragment 17 | (1am:is (null (cljsp:parse "#"))) ; my impl returns nil. 18 | (1am:signals cl-json-pointer:json-pointer-error 19 | (cljsp:parse "#a")) 20 | (1am:is (equal (cljsp:parse "#/a/b") '("a" "b"))) 21 | (1am:is (equal (cljsp:parse "#/~0/~1") '("~" "/"))) 22 | ;; TODO: required? 23 | #+ () 24 | (1am:is (equal (cljsp:parse "#/~0%20/~1%20") '("~ " "/ ")))) 25 | 26 | (1am:test test4-parse-pointer 27 | (1am:signals cl-json-pointer:json-pointer-error 28 | (cljsp:parse "#" :accept-uri-fragment nil)) 29 | (1am:signals cl-json-pointer:json-pointer-error 30 | (cljsp:parse "#a" :accept-uri-fragment nil)) 31 | (1am:signals cl-json-pointer:json-pointer-error 32 | (cljsp:parse "#/a/b" :accept-uri-fragment nil)) 33 | (1am:signals cl-json-pointer:json-pointer-error 34 | (cljsp:parse "#/~0/~1" :accept-uri-fragment nil))) 35 | 36 | ;;; nothing for 'isPointer', 'isFragment', 'compile', 'compilePointer', 37 | ;;; 'compileFragment', 'hasJsonProp', 'hasOwnProp', 'hasProp'. 38 | 39 | ;;; 'get' is same for RFC6901 example. 40 | 41 | (define-constant +test4-has-object+ 42 | #{ 43 | "a": 1, 44 | "b": [2,3] 45 | } 46 | :test #'equal) 47 | 48 | (1am:test test4-has 49 | (let ((obj (read-json-string +test4-has-object+))) 50 | (1am:is (cljsp:exists-p obj "")) 51 | (1am:is (cljsp:exists-p obj "/a")) 52 | (1am:is (cljsp:exists-p obj "/b/0")) 53 | (1am:is (not (cljsp:exists-p obj "/c"))) 54 | (1am:is (not (cljsp:exists-p obj "/b/-"))))) 55 | 56 | (1am:test test4-set 57 | (let ((obj (read-json-string 58 | #{}))) 59 | (cljsp:update obj "" 1) 60 | (1am:is (eql obj 1))) 61 | (let ((obj (read-json-string 62 | #{}))) 63 | (cljsp:update obj "/a" 1) 64 | (1am:is (eql (cljsp:get obj "/a") 1))) 65 | (let ((obj (read-json-string 66 | #{ "a": {} }))) 67 | (cljsp:update obj "/a/b/c" 1) 68 | (1am:is (eql (cljsp:get obj "/a/b/c") 1))) 69 | (let ((obj (read-json-string 70 | #[]))) 71 | (cljsp:update obj "/-" 1) 72 | (1am:is (eql (cljsp:get obj "/0") 1))) 73 | (let ((obj (read-json-string 74 | #[[]]))) 75 | (cljsp:update obj "/0/-/-" 1) 76 | (1am:is (eql (cljsp:get obj "/0/0/0") 1)))) 77 | 78 | (1am:test test4-delete 79 | (let ((obj #{})) 80 | (cljsp:deletef obj "") 81 | (1am:is (eql obj nil))) 82 | (let ((obj (read-json-string 83 | #{ "a": 1 }))) 84 | (cljsp:deletef obj "/a") 85 | (1am:is (cljsp:exists-p obj "")) 86 | (1am:is (not (cljsp:exists-p obj "/a")))) 87 | (let ((obj (read-json-string 88 | #{ "a": { "b": { "c": 1 } } }))) 89 | (cljsp:deletef obj "/a/b/c") 90 | (1am:is (cljsp:exists-p obj "")) 91 | (1am:is (cljsp:exists-p obj "/a")) 92 | (1am:is (cljsp:exists-p obj "/a/b")) 93 | (1am:is (not (cljsp:exists-p obj "/a/b/c")))) 94 | (let ((obj (read-json-string 95 | #{ "a": 1 }))) 96 | (1am:signals cl-json-pointer:json-pointer-error 97 | (cljsp:delete obj "/b"))) 98 | (let ((obj (read-json-string 99 | #[ 1 ]))) 100 | (cljsp:deletef obj "/0") 101 | (1am:is (cljsp:exists-p obj "")) ; the root always exists. 102 | (esubtypecase (*current-array-type*) 103 | (list (1am:is (not (cljsp:exists-p obj "/0")))) 104 | (array (1am:is (null (cljsp:get obj "/0")))))) 105 | (let ((obj (read-json-string 106 | #[[[1]]]))) 107 | (cljsp:deletef obj "/0/0/0") 108 | (1am:is (cljsp:exists-p obj "")) 109 | (1am:is (cljsp:exists-p obj "/0")) 110 | (1am:is (cljsp:exists-p obj "/0/0")) 111 | (esubtypecase (*current-array-type*) 112 | (list (1am:is (not (cljsp:exists-p obj "/0/0/0")))) 113 | (array (1am:is (null (cljsp:get obj "/0/0/0")))))) 114 | (let ((obj (read-json-string 115 | #[ 1 ]))) 116 | (1am:signals cl-json-pointer:json-pointer-error 117 | (cljsp:delete obj "/-")))) 118 | 119 | ;;; nothing for 'simplified', 'bind', 'rebind', 'bound meta data' 120 | -------------------------------------------------------------------------------- /src/parser.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | (defconstant +end+ 4 | '- 5 | "A symbol indicates 'the (nonexistent) member after the last array element', denoted by '-'") 6 | 7 | ;;; Reference Token 8 | 9 | (defun read-reference-token-as-index (rtoken &optional (errorp t)) 10 | (etypecase rtoken 11 | (integer rtoken) 12 | (symbol (assert (eq rtoken +end+) 13 | () 'json-pointer-bad-reference-token-error 14 | :reference-token rtoken 15 | :format-control "reference token (~A) is not a known symbol") 16 | rtoken) 17 | (string 18 | (flet ((error-if-required (&rest error-args) 19 | (let ((e (apply #'make-condition error-args))) 20 | (if errorp (error e) e)))) 21 | (cond ((and (> (length rtoken) 1) 22 | (char= (char rtoken 0) #\0)) ; RFC6901 does not allow '0' at the beginning. 23 | (values nil 24 | (error-if-required 'json-pointer-bad-reference-token-0-used-error 25 | :reference-token rtoken))) 26 | (t 27 | (handler-case (parse-integer rtoken) 28 | (error () 29 | (values nil 30 | (error-if-required 'json-pointer-bad-reference-token-not-numeric-error 31 | :reference-token rtoken)))))))))) 32 | 33 | ;;; object key 34 | 35 | (defgeneric intern-object-key (flavor rtoken) 36 | (:documentation "Interns RTOKEN as JSON object key, with JSON lib flavor of FLAVOR") 37 | (:method (flavor (rtoken symbol)) 38 | (declare (ignore flavor)) 39 | rtoken) 40 | (:method (flavor (rtoken string)) ; This case is ambigouns 41 | "Interns RTOKEN itself as JSON object key. 42 | This is suitable for yason, st-json, jsown, json-streams, and com.gigamonkeys.json." 43 | (declare (ignore flavor)) 44 | rtoken)) 45 | 46 | ;;; Parser 47 | 48 | (deftype parsed-json-pointer () 49 | 'list) 50 | 51 | (defgeneric parse-json-pointer (obj &key start end accept-uri-fragment) 52 | (:documentation "Parses OBJ to an internal representation")) 53 | 54 | (defmethod parse-json-pointer (pointer &key &allow-other-keys) 55 | (error 'json-pointer-parse-error 56 | :format-control "Unsupported object for parsing" 57 | :format-arguments (list pointer))) 58 | 59 | (defmethod parse-json-pointer ((pointer list) &key &allow-other-keys) 60 | ;; a short circuit for current `parsed-json-pointer' definition. 61 | pointer) 62 | 63 | (defconstant +parse-json-pointer-default-buffer-length+ 16) 64 | 65 | (defmethod parse-json-pointer ((stream stream) &key (accept-uri-fragment t) &allow-other-keys) 66 | ;; checks '#' 67 | (when accept-uri-fragment 68 | (case (peek-char nil stream nil) 69 | (#\# (read-char stream)) ; accepts '#' 70 | (otherwise (progn)))) 71 | ;; checks '/' at the beginning, and consume it here. 72 | (let ((char0 (read-char stream nil :eof))) 73 | (case char0 74 | (:eof ; I think RFC6901 says an empty string should be accepted. 75 | (return-from parse-json-pointer nil)) 76 | (#\/ 77 | (progn)) ; ok 78 | (otherwise 79 | (error 'json-pointer-parse-error 80 | :format-control "Not started by '/', appeared '~A'" 81 | :format-arguments (list char0))))) 82 | ;; main loop 83 | (let ((buf (make-array +parse-json-pointer-default-buffer-length+ 84 | :element-type 'character :adjustable t :fill-pointer 0)) 85 | (tokens nil)) 86 | (declare (type string buf) 87 | (dynamic-extent buf)) 88 | (flet ((push-reference-token () 89 | (push (if (string= buf "-") 90 | +end+ 91 | (copy-seq buf)) 92 | tokens) 93 | (setf (fill-pointer buf) 0))) 94 | (loop with parsing-escape-token? of-type boolean = nil 95 | for c of-type (or character symbol) = (read-char stream nil :eof) 96 | if parsing-escape-token? 97 | do (case c 98 | (#\0 (vector-push-extend #\~ buf)) 99 | (#\1 (vector-push-extend #\/ buf)) 100 | (otherwise 101 | (error 'json-pointer-parse-error 102 | :format-control "bad char as escape: ~A" 103 | :format-arguments (list c)))) 104 | (setf parsing-escape-token? nil) 105 | else 106 | do (case c 107 | (:eof (push-reference-token) 108 | (loop-finish)) 109 | (#\/ (push-reference-token)) 110 | (#\~ (setf parsing-escape-token? t)) 111 | (otherwise (vector-push-extend c buf))))) 112 | (nreverse tokens))) 113 | 114 | (defmethod parse-json-pointer ((pointer string) &key (start 0) (end (length pointer)) 115 | (accept-uri-fragment t) &allow-other-keys) 116 | (with-input-from-string (in pointer :start start :end end) 117 | (parse-json-pointer in :accept-uri-fragment accept-uri-fragment))) 118 | -------------------------------------------------------------------------------- /test/test1.lisp: -------------------------------------------------------------------------------- 1 | ;;; Test codes by: 2 | ;;; https://github.com/janl/node-jsonpointer 3 | 4 | (in-package :cl-json-pointer/test) 5 | (in-readtable cjp-test-syntax) 6 | 7 | ;;; Test cases in top page. 8 | 9 | (define-constant +test1-top-page+ 10 | #{ "foo": 1, "bar": { "baz": 2}, "qux": [3, 4, 5]} 11 | :test 'equal) 12 | 13 | (1am:test test1-top-page 14 | (let ((obj (read-json-string +test1-top-page+))) 15 | (1am:is (equal (get-by-json-pointer obj "/foo") 1)) 16 | (1am:is (equal (get-by-json-pointer obj "/bar/baz") 2)) 17 | (1am:is (equal (get-by-json-pointer obj "/qux/0") 3)) 18 | (1am:is (equal (get-by-json-pointer obj "/qux/1") 4)) 19 | (1am:is (equal (get-by-json-pointer obj "/qux/2") 5)) 20 | (1am:is (not (get-by-json-pointer obj "/quo"))) 21 | 22 | (setf obj (set-by-json-pointer obj "/foo" 6)) 23 | (1am:is (equal (get-by-json-pointer obj "/foo") 6)) 24 | (setf obj (set-by-json-pointer obj "/foo" 7)) 25 | (1am:is (equal (get-by-json-pointer obj "/foo") 7)) 26 | 27 | (setf obj (set-by-json-pointer obj "/qux/-" 6)) 28 | (let ((qux (get-by-json-pointer obj "/qux"))) 29 | (json-streams-array-pop-prefix qux) 30 | (1am:is (equalp qux 31 | (esubtypecase (*current-array-type*) 32 | (list '(3 4 5 6)) 33 | (array #(3 4 5 6)))))) 34 | 35 | (setf obj (set-by-json-pointer obj "/qux/-" 99)) 36 | (let ((qux (get-by-json-pointer obj "/qux"))) 37 | (json-streams-array-pop-prefix qux) 38 | (1am:is (equalp qux 39 | (esubtypecase (*current-array-type*) 40 | (list '(3 4 5 6 99)) 41 | (array #(3 4 5 6 99)))))) 42 | 43 | (let ((pointer (parse-json-pointer "/foo"))) 44 | (1am:is (equal (get-by-json-pointer obj pointer) 7)) 45 | (setf obj (set-by-json-pointer obj pointer 999)) 46 | (1am:is (equal (get-by-json-pointer obj pointer) 999))))) 47 | 48 | ;;; Test cases in test.js 49 | 50 | (define-constant +test1-obj+ 51 | #{ 52 | "a": 1, 53 | "b": { 54 | "c": 2 55 | }, 56 | "d": { 57 | "e": [{ "a": 3 }, { "b": 4 }, { "c": 5 }] 58 | } 59 | } 60 | :test 'equal) 61 | 62 | (1am:test test1-obj 63 | (let ((obj (read-json-string +test1-obj+))) 64 | (1am:is (equal (cljsp:get obj "/a") 1)) 65 | (1am:is (equal (cljsp:get obj "/b/c") 2)) 66 | (1am:is (equal (cljsp:get obj "/d/e/0/a") 3)) 67 | (1am:is (equal (cljsp:get obj "/d/e/1/b") 4)) 68 | (1am:is (equal (cljsp:get obj "/d/e/2/c") 5)) 69 | 70 | (cljsp:update obj "/a" 2) 71 | (1am:is (equal (cljsp:get obj "/a") 2)) 72 | (cljsp:update obj "/b/c" 3) 73 | (1am:is (equal (cljsp:get obj "/b/c") 3)) 74 | (cljsp:update obj "/d/e/0/a" 4) 75 | (1am:is (equal (cljsp:get obj "/d/e/0/a") 4)) 76 | (cljsp:update obj "/d/e/1/b" 5) 77 | (1am:is (equal (cljsp:get obj "/d/e/1/b") 5)) 78 | (cljsp:update obj "/d/e/2/c" 6) 79 | (1am:is (equal (cljsp:get obj "/d/e/2/c") 6)) 80 | 81 | ;; set nested properties 82 | (cljsp:update obj "/f/g/h/i" 6) 83 | (1am:is (equal (cljsp:get obj "/f/g/h/i") 6)) 84 | 85 | ;; set an array 86 | (cljsp:update obj "/f/g/h/foo/-" "test") 87 | (let ((arr (cljsp:get obj "/f/g/h/foo"))) 88 | ;; TODO: add a way to specify type. 89 | ;; (1am:is (typep arr 'array)) 90 | (json-streams-array-pop-prefix arr) 91 | (1am:is (equal (elt arr 0) "test"))) 92 | 93 | ;; can set `null` as a value 94 | (cljsp:update obj "/f/g/h/foo/0" nil) 95 | (1am:is (null (cljsp:get obj "/f/g/h/foo/0"))) 96 | (cljsp:update obj "/b/c" nil) 97 | (1am:is (null (cljsp:get obj "/b/c"))) 98 | 99 | (1am:is (equalp (cljsp:get obj "") obj)) 100 | (1am:signals cl-json-pointer:json-pointer-error 101 | (cljsp:get obj "a")) 102 | (1am:signals cl-json-pointer:json-pointer-error 103 | (cljsp:get obj "a/")) 104 | 105 | ;; delete operations. 106 | ;; (In JS: can unset values with `undefined`) 107 | (cljsp:delete obj "/a") 108 | (1am:is (not (cljsp:exists-p obj "/a"))) 109 | (cljsp:delete obj "/d/e/1") 110 | (esubtypecase (*current-array-type*) 111 | (list 112 | (1am:is (cljsp:exists-p obj "/d/e/0")) 113 | (1am:is (cljsp:exists-p obj "/d/e/0/a")) 114 | (1am:is (cljsp:exists-p obj "/d/e/1")) 115 | (1am:is (not (cljsp:exists-p obj "/d/e/1/b"))) 116 | (1am:is (cljsp:exists-p obj "/d/e/1/c")) 117 | (1am:is (not (cljsp:exists-p obj "/d/e/2")))) 118 | (array 119 | ;; In my implementation, deleting from array only sets `nil', so the element still exists. 120 | (1am:is (null (cljsp:get obj "/d/e/1"))) 121 | (1am:is (cljsp:exists-p obj "/d/e/1")))) 122 | 123 | ;; returns `undefined` when path extends beyond any existing objects 124 | (1am:is (not (cljsp:exists-p obj "/x/y/z"))))) 125 | 126 | 127 | (define-constant +test1-complex-keys+ 128 | #{ 129 | "a/b": { 130 | "c": 1 131 | }, 132 | "d": { 133 | "e/f": 2 134 | }, 135 | "~1": 3, 136 | "01": 4 137 | } 138 | :test 'equal) 139 | 140 | (1am:test test1-complex-keys 141 | (let ((obj (read-json-string +test1-complex-keys+))) 142 | (1am:is (equal (cljsp:get obj "/a~1b/c") 1)) 143 | (1am:is (equal (cljsp:get obj "/d/e~1f") 2)) 144 | (1am:is (equal (cljsp:get obj "/~01") 3)) 145 | (1am:is (equal (cljsp:get obj "/01") 4)) 146 | (1am:is (equal (cljsp:get obj "/a/b/c") nil)) 147 | (1am:is (equal (cljsp:exists-p obj "/a/b/c") nil)) 148 | (1am:is (equal (cljsp:get obj "/~1") nil)) 149 | (1am:is (equal (cljsp:exists-p obj "/~1") nil)))) 150 | 151 | 152 | (define-constant +test1-ary+ 153 | #[ "zero", "one", "two" ] 154 | :test 'equal) 155 | 156 | (1am:test test1-ary 157 | (let ((ary (read-json-string +test1-ary+))) 158 | ;; draft-ietf-appsawg-json-pointer-08 has special array rules 159 | (1am:signals cl-json-pointer:json-pointer-error 160 | (cljsp:get ary "/01")) 161 | (cljsp:update ary "/-" "three") 162 | (let ((ary ary)) 163 | (json-streams-array-pop-prefix ary) 164 | (1am:is (equal (elt ary 3) "three"))))) 165 | 166 | 167 | (define-constant +test1-example+ 168 | #{ 169 | "foo": ["bar", "baz"], 170 | "": 0, 171 | "a/b": 1, 172 | "c%d": 2, 173 | "e^f": 3, 174 | "g|h": 4, 175 | "i\\j": 5, 176 | "k\"l": 6, 177 | " ": 7, 178 | "m~n": 8 179 | } 180 | :test 'equal) 181 | 182 | (1am:test test1-example 183 | (let ((example (read-json-string +test1-example+))) 184 | (1am:is (equal (cljsp:get example "") example)) 185 | 186 | (let ((ans (cljsp:get example "/foo"))) 187 | (json-streams-array-pop-prefix ans) 188 | (1am:is (equal (length ans) 2)) 189 | (1am:is (equal (elt ans 0) "bar")) 190 | (1am:is (equal (elt ans 1) "baz"))) 191 | 192 | (1am:is (equal (cljsp:get example "/foo/0") "bar")) 193 | (1am:is (equal (cljsp:get example "/") 0)) 194 | (1am:is (equal (cljsp:get example "/a~1b") 1)) 195 | (1am:is (equal (cljsp:get example "/c%d") 2)) 196 | (1am:is (equal (cljsp:get example "/e^f") 3)) 197 | (1am:is (equal (cljsp:get example "/g|h") 4)) 198 | (1am:is (equal (cljsp:get example "/i\\j") 5)) 199 | (if (eq *json-object-flavor* :boost-json) 200 | (warn "boost-json has a problem to read escape chars. Skipping one test.") 201 | (1am:is (equal (cljsp:get example "/k\"l") 6))) 202 | (1am:is (equal (cljsp:get example "/ ") 7)) 203 | (1am:is (equal (cljsp:get example "/m~0n") 8)))) 204 | 205 | 206 | (define-constant +test1-a+ 207 | #{"foo": "bar"} 208 | :test 'equal) 209 | 210 | (1am:test test1-a 211 | (let ((a (read-json-string +test1-a+)) 212 | (pointer (cljsp:parse "/foo"))) 213 | (1am:is (equal (cljsp:get a pointer) "bar")) 214 | (cljsp:update a pointer "test") 215 | (1am:is (equal (cljsp:get a pointer) "test")) 216 | 217 | (let ((result-obj (read-json-string #{"foo": "test"}))) 218 | (1am:is (equal (cljsp:get a "/foo") 219 | (cljsp:get result-obj "/foo")))))) 220 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Abstract 2 | 3 | A JSON Pointer ( [RFC6901](https://tools.ietf.org/html/rfc6901) ) implementation for Common Lisp. 4 | 5 | This libary aims to be independent from any JSON libraries (as much as possible). 6 | 7 | # News 8 | 9 | - (2022-07-31) Added supports for com.inuoe.jzon, shasht, trivial-json-codec, boost-json, and json-lib. 10 | 11 | # License 12 | 13 | The MIT License. See LICENSE file. 14 | 15 | # Loading 16 | 17 | ## Load by quicklisp 18 | 19 | [![Quicklisp](http://quickdocs.org/badge/cl-json-pointer.svg)](http://quickdocs.org/cl-json-pointer/) 20 | 21 | ```lisp 22 | (ql:quickload "cl-json-pointer") 23 | ``` 24 | 25 | ## or, Load manually 26 | 27 | ### Libraries depending on 28 | 29 | * alexandria 30 | * closer-mop 31 | 32 | This library itself does not depend on any JSON libraries. 33 | You can work with your favorite one. 34 | 35 | Current supported JSON libs are (alphabetical order): 36 | 37 | - boost-json 38 | - cl-json 39 | - com.gigamonkeys.json 40 | - com.inuoe.jzon 41 | - jonathan (as `:plist` only) 42 | - json-lib 43 | - json-streams 44 | - jsown 45 | - shasht 46 | - st-json 47 | - trivial-json-codec (`deserialize-json` and `deserialize-json-raw`) 48 | - yason 49 | 50 | ### Loading 51 | 52 | ```lisp 53 | (asdf:load-asd "cl-json-pointer.asd") 54 | (asdf:load-system :cl-json-pointer) 55 | ``` 56 | 57 | ### Running tests. 58 | 59 | The test code depends additinal libraries: 60 | 61 | - All JSON Libraries enumerated above. 62 | - 1am 63 | - named-readtable 64 | 65 | For running tests, do below additionally. 66 | 67 | ```lisp 68 | (asdf:load-asd "cl-json-pointer-test.asd") 69 | (asdf:test-system :cl-json-pointer) 70 | ``` 71 | 72 | # Examples 73 | 74 | ## get opetations (with st-json) 75 | 76 | ```lisp 77 | (in-package :cl-user) 78 | (use-package :cl-json-pointer) 79 | 80 | (defparameter *rfc6901-example* 81 | "{ 82 | \"foo\": [\"bar\", \"baz\"], 83 | \"\": 0, 84 | \"a/b\": 1, 85 | \"c%d\": 2, 86 | \"e^f\": 3, 87 | \"g|h\": 4, 88 | \"i\\\\j\": 5, 89 | \"k\\\"l\": 6, 90 | \" \": 7, 91 | \"m~n\": 8 92 | }") 93 | 94 | (let ((obj (st-json:read-json-from-string *rfc6901-example*)) 95 | (cl-json-pointer:*json-object-flavor* :st-json)) 96 | (eql obj (get-by-json-pointer obj "")) ; => T 97 | (get-by-json-pointer obj "/foo") ; => ("bar" "baz") 98 | (get-by-json-pointer obj "/foo/0") ; => "bar" 99 | (get-by-json-pointer obj "/") ; => 0 100 | (get-by-json-pointer obj "/a~1b") ; => 1 101 | (get-by-json-pointer obj "/c%d") ; => 2 102 | (get-by-json-pointer obj "/e^f") ; => 3 103 | (get-by-json-pointer obj "/g|h") ; => 4 104 | (get-by-json-pointer obj "/i\\j") ; => 5 105 | (get-by-json-pointer obj "/k\"l") ; => 6 106 | (get-by-json-pointer obj "/ ") ; => 7 107 | (get-by-json-pointer obj "/m~0n") ; => 8 108 | ) 109 | ``` 110 | 111 | ## set operations (with cl-json) 112 | 113 | ### setting to an object 114 | 115 | ```lisp 116 | 117 | ;;; Uses *rfc6901-example* above. 118 | 119 | (defparameter *obj* 120 | (cl-json:decode-json-from-string *rfc6901-example*)) 121 | 122 | (get-by-json-pointer *obj* "/hoge" :flavor :cl-json) ; => nil 123 | (exists-p-by-json-pointer *obj* "/hoge" :flavor :cl-json) ; => nil 124 | 125 | 126 | ;; Sets into "hoge" field. 127 | 128 | (setf *obj* 129 | (set-by-json-pointer *obj* "/hoge" "something" :flavor :cl-json)) 130 | 131 | (get-by-json-pointer *obj* "/hoge" :flavor :cl-json) ; => "something" 132 | (exists-p-by-json-pointer *obj* "/hoge" :flavor :cl-json) ; => T 133 | 134 | 135 | ;; `update-by-json-pointer' is a modify macro of `set-by-json-pointer`. 136 | 137 | (update-by-json-pointer *obj* "/hoge" "something-2" :flavor :cl-json) 138 | 139 | (get-by-json-pointer *obj* "/hoge" :flavor :cl-json) ; => "something-2" 140 | (exists-p-by-json-pointer *obj* "/hoge" :flavor :cl-json) ; => T 141 | 142 | 143 | ;; setf to `(get-by-json-pointer ...)' can also be used. 144 | 145 | (setf (get-by-json-pointer *obj* "/hoge" :flavor :cl-json) "fuga") 146 | 147 | (get-by-json-pointer *obj* "/hoge" :flavor :cl-json) ; => "fuga" 148 | 149 | ``` 150 | 151 | ### setting to an array 152 | 153 | 154 | ``` lisp 155 | 156 | ;; setting to array with index 157 | 158 | (defparameter *obj* 159 | (cl-json:decode-json-from-string *rfc6901-example*)) 160 | 161 | (setf *json-object-flavor* :cl-json) ; defaults :flavor to :cl-json 162 | 163 | (get-by-json-pointer *obj* "/foo") ; => ("bar" "baz") 164 | 165 | (update-by-json-pointer *obj* "/foo/0" "zero") 166 | (update-by-json-pointer *obj* "/foo/1" "one") 167 | 168 | (get-by-json-pointer *obj* "/foo") ; => ("zero" "one") 169 | 170 | 171 | ;; adding to an array tail with index 172 | 173 | (exists-p-by-json-pointer *obj* "/foo/2") ; => NIL 174 | 175 | (update-by-json-pointer *obj* "/foo/3" "three") 176 | 177 | (get-by-json-pointer *obj* "/foo/3") ; => "three" 178 | (exists-p-by-json-pointer *obj* "/foo/3") ; => T 179 | 180 | (get-by-json-pointer *obj* "/foo/2") ; => NIL 181 | (exists-p-by-json-pointer *obj* "/foo/2") ; => T 182 | 183 | 184 | ;; pushing to array tail with '-' 185 | 186 | (exists-p-by-json-pointer *obj* "/foo/4") ; => NIL 187 | 188 | (update-by-json-pointer *obj* "/foo/-" "four") 189 | 190 | (get-by-json-pointer *obj* "/foo") ; => ("zero" "one" NIL "three" "four") 191 | (exists-p-by-json-pointer *obj* "/foo/4") ; => T 192 | ``` 193 | 194 | ## delete operations 195 | 196 | ### deleting from an object (with jsown) 197 | 198 | ```lisp 199 | 200 | ;;; Uses *rfc6901-example* above. 201 | 202 | (defparameter *obj* 203 | (jsown:parse *rfc6901-example*)) 204 | 205 | (setf cl-json-pointer:*json-object-flavor* :jsown) 206 | 207 | 208 | (get-by-json-pointer *obj* "/m~0n") ; => 8 209 | 210 | (setf *obj* 211 | (delete-by-json-pointer *obj* "/m~0n")) 212 | 213 | (get-by-json-pointer *obj* "/m~0n") ; => NIL 214 | (exists-p-by-json-pointer *obj* "/m~0n") ; => NIL 215 | 216 | 217 | ;; `deletef-by-json-pointer' is a modify macro of `delete-by-json-pointer`. 218 | 219 | (get-by-json-pointer *obj* "/ ") ; => 7 220 | 221 | (deletef-by-json-pointer *obj* "/ ") 222 | 223 | (get-by-json-pointer *obj* "/ ") ; => NIL 224 | (exists-p-by-json-pointer *obj* "/ ") ; => NIL 225 | 226 | ``` 227 | 228 | ### Deleting from an array (with yason) 229 | 230 | ```lisp 231 | 232 | ;;; Uses "cl-json-pointer/synonyms" system. 233 | ;;; This provides 'cljsp' package contains shorter symbols. 234 | 235 | (asdf:load-system :cl-json-pointer/synonyms) 236 | 237 | 238 | (defparameter *obj* 239 | (yason:parse *rfc6901-example*)) 240 | 241 | (setf cl-json-pointer:*json-object-flavor* :yason) 242 | 243 | 244 | (cljsp:get *obj* "/foo") ; => ("bar" "baz") 245 | 246 | (cljsp:deletef *obj* "/foo/0") 247 | (cljsp:get *obj* "/foo") ; => ("baz") 248 | ``` 249 | 250 | # API 251 | 252 | These symbols are exported from the `cl-json-pointer` package. 253 | Please see their docstring. 254 | 255 | - `parse-json-pointer` 256 | - `*json-object-flavor*` 257 | - `get-by-json-pointer` 258 | - `exists-p-by-json-pointer` 259 | - `set-by-json-pointer` 260 | - `update-by-json-pointer` 261 | - `delete-by-json-pointer` 262 | - `deletef-by-json-pointer` 263 | 264 | ## symbols of `cl-json-pointer/synonyms` 265 | 266 | Another "cl-json-pointer/synonyms" system provides "cljsp" package. 267 | This package contains some shorter symbols. 268 | 269 | For using this, please evaluate: 270 | ```lisp 271 | (asdf:load-system :cl-json-pointer/synonyms) 272 | ``` 273 | 274 | After that, 'cljsp' package will be defined. It exports these symbols: 275 | 276 | - `parse` 277 | - `get` 278 | - `exists-p` 279 | - `set` 280 | - `update` 281 | - `delete` 282 | - `deletef` 283 | 284 | # See Also 285 | 286 | ## Related libraries 287 | 288 | - [`jsown:val`](https://github.com/madnificent/jsown) functionalities. 289 | (I think, I cound simply depend only `jsown` for implementing RFC6901.) 290 | 291 | - [`access`](https://github.com/AccelerationNet/access/) library 292 | traverses many kind of Lisp objects like cl-json-pointer do. 293 | 294 | - [`jsown-utils`](https://github.com/muyinliu/jsown-utils/) has some 295 | accessors works like JSON pointers. 296 | 297 | ## Reviews 298 | 299 | - [cl-json-pointer review in "Review of CL Json Libraries"](https://sabracrolleton.github.io/json-review#cl-json-pointer) by [@sabracrolleton](https://github.com/sabracrolleton). 300 | - [cl-json-pointer review in "Lisp Project of the Day"](https://40ants.com/lisp-project-of-the-day/2020/08/0158-cl-json-pointer.html) by [@40ants](https://github.com/40ants). 301 | -------------------------------------------------------------------------------- /test/test-utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer/test) 2 | 3 | (1am:test test-clone-and-replace-on-cons 4 | (let ((list0 (list 0 1 2 3 4 5))) 5 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons list0 (nthcdr 0 list0) 'a) 6 | '(a 1 2 3 4 5))) 7 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons list0 (nthcdr 1 list0) 'a) 8 | '(0 a 2 3 4 5))) 9 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons list0 (nthcdr 3 list0) 'a) 10 | '(0 1 2 a 4 5))) 11 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons list0 (nthcdr 5 list0) 'a) 12 | '(0 1 2 3 4 a))) 13 | (1am:signals type-error 14 | (cl-json-pointer::clone-and-replace-on-cons list0 999 'xxxa)) 15 | ;; Use nil. 16 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons list0 nil 'nil-replaced) 17 | '(0 1 2 3 4 5 nil-replaced))) 18 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons nil (list 1 2) 'nil-replaced) 19 | '(nil-replaced 2))) 20 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons nil nil 'nil-replaced) 21 | '(nil-replaced))) 22 | ;; Another cons. 23 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons list0 (cons 5 nil) 'a) 24 | '(0 1 2 3 4 5 a))) 25 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons list0 (list #\a #\b #\c) 'head) 26 | '(0 1 2 3 4 5 head #\b #\c))) 27 | ;; Dotted list. 28 | (1am:signals error 29 | (1am:is (equal (cl-json-pointer::clone-and-replace-on-cons (list* 1 2 3) (cons 5 nil) 'a) 30 | '(0 1 2 3 4 5 a)))) 31 | t)) 32 | 33 | (1am:test test-remove-cons 34 | (let ((list0 (list 0 1 2 3 4 5))) 35 | (1am:is (equal (cl-json-pointer::remove-cons list0 (nthcdr 0 list0)) 36 | '(1 2 3 4 5))) 37 | (1am:is (equal (cl-json-pointer::remove-cons list0 (nthcdr 0 list0) 3) 38 | '(3 4 5))) 39 | (1am:is (equal (cl-json-pointer::remove-cons list0 (nthcdr 0 list0) 999) 40 | nil)) 41 | (1am:is (equal (cl-json-pointer::remove-cons list0 (nthcdr 1 list0)) 42 | '(0 2 3 4 5))) 43 | (1am:is (equal (cl-json-pointer::remove-cons list0 (nthcdr 3 list0)) 44 | '(0 1 2 4 5))) 45 | (1am:is (equal (cl-json-pointer::remove-cons list0 (nthcdr 3 list0) 2) 46 | '(0 1 2 5))) 47 | (1am:is (equal (cl-json-pointer::remove-cons list0 (nthcdr 3 list0) 3) 48 | '(0 1 2))) 49 | (1am:is (equal (cl-json-pointer::remove-cons list0 (nthcdr 5 list0)) 50 | '(0 1 2 3 4))) 51 | (1am:signals type-error 52 | (cl-json-pointer::remove-cons list0 'xxx)) 53 | ;; Use nil. 54 | (1am:is (equal (cl-json-pointer::remove-cons list0 nil) 55 | list0)) 56 | (1am:is (equal (cl-json-pointer::remove-cons nil (list 1 2)) 57 | '(2))) 58 | (1am:is (equal (cl-json-pointer::remove-cons nil (list 1 2) 10) 59 | nil)) 60 | (1am:is (equal (cl-json-pointer::remove-cons nil nil) 61 | nil)) 62 | ;; Another cons. 63 | (1am:is (equal (cl-json-pointer::remove-cons list0 (cons 5 nil)) 64 | '(0 1 2 3 4 5))) 65 | (1am:is (equal (cl-json-pointer::remove-cons list0 (list #\a #\b #\c)) 66 | '(0 1 2 3 4 5 #\b #\c))) 67 | (1am:is (equal (cl-json-pointer::remove-cons list0 (list #\a #\b #\c) 2) 68 | '(0 1 2 3 4 5 #\c))) 69 | (1am:is (equal (cl-json-pointer::remove-cons list0 (list #\a #\b #\c) 999) 70 | '(0 1 2 3 4 5))) 71 | ;; Dotted list 72 | (1am:is (equal (cl-json-pointer::remove-cons (list* 0 1 2 3 4 5) (cons 5 nil)) 73 | '(0 1 2 3 4))) 74 | (1am:is (equal (cl-json-pointer::remove-cons (list* 0 1 2 3 4 5) (list #\a #\b #\c)) 75 | '(0 1 2 3 4 #\b #\c))) 76 | (1am:is (equal (cl-json-pointer::remove-cons (list* 0 1 2 3 4 5) (list* #\a #\b #\c)) 77 | '(0 1 2 3 4 #\b . #\c))) 78 | t)) 79 | 80 | (1am:test test-delete-cons 81 | (let ((list0 (list 0 1 2 3 4 5))) 82 | (let ((ret1 (cl-json-pointer::delete-cons list0 (nthcdr 1 list0)))) 83 | (1am:is (equal ret1 '(0 2 3 4 5))) 84 | (1am:is (eq ret1 list0)))) 85 | (macrolet ((with-tmplist (&body body) 86 | `(let ((* (list 0 1 2 3 4 5))) 87 | ,@body)) 88 | (with-tmplist-per-form (&body forms) 89 | (loop for f in forms 90 | collect `(with-tmplist ,f) into xforms 91 | finally (return `(progn ,@xforms))))) 92 | (with-tmplist-per-form 93 | (1am:is (equal (cl-json-pointer::delete-cons * (nthcdr 0 *)) 94 | '(1 2 3 4 5))) 95 | (1am:is (equal (cl-json-pointer::delete-cons * (nthcdr 0 *) 3) 96 | '(3 4 5))) 97 | (1am:is (equal (cl-json-pointer::delete-cons * (nthcdr 0 *) 999) 98 | nil)) 99 | (1am:is (equal (cl-json-pointer::delete-cons * (nthcdr 1 *)) 100 | '(0 2 3 4 5))) 101 | (1am:is (equal (cl-json-pointer::delete-cons * (nthcdr 3 *)) 102 | '(0 1 2 4 5))) 103 | (1am:is (equal (cl-json-pointer::delete-cons * (nthcdr 3 *) 2) 104 | '(0 1 2 5))) 105 | (1am:is (equal (cl-json-pointer::delete-cons * (nthcdr 3 *) 3) 106 | '(0 1 2))) 107 | (1am:is (equal (cl-json-pointer::delete-cons * (nthcdr 5 *)) 108 | '(0 1 2 3 4))) 109 | (1am:signals type-error 110 | (cl-json-pointer::delete-cons * 'xxx)) 111 | ;; Use nil. 112 | (1am:is (equal (cl-json-pointer::delete-cons * nil) 113 | *)) 114 | (1am:is (equal (cl-json-pointer::delete-cons nil (list 1 2 3)) 115 | '(2 3))) 116 | (1am:is (equal (cl-json-pointer::delete-cons nil (list 1 2)) 117 | '(2))) 118 | (1am:is (equal (cl-json-pointer::delete-cons nil (list 1 2) 10) 119 | nil)) 120 | (1am:is (equal (cl-json-pointer::delete-cons nil nil) 121 | nil)) 122 | ;; Another cons. 123 | (1am:is (equal (cl-json-pointer::delete-cons * (cons 5 nil)) 124 | '(0 1 2 3 4 5))) 125 | (1am:is (equal (cl-json-pointer::delete-cons * (list #\a #\b #\c)) 126 | '(0 1 2 3 4 5 #\b #\c))) 127 | (1am:is (equal (cl-json-pointer::delete-cons * (list #\a #\b #\c) 2) 128 | '(0 1 2 3 4 5 #\c))) 129 | (1am:is (equal (cl-json-pointer::delete-cons * (list #\a #\b #\c) 999) 130 | '(0 1 2 3 4 5))) 131 | ;; Dotted list 132 | (1am:is (equal (cl-json-pointer::delete-cons (list* 0 1 2 3 4 5) (cons 5 nil)) 133 | '(0 1 2 3 4))) 134 | (1am:is (equal (cl-json-pointer::delete-cons (list* 0 1 2 3 4 5) (list #\a #\b #\c)) 135 | '(0 1 2 3 4 #\b #\c))) 136 | (1am:is (equal (cl-json-pointer::delete-cons (list* 0 1 2 3 4 5) (list* #\a #\b #\c)) 137 | '(0 1 2 3 4 #\b . #\c))) 138 | t))) 139 | 140 | (1am:test test-extend-list 141 | (1am:is (equal (cl-json-pointer::extend-list nil 0) 142 | nil)) 143 | (1am:is (equal (cl-json-pointer::extend-list nil 2) 144 | '(nil nil))) 145 | (1am:is (equal (cl-json-pointer::extend-list nil 2 :initial-element 0) 146 | '(0 0))) 147 | (1am:is (equal (cl-json-pointer::extend-list nil -2) 148 | nil)) 149 | (let ((lis (list 1 2))) 150 | (1am:is (equal (cl-json-pointer::extend-list lis -2) 151 | '(1 2))) 152 | (1am:is (equal (cl-json-pointer::extend-list lis 0) 153 | '(1 2))) 154 | (1am:is (equal (cl-json-pointer::extend-list lis 1) 155 | '(1 2))) 156 | (1am:is (equal (cl-json-pointer::extend-list lis 2) 157 | '(1 2))) 158 | (1am:is (equal (cl-json-pointer::extend-list lis 3) 159 | '(1 2 nil))) 160 | (1am:is (equal (cl-json-pointer::extend-list lis 4) 161 | '(1 2 nil nil))) 162 | (1am:is (equal (cl-json-pointer::extend-list lis 5) 163 | '(1 2 nil nil nil))) 164 | (1am:is (eq (cl-json-pointer::extend-list lis 8) lis))) 165 | (1am:is (equal (cl-json-pointer::extend-list (list 1 2) 0 :initial-element #\a) 166 | '(1 2))) 167 | (1am:is (equal (cl-json-pointer::extend-list (list 1 2) 5 :initial-element #\a) 168 | '(1 2 #\a #\a #\a))) 169 | t) 170 | -------------------------------------------------------------------------------- /src/traversal.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-json-pointer) 2 | 3 | ;;; Switches 4 | 5 | (defvar *traverse-treat-string-as-atom* t 6 | ;; I don't want to treat string as an array. 7 | "If this is T, cl-json-pointer trests string as atom.") 8 | 9 | (defvar *traverse-nil-set-to-last-method* :list 10 | "Determines how to set to the last (by '-') of NIL. 11 | - `:list' :: (Default) pushes as an ordinal list. 12 | - `:alist' :: pushes (reference-token . ) as an alist. 13 | - `:plist' :: appends (reference-token ) as an plist. 14 | - `:array' :: makes a new array contains .") 15 | (declaim (type symbol *traverse-nil-set-to-last-method*)) 16 | 17 | (defvar *traverse-nil-set-to-index-method* :list 18 | "Determines how to set to NIL by an index. 19 | - `:list' :: (Default) makes a new list and set into nth point. 20 | - `:alist' :: pushes (reference-token . ) as an alist. 21 | - `:plist' :: appends (reference-token ) as an plist. 22 | - `:error' :: throws an error.") 23 | (declaim (type symbol *traverse-nil-set-to-index-method*)) 24 | 25 | (defvar *traverse-nil-set-to-name-method* :alist 26 | "Determines how to set to NIL by a name. 27 | - `:alist' :: (Default) pushes (reference-token . ) as an alist. 28 | - `:plist' :: appends (reference-token ) as an plist.") 29 | (declaim (type symbol *traverse-nil-set-to-name-method*)) 30 | 31 | (defvar *traverse-object-like-kinds* '(:alist :plist)) 32 | 33 | ;;; Tools 34 | 35 | (defmacro chained-setter-lambda 36 | ((&rest vars) (next-function &optional (next-arg nil na-supplied-p)) &body body) 37 | `(lambda (,@vars) 38 | (funcall ,next-function 39 | (progn ,@body 40 | ,@(if na-supplied-p `(,next-arg) ()))))) 41 | 42 | ;;; Main traversal. 43 | 44 | (defgeneric traverse-by-reference-token (flavor obj rtoken set-method next-setter) 45 | (:documentation "Traverses OBJ with a reference token (RTOKEN), and 46 | returns three values: a referred object, existence (boolean), and a 47 | closure can be used as a setter. 48 | 49 | FLAVOR is used when OBJ's type is ambiguous, especially lists.")) 50 | 51 | (defun bad-deleter-error (obj rtoken) 52 | (error 'json-pointer-access-error 53 | :format-control "Object ~S's point ~A is not a place to delete" 54 | :format-arguments (list obj rtoken))) 55 | 56 | ;;; Atoms 57 | 58 | (defun error-on-traversing-atom (flavor obj rtoken) 59 | ;; FIXME: I think this should be error, but a kind of 'silent' option is required.. 60 | (values nil nil 61 | (thunk-lambda 62 | (error 'json-pointer-access-error 63 | :format-control "Obj ~S is considered as atom in cl-json-pointer and not is not allowed to traverse (reference token: ~A, flavor: ~A)" 64 | :format-arguments (list obj rtoken flavor))))) 65 | 66 | (defmethod traverse-by-reference-token (flavor obj rtoken set-method next-setter) 67 | (declare (ignore set-method next-setter)) 68 | ;; bottom case -- refers an unsupported object. 69 | (error-on-traversing-atom obj flavor rtoken)) 70 | 71 | (defmethod traverse-by-reference-token (flavor (obj string) rtoken set-method next-setter) 72 | (declare (ignore set-method next-setter)) 73 | (if *traverse-treat-string-as-atom* 74 | (error-on-traversing-atom obj flavor rtoken) 75 | (call-next-method))) 76 | 77 | ;;; List 78 | 79 | (defmethod traverse-by-reference-token ((flavor (eql :alist)) (alist list) rtoken 80 | set-method next-setter) 81 | ;; accepts `nil' as alist. 82 | (flet ((add-to-head (x) 83 | (acons rtoken x alist))) ; assumes RTOKEN is interned. 84 | (if-let ((entry (assoc rtoken alist :test #'compare-string-by-readtable-case))) 85 | (values (cdr entry) entry 86 | (ecase set-method 87 | ((nil) nil) 88 | (:update 89 | (chained-setter-lambda (x) (next-setter alist) 90 | (setf (cdr entry) x))) 91 | (:add 92 | (chained-setter-lambda (x) (next-setter) 93 | (add-to-head x))) 94 | (:delete 95 | (chained-setter-lambda () (next-setter) 96 | (delete entry alist))) 97 | (:remove 98 | (chained-setter-lambda () (next-setter) 99 | (remove entry alist))))) 100 | (values nil nil 101 | (ecase set-method 102 | ((nil) nil) 103 | ((:add :update) 104 | (chained-setter-lambda (x) (next-setter) 105 | (add-to-head x))) 106 | ((:delete :remove) 107 | (thunk-lambda 108 | (bad-deleter-error alist rtoken)))))))) 109 | 110 | (defmethod traverse-by-reference-token ((flavor (eql :plist)) (plist list) rtoken 111 | set-method next-setter) 112 | ;; accepts `nil' as plist. 113 | (flet ((add-to-head (x) 114 | (list* rtoken x plist))) ; assumes RTOKEN is interned. 115 | (loop for plist-head on plist by #'cddr 116 | as (k v) = plist-head 117 | when (compare-string-by-readtable-case k rtoken) ; plist often uses `eq', but I use this. 118 | return (values v plist-head 119 | (ecase set-method 120 | ((nil) nil) 121 | (:update 122 | (chained-setter-lambda (x) (next-setter plist) 123 | (setf (cadr plist-head) x))) 124 | (:add 125 | (chained-setter-lambda (x) (next-setter) 126 | (add-to-head x))) 127 | (:delete 128 | (chained-setter-lambda () (next-setter) 129 | (delete-cons plist plist-head 2))) 130 | (:remove 131 | (chained-setter-lambda () (next-setter) 132 | (remove-cons plist plist-head 2))))) 133 | finally 134 | (return (values nil nil 135 | (ecase set-method 136 | ((nil) nil) 137 | ((:update :add) 138 | (chained-setter-lambda (x) (next-setter) 139 | (add-to-head x))) 140 | ((:delete :remove) 141 | (thunk-lambda 142 | (bad-deleter-error plist rtoken))))))))) 143 | 144 | (defmethod traverse-by-reference-token ((flavor (eql :list)) (list list) 145 | (rtoken (eql +end+)) set-method next-setter) 146 | "Pushing to an ordinal list." 147 | (values nil nil 148 | (ecase set-method 149 | ((nil) nil) 150 | (:update 151 | (chained-setter-lambda (x) (next-setter) 152 | (nconc list (list x)))) 153 | (:add 154 | (chained-setter-lambda (x) (next-setter) 155 | (append list (list x)))) 156 | ((:delete :remove) 157 | (thunk-lambda 158 | (bad-deleter-error list rtoken)))))) 159 | 160 | (defmethod traverse-by-reference-token ((flavor (eql :list)) (list list) 161 | (index integer) set-method next-setter) 162 | "Indexing to an ordinal list." 163 | (if-let ((this-cons (nthcdr index list))) 164 | (values (car this-cons) this-cons 165 | (ecase set-method 166 | ((nil) nil) 167 | (:update 168 | (chained-setter-lambda (x) (next-setter list) 169 | (setf (car this-cons) x))) 170 | (:add 171 | (chained-setter-lambda (x) (next-setter) 172 | (clone-and-replace-on-cons list this-cons x))) 173 | (:delete 174 | (chained-setter-lambda () (next-setter) 175 | (delete-cons list this-cons))) 176 | (:remove 177 | (chained-setter-lambda () (next-setter) 178 | (remove-cons list this-cons))))) 179 | (values nil nil 180 | (ecase set-method 181 | ((nil) nil) 182 | ((:delete :remove) 183 | (thunk-lambda 184 | (bad-deleter-error list index))) 185 | (:update 186 | (chained-setter-lambda (x) (next-setter list) 187 | ;; TODO: should be more efficient.. 188 | (setf list (extend-list list (1+ index))) 189 | (setf (nth index list) x))) 190 | (:add 191 | (chained-setter-lambda (x) (next-setter list) 192 | ;; TODO: should be more efficient.. 193 | (setf list (extend-list (copy-list list) (1+ index))) 194 | (setf (nth index list) x))))))) 195 | 196 | (defmethod traverse-by-reference-token ((flavor (eql :list)) (list list) 197 | (rtoken string) set-method next-setter) 198 | "Indexing to an ordinal list." 199 | (traverse-by-reference-token flavor list 200 | (read-reference-token-as-index rtoken) 201 | set-method next-setter)) 202 | 203 | (defmethod traverse-by-reference-token (flavor (obj list) (rtoken (eql +end+)) set-method next-setter) 204 | (declare (ignore flavor)) 205 | (traverse-by-reference-token :list obj rtoken set-method next-setter)) 206 | 207 | (defmethod traverse-by-reference-token (flavor (obj list) (rtoken integer) set-method next-setter) 208 | (declare (ignore flavor)) 209 | (traverse-by-reference-token :list obj rtoken set-method next-setter)) 210 | 211 | (defun list-try-traverse (kinds flavor list rtoken set-method next-setter) 212 | ;; RTOKEN may be ambiguous with an index or a name of object fields. 213 | ;; 214 | ;; 1. Try to use it as an existed field name. 215 | ;; FIXME: This loop is too heavy! (but I think this is required..) 216 | (let* ((set-to-nil-kind-default nil) 217 | (interned-rtoken (intern-object-key flavor rtoken)) 218 | (try-results 219 | (loop for kind in kinds 220 | as ret = 221 | (handler-case 222 | (multiple-value-list 223 | (traverse-by-reference-token kind list interned-rtoken set-method next-setter)) 224 | (error () nil)) 225 | if (second ret) ; exists? 226 | do (return-from list-try-traverse 227 | (values-list ret)) 228 | else if (eq kind *traverse-nil-set-to-name-method*) 229 | do (setf set-to-nil-kind-default ret) ; See '3-1.' below. 230 | else 231 | collect ret))) 232 | ;; RTOKEN is not a name of object fields. 233 | ;; 234 | ;; 2. If it can be read as an index, I treat OBJ as an ordinal list. 235 | (multiple-value-bind (index bad-index-condition) 236 | (read-reference-token-as-index rtoken nil) 237 | (when index ; yes, an ordinal list! 238 | (return-from list-try-traverse 239 | (traverse-by-reference-token :list list rtoken set-method next-setter))) 240 | (when (typep bad-index-condition 'json-pointer-bad-reference-token-0-used-error) 241 | (error bad-index-condition))) 242 | ;; 3. RTOKEN assumed as a field name, but not found in the list. 243 | ;; 3-1. use the specified default. 244 | (when (and set-to-nil-kind-default 245 | (third set-to-nil-kind-default)) 246 | (return-from list-try-traverse 247 | (values-list set-to-nil-kind-default))) 248 | ;; 3-2. use a found one. 249 | (loop for ret in try-results 250 | when (third ret) 251 | return (return-from list-try-traverse 252 | (values-list ret))) 253 | ;; 3-3. no way... 254 | (values nil nil 255 | (if set-method 256 | (thunk-lambda 257 | (error 'json-pointer-access-error 258 | :format-control "There is no way to set to ~A (rtoken ~A)" 259 | :format-arguments (list list rtoken))))))) 260 | 261 | (defmethod traverse-by-reference-token (flavor (obj list) (rtoken string) set-method next-setter) 262 | (list-try-traverse *traverse-object-like-kinds* flavor 263 | obj rtoken set-method next-setter)) 264 | 265 | (defmethod traverse-by-reference-token (flavor (obj null) rtoken set-method next-setter) 266 | ;; empty. this is problematic for setting. 267 | (values nil nil 268 | (ecase set-method 269 | ((nil) nil) 270 | ((:delete :remove) 271 | (thunk-lambda 272 | (bad-deleter-error obj rtoken))) 273 | ((:update :add) 274 | (let* ((index (read-reference-token-as-index rtoken nil)) 275 | (nil-method 276 | (cond ((eq index +end+) 277 | *traverse-nil-set-to-last-method*) 278 | ((integerp index) 279 | *traverse-nil-set-to-index-method*) 280 | (t 281 | *traverse-nil-set-to-name-method*)))) 282 | (ecase nil-method 283 | ((:alist :plist) 284 | (nth-value 2 (traverse-by-reference-token 285 | nil-method obj 286 | (intern-object-key flavor rtoken) 287 | set-method next-setter))) 288 | (:list 289 | (nth-value 2 (traverse-by-reference-token 290 | nil-method obj rtoken set-method next-setter))) 291 | (:array 292 | (chained-setter-lambda (x) (next-setter) 293 | (make-array 1 :adjustable t :initial-element x :fill-pointer t))) 294 | (:error 295 | (thunk-lambda 296 | (error 'json-pointer-access-error 297 | :format-control "Set to nil by '~A' is not supported" index))))))))) 298 | 299 | ;;; Objects 300 | 301 | (defun traverse-by-reference-token-using-class (flavor obj rtoken set-method next-setter class) 302 | (let ((object-key (intern-object-key flavor rtoken))) 303 | (if-let ((slot (find object-key (class-slots class) 304 | :key #'slot-definition-name 305 | :test #'string=))) 306 | (let ((bound? (slot-boundp-using-class class obj slot))) 307 | (values (if bound? 308 | (slot-value-using-class class obj slot)) 309 | bound? 310 | (ecase set-method 311 | ((nil) nil) 312 | ((:update :add) 313 | (chained-setter-lambda (x) (next-setter obj) 314 | (setf (slot-value-using-class class obj slot) x))) 315 | ((:remove :delete) 316 | (if bound? 317 | (chained-setter-lambda () (next-setter obj) 318 | (slot-makunbound-using-class class obj slot)) 319 | (thunk-lambda 320 | (error 'json-pointer-access-error 321 | :format-control "object ~A's '~A' slot is unbound" 322 | :format-arguments (list obj rtoken)))))))) 323 | (values nil nil 324 | (if set-method ; TODO: add slot? (only if "add") 325 | (thunk-lambda 326 | (error 'json-pointer-access-error 327 | :format-control "object ~A does not have '~A' slot" 328 | :format-arguments (list obj rtoken)))))))) 329 | 330 | (defmethod traverse-by-reference-token (flavor (obj standard-object) rtoken set-method next-setter) 331 | ;; `cl-json:fluid-object' can be treated here. 332 | (traverse-by-reference-token-using-class flavor obj rtoken set-method next-setter (class-of obj))) 333 | 334 | (defmethod traverse-by-reference-token (flavor (obj structure-object) rtoken set-method next-setter) 335 | (traverse-by-reference-token-using-class flavor obj rtoken set-method next-setter (class-of obj))) 336 | 337 | ;;; Hash table 338 | 339 | (defmethod traverse-by-reference-token (flavor (obj hash-table) rtoken set-method next-setter) 340 | (let ((object-key (intern-object-key flavor rtoken))) 341 | (multiple-value-bind (value exists?) (gethash object-key obj) 342 | (values value exists? 343 | (ecase set-method 344 | ((nil) nil) 345 | ((:add :update) 346 | (chained-setter-lambda (x) (next-setter obj) 347 | (setf (gethash object-key obj) x))) 348 | ((:delete :remove) 349 | (if exists? 350 | (chained-setter-lambda () (next-setter obj) 351 | (remhash object-key obj)) 352 | (thunk-lambda 353 | (error 'json-pointer-access-error 354 | :format-control "Hash-table ~A does not have ~A key" 355 | :format-arguments (list obj rtoken)))))))))) 356 | 357 | ;;; Array 358 | 359 | (defmethod traverse-by-reference-token (flavor (obj array) (rtoken (eql +end+)) set-method next-setter) 360 | (declare (ignore flavor)) 361 | (values nil nil 362 | (ecase set-method 363 | ((nil) nil) 364 | ((:update :add) 365 | (chained-setter-lambda (x) (next-setter obj) 366 | (unless (array-try-push obj x) 367 | ;; Automatically extends it. 368 | (let ((old-length (length obj))) 369 | (setf obj (extend-array obj (1+ old-length) old-length))) 370 | (vector-push x obj)))) 371 | ((:delete :remove) 372 | (thunk-lambda 373 | (bad-deleter-error obj rtoken)))))) 374 | 375 | (defun vector-in-bounds-p (vector index) 376 | "Because `array-in-bounds-p' ignores fill-pointers." 377 | (and (<= 0 index) (< index (length vector)))) 378 | 379 | (defmethod traverse-by-reference-token (flavor (obj array) (rtoken integer) set-method next-setter) 380 | (declare (ignore flavor)) 381 | (if (not (vector-in-bounds-p obj rtoken)) 382 | (values nil nil 383 | (ecase set-method 384 | ((nil) nil) 385 | ((:update :add) 386 | (chained-setter-lambda (x) (next-setter obj) 387 | ;; Automatically extends it. 388 | (setf obj (extend-array obj (1+ rtoken) t) 389 | (aref obj rtoken) x))) 390 | ((:delete :remove) 391 | (thunk-lambda 392 | (bad-deleter-error obj rtoken))))) 393 | (values (aref obj rtoken) rtoken 394 | (ecase set-method 395 | ((nil) nil) 396 | ((:update :add) 397 | (chained-setter-lambda (x) (next-setter obj) 398 | (setf (aref obj rtoken) x))) 399 | ((:delete :remove) 400 | (chained-setter-lambda () (next-setter obj) 401 | ;; Fills with NIL. (There is no way to 'remove nil') 402 | (setf (aref obj rtoken) nil))))))) 403 | 404 | (defmethod traverse-by-reference-token (flavor (obj array) (rtoken string) set-method next-setter) 405 | (let ((index (read-reference-token-as-index rtoken))) 406 | (traverse-by-reference-token flavor obj index set-method next-setter))) 407 | 408 | ;;; Entry Point 409 | 410 | (defun traverse-by-json-pointer (obj flavor pointer set-method) 411 | "Traverses OBJ with a parsed json-pointer (POINTER), and returns three values: 412 | the referred object, existence (boolean), and a closure can be used as a setter. 413 | 414 | SET-METHOD determines how to _set_ into OBJ by the returned setter: 415 | - `nil' :: No setters made. (Do not set to OBJ.) 416 | - `:update' :: Destructively updates into OBJ. 417 | - `:delete' :: Destructively deletes from OBJ. 418 | - `:add' :: If changing a list, makes a new list containing the set'ed value. (non-list objs are still modified). 419 | - `:remove' :: If deleting form a list, makes a new list not containing the removed value. (non-list objs are still modified). 420 | 421 | FLAVOR is a keyword specifies the JSON object flavors. 422 | See `*cl-json-pointer-supported-json-flavors*' 423 | " 424 | (let ((value obj) 425 | (exists? t) 426 | (setter 427 | (if set-method 428 | (lambda (&optional x) (setf obj x))))) 429 | (loop for (rtoken . next) on pointer 430 | as this-set-method = (ecase set-method 431 | ((:add :update nil) set-method) 432 | ;; Makes a deleter only at last. 433 | (:remove (if next :add :remove)) 434 | (:delete (if next :update :delete))) 435 | do (setf (values value exists? setter) 436 | (traverse-by-reference-token flavor value rtoken this-set-method setter)) 437 | while next) 438 | (values value exists? setter))) 439 | --------------------------------------------------------------------------------