├── .github └── workflows │ └── CI.yml ├── .gitignore ├── COPYING ├── README.md ├── json-mop.asd ├── src ├── conditions.lisp ├── json-mop.lisp ├── package.lisp ├── to-json.lisp └── to-lisp.lisp └── tests ├── encode-decode.lisp ├── json-mop-tests.asd ├── package.lisp ├── redefine-class.lisp └── tests.lisp /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | # Based on https://github.com/3b/ci-example 2 | 3 | # Copyright (c) 2020 3b 4 | # Copyright (c) 2021 Grim Schjetne 5 | 6 | # This source code is licensed under the MIT license found in the 7 | # COPYING file in the root directory of this source tree. 8 | 9 | name: CI 10 | 11 | # Controls when the action will run. Triggers the workflow on push for any branch, and 12 | # pull requests to master 13 | on: 14 | workflow_dispatch: 15 | push: 16 | pull_request: 17 | branches: [ master ] 18 | 19 | # A workflow run is made up of one or more jobs that can run sequentially or in parallel 20 | jobs: 21 | test: 22 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 23 | strategy: 24 | matrix: 25 | lisp: [ sbcl-bin ] 26 | os: [ ubuntu-latest ] 27 | 28 | # run the job on every combination of "lisp" and "os" above 29 | runs-on: ${{ matrix.os }} 30 | 31 | steps: 32 | # tell git not to convert line endings 33 | # change roswell install dir and add it to path 34 | - name: windows specific settings 35 | if: matrix.os == 'windows-latest' 36 | run: | 37 | git config --global core.autocrlf false 38 | echo "ROSWELL_INSTALL_DIR=$HOME/ros" >> $GITHUB_ENV 39 | echo "$HOME/ros/bin" >> $GITHUB_PATH 40 | 41 | # Check out your repository under $GITHUB_WORKSPACE, so your job can access it 42 | - uses: actions/checkout@v2 43 | 44 | - name: cache .roswell 45 | id: cache-dot-roswell 46 | uses: actions/cache@v1 47 | with: 48 | path: ~/.roswell 49 | key: ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}-${{ hashFiles('**/*.asd') }} 50 | restore-keys: | 51 | ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}- 52 | ${{ runner.os }}-dot-roswell- 53 | - name: install roswell 54 | shell: bash 55 | # always run install, since it does some global installs and setup that isn't cached 56 | env: 57 | LISP: ${{ matrix.lisp }} 58 | run: curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh -x 59 | - name: run lisp 60 | continue-on-error: true 61 | shell: bash 62 | run: | 63 | ros -e '(format t "~a:~a on ~a~%...~%~%" (lisp-implementation-type) (lisp-implementation-version) (machine-type))' 64 | ros -e '(format t " fixnum bits:~a~%" (integer-length most-positive-fixnum))' 65 | ros -e "(ql:quickload 'trivial-features)" -e '(format t "features = ~s~%" *features*)' 66 | - name: update ql dist if we have one cached 67 | shell: bash 68 | run: ros -e "(ql:update-all-dists :prompt nil)" 69 | 70 | - name: load code and run tests 71 | shell: bash 72 | run: | 73 | ros -e "(ql:quickload 'json-mop-tests)" -e "(unless (it.bese.fiveam:run-all-tests) (uiop:quit 1))" 74 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.abcl 3 | *.d64fsl 4 | *.dfsl 5 | *.dx32fsl 6 | *.dx64fsl 7 | *.fasl 8 | *.fx32fsl 9 | *.fx64fsl 10 | *.lisp-temp 11 | *.lx32fsl 12 | *.lx64fsl 13 | *.p64fsl 14 | *.pfsl 15 | *.sx32fsl 16 | *.sx64fsl 17 | *.wx32fsl 18 | *.wx64fsl 19 | *~ -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Grim Schjetne 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # JSON-MOP 2 | 3 | [![Quicklisp dist](http://quickdocs.org/badge/json-mop.svg)](http://quickdocs.org/json-mop/) 4 | 5 | [![CI](https://github.com/gschjetne/json-mop/actions/workflows/CI.yml/badge.svg)](https://github.com/gschjetne/json-mop/actions/workflows/CI.yml) 6 | 7 | ## Introduction 8 | 9 | JSON-MOP is a small library aiming to cut down time spent moving data 10 | between CLOS and JSON objects. It depends on 11 | [YASON](https://github.com/hanshuebner/yason) and it should be 12 | possible to use it alongside straight calls to functions from YASON. 13 | 14 | ## Quick Start 15 | 16 | To use JSON-MOP, define your classes with the class option 17 | `(:metaclass json-serializable-class)`. For slots that you want to appear in 18 | the JSON representation of your class, add the slot option `:json-key` 19 | with the string to use as the attribute name. The option `:json-type` 20 | defaults to `:any`, but you can control how each slot value is 21 | transformed to and from JSON with one of the following: 22 | 23 | ### JSON type specifiers 24 | 25 | Type | Remarks 26 | --------------|-------------------------------------------- 27 | `:any` | Guesses the way to encode and decode the value 28 | `:string` | Enforces a string value 29 | `:number` | Enforces a number value 30 | `:integer` | Enforces an integer value 31 | `:hash-table` | Enforces a hash table value 32 | `:vector` | Enforces a vector value 33 | `:list` | Enforces a list value 34 | `:bool` | Maps `T` and `NIL` with `true` and `false` 35 | `` | Uses a `(:metaclass json-serializable-class)` class definition to direct the transformation of the value 36 | 37 | ### Homogeneous sequences and objects 38 | 39 | In addition, the type specifier may be a list of two elements, first 40 | element is one of `:list`, `:vector`, `:hash-table`; the second is any JSON type 41 | specifier that is to be applied to the elements of the list or the values of the hash-table. 42 | 43 | ### NIL and null semantics 44 | 45 | JSON `null` is treated as an unbound slot in CLOS. Unbound slots are 46 | ignored when encoding objects, unless `*encode-unbound-slots*` is 47 | bound to `T`, in which case they are represented as JSON `null`. 48 | 49 | Slots bound to `NIL` with JSON types other `:bool` will signal an 50 | error, but this may change in the future. 51 | 52 | ### Encoding and decoding JSON 53 | 54 | Turning an object into JSON is done with the `yason:encode` generic 55 | function. Turning it back into an object is slightly more involved, 56 | using `json-to-clos` on a stream, string or hash table; a class name; 57 | and optional initargs for the class. Values decoded from the JSON will 58 | override values specified in the initargs. 59 | 60 | ### Example 61 | 62 | First, define your classes: 63 | 64 | ```lisp 65 | (defclass book () 66 | ((title :initarg :title 67 | :json-type :string 68 | :json-key "title") 69 | (published-year :initarg :year 70 | :json-type :number 71 | :json-key "year_published") 72 | (fiction :initarg :fiction 73 | :json-type :bool 74 | :json-key "is_fiction")) 75 | (:metaclass json-serializable-class)) 76 | 77 | (defclass author () 78 | ((name :initarg :name 79 | :json-type :string 80 | :json-key "name") 81 | (birth-year :initarg :year 82 | :json-type :number 83 | :json-key "year_birth") 84 | (bibliography :initarg :bibliography 85 | :json-type (:list book) 86 | :json-key "bibliography")) 87 | (:metaclass json-serializable-class)) 88 | ``` 89 | 90 | Let's try creating an instance: 91 | 92 | ```lisp 93 | (defparameter *author* 94 | (make-instance 'author 95 | :name "Mark Twain" 96 | :year 1835 97 | :bibliography 98 | (list 99 | (make-instance 'book 100 | :title "The Gilded Age: A Tale of Today" 101 | :year 1873 102 | :fiction t) 103 | (make-instance 'book 104 | :title "Life on the Mississippi" 105 | :year 1883 106 | :fiction nil) 107 | (make-instance 'book 108 | :title "Adventures of Huckleberry Finn" 109 | :year 1884 110 | :fiction t)))) 111 | ``` 112 | 113 | To turn it into JSON, `encode` it: 114 | 115 | ```lisp 116 | (encode *author*) 117 | ``` 118 | 119 | This will print the following: 120 | 121 | ```javascript 122 | {"name":"Mark Twain","year_birth":1835,"bibliography":[{"title":"The Gilded Age: A Tale of Today","year_published":1873,"is_fiction":true},{"title":"Life on the Mississippi","year_published":1883,"is_fiction":false},{"title":"Adventures of Huckleberry Finn","year_published":1884,"is_fiction":true}]} 123 | ``` 124 | 125 | The same can be turned back into a CLOS object with `(json-to-clos input 'author)` 126 | 127 | ## Licence 128 | 129 | Copyright (c) 2015 Grim Schjetne 130 | 131 | Permission is hereby granted, free of charge, to any person obtaining 132 | a copy of this software and associated documentation files (the 133 | "Software"), to deal in the Software without restriction, including 134 | without limitation the rights to use, copy, modify, merge, publish, 135 | distribute, sublicense, and/or sell copies of the Software, and to 136 | permit persons to whom the Software is furnished to do so, subject to 137 | the following conditions: 138 | 139 | The above copyright notice and this permission notice shall be 140 | included in all copies or substantial portions of the Software. 141 | 142 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 143 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 144 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 145 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 146 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 147 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 148 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 149 | -------------------------------------------------------------------------------- /json-mop.asd: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2016 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (asdf:defsystem #:json-mop 24 | :description "A metaclass for bridging CLOS and JSON" 25 | :author "Grim Schjetne" 26 | :license "MIT" 27 | :depends-on (#:closer-mop 28 | #:yason 29 | #:anaphora) 30 | :serial t 31 | :components ((:module "src" 32 | :serial t 33 | :components 34 | ((:file "package") 35 | (:file "conditions") 36 | (:file "json-mop") 37 | (:file "to-lisp") 38 | (:file "to-json"))))) 39 | -------------------------------------------------------------------------------- /src/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2015 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (in-package #:json-mop) 24 | 25 | (define-condition slot-not-serializable (warning) 26 | ((slot-name :initarg :slot-name 27 | :reader slot-name)) 28 | (:report (lambda (condition stream) 29 | (format stream "Slot ~A has no JSON metadata associated with it." 30 | (slot-name condition))))) 31 | 32 | ;; TODO: inherit TYPE-ERROR and change all occurences to specify 33 | ;; :expected-type, likewise change relevant occurrences of TYPE-ERROR 34 | ;; to JSON-TYPE-ERROR 35 | (define-condition json-type-error (error) 36 | ((json-type :initarg :json-type 37 | :reader json-type))) 38 | 39 | (define-condition null-value (json-type-error) ()) 40 | 41 | (define-condition null-in-homogeneous-sequence (json-type-error) () 42 | (:report (lambda (condition stream) 43 | (format stream "null encountered in a homogeneous sequence of type ~S" 44 | (json-type condition))))) 45 | 46 | (define-condition no-values-parsed (warning) 47 | ((hash-table :initarg :hash-table 48 | :reader no-values-hash-table) 49 | (class-name :initarg :class-name 50 | :reader no-values-class)) 51 | (:report (lambda (condition stream) 52 | (format stream "No keys corresponding to slots in ~A found in ~A" 53 | (no-values-class condition) 54 | (no-values-hash-table condition))))) 55 | 56 | (defun read-eval-query () 57 | (format *query-io* "Eval: ") 58 | (list (eval (read *query-io*)))) 59 | -------------------------------------------------------------------------------- /src/json-mop.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2015 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (in-package #:json-mop) 24 | 25 | (defclass json-serializable-class (closer-mop:standard-class) ()) 26 | 27 | (defmethod closer-mop:validate-superclass ((class json-serializable-class) 28 | (super closer-mop:standard-class)) t) 29 | 30 | (defmethod closer-mop:validate-superclass ((class standard-class) 31 | (super json-serializable-class)) t) 32 | 33 | (defclass json-serializable-slot (closer-mop:standard-direct-slot-definition) 34 | ((json-key :initarg :json-key 35 | :initform nil 36 | :reader json-key-name) 37 | (json-type :initarg :json-type 38 | :initform :any 39 | :reader json-type))) 40 | 41 | (defmethod json-key-name ((slot closer-mop:standard-direct-slot-definition)) 42 | (warn 'slot-not-serializable 43 | :slot-name (closer-mop:slot-definition-name slot))) 44 | 45 | (defmethod closer-mop:direct-slot-definition-class ((class json-serializable-class) 46 | &rest initargs) 47 | (declare (ignore class initargs)) 48 | (find-class 'json-serializable-slot)) 49 | 50 | (defclass json-serializable () ()) 51 | 52 | (defmethod initialize-instance :around ((class json-serializable-class) 53 | &rest rest &key direct-superclasses) 54 | (apply #'call-next-method 55 | class 56 | :direct-superclasses 57 | (append direct-superclasses (list (find-class 'json-serializable))) 58 | rest)) 59 | 60 | (defmethod reinitialize-instance :around ((class json-serializable-class) 61 | &rest rest &key direct-superclasses) 62 | (apply #'call-next-method 63 | class 64 | :direct-superclasses 65 | (append direct-superclasses (list (find-class 'json-serializable))) 66 | rest)) 67 | 68 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2015 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (defpackage #:json-mop 24 | (:use #:cl) 25 | (:import-from #:yason 26 | #:true 27 | #:false 28 | #:parse 29 | #:encode 30 | #:encode-array-element 31 | #:encode-object-element 32 | #:with-output 33 | #:with-array 34 | #:with-object) 35 | (:import-from #:anaphora 36 | #:awhen 37 | #:it) 38 | (:export #:json-serializable 39 | #:json-serializable-class 40 | #:to-lisp-value 41 | #:to-json-value 42 | #:json-to-clos 43 | ;; Re-export yason:encode 44 | #:encode 45 | ;; Conditions 46 | #:slot-not-serializable 47 | #:slot-name 48 | #:json-type-error 49 | #:json-type 50 | #:null-value 51 | #:null-in-homogenous-sequence 52 | #:no-values-parsed 53 | #:no-values-hash-table 54 | #:no-values-class)) 55 | -------------------------------------------------------------------------------- /src/to-json.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2015 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (in-package #:json-mop) 24 | 25 | (defvar *encode-unbound-slots* nil) 26 | 27 | (defgeneric to-json-value (value json-type) 28 | (:documentation 29 | "Turns a VALUE into a form appropriate for consumption by Yason")) 30 | 31 | (defmethod to-json-value (value (json-type (eql :any))) 32 | "When the JSON type is :ANY, Pass the VALUE unchanged" 33 | value) 34 | 35 | (defmethod to-json-value ((value null) json-type) 36 | (error 'null-value :json-type json-type)) 37 | 38 | (defmethod to-json-value ((value string) (json-type (eql :string))) 39 | "Return the string VALUE" 40 | value) 41 | 42 | (defmethod to-json-value ((value number) (json-type (eql :number))) 43 | "Return the number VALUE" 44 | value) 45 | 46 | (defmethod to-json-value ((value integer) (json-type (eql :integer))) 47 | "Return the integer VALUE" 48 | value) 49 | 50 | (defmethod to-json-value ((value hash-table) (json-type (eql :hash-table))) 51 | "Return the hash-table VALUE" 52 | value) 53 | 54 | (defmethod to-json-value ((value vector) (json-type (eql :vector))) 55 | "Return the vector VALUE" 56 | value) 57 | 58 | (defmethod to-json-value ((value list) (json-type (eql :list))) 59 | "Return the list VALUE" 60 | value) 61 | 62 | (defmethod to-json-value ((value null) (json-type (eql :list))) 63 | "Return the empty list VALUE" 64 | #()) 65 | 66 | (defmethod to-json-value (value (json-type (eql :bool))) 67 | "Return the boolean true" 68 | 'true) 69 | 70 | (defmethod to-json-value ((value null) (json-type (eql :bool))) 71 | "Return the boolean false" 72 | 'false) 73 | 74 | (defclass homogeneous-hash-table-intermediate-class () 75 | ((values :initarg :values) 76 | (hash-table-json-type :initarg :hash-table-json-type) 77 | (element-json-type :initarg :element-json-type))) 78 | 79 | (defmethod to-json-value ((value hash-table) (json-type cons)) 80 | "Return the homogeneous hash-table VALUE" 81 | (ecase (first json-type) 82 | (:hash-table (check-type value hash-table))) 83 | (make-instance 'homogeneous-hash-table-intermediate-class 84 | :values value 85 | :hash-table-json-type (first json-type) 86 | :element-json-type (second json-type))) 87 | 88 | (defmethod to-json-value ((value sequence) (json-type cons)) 89 | "Return the homogeneous sequence VALUE" 90 | (ecase (first json-type) 91 | (:list (check-type value list)) 92 | (:vector (check-type value vector))) 93 | (make-instance 'homogeneous-sequence-intermediate-class 94 | :values value 95 | :sequence-json-type (first json-type) 96 | :element-json-type (second json-type))) 97 | 98 | (defclass homogeneous-sequence-intermediate-class () 99 | ((values :initarg :values) 100 | (sequence-json-type :initarg :sequence-json-type) 101 | (element-json-type :initarg :element-json-type))) 102 | 103 | (defmethod to-json-value (value (json-type symbol)) 104 | (if (eql (class-of value) (find-class json-type)) 105 | value 106 | (error 'json-type-error :json-type json-type))) 107 | 108 | (defmethod encode ((sequence homogeneous-sequence-intermediate-class) 109 | &optional (stream *standard-output*)) 110 | (with-output (stream) 111 | (with-array () 112 | (with-slots (values sequence-json-type element-json-type) sequence 113 | (map nil (lambda (element) 114 | (handler-case 115 | (encode-array-element (to-json-value element element-json-type)) 116 | (null-value (condition) 117 | (declare (ignore condition)) 118 | (restart-case (error 'null-in-homogeneous-sequence 119 | :json-type (list sequence-json-type 120 | element-json-type)) 121 | (use-value (value) 122 | :report "Specify a value to use in place of the null" 123 | :interactive read-eval-query 124 | (encode-array-element value)))))) 125 | values)))) 126 | sequence) 127 | 128 | (defmethod encode ((hash-table homogeneous-hash-table-intermediate-class) 129 | &optional (stream *standard-output*)) 130 | (with-output (stream) 131 | (with-object () 132 | (with-slots (values hash-table-json-type element-json-type) 133 | hash-table 134 | (maphash (lambda (key value) 135 | (encode-object-element 136 | (to-json-value key :string) 137 | (to-json-value value element-json-type))) 138 | values)))) 139 | hash-table) 140 | 141 | (defmethod encode ((object json-serializable) 142 | &optional (stream *standard-output*)) 143 | (with-output (stream) 144 | (with-object () 145 | (loop for class in (closer-mop:class-precedence-list (class-of object)) 146 | do (loop for slot in (closer-mop:class-direct-slots class) 147 | when (typep slot 'json-serializable-slot) 148 | do (awhen (json-key-name slot) 149 | (handler-case 150 | (encode-object-element 151 | it 152 | (to-json-value 153 | (slot-value object (closer-mop:slot-definition-name slot)) 154 | (json-type slot))) 155 | (unbound-slot (condition) 156 | (declare (ignore condition)) 157 | (when *encode-unbound-slots* 158 | (encode-object-element it nil))))))))) 159 | object) 160 | 161 | -------------------------------------------------------------------------------- /src/to-lisp.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2015 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (in-package #:json-mop) 24 | 25 | (defgeneric to-lisp-value (value json-type) 26 | (:documentation 27 | "Turns a value passed by Yason into the appropriate 28 | Lisp type as specified by JSON-TYPE")) 29 | 30 | (defmethod to-lisp-value ((value (eql :null)) json-type) 31 | "When the value is JSON null, signal NULL-VALUE error" 32 | (error 'null-value :json-type json-type)) 33 | 34 | (defmethod to-lisp-value (value (json-type (eql :any))) 35 | "When the JSON type is :ANY, Pass the VALUE unchanged" 36 | value) 37 | 38 | (defmethod to-lisp-value ((value hash-table) (json-type (eql :any))) 39 | "When the JSON type is :ANY, Pass the hash-table VALUE unchanged" 40 | value) 41 | 42 | (defmethod to-lisp-value ((value string) (json-type (eql :string))) 43 | "Return the string VALUE" 44 | value) 45 | 46 | (defmethod to-lisp-value ((value number) (json-type (eql :number))) 47 | "Return the number VALUE" 48 | value) 49 | 50 | (defmethod to-lisp-value ((value integer) (json-type (eql :integer))) 51 | "Return the number VALUE" 52 | value) 53 | 54 | (defmethod to-lisp-value ((value hash-table) (json-type (eql :hash-table))) 55 | "Return the hash-table VALUE" 56 | value) 57 | 58 | (defmethod to-lisp-value ((value hash-table) (json-type cons)) 59 | "Return the homogeneous hash-table VALUE" 60 | (destructuring-bind (hash-keyword out-type) 61 | json-type 62 | (ecase hash-keyword 63 | (:hash-table 64 | (let ((out (make-hash-table :test 'equal :size (hash-table-size value)))) 65 | (maphash (lambda (k v) 66 | (setf (gethash k out) (to-lisp-value v out-type))) 67 | value) 68 | out))))) 69 | 70 | (defmethod to-lisp-value ((value vector) (json-type (eql :vector))) 71 | "Return the vector VALUE" 72 | value) 73 | 74 | (defmethod to-lisp-value ((value vector) (json-type (eql :list))) 75 | "Return the list VALUE" 76 | (coerce value 'list)) 77 | 78 | (defmethod to-lisp-value (value (json-type (eql :bool))) 79 | "Return the boolean VALUE" 80 | (ecase value (true t) (false nil))) 81 | 82 | (defmethod to-lisp-value ((value vector) (json-type cons)) 83 | "Return the homogeneous sequence VALUE" 84 | (map (ecase (first json-type) 85 | (:vector 'vector) 86 | (:list 'list)) 87 | (lambda (item) 88 | (handler-case (to-lisp-value item (second json-type)) 89 | (null-value (condition) 90 | (declare (ignore condition)) 91 | (restart-case (error 'null-in-homogenous-sequence 92 | :json-type json-type) 93 | (use-value (value) 94 | :report "Specify a value to use in place of the null" 95 | :interactive read-eval-query 96 | value))))) 97 | value)) 98 | 99 | (defmethod to-lisp-value ((value hash-table) (json-type symbol)) 100 | "Return the CLOS object VALUE" 101 | (json-to-clos value json-type)) 102 | 103 | (defun initialize-slots-from-json (input lisp-object class-obj &optional (key-count 0)) 104 | "Initializes all slots from LISP-OBJECT from INPUT. 105 | 106 | All slots, direct or inherited, that exist in class CLASS-OBJ are considered." 107 | (loop for superclass in (closer-mop:class-direct-superclasses class-obj) 108 | unless (eq superclass (find-class 'json-serializable)) 109 | do (setf (values lisp-object key-count) 110 | (initialize-slots-from-json input lisp-object superclass key-count))) 111 | (loop for slot in (closer-mop:class-direct-slots class-obj) 112 | do (awhen (json-key-name slot) 113 | (handler-case 114 | (progn 115 | (setf (slot-value lisp-object 116 | (closer-mop:slot-definition-name slot)) 117 | (to-lisp-value (gethash it input :null) 118 | (json-type slot))) 119 | (incf key-count)) 120 | (null-value (condition) 121 | (declare (ignore condition)) nil)))) 122 | (values lisp-object key-count)) 123 | 124 | (defgeneric json-to-clos (input class &rest initargs)) 125 | 126 | (defmethod json-to-clos ((input hash-table) class &rest initargs) 127 | (multiple-value-bind (lisp-object key-count) 128 | (initialize-slots-from-json input 129 | (apply #'make-instance class initargs) 130 | (find-class class)) 131 | (when (zerop key-count) (warn 'no-values-parsed 132 | :hash-table input 133 | :class-name class)) 134 | (values lisp-object key-count))) 135 | 136 | (defmethod json-to-clos ((input stream) class &rest initargs) 137 | (apply #'json-to-clos 138 | (parse input 139 | :object-as :hash-table 140 | :json-arrays-as-vectors t 141 | :json-booleans-as-symbols t 142 | :json-nulls-as-keyword t) 143 | class initargs)) 144 | 145 | (defmethod json-to-clos ((input pathname) class &rest initargs) 146 | (with-open-file (stream input) 147 | (apply #'json-to-clos stream class initargs))) 148 | 149 | (defmethod json-to-clos ((input string) class &rest initargs) 150 | (apply #'json-to-clos (make-string-input-stream input) class initargs)) 151 | -------------------------------------------------------------------------------- /tests/encode-decode.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2016 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (in-package #:json-mop-tests) 24 | 25 | (def-suite encode-decode 26 | :in test-all 27 | :description "Test encoding and decoding slots") 28 | 29 | (in-suite encode-decode) 30 | 31 | (test string 32 | (for-all ((obj (gen-object))) 33 | (is (equal (get-string obj) 34 | (get-string (obj-rt obj)))))) 35 | 36 | (test number 37 | (for-all ((obj (gen-object))) 38 | (is (= (get-number obj) 39 | (get-number (obj-rt obj)))))) 40 | 41 | (test integer 42 | (for-all ((obj (gen-object))) 43 | (is (= (get-integer obj) 44 | (get-integer (obj-rt obj)))))) 45 | 46 | (test hash-table 47 | (for-all ((obj (gen-object))) 48 | (is (equalp (get-hash-table obj) 49 | (get-hash-table (obj-rt obj)))))) 50 | 51 | (test vector 52 | (for-all ((obj (gen-object))) 53 | (is (equalp (get-vector obj) 54 | (get-vector (obj-rt obj)))))) 55 | 56 | (test list 57 | (for-all ((obj (gen-object))) 58 | (is (equal (get-list obj) 59 | (get-list (obj-rt obj)))))) 60 | 61 | (test bool 62 | (for-all ((obj (gen-object))) 63 | (is (eql (get-bool obj) 64 | (get-bool (obj-rt obj)))))) 65 | 66 | (test object 67 | (for-all ((obj (gen-object))) 68 | (is (= (get-number (get-object obj)) 69 | (get-number (get-object (obj-rt obj))))))) 70 | 71 | (test any 72 | (for-all ((obj (gen-object))) 73 | (is (equalp (get-any obj) 74 | (get-any (obj-rt obj)))))) 75 | 76 | (test any-hash-table 77 | (for-all ((obj (gen-object))) 78 | (is (equalp (get-any-hash-table obj) 79 | (get-any-hash-table (obj-rt obj)))))) 80 | 81 | (test obj-hash-table 82 | (for-all ((obj (gen-object))) 83 | (is (equalp (get-obj-hash-table obj) 84 | (get-obj-hash-table (obj-rt obj)))))) 85 | 86 | (test inheritance-encode 87 | (let ((child (make-instance 'child)) 88 | (parent-only (make-instance 'parent))) 89 | (is (string= (with-output-to-string (s) (encode child s)) 90 | (with-output-to-string (s) (encode parent-only s)))))) 91 | 92 | (test inheritance-decode 93 | (let* ((child (make-instance 'child :foo "hello" :bar "quux")) 94 | (child-rt (obj-rt child))) 95 | (is (string= (foo child) (foo child-rt))) 96 | (is (string= (bar child) (bar child-rt))))) 97 | -------------------------------------------------------------------------------- /tests/json-mop-tests.asd: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2016 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (asdf:defsystem #:json-mop-tests 24 | :description "Test suite for JSON-MOP" 25 | :author "Grim Schjetne" 26 | :license "LGPLv3+" 27 | :depends-on (#:json-mop 28 | #:fiveam) 29 | :serial t 30 | :components ((:file "package") 31 | (:file "tests") 32 | (:file "encode-decode") 33 | (:file "redefine-class"))) 34 | -------------------------------------------------------------------------------- /tests/package.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2016 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (defpackage #:json-mop-tests 24 | (:use #:cl 25 | #:json-mop 26 | #:fiveam) 27 | (:export #:test-all 28 | #:encode-decode)) 29 | -------------------------------------------------------------------------------- /tests/redefine-class.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2023 Grim Schjetne 2 | ;; See COPYING for license information 3 | 4 | (in-package #:json-mop-tests) 5 | 6 | (def-suite redefine-class 7 | :in test-all 8 | :description "Test redefining serializable class") 9 | 10 | (in-suite redefine-class) 11 | 12 | (test redefine-class 13 | (defclass redefined-class () 14 | () 15 | (:metaclass json-serializable-class)) 16 | 17 | (defclass redefined-class () 18 | ((foo :json-key "foo" 19 | :json-type :number 20 | :initform 1)) 21 | (:metaclass json-serializable-class)) 22 | 23 | (let* ((instance (make-instance 'redefined-class)) 24 | (parsed (yason:parse (json-string instance)))) 25 | (is (= 1 (gethash "foo" parsed))))) 26 | -------------------------------------------------------------------------------- /tests/tests.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2016 Grim Schjetne 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person 4 | ;; obtaining a copy of this software and associated documentation 5 | ;; files (the "Software"), to deal in the Software without 6 | ;; restriction, including without limitation the rights to use, copy, 7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;; of the Software, and to permit persons to whom the Software is 9 | ;; furnished to do so, subject to the following conditions: 10 | ;; 11 | ;; The above copyright notice and this permission notice shall be 12 | ;; included in all copies or substantial portions of the Software. 13 | ;; 14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (in-package #:json-mop-tests) 24 | 25 | (defclass test-class () 26 | ((string :initarg :string 27 | :reader get-string 28 | :json-type :string 29 | :json-key "str") 30 | (number :initarg :number 31 | :reader get-number 32 | :json-type :number 33 | :json-key "num") 34 | (integer :initarg :integer 35 | :reader get-integer 36 | :json-type :integer 37 | :json-key "int") 38 | (hash :initarg :hash-table 39 | :reader get-hash-table 40 | :json-type :hash-table 41 | :json-key "hash") 42 | (any-hash :initarg :any-hash-table 43 | :reader get-any-hash-table 44 | :json-type :any 45 | :json-key "anyHash") 46 | (obj-hash :initarg :obj-hash-table 47 | :reader get-obj-hash-table 48 | :json-type (:hash-table (:vector :string)) 49 | :json-key "objHash") 50 | (vector :initarg :vector 51 | :reader get-vector 52 | :json-type :vector 53 | :json-key "vect") 54 | (list :initarg :list 55 | :reader get-list 56 | :json-type :list 57 | :json-key "list") 58 | (bool :initarg :bool 59 | :reader get-bool 60 | :json-type :bool 61 | :json-key "bool") 62 | (object :initarg :object 63 | :reader get-object 64 | :json-type test-class 65 | :json-key "obj") 66 | (any :initarg :any 67 | :reader get-any 68 | :json-type :any 69 | :json-key "any")) 70 | (:metaclass json-serializable-class)) 71 | 72 | ;;; as per https://github.com/gschjetne/json-mop/issues/1 73 | (defclass parent () 74 | ((foo :accessor foo :initarg :foo 75 | :initform "Foo" 76 | :json-key "foo")) 77 | (:metaclass json-serializable-class)) 78 | 79 | (defclass child (parent) 80 | ((bar :accessor bar :initarg :bar 81 | :json-key "bar")) 82 | (:metaclass json-serializable-class)) 83 | 84 | (defun json-string (object) 85 | (with-output-to-string (s) 86 | (encode object s))) 87 | 88 | (defun obj-rt (object) 89 | (json-to-clos (json-string object) 90 | (class-name (class-of object)))) 91 | 92 | (defun gen-vector (&key 93 | (length (gen-integer :min 0 :max 10)) 94 | (elements (gen-integer :min -10 :max 10))) 95 | (lambda () 96 | (let* ((l (funcall length)) 97 | (vector (make-array l))) 98 | (loop for i from 0 to (1- l) do 99 | (setf (aref vector i) (funcall elements))) 100 | vector))) 101 | 102 | (defun gen-bool () 103 | (lambda () (zerop (random 2)))) 104 | 105 | (defun gen-any (&key (choices (list (gen-string) 106 | (gen-float) 107 | (gen-vector)))) 108 | (lambda () 109 | (funcall (nth (random (length choices)) 110 | choices)))) 111 | 112 | (defun gen-hash-table (&key 113 | (length (gen-integer :min 0 :max 10)) 114 | (keys (gen-string)) 115 | (elements (gen-integer))) 116 | (lambda () 117 | (let ((hash-table (make-hash-table :test 'equal))) 118 | (loop repeat (funcall length) 119 | do (setf (gethash (funcall keys) hash-table) 120 | (funcall elements))) 121 | hash-table))) 122 | 123 | (defun gen-object (&key 124 | (string (gen-string)) 125 | (number (gen-float)) 126 | (integer (gen-integer)) 127 | (hash-table (gen-hash-table)) 128 | (obj-hash-table 129 | (gen-hash-table 130 | :elements (gen-vector :elements (gen-string)))) 131 | (vector (gen-vector)) 132 | (list (gen-list)) 133 | (bool (gen-bool)) 134 | (object (lambda () (make-instance 135 | 'test-class 136 | :number (funcall (gen-integer))))) 137 | (any (gen-any))) 138 | (lambda () 139 | (make-instance 'test-class 140 | :string (funcall string) 141 | :number (funcall number) 142 | :integer (funcall integer) 143 | :hash-table (funcall hash-table) 144 | :any-hash-table (funcall hash-table) 145 | :obj-hash-table (funcall obj-hash-table) 146 | :vector (funcall vector) 147 | :list (funcall list) 148 | :bool (funcall bool) 149 | :object (funcall object) 150 | :any (funcall any)))) 151 | 152 | (def-suite test-all) 153 | --------------------------------------------------------------------------------