| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Test for the charbuf scanner |
| 4 | ;;; |
| 5 | ;;; (c) 2009 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 | ;;; The charbuf scanner is a hairy beast and in need of a thorough going |
| 27 | ;;; over. |
| 28 | |
| 29 | (cl:in-package #:sod-test) |
| 30 | |
| 31 | ;;;-------------------------------------------------------------------------- |
| 32 | ;;; Tests of the low-level seeking and fetching machinery. |
| 33 | |
| 34 | (defclass charbuf-test (test-case) (scanner)) |
| 35 | (add-test *sod-test-suite* (get-suite charbuf-test)) |
| 36 | |
| 37 | (defparameter *background-pattern* |
| 38 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789." |
| 39 | "Basic pattern underlying our initial buffer contents. |
| 40 | |
| 41 | The pattern is one character short of the base-64 sequence `A-Za-z0-9./', |
| 42 | with the aim of making its length be prime to the actual buffer length -- |
| 43 | so that the pattern doesn't repeat exactly for many buffers.") |
| 44 | (assert (= (gcd (length *background-pattern*) charbuf-size) 1)) |
| 45 | |
| 46 | (defun make-pattern-string (start end) |
| 47 | "Return a string containing the buffer pattern between START and END. |
| 48 | |
| 49 | The most interesting cases occur at the boundaries between buffers; so we |
| 50 | shall want to put recognizable patterns there. The buffers are quite big |
| 51 | (we import `charbuf-size' off the books so that we don't actually have to |
| 52 | know exactly) but we should still fill with a repeating pattern so that we |
| 53 | can detect synchronization failures. |
| 54 | |
| 55 | We fill most of the buffer with the `*background-pattern*', which has been |
| 56 | chosen so as not to align nicely with the buffer size. Across the joins, |
| 57 | we write a string `<<N][N+1>>', where the boundary is between `]' and `[', |
| 58 | and the numbers N and N + 1 are the numbers, in words, of the respective |
| 59 | buffers." |
| 60 | |
| 61 | (with-output-to-string (out) |
| 62 | (multiple-value-bind (n0 i0) (floor start charbuf-size) |
| 63 | (multiple-value-bind (n1 i1) (floor end charbuf-size) |
| 64 | |
| 65 | (do ((n n0 (1+ n))) ((> n n1)) |
| 66 | (let* ((l (format nil "[~R>>" n)) |
| 67 | (r (format nil "<<~R]" n)) |
| 68 | (m (length l)) |
| 69 | (q (length *background-pattern*)) |
| 70 | (i (if (= n n0) i0 0)) |
| 71 | (e (if (= n n1) i1 charbuf-size)) |
| 72 | (k (min (- charbuf-size m) e))) |
| 73 | (when (< i (length l)) |
| 74 | (write-string l out :start i :end (min e m)) |
| 75 | (setf i m)) |
| 76 | (do ((o (mod (+ (* charbuf-size n) i) q) 0)) |
| 77 | ((>= i k)) |
| 78 | (let ((p (min (- k i) (- q o)))) |
| 79 | (write-string *background-pattern* out :start o :end (+ o p)) |
| 80 | (incf i p))) |
| 81 | (when (< k e) |
| 82 | (write-string r out :start (- i k) :end (- e k))))))))) |
| 83 | |
| 84 | (defparameter *test-pattern* (make-pattern-string 0 10000) |
| 85 | "The pattern that our test scanner is reading.") |
| 86 | |
| 87 | (defmethod set-up ((test charbuf-test)) |
| 88 | (with-slots (scanner) test |
| 89 | (let ((stream (make-string-input-stream *test-pattern*))) |
| 90 | (setf scanner (make-instance 'charbuf-scanner |
| 91 | :stream stream |
| 92 | :filename "<magic test>"))))) |
| 93 | |
| 94 | (defun skip (scanner n) |
| 95 | (assert (>= n 0)) |
| 96 | (charbuf-scanner-map scanner |
| 97 | (lambda (buf start end) |
| 98 | (declare (ignore buf)) |
| 99 | (let ((d (- end start))) |
| 100 | (if (>= d n) |
| 101 | (values t (+ start n)) |
| 102 | (progn (decf n d) (values nil 0))))))) |
| 103 | |
| 104 | (defun assert-string-next (scanner pos len) |
| 105 | "Assert that the next LEN characters from SCANNER are correct. |
| 106 | |
| 107 | That is, that they match the corresponding LEN characters starting at |
| 108 | position POS as returned by `make-pattern-string'." |
| 109 | (let ((want (make-pattern-string pos (+ pos len)))) |
| 110 | (dotimes (i len) |
| 111 | (assert-false (scanner-at-eof-p scanner)) |
| 112 | (assert-eql (scanner-current-char scanner) (char want i)) |
| 113 | (scanner-step scanner)))) |
| 114 | |
| 115 | (def-test-method test-pattern ((test charbuf-test) :run nil) |
| 116 | ;; Make sure the pattern is what we expect. This is a completely different |
| 117 | ;; (and considerably more stupid) way of generating the basic pattern up to |
| 118 | ;; a particular length. |
| 119 | (let* ((len (length *background-pattern*)) |
| 120 | (string "")) |
| 121 | (loop while (< (length string) len) |
| 122 | do (setf string (concatenate 'string string *test-pattern*))) |
| 123 | (loop for n from 0 |
| 124 | for i from 0 by charbuf-size below len |
| 125 | for l = (format nil "[~R>>" n) and r = (format nil "<<~R]" n) |
| 126 | for e = (- (+ i charbuf-size) (length r)) |
| 127 | do (setf (subseq string i) l) |
| 128 | when (< e len) do (setf (subseq string e) r)) |
| 129 | (assert-equal (subseq string 0 len) |
| 130 | (make-pattern-string 0 len)))) |
| 131 | |
| 132 | (def-test-method test-read ((test charbuf-test) :run nil) |
| 133 | ;; Test reading from various places. |
| 134 | (with-slots (scanner) test |
| 135 | (loop for prev = 0 then (+ pos len) |
| 136 | for (pos len) in '((0 10) (50 250) (4086 20) |
| 137 | (5000 3192) (9800 200)) do |
| 138 | (assert (>= pos prev)) |
| 139 | (skip scanner (- pos prev)) |
| 140 | (assert-string-next scanner pos len)) |
| 141 | (assert-true (scanner-at-eof-p scanner)))) |
| 142 | |
| 143 | (def-test-method test-unread ((test charbuf-test) :run nil) |
| 144 | ;; Torture test for `scanner-unread', which is distressingly hairy. |
| 145 | (with-slots (scanner) test |
| 146 | |
| 147 | (flet ((test (here next skip there note) |
| 148 | (assert-eql (scanner-current-char scanner) here |
| 149 | (format nil "Here (~A)." note)) |
| 150 | (scanner-step scanner) |
| 151 | (assert-eql (scanner-current-char scanner) next |
| 152 | (format nil "Next (~A)." note)) |
| 153 | (scanner-unread scanner here) |
| 154 | (with-scanner-place (place scanner) |
| 155 | (assert-eql (scanner-current-char scanner) here |
| 156 | (format nil "Here again (~A)." note)) |
| 157 | (scanner-step scanner) |
| 158 | (assert-eql (scanner-current-char scanner) next |
| 159 | (format nil "Next again (~A)." note)) |
| 160 | (skip scanner skip) |
| 161 | (assert-eql (scanner-current-char scanner) there |
| 162 | (format nil "There (~A)." note)) |
| 163 | (scanner-unread scanner there) |
| 164 | (with-scanner-place (another-place scanner) |
| 165 | (scanner-restore-place scanner place) |
| 166 | (assert-eql (scanner-current-char scanner) here |
| 167 | (format nil "Here restored (~A)." note)))))) |
| 168 | |
| 169 | (test #\[ #\z 51 #\0 "start") |
| 170 | (skip scanner 4095) |
| 171 | (test #\] #\[ 4096 #\[ "edge") |
| 172 | |
| 173 | ;; Check behaviour at EOF. Ought to test behaviour when EOF is on a |
| 174 | ;; buffer boundary too. |
| 175 | (skip scanner 5904) |
| 176 | (assert-false (scanner-at-eof-p scanner)) |
| 177 | (assert-eql (scanner-current-char scanner) #\t "EOF.") |
| 178 | (scanner-step scanner) |
| 179 | (assert-true (scanner-at-eof-p scanner)) |
| 180 | (scanner-unread scanner #\t) |
| 181 | (assert-false (scanner-at-eof-p scanner)) |
| 182 | (assert-eql (scanner-current-char scanner) #\t "EOF again.")))) |
| 183 | |
| 184 | (def-test-method test-rewind ((test charbuf-test) :run nil) |
| 185 | ;; Test reading, like before, but this time with rewinding. |
| 186 | (with-slots (scanner) test |
| 187 | (let* ((list '((0 10) (0 10000) (50 250) (4086 20) |
| 188 | (4095 4097) (5000 3192) (9999 1))) |
| 189 | (places (loop for prev = 0 then pos |
| 190 | for (pos) in list |
| 191 | do (skip scanner (- pos prev)) |
| 192 | collect (scanner-capture-place scanner)))) |
| 193 | (loop for (pos len) in list |
| 194 | for place in places do |
| 195 | (scanner-restore-place scanner place) |
| 196 | (assert-string-next scanner pos len)) |
| 197 | (assert-true (scanner-at-eof-p scanner))))) |
| 198 | |
| 199 | (def-test-method test-interval ((test charbuf-test) :run nil) |
| 200 | ;; Test fetching intervals of text. |
| 201 | (with-slots (scanner) test |
| 202 | (let* ((posns '(0 12 4080 4110 5000 9000 10000)) |
| 203 | (places (loop for prev = 0 then pos |
| 204 | for pos in posns |
| 205 | do (skip scanner (- pos prev)) |
| 206 | collect (scanner-capture-place scanner)))) |
| 207 | (loop for p0 in places |
| 208 | for i0 in posns do |
| 209 | (loop for p1 in places |
| 210 | for i1 in posns do |
| 211 | (if (< i1 i0) |
| 212 | (assert-condition 'error (scanner-interval p0 p1)) |
| 213 | (assert-equal (scanner-interval scanner p0 p1) |
| 214 | (make-pattern-string i0 i1) |
| 215 | (format nil "Mismatch interval ~A .. ~A." |
| 216 | i0 i1))) |
| 217 | (assert-true (scanner-at-eof-p scanner))))))) |
| 218 | |
| 219 | ;;;-------------------------------------------------------------------------- |
| 220 | ;;; Tests of the position tracking machinery. |
| 221 | |
| 222 | (defparameter *position-test-text* |
| 223 | ;; Use a roundabout method of getting tabs in there, so that they don't get |
| 224 | ;; screwed by strange editors and suchlike. |
| 225 | (substitute #\tab #\@ "Line one |
| 226 | Line two is rather longer, but not noticeably more interesting. |
| 227 | Line three explains that line four contains column numbers mod 10. |
| 228 | 012345678@6789@@2345678@012 |
| 229 | @@Line five is indented somewhat.") |
| 230 | "Text for the position-tracking test. |
| 231 | |
| 232 | The text should /look/ like the following. Note that this text here may |
| 233 | get trashed by tab/space conversions and whatever, and I've indented it so |
| 234 | that it doesn't look daft in the source; but the columns should remain |
| 235 | where they are. |
| 236 | |
| 237 | 0 1 2 3 4 5 6 7 |
| 238 | 0123456789012345678901234567890123456789012345678901234567890123456789012 |
| 239 | Line one |
| 240 | Line two is rather longer, but not noticeably more interesting. |
| 241 | Line three explains that line four contains column numbers mod 10. |
| 242 | 012345678 6789 2345678 012 |
| 243 | Line five is indented somewhat. |
| 244 | |
| 245 | It would be nice at some point to add additional tests for edge cases |
| 246 | around buffer boundaries. This isn't completely essential, though: the |
| 247 | current implementation manages positions fairly independently of the |
| 248 | buffering.") |
| 249 | |
| 250 | (defparameter *known-positions* |
| 251 | '( |
| 252 | ;; The first few line aren't actually very interesting. We'll |
| 253 | ;; check the start and end positions, and maybe a few in the |
| 254 | ;; middle. Note that a newline character is logically a part of |
| 255 | ;; the preceding line. |
| 256 | (0 #\L 1 0 #\i 1 1 0) (5 #\o 1 5 #\n 1 6 5) (8 #\newline 1 8 #\L 2 0 0) |
| 257 | (9 #\L 2 0 #\i 2 1 0) (72 #\newline 2 63 #\L 3 0 0) |
| 258 | (73 #\L 3 0 #\i 3 1 0) (139 #\newline 3 66 #\0 4 0 0) |
| 259 | |
| 260 | ;; Now for the line with the fancy tabbings. |
| 261 | (140 #\0 4 0 #\1 4 1 0) |
| 262 | (148 #\8 4 8 #\tab 4 9 8) ; nothing so far |
| 263 | (149 #\tab 4 9 #\6 4 16 15) ; the tab itself just follows on |
| 264 | (150 #\6 4 16 #\7 4 17 16) ; but the char after is tabbed |
| 265 | (154 #\tab 4 20 #\tab 4 24 23) ; next tab position |
| 266 | (155 #\tab 4 24 #\2 4 32 31) ; two in a row |
| 267 | (156 #\2 4 32 #\3 4 33 32) ; should be here now |
| 268 | (162 #\8 4 38 #\tab 4 39 38) ; skip to the next bit |
| 269 | (163 #\tab 4 39 #\0 4 40 39) ; tab is here |
| 270 | (164 #\0 4 40 #\1 4 41 40) ; and doesn't move us much |
| 271 | (166 #\2 4 42 #\newline 4 43 42) ; last actual character on the line |
| 272 | (167 #\newline 4 43 #\tab 5 0 0) ; and the ending newline |
| 273 | |
| 274 | ;; And the final line. |
| 275 | (168 #\tab 5 0 #\tab 5 8 7) ; first tab on next line |
| 276 | (169 #\tab 5 8 #\L 5 16 15) ; and the second |
| 277 | (170 #\L 5 16 #\i 5 17 16) ; beginning of the text |
| 278 | (200 #\. 5 46 :eof 5 47 46) ; last character in the stream |
| 279 | (201 :eof 5 47)) ; but eof has a position too |
| 280 | "List of character positions, characters and line/column numbers. |
| 281 | |
| 282 | The characters are there for sanity-checking purposes. The format is |
| 283 | |
| 284 | (INDEX CHAR LINE COLUMN NEXT-CHAR |
| 285 | NEXT-LINE NEXT-COLUMN REWIND-COLUMN) |
| 286 | |
| 287 | which asserts that the character at INDEX is CHAR, found at the given LINE |
| 288 | and COLUMN, that the next character is NEXT-CHAR, at the NEXT-LINE and |
| 289 | NEXT-COLUMN, and if one unreads from there, it will be (possibly |
| 290 | erroneously) claimed that the character at INDEX is at REWIND-COLUMN. |
| 291 | (Restoring a captured place shouldn't get the column wrong -- only |
| 292 | unreading.) |
| 293 | |
| 294 | The symbol `:eof' means that there is no character at the given INDEX, |
| 295 | because the file has already ended. However, EOF has a position which |
| 296 | should be correct, and it should be possible to unread from EOF.") |
| 297 | |
| 298 | (defclass charbuf-position-test (test-case) (scanner)) |
| 299 | (add-test *sod-test-suite* (get-suite charbuf-position-test)) |
| 300 | |
| 301 | (defmethod set-up ((test charbuf-position-test)) |
| 302 | (with-slots (scanner) test |
| 303 | (let ((stream (make-string-input-stream *position-test-text*))) |
| 304 | (setf scanner (make-instance 'charbuf-scanner |
| 305 | :stream stream |
| 306 | :filename "<position test>"))))) |
| 307 | |
| 308 | (defun check-position (scanner pos char line column note) |
| 309 | (if (eq char :eof) |
| 310 | (assert-true (scanner-at-eof-p scanner) |
| 311 | (format nil "EOF, position ~A (~A)." pos note)) |
| 312 | (assert-eql char (scanner-current-char scanner) |
| 313 | (format nil "Character, position ~A (~A)." pos note))) |
| 314 | (assert-eql line (scanner-line scanner) |
| 315 | (format nil "Line number, position ~A (~A)." pos note)) |
| 316 | (assert-eql column (scanner-column scanner) |
| 317 | (format nil "Column number, position ~A (~A)." pos note))) |
| 318 | |
| 319 | (def-test-method test-simple-positions |
| 320 | ((test charbuf-position-test) :run nil) |
| 321 | (with-slots (scanner) test |
| 322 | (loop for prev = 0 then pos |
| 323 | for (pos char line column) in *known-positions* do |
| 324 | (loop repeat (- pos prev) do (scanner-step scanner)) |
| 325 | (check-position scanner pos char line column "simple")))) |
| 326 | |
| 327 | (def-test-method test-rewind-positions |
| 328 | ((test charbuf-position-test) :run nil) |
| 329 | (with-slots (scanner) test |
| 330 | (let ((places (loop for prev = 0 then pos |
| 331 | for (pos char line column) in *known-positions* do |
| 332 | (skip scanner (- pos prev)) |
| 333 | (check-position scanner pos char line column "skip") |
| 334 | collect (scanner-capture-place scanner)))) |
| 335 | (loop for place in places |
| 336 | for (pos char line column |
| 337 | next-char next-line next-column |
| 338 | rewind-column) |
| 339 | in *known-positions* do |
| 340 | (scanner-restore-place scanner place) |
| 341 | (check-position scanner pos char line column "rewind") |
| 342 | (unless (eq char :eof) |
| 343 | (scanner-step scanner) |
| 344 | (check-position scanner (1+ pos) next-char |
| 345 | next-line next-column "step") |
| 346 | (scanner-unread scanner char) |
| 347 | (check-position scanner pos char line rewind-column |
| 348 | "unread") |
| 349 | (scanner-step scanner) |
| 350 | (check-position scanner (1+ pos) next-char |
| 351 | next-line next-column "restep")))))) |
| 352 | |
| 353 | ;;;----- That's all, folks -------------------------------------------------- |