Mercurial > core / lisp/lib/obj/tests.lisp
| changeset 698: |
96958d3eb5b0 |
| parent: |
9e7d4393eac6
|
| author: |
Richard Westhaver <ellis@rwest.io> |
| date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
| permissions: |
-rw-r--r-- |
| description: |
fixes |
2 (:use :cl :std :rt :obj :uuid :url)) 4 (in-package :obj/tests) 9 (defun eps= (a b &optional (eps 1e-10)) 10 (<= (abs (- a b)) eps)) 12 (defun rgb= (rgb1 rgb2 &optional (eps 1e-10)) 13 "Compare RGB colors for (numerical) equality." 14 (let ((r1 (rgb-red rgb1)) 25 (rgb (random 1d0) (random 1d0) (random 1d0))) 28 (hsv (random 360d0) (random 1d0) (random 1d0))) 32 (let ((rgb (random-rgb)) 34 (is (typep (as-hsv rgb) 'hsv)) 35 (is (typep (as-rgb hsv) 'rgb)))) 36 (let ((rgb (rgb 0.070 0.203 0.337))) 37 (is (equal "#123456" (print-hex-rgb rgb))) 38 (is (equal "123456" (print-hex-rgb rgb :hash nil))) 39 (is (equal "#135" (print-hex-rgb rgb :short t))) 40 (is (equal "135" (print-hex-rgb rgb :short t :hash nil))) 41 (is (equal "12345678" (print-hex-rgb rgb :alpha 0.47))) 42 (is (equal "#1357" (print-hex-rgb rgb :alpha 0.47 :short t))) 43 (is (equal "1357" (print-hex-rgb rgb :alpha 0.47 :hash nil :short t))) 44 (is (rgb= rgb (parse-hex-rgb "#123456") 0.01)) 45 (is (rgb= rgb (parse-hex-rgb "123456") 0.01)) 46 (is (rgb= rgb (parse-hex-rgb "#135") 0.01)) 47 (is (rgb= rgb (parse-hex-rgb "135") 0.01)) 49 (and (rgb= (car l1) (car l2) 0.01) 50 (eps= (cadr l1) (cadr l2) 0.01)))) 51 (is (aux (list rgb 0.47) (multiple-value-list (parse-hex-rgb "#12345678")))) 52 (is (aux (list rgb 0.47) (multiple-value-list (parse-hex-rgb "12345678")))) 53 (is (aux (list rgb 0.47) (multiple-value-list (parse-hex-rgb "#1357")))) 54 (is (aux (list rgb 0.47) (multiple-value-list (parse-hex-rgb "1357"))))) 55 (is (equal "#123456" (with-output-to-string (*standard-output*) 56 (print-hex-rgb rgb :destination t)))) 57 (is (rgb= rgb (parse-hex-rgb "foo#123456zzz" :start 3 :end 10) 0.001)))) 60 (is (= (reset-id t) (reset-id '(1 2 3)))) 61 (is (not (equalp (make-id nil) (make-id nil))))) 64 (macrolet ((is-uuid (obj) `(is (typep ,obj 'uuid)))) 65 (is-uuid (make-v1-uuid)) 66 (is-uuid (make-v4-uuid)))) 72 (deftest castable-solo () 73 (is (typep (make-castable) 'castable)) 74 (is (null (clrchash (make-castable)))) 75 (is (eql nil (getchash nil (make-castable)))) 76 (is (eql nil (getchash t (make-castable)))) 77 (is (eql t (getchash nil (make-castable) t))) 78 (is (eql t (setf (getchash t (make-castable)) t))) 79 (is (null (remchash t (make-castable)))) 80 (let ((map (make-castable))) ;; basic 81 (is (setf (getchash t map) t)) 84 (is (null (getchash t map))) 85 (is (null (remchash t map)))) 86 (let ((map (make-castable))) ;; rizzlin and sizzlin 87 (is (null (dotimes (i 100) (setf (getchash i map) i)))) 88 (is (loop for i from 0 below 100 always (= i (getchash i map)))) 89 (is (= 100 (castable-count map))) 90 (is (null (clrchash map))) 91 (is (= 0 (castable-count map))) 92 (is (null (getchash 0 map)))) 93 (let ((map (make-castable :test 'eq)) ;;eq 94 (key (make-string 1 :initial-element #\a))) 95 (is (setf (getchash key map) t)) 96 (is (getchash key map)) 97 (is (null (getchash (make-string 1 :initial-element #\a) map)))) 98 (let ((map (make-castable :test 'eq))) ;;eql 99 (is (setf (getchash 0 map) t)) 100 (is (getchash 0 map)) 101 (is (null (getchash 0.0 map)))) 102 (let ((map (make-castable :test 'equal))) ;;equal 103 (is (setf (getchash "a" map) t)) 104 (is (null (getchash "A" map)))) 105 (let ((map (make-castable :test 'equalp))) ;;equalp 106 (is (setf (getchash #\a map) t)) 107 (is (getchash #\A map)))) 109 (deftest castable-multi (:skip t) 112 (let ((table (make-castable))) 113 (with-threads (_ threads) 114 (loop repeat tries do (setf (getchash t table) t))) 115 (is (eql t (getchash t table))) 116 (is (= 1 (castable-count table)))) 117 (let ((table (make-castable)) 118 (/thread (floor (/ tries threads)))) 120 (with-threads (idx threads) 121 (loop for i from (* idx /thread) below (* (1+ idx) /thread) 122 do (setf (getchash i table) i)))) 123 (print (castable-count table)) 124 ;; (is (= tries (castable-count table))) 125 (is (loop for i from 0 below tries 126 do (print (getchash i table)) 127 always (equal i (getchash i table))))) 128 ;; Concurrent set on same fields 129 (let ((table (make-castable))) 132 (with-threads (idx threads) 133 (loop for i from 0 below tries 134 do (setf (getchash i table) i))))) 135 (is = tries (castable-count table)) 136 (is eql T (loop for i from 0 below tries 137 always (eql i (getchash i table))))) 138 ;; Concurrent set on randomised fields 139 (let ((table (make-castable))) 140 (flet ((random-index (idx i) 141 (floor (* tries (/ (sxhash (+ (* idx tries) i)) most-positive-fixnum))))) 144 (with-threads (idx threads) 145 (loop for i from 0 below tries 146 for j = (random-index idx i) 147 do (setf (getchash j table) j))))) 148 (is <= tries (castable-count table)))) 149 ;; Concurrent set & remove 150 (let ((table (make-castable))) 153 (with-threads (idx (/ threads 2)) 154 (loop for i from idx below tries by threads 155 do (setf (getchash i table) i))) 156 (with-threads (idx (/ threads 2)) 157 (loop for i from idx below tries by threads 158 do (loop until (remchash i table)))))) 159 (is = 0 (castable-count table))))) 163 (deftest generic-tree () 164 (let ((tree (make-binary-node 166 (make-binary-node 1 (make-node 0) (make-node 1)) 167 (make-binary-node 2 (make-node 2) (make-node 3))))) 168 (is (typep tree 'binary-node)))) 171 (is (sb-brothertree::make-binary-node 0 nil nil))) 176 (is (make-avl-node 0 0 nil nil))) 178 (deftest basic-graph () 179 "Test basic graph functionality." 180 (let ((g1 (make-instance 'graph:graph))) 181 (is (typep g1 'graph:graph)) 182 (graph:add-node g1 :foo) 183 (graph:add-node g1 :bar) 184 (graph:add-edge g1 '(:foo :bar)) 185 ;; graph is undirected, so this is no-op 186 (graph:add-edge g1 '(:bar :foo)) 187 ;; and only 1 edge exists 188 (is (= 1 (length (hash-table-keys (graph:edges g1))))) 189 (let ((g2 (make-instance 'graph:directed-graph))) 190 (is (typep g2 'graph:directed-graph)) 191 (graph:add-node g2 :baz) 192 (graph:add-node g2 :buz) 193 (graph:add-edge g2 '(:baz :buz)) 194 ;; graph is directed, so this is a unique edge 195 (graph:add-edge g2 '(:buz :baz)) 197 (is (= 2 (length (hash-table-keys (graph:edges g2))))) 198 ;; (graph:add-node g1 g2) 199 ;; (is (graph::has-node-p g1 g2)) 200 ;; (graph::delete-node g1 g2) 201 ;; (is (not (graph::has-node-p g1 g2))) 206 "Tests for different types of URIs. Attempts to conform with RFCs and test suites." 207 (let ((local #.(parse-uri "https://localhost/stash/index.json")) 208 (local2 (parse-uri "https://localhost/stash/index.json")) 209 (ftp (parse-uri "ftp://ftp.is.co.za/rfc/rfc1808.txt"))) 210 (is (equal "localhost" (uri-host local))) 211 (is (eql :ftp (uri-scheme ftp))) 212 (is (= (obj/uri::uri-hash local) (obj/uri::uri-hash local2))) 213 (is (equal "foo%25bar" (uri-path (parse-uri "foo%25bar")))) 214 (is (equal "/test/foo%25bar.lisp" 215 (uri-to-string (string-to-uri "/test/foo%25bar.lisp")))) 217 "/test/foo%25bar.lisp" 218 (render-uri (parse-uri "/test/foo%25bar.lisp") nil))) 219 (is (equal "http://franz.com/foo?val=a%2b%3d%26b+is+c" 220 (render-uri (parse-uri "http://franz.com/foo?val=a%2b%3d%26b+is+c") nil))) 222 (dolist (xx ;; (list user-info ipaddr port) 223 '((nil "192.132.95.22" nil) 224 (nil "192.132.95.22" 81) 225 ("layer" "192.132.95.22" nil) 226 ("layer" "192.132.95.22" 81) 227 ("layer:pass" "192.132.95.22" nil) 228 ("layer:pass" "192.132.95.22" 81) 229 (nil "fe80::230:48ff:feb9:bbea" nil) 230 (nil "fe80::230:48ff:feb9:bbea" 81) 231 (nil "2001:470:1f05:548:230:48ff:feb9:bbea" nil) 232 (nil "2001:470:1f05:548:230:48ff:feb9:bbea" 81) 235 (destructuring-bind (user-info host port) xx 236 (let* ((h (if (and (stringp host) (find #\: host)) 237 (format nil "[~a]" host) 239 (s (format nil "https://~@[~a@~]~a~a/foo.html" 240 user-info h (or (when port (format nil ":~d" port)) ""))) 242 (is (string= s (princ-to-string u))) 243 (is (string= host (uri-host u))) 245 (is (string= user-info (uri-userinfo u)))) 246 (is (equal port (uri-port u)))))))) 249 (is (equal (url-encode "/fooあ") (url-encode (url-decode "%2Ffoo%E3%81%82"))))) 251 (defclass bogus-data-source (data-source) ((db :initform nil :initarg :db))) 253 (defvar *basic-query* "SELECT * FROM employee WHERE state = 'CT'") 255 (deftest query-basic () 256 "Test the simple query `SELECT * FROM employee WHERE state = 'CT'` by manually 257 building a query-plan." 258 (make-query *basic-query*))
