Mercurial > hg > xemacs-beta

comparison tests/automated/case-tests.el @ 4962:e813cf16c015

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Mon, 01 Feb 2010 05:29:05 -0600
parents 9e7f5a77cc84
children 0f66906b6e37
comparison
equal deleted inserted replaced
4961:b90f8cf474e0 4962:e813cf16c015
27 27
28 ;;; Synched up with: Not in FSF. 28 ;;; Synched up with: Not in FSF.
29 29
30 ;;; Commentary: 30 ;;; Commentary:
31 31
32 ;; Test case-table related functionality. 32 ;; Test case-table related functionality. See test-harness.el for
33 33 ;; instructions on how to run these tests.
34 (defvar pristine-case-table nil 34
35 "The standard case table, without manipulation from case-tests.el") 35 ;; NOTE NOTE NOTE: See also:
36 36 ;;
37 (setq pristine-case-table (or 37 ;; (1) regexp-tests.el, for case-related regexp searching.
38 ;; This is the compiled run; we've retained 38 ;; (2) search-tests.el, for case-related non-regexp searching.
39 ;; it from the interpreted run. 39 ;; (3) lisp-tests.el, for case-related comparisons with `equalp'.
40 pristine-case-table 40
41 ;; This is the interpreted run; set it. 41 ;; NOTE NOTE NOTE: There is some domain overlap among case-tests.el,
42 (copy-case-table (standard-case-table)))) 42 ;; lisp-tests.el, regexp-tests.el, and search-tests.el. The current rule
43 ;; for what goes where is:
44 ;;
45 ;; (1) Anything regexp-related goes in regexp-tests.el, including searches.
46 ;; (2) Non-regexp searches go in search-tests.el. This includes case-folding
47 ;; searches in the situation where the test tests both folding and
48 ;; non-folding behavior.
49 ;; (3) Anything else that involves case-testing but in an ancillary manner
50 ;; goes into whichever primary area it is involved in (e.g. searches for
51 ;; search-tests.el, Lisp primitives in lisp-tests.el). But if it is
52 ;; primarily case-related and happens to involve other areas in an
53 ;; ancillary manner, it goes into case-tests.el. This includes, for
54 ;; example, the Unicode case map torture tests.
55
43 56
44 (Assert (case-table-p (standard-case-table))) 57 (Assert (case-table-p (standard-case-table)))
45 ;; Old case table test. 58 ;; Old case table test.
46 (Assert (case-table-p (list 59 (Assert (case-table-p (list
47 (make-string 256 ?a) 60 (make-string 256 ?a)
159 "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ")) 172 "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
160 (Assert 173 (Assert
161 (string= 174 (string=
162 (downcase "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ") 175 (downcase "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ")
163 "!\"#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz"))) 176 "!\"#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz")))
164
165 (with-temp-buffer
166 (insert "Test Buffer")
167 (let ((case-fold-search t))
168 (goto-char (point-min))
169 (Assert-eq (search-forward "test buffer" nil t) 12)
170 (goto-char (point-min))
171 (Assert-eq (search-forward "Test buffer" nil t) 12)
172 (goto-char (point-min))
173 (Assert-eq (search-forward "Test Buffer" nil t) 12)
174
175 (setq case-fold-search nil)
176 (goto-char (point-min))
177 (Assert (not (search-forward "test buffer" nil t)))
178 (goto-char (point-min))
179 (Assert (not (search-forward "Test buffer" nil t)))
180 (goto-char (point-min))
181 (Assert-eq (search-forward "Test Buffer" nil t) 12)))
182
183 (with-temp-buffer
184 (insert "abcdefghijklmnäopqrstuÄvwxyz")
185 ;; case insensitive
186 (Assert (not (search-forward "ö" nil t)))
187 (goto-char (point-min))
188 (Assert-eq 16 (search-forward "ä" nil t))
189 (Assert-eq 24 (search-forward "ä" nil t))
190 (goto-char (point-min))
191 (Assert-eq 16 (search-forward "Ä" nil t))
192 (Assert-eq 24 (search-forward "Ä" nil t))
193 (goto-char (point-max))
194 (Assert-eq 23 (search-backward "ä" nil t))
195 (Assert-eq 15 (search-backward "ä" nil t))
196 (goto-char (point-max))
197 (Assert-eq 23 (search-backward "Ä" nil t))
198 (Assert-eq 15 (search-backward "Ä" nil t))
199 ;; case sensitive
200 (setq case-fold-search nil)
201 (goto-char (point-min))
202 (Assert (not (search-forward "ö" nil t)))
203 (goto-char (point-min))
204 (Assert-eq 16 (search-forward "ä" nil t))
205 (Assert (not (search-forward "ä" nil t)))
206 (goto-char (point-min))
207 (Assert-eq 24 (search-forward "Ä" nil t))
208 (goto-char 16)
209 (Assert-eq 24 (search-forward "Ä" nil t))
210 (goto-char (point-max))
211 (Assert-eq 15 (search-backward "ä" nil t))
212 (goto-char 15)
213 (Assert (not (search-backward "ä" nil t)))
214 (goto-char (point-max))
215 (Assert-eq 23 (search-backward "Ä" nil t))
216 (Assert (not (search-backward "Ä" nil t))))
217
218 (with-temp-buffer
219 (insert "aaaaäÄäÄäÄäÄäÄbbbb")
220 (goto-char (point-min))
221 (Assert-eq 15 (search-forward "ää" nil t 5))
222 (goto-char (point-min))
223 (Assert (not (search-forward "ää" nil t 6)))
224 (goto-char (point-max))
225 (Assert-eq 5 (search-backward "ää" nil t 5))
226 (goto-char (point-max))
227 (Assert (not (search-backward "ää" nil t 6))))
228
229 (when (featurep 'mule)
230 (let* ((hiragana-a (make-char 'japanese-jisx0208 36 34))
231 (a-diaeresis ?ä)
232 (case-table (copy-case-table (standard-case-table)))
233 (str-hiragana-a (char-to-string hiragana-a))
234 (str-a-diaeresis (char-to-string a-diaeresis))
235 (string (concat str-hiragana-a str-a-diaeresis)))
236 (put-case-table-pair hiragana-a a-diaeresis case-table)
237 (with-temp-buffer
238 (set-case-table case-table)
239 (insert hiragana-a "abcdefg" a-diaeresis)
240 ;; forward
241 (goto-char (point-min))
242 (Assert (not (search-forward "ö" nil t)))
243 (goto-char (point-min))
244 (Assert-eq 2 (search-forward str-hiragana-a nil t))
245 (goto-char (point-min))
246 (Assert-eq 2 (search-forward str-a-diaeresis nil t))
247 (goto-char (1+ (point-min)))
248 (Assert-eq (point-max)
249 (search-forward str-hiragana-a nil t))
250 (goto-char (1+ (point-min)))
251 (Assert-eq (point-max)
252 (search-forward str-a-diaeresis nil t))
253 ;; backward
254 (goto-char (point-max))
255 (Assert (not (search-backward "ö" nil t)))
256 (goto-char (point-max))
257 (Assert-eq (1- (point-max)) (search-backward str-hiragana-a nil t))
258 (goto-char (point-max))
259 (Assert-eq (1- (point-max)) (search-backward str-a-diaeresis nil t))
260 (goto-char (1- (point-max)))
261 (Assert-eq 1 (search-backward str-hiragana-a nil t))
262 (goto-char (1- (point-max)))
263 (Assert-eq 1 (search-backward str-a-diaeresis nil t))
264 (replace-match "a")
265 (Assert (looking-at (format "abcdefg%c" a-diaeresis))))
266 (with-temp-buffer
267 (set-case-table case-table)
268 (insert string)
269 (insert string)
270 (insert string)
271 (insert string)
272 (insert string)
273 (goto-char (point-min))
274 (Assert-eq 11 (search-forward string nil t 5))
275 (goto-char (point-min))
276 (Assert (not (search-forward string nil t 6)))
277 (goto-char (point-max))
278 (Assert-eq 1 (search-backward string nil t 5))
279 (goto-char (point-max))
280 (Assert (not (search-backward string nil t 6))))))
281
282 ;; Bug reported in http://mid.gmane.org/y9lk5lu5orq.fsf@deinprogramm.de from
283 ;; Michael Sperber. Fixed 2008-01-29.
284 (with-string-as-buffer-contents "\n\nDer beruhmte deutsche Flei\xdf\n\n"
285 (goto-char (point-min))
286 (Assert (search-forward "Flei\xdf")))
287
288 (with-temp-buffer
289 (let ((target "M\xe9zard")
290 (debug-xemacs-searches 1))
291 (Assert (not (search-forward target nil t)))
292 (insert target)
293 (goto-char (point-min))
294 ;; #### search-algorithm-used is simple-search after the following,
295 ;; which shouldn't be necessary; it should be possible to use
296 ;; Boyer-Moore.
297 ;;
298 ;; But searches for ASCII strings in buffers with nothing above ?\xFF
299 ;; use Boyer Moore with the current implementation, which is the
300 ;; important thing for the Gnus use case.
301 (Assert= (1+ (length target)) (search-forward target nil t))))
302
303 (Skip-Test-Unless
304 (boundp 'debug-xemacs-searches) ; normal when we have DEBUG_XEMACS
305 "not a DEBUG_XEMACS build"
306 "checks that the algorithm chosen by #'search-forward is relatively sane"
307 (let ((debug-xemacs-searches 1))
308 (with-temp-buffer
309 (set-case-table pristine-case-table)
310 (insert "\n\nDer beruhmte deutsche Fleiss\n\n")
311 (goto-char (point-min))
312 (Assert (search-forward "Fleiss"))
313 (delete-region (point-min) (point-max))
314 (insert "\n\nDer beruhmte deutsche Flei\xdf\n\n")
315 (goto-char (point-min))
316 (Assert (search-forward "Flei\xdf"))
317 (Assert-eq 'boyer-moore search-algorithm-used)
318 (delete-region (point-min) (point-max))
319 (when (featurep 'mule)
320 (insert "\n\nDer beruhmte deutsche Flei\xdf\n\n")
321 (goto-char (point-min))
322 (Assert
323 (search-forward (format "Fle%c\xdf"
324 (make-char 'latin-iso8859-9 #xfd))))
325 (Assert-eq 'boyer-moore search-algorithm-used)
326 (insert (make-char 'latin-iso8859-9 #xfd))
327 (goto-char (point-min))
328 (Assert (search-forward "Flei\xdf"))
329 (Assert-eq 'simple-search search-algorithm-used)
330 (goto-char (point-min))
331 (Assert (search-forward (format "Fle%c\xdf"
332 (make-char 'latin-iso8859-9 #xfd))))
333 (Assert-eq 'simple-search search-algorithm-used)))))
334 177
335 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 178 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
336 179
337 ;; Torture test, using all the non-"full" mappings from the Unicode case 180 ;; Torture test, using all the non-"full" mappings from the Unicode case
338 ;; tables. (Full mappings are those that involve sequences of more than one 181 ;; tables. (Full mappings are those that involve sequences of more than one
1599 (?\U00010424 ?\U0001044C) ;; DESERET CAPITAL LETTER EN 1442 (?\U00010424 ?\U0001044C) ;; DESERET CAPITAL LETTER EN
1600 (?\U00010425 ?\U0001044D) ;; DESERET CAPITAL LETTER ENG 1443 (?\U00010425 ?\U0001044D) ;; DESERET CAPITAL LETTER ENG
1601 (?\U00010426 ?\U0001044E) ;; DESERET CAPITAL LETTER OI 1444 (?\U00010426 ?\U0001044E) ;; DESERET CAPITAL LETTER OI
1602 (?\U00010427 ?\U0001044F) ;; DESERET CAPITAL LETTER EW 1445 (?\U00010427 ?\U0001044F) ;; DESERET CAPITAL LETTER EW
1603 )) 1446 ))
1604 (uni-casetab (loop 1447 ;; a table to track mappings that overlap with some other mapping
1605 with case-table = (make-case-table) 1448 (multi-hash (make-hash-table))
1606 for (uc lc) in uni-mappings 1449 (uni-casetab
1607 do (put-case-table-pair uc lc case-table) 1450 (loop
1608 finally return case-table)) 1451 with case-table = (make-case-table)
1609 ;; All lowercase 1452 for (uc lc) in uni-mappings do
1610 (lower (with-output-to-string 1453 ;; see if there are existing mappings for either char of the new
1611 (loop for (uc lc) in uni-mappings do (princ lc)))) 1454 ;; mapping pair.
1612 ;; All uppercase 1455 (let* ((curucval (get-case-table 'downcase uc case-table))
1613 (upper (with-output-to-string 1456 (curlcval (get-case-table 'upcase lc case-table))
1614 (loop for (uc lc) in uni-mappings do (princ lc)))) 1457 (curucval (and (not (eq curucval uc)) curucval))
1615 ;; For each pair, lower followed by upper 1458 (curlcval (and (not (eq curlcval lc)) curlcval))
1616 (lowerupper (with-output-to-string 1459 )
1617 (loop for (uc lc) in uni-mappings 1460 ;; if so, flag both the existing and new mapping pair as having
1618 do (princ lc) (princ uc)))) 1461 ;; an overlapping mapping.
1619 ;; For each pair, upper followed by lower 1462 (when (or curucval curlcval)
1620 (upperlower (with-output-to-string 1463 (loop for ch in (list curucval curlcval uc lc) do
1621 (loop for (uc lc) in uni-mappings 1464 (puthash ch t multi-hash)))
1622 do (princ uc) (princ lc)))) 1465
1623 ) 1466 ;; finally, make the new mapping.
1624 (with-case-table uni-casetab 1467 (put-case-table-pair uc lc case-table))
1625 (Assert-equalp lower upper) 1468 finally return case-table)))
1626 (Assert-equalp lowerupper upperlower) 1469 (flet ((ismulti (uc lc)
1627 (Assert-equal lower (downcase upper)) 1470 (or (gethash uc multi-hash) (gethash lc multi-hash))))
1628 (Assert-equal upper (downcase lower)) 1471 (let (
1629 (Assert-equal lower (downcase upper)) 1472 ;; All lowercase
1630 (Assert-equal upper (downcase lower)) 1473 (lowermulti (with-output-to-string
1631 (Assert-equal (downcase lower) (downcase (downcase lower))) 1474 (loop for (uc lc) in uni-mappings do (princ lc))))
1632 (Assert-equal (upcase lowerupper) (upcase upperlower)) 1475 ;; All uppercase
1633 (Assert-equal (downcase lowerupper) (downcase upperlower)) 1476 (uppermulti (with-output-to-string
1634 (with-temp-buffer 1477 (loop for (uc lc) in uni-mappings do (princ uc))))
1635 (set-case-table uni-casetab) 1478 ;; For each pair, lower followed by upper
1636 (loop for (str1 str2) in `((,lower ,upper) 1479 (loweruppermulti (with-output-to-string
1637 (,lowerupper ,upperlower) 1480 (loop for (uc lc) in uni-mappings
1638 (,upper ,lower) 1481 do (princ lc) (princ uc))))
1639 (,upperlower ,lowerupper)) 1482 ;; For each pair, upper followed by lower
1640 do 1483 (upperlowermulti (with-output-to-string
1641 (erase-buffer) 1484 (loop for (uc lc) in uni-mappings
1642 (Assert= (point-min) 1) 1485 do (princ uc) (princ lc))))
1643 (Assert= (point) 1) 1486 ;; All lowercase, no complex mappings
1644 (insert str1) 1487 (lower (with-output-to-string
1645 (let ((point (point)) 1488 (loop for (uc lc) in uni-mappings do
1646 (case-fold-search t)) 1489 (unless (ismulti uc lc) (princ lc)))))
1647 (Assert= (length str1) (1- point)) 1490 ;; All uppercase, no complex mappings
1648 (goto-char (point-min)) 1491 (upper (with-output-to-string
1649 (Assert-eql (search-forward str2 nil t) point))) 1492 (loop for (uc lc) in uni-mappings do
1650 (loop for (uc lc) in uni-mappings do 1493 (unless (ismulti uc lc) (princ uc)))))
1651 (loop for (ch1 ch2) in `((,uc ,lc) 1494 ;; For each pair, lower followed by upper, no complex mappings
1652 (,lc ,uc)) 1495 (lowerupper (with-output-to-string
1496 (loop for (uc lc) in uni-mappings do
1497 (unless (ismulti uc lc) (princ lc) (princ uc)))))
1498 ;; For each pair, upper followed by lower, no complex mappings
1499 (upperlower (with-output-to-string
1500 (loop for (uc lc) in uni-mappings do
1501 (unless (ismulti uc lc) (princ uc) (princ lc)))))
1502 )
1503 (with-case-table
1504 uni-casetab
1505 ;; Comparison with `equalp' uses a canonical mapping internally and
1506 ;; so should be able to handle multi-mappings. Just comparing
1507 ;; using downcase and upcase, however, won't necessarily work in
1508 ;; the presence of such mappings -- that's what the internal canon
1509 ;; and eqv tables are for.
1510 (Assert-equalp lowermulti uppermulti)
1511 (Assert-equalp loweruppermulti upperlowermulti)
1512 (Assert-equal lower (downcase upper))
1513 (Assert-equal upper (upcase lower))
1514 (Assert-equal (downcase lower) (downcase (downcase lower)))
1515 (Assert-equal (upcase lowerupper) (upcase upperlower))
1516 (Assert-equal (downcase lowerupper) (downcase upperlower))
1517 ;; Individually -- we include multi-mappings since we're using
1518 ;; `equalp'.
1519 (loop
1520 for (uc lc) in uni-mappings do
1521 (Assert-equalp uc lc)
1522 (Assert-equalp (string uc) (string lc)))
1523 )
1524
1525 ;; Here we include multi-mappings -- searching should be able to
1526 ;; handle it.
1527 (with-temp-buffer
1528 (set-case-table uni-casetab)
1529 (loop for (str1 str2) in `((,lowermulti ,uppermulti)
1530 (,loweruppermulti ,upperlowermulti)
1531 (,uppermulti ,lowermulti)
1532 (,upperlowermulti ,loweruppermulti))
1653 do 1533 do
1654 (erase-buffer) 1534 (erase-buffer)
1655 (insert ?a) 1535 (Assert= (point-min) 1)
1656 (insert ch1) 1536 (Assert= (point) 1)
1657 (insert ?b) 1537 (insert str1)
1658 (goto-char (point-min)) 1538 (let ((point (point))
1659 (Assert-eql (search-forward (char-to-string ch2) nil t) 3 1539 (case-fold-search t))
1660 (format "Case-folded searching doesn't equate %s and %s" 1540 (Assert= (length str1) (1- point))
1661 (char-as-unicode-escape ch1) 1541 (goto-char (point-min))
1662 (char-as-unicode-escape ch2)))))))) 1542 (Assert-eql (search-forward str2 nil t) point)))
1543 (loop for (uc lc) in uni-mappings do
1544 (loop for (ch1 ch2) in `((,uc ,lc)
1545 (,lc ,uc))
1546 do
1547 (erase-buffer)
1548 (insert ?0)
1549 (insert ch1)
1550 (insert ?1)
1551 (goto-char (point-min))
1552 (Assert-eql (search-forward (char-to-string ch2) nil t) 3
1553 (format "Case-folded searching doesn't equate %s and %s"
1554 (char-as-unicode-escape ch1)
1555 (char-as-unicode-escape ch2))))))
1556 )))