Mercurial > core / lisp/lib/obj/tests.lisp
| changeset 275: |
78ef6145e272 |
| parent: |
d7aa08025537
|
| child: |
9eb2c112aa16 |
| author: |
Richard Westhaver <ellis@rwest.io> |
| date: |
Fri, 12 Apr 2024 18:41:40 -0400 |
| permissions: |
-rw-r--r-- |
| description: |
return of the uri |
2 (:use :cl :std :rt :obj)) 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)))) 59 (defun random-csv-file (&optional (name (symbol-name (gensym))) (n 1000)) 60 (let ((path (merge-pathnames (format nil "~a.csv" name) "/tmp/"))) 61 (with-open-file (f path :direction :output) 62 (dotimes (i n) (format f "~a,test~a,~x,~%" i (+ n i) (random 8d0)))) 66 (let ((csv (random-csv-file))) 67 (is (typep (table-from-csv csv) 'table)))) 70 (is (= (reset-id t) (reset-id '(1 2 3)))) 71 (is (not (equalp (make-id nil) (make-id nil))))) 77 (deftest castable-solo () 78 (is (typep (make-castable) 'castable)) 79 (is (null (clrchash (make-castable)))) 80 (is (eql nil (getchash nil (make-castable)))) 81 (is (eql nil (getchash t (make-castable)))) 82 (is (eql t (getchash nil (make-castable) t))) 83 (is (eql t (setf (getchash t (make-castable)) t))) 84 (is (null (remchash t (make-castable)))) 85 (let ((map (make-castable))) ;; basic 86 (is (setf (getchash t map) t)) 89 (is (null (getchash t map))) 90 (is (null (remchash t map)))) 91 (let ((map (make-castable))) ;; rizzlin and sizzlin 92 (is (null (dotimes (i 100) (setf (getchash i map) i)))) 93 (is (loop for i from 0 below 100 always (= i (getchash i map)))) 94 (is (= 100 (castable-count map))) 95 (is (null (clrchash map))) 96 (is (= 0 (castable-count map))) 97 (is (null (getchash 0 map)))) 98 (let ((map (make-castable :test 'eq)) ;;eq 99 (key (make-string 1 :initial-element #\a))) 100 (is (setf (getchash key map) t)) 101 (is (getchash key map)) 102 (is (null (getchash (make-string 1 :initial-element #\a) map)))) 103 (let ((map (make-castable :test 'eq))) ;;eql 104 (is (setf (getchash 0 map) t)) 105 (is (getchash 0 map)) 106 (is (null (getchash 0.0 map)))) 107 (let ((map (make-castable :test 'equal))) ;;equal 108 (is (setf (getchash "a" map) t)) 109 (is (null (getchash "A" map)))) 110 (let ((map (make-castable :test 'equalp))) ;;equalp 111 (is (setf (getchash #\a map) t)) 112 (is (getchash #\A map)))) 114 (deftest castable-multi (:disabled t) 117 (let ((table (make-castable))) 118 (with-threads (_ threads) 119 (loop repeat tries do (setf (getchash t table) t))) 120 (is (eql t (getchash t table))) 121 (is (= 1 (castable-count table)))) 122 (let ((table (make-castable)) 123 (/thread (floor (/ tries threads)))) 125 (with-threads (idx threads) 126 (loop for i from (* idx /thread) below (* (1+ idx) /thread) 127 do (setf (getchash i table) i)))) 128 (print (castable-count table)) 129 ;; (is (= tries (castable-count table))) 130 (is (loop for i from 0 below tries 131 do (print (getchash i table)) 132 always (equal i (getchash i table))))) 133 ;; Concurrent set on same fields 134 (let ((table (make-castable))) 137 (with-threads (idx threads) 138 (loop for i from 0 below tries 139 do (setf (getchash i table) i))))) 140 (is = tries (castable-count table)) 141 (is eql T (loop for i from 0 below tries 142 always (eql i (getchash i table))))) 143 ;; Concurrent set on randomised fields 144 (let ((table (make-castable))) 145 (flet ((random-index (idx i) 146 (floor (* tries (/ (sxhash (+ (* idx tries) i)) most-positive-fixnum))))) 149 (with-threads (idx threads) 150 (loop for i from 0 below tries 151 for j = (random-index idx i) 152 do (setf (getchash j table) j))))) 153 (is <= tries (castable-count table)))) 154 ;; Concurrent set & remove 155 (let ((table (make-castable))) 158 (with-threads (idx (/ threads 2)) 159 (loop for i from idx below tries by threads 160 do (setf (getchash i table) i))) 161 (with-threads (idx (/ threads 2)) 162 (loop for i from idx below tries by threads 163 do (loop until (remchash i table)))))) 164 (is = 0 (castable-count table))))) 168 (deftest generic-tree () 169 (let ((tree (make-binary-node 171 (make-binary-node 1 (make-node 0) (make-node 1)) 172 (make-binary-node 2 (make-node 2) (make-node 3))))) 173 (is (typep tree 'binary-node)))) 175 (deftest bro-tree ()) 179 (deftest avl-tree ()) 185 "Tests for different types of URIs. Attempts to conform with RFCs and test suites." 186 (let ((local #.(parse-uri "https://localhost/stash/index.json")) 187 (local2 (parse-uri "https://localhost/stash/index.json")) 188 (ftp (parse-uri "ftp://ftp.is.co.za/rfc/rfc1808.txt"))) 189 (is (equal "localhost" (uri-host local))) 190 (is (eql :ftp (uri-scheme ftp))) 191 (is (= (obj/uri::uri-hash local) (obj/uri::uri-hash local2))) 192 (is (equal "foo%25bar" (uri-path (parse-uri "foo%25bar")))) 193 (is (equal "/test/foo%25bar.lisp" 194 (uri-to-string (string-to-uri "/test/foo%25bar.lisp")))) 196 "/test/foo%25bar.lisp" 197 (render-uri (parse-uri "/test/foo%25bar.lisp") nil))) 198 (is (equal "http://franz.com/foo?val=a%2b%3d%26b+is+c" 199 (render-uri (parse-uri "http://franz.com/foo?val=a%2b%3d%26b+is+c") nil))) 201 (dolist (xx ;; (list user-info ipaddr port) 202 '((nil "192.132.95.22" nil) 203 (nil "192.132.95.22" 81) 204 ("layer" "192.132.95.22" nil) 205 ("layer" "192.132.95.22" 81) 206 ("layer:pass" "192.132.95.22" nil) 207 ("layer:pass" "192.132.95.22" 81) 208 (nil "fe80::230:48ff:feb9:bbea" nil) 209 (nil "fe80::230:48ff:feb9:bbea" 81) 210 (nil "2001:470:1f05:548:230:48ff:feb9:bbea" nil) 211 (nil "2001:470:1f05:548:230:48ff:feb9:bbea" 81) 214 (destructuring-bind (user-info host port) xx 215 (let* ((h (if (and (stringp host) (find #\: host)) 216 (format nil "[~a]" host) 218 (s (format nil "https://~@[~a@~]~a~a/foo.html" 219 user-info h (or (when port (format nil ":~d" port)) ""))) 221 (format t ";; ~a~%" s) 222 (is (string= s (princ-to-string u))) 223 (is (string= host (uri-host u))) 225 (is (string= user-info (uri-userinfo u)))) 226 (is (equal port (uri-port u))))))))
