| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Test the property set implementation |
| 4 | ;;; |
| 5 | ;;; (c) 2013 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 11 | ;;; |
| 12 | ;;; SOD is free software; you can redistribute it and/or modify |
| 13 | ;;; it under the terms of the GNU General Public License as published by |
| 14 | ;;; the Free Software Foundation; either version 2 of the License, or |
| 15 | ;;; (at your option) any later version. |
| 16 | ;;; |
| 17 | ;;; SOD is distributed in the hope that it will be useful, |
| 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;;; GNU General Public License for more details. |
| 21 | ;;; |
| 22 | ;;; You should have received a copy of the GNU General Public License |
| 23 | ;;; along with SOD; if not, write to the Free Software Foundation, |
| 24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 25 | |
| 26 | (cl:in-package #:sod-test) |
| 27 | |
| 28 | ;;;-------------------------------------------------------------------------- |
| 29 | ;;; Here we go. |
| 30 | |
| 31 | (defclass pset-test (test-case) ()) |
| 32 | (add-test *sod-test-suite* (get-suite pset-test)) |
| 33 | |
| 34 | ;;;-------------------------------------------------------------------------- |
| 35 | ;;; Utilities. |
| 36 | |
| 37 | (defun pset-equal-p (pset-a pset-b) |
| 38 | (do ((i 0 (1+ i)) |
| 39 | (p (or pset-a (make-property-set)) q) |
| 40 | (q (or pset-b (make-property-set)) p)) |
| 41 | ((>= i 2) t) |
| 42 | (with-pset-iterator (next p) |
| 43 | (loop (let ((prop (next))) |
| 44 | (when (null prop) (return)) |
| 45 | (let ((other (pset-get q (p-key prop)))) |
| 46 | (unless (and other |
| 47 | (equal (p-name prop) (p-name other)) |
| 48 | (eq (p-type prop) (p-type other)) |
| 49 | (equal (p-value prop) (p-value other))) |
| 50 | (return-from pset-equal-p nil)))))))) |
| 51 | |
| 52 | (defun assert-pset-equal (pset-a pset-b) |
| 53 | (unless (pset-equal-p pset-a pset-b) |
| 54 | (failure "Assert equal property sets: ~A ~_and ~A" pset-a pset-b))) |
| 55 | |
| 56 | ;;;-------------------------------------------------------------------------- |
| 57 | ;;; Parser tests. |
| 58 | |
| 59 | (defun check-pset-parse (string pset) |
| 60 | (let* ((char-scanner (make-string-scanner string)) |
| 61 | (scanner (make-instance 'sod-token-scanner |
| 62 | :char-scanner char-scanner |
| 63 | :filename "<none>")) |
| 64 | (errors nil)) |
| 65 | (with-parser-context (token-scanner-context :scanner scanner) |
| 66 | (multiple-value-bind (result winp consumedp) |
| 67 | (handler-bind ((error (lambda (cond) |
| 68 | (declare (ignore cond)) |
| 69 | (setf errors t) |
| 70 | (if (find-restart 'continue) |
| 71 | (invoke-restart 'continue) |
| 72 | :decline)))) |
| 73 | (parse-property-set scanner)) |
| 74 | (declare (ignore consumedp)) |
| 75 | (when errors (setf winp nil)) |
| 76 | (cond ((null pset) |
| 77 | (assert-false winp)) |
| 78 | (t |
| 79 | (assert-true winp) |
| 80 | (unless (eq pset t) |
| 81 | (assert-pset-equal result pset)))))))) |
| 82 | |
| 83 | (def-test-method parse-empty ((test pset-test) :run nil) |
| 84 | (check-pset-parse "anything" (make-property-set))) |
| 85 | |
| 86 | (def-test-method parse-simple ((test pset-test) :run nil) |
| 87 | (check-pset-parse "[ thing = 69 ]" |
| 88 | (make-property-set "thing" 69))) |
| 89 | |
| 90 | (def-test-method parse-wrong ((test pset-test) :run nil) |
| 91 | (check-pset-parse "[ broken = (1 + ]" nil)) |
| 92 | |
| 93 | (def-test-method parse-arith ((test pset-test) :run nil) |
| 94 | (check-pset-parse (concatenate 'string "[ " |
| 95 | "one = 13*5 - 16*4, " |
| 96 | "two = \"spong\", " |
| 97 | "three = 'c', " |
| 98 | "four = something_different" |
| 99 | "]") |
| 100 | (make-property-set "one" 1 |
| 101 | "two" "spong" |
| 102 | "three" #\c |
| 103 | "four" (cons :id |
| 104 | "something_different")))) |
| 105 | |
| 106 | ;;;----- That's all, folks -------------------------------------------------- |