From: Michal Nazarewicz <mina86@mina86.com>
To: 24603@debbugs.gnu.org
Subject: bug#24603: [PATCH 1/3] Add tests for casefiddle.c
Date: Tue, 18 Oct 2016 00:03:43 +0200 [thread overview]
Message-ID: <1476741825-32172-2-git-send-email-mina86@mina86.com> (raw)
In-Reply-To: <1476741825-32172-1-git-send-email-mina86@mina86.com>
Fixes cases marked FIXME upcoming in followup commits.
* test/src/casefiddle-tests.el (casefiddle-tests-char-properties,
casefiddle-tests-case-table, casefiddle-tests-casing-character,
casefiddle-tests-casing, casefiddle-tests-casing-byte8,
casefiddle-tests-casing-byte8-with-changes): New tests.
(casefiddle-tests--test-casing): New helper function for runnig
some of the tests.
---
test/src/casefiddle-tests.el | 251 +++++++++++++++++++++++++++++++++++++++++++
1 file changed, 251 insertions(+)
create mode 100644 test/src/casefiddle-tests.el
diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el
new file mode 100644
index 0000000..b5a77a1
--- /dev/null
+++ b/test/src/casefiddle-tests.el
@@ -0,0 +1,251 @@
+;;; casefiddle-tests.el --- tests for casefiddle.c functions -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest casefiddle-tests-char-properties ()
+ "Sanity check of character Unicode properties."
+ (should-not
+ (let (errors)
+ ;; character uppercase lowercase titlecase
+ (dolist (test '((?A nil ?a nil)
+ (?a ?A nil ?A)
+ (?Ł nil ?ł nil)
+ (?ł ?Ł nil ?Ł)
+
+ (?DŽ nil ?dž ?Dž)
+ (?Dž ?DŽ ?dž ?Dž)
+ (?dž ?DŽ nil ?Dž)
+
+ (?Σ nil ?σ nil)
+ (?σ ?Σ nil ?Σ)
+ (?ς ?Σ nil ?Σ)
+
+ (?ⅷ ?Ⅷ nil ?Ⅷ)
+ (?Ⅷ nil ?ⅷ nil)))
+ (let ((ch (car test))
+ (expected (cdr test))
+ (props '(uppercase lowercase titlecase)))
+ (while props
+ (let ((got (get-char-code-property ch (car props))))
+ (unless (equal (car expected) got)
+ (push (format "\n%c %s; expected: %s but got: %s"
+ ch (car props) (car expected) got)
+ errors)))
+ (setq props (cdr props) expected (cdr expected)))))
+ (when errors
+ (mapconcat (lambda (line) line) (nreverse errors) "")))))
+
+
+(defconst casefiddle-tests--characters
+ ;; character uppercase lowercase titlecase
+ '((?A ?A ?a ?A)
+ (?a ?A ?a ?A)
+ (?Ł ?Ł ?ł ?Ł)
+ (?ł ?Ł ?ł ?Ł)
+
+ ;; FIXME: We should have:
+ ;;(?DŽ ?DŽ ?dž ?Dž)
+ ;; but instead we have:
+ (?DŽ ?DŽ ?dž ?DŽ)
+ ;; FIXME: Those two are broken at the moment:
+ ;;(?Dž ?DŽ ?dž ?Dž)
+ ;;(?dž ?DŽ ?dž ?Dž)
+
+ (?Σ ?Σ ?σ ?Σ)
+ (?σ ?Σ ?σ ?Σ)
+ ;; FIXME: Another broken one:
+ ;;(?ς ?Σ ?ς ?Σ)
+
+ (?Ⅷ ?Ⅷ ?ⅷ ?Ⅷ)
+ (?ⅷ ?Ⅷ ?ⅷ ?Ⅷ)))
+
+
+(ert-deftest casefiddle-tests-case-table ()
+ "Sanity check of down and up case tables."
+ (should-not
+ (let (errors
+ (up (case-table-get-table (current-case-table) 'up))
+ (down (case-table-get-table (current-case-table) 'down)))
+ (dolist (test casefiddle-tests--characters)
+ (let ((ch (car test))
+ (expected (cdr test))
+ (props '(uppercase lowercase))
+ (tabs (list up down)))
+ (while props
+ (let ((got (aref (car tabs) ch)))
+ (unless (equal (car expected) got)
+ (push (format "\n%c %s; expected: %s but got: %s"
+ ch (car props) (car expected) got)
+ errors)))
+ (setq props (cdr props) tabs (cdr tabs) expected (cdr expected)))))
+ (when errors
+ (mapconcat (lambda (line) line) (nreverse errors) "")))))
+
+
+(ert-deftest casefiddle-tests-casing-character ()
+ (should-not
+ (let (errors)
+ (dolist (test casefiddle-tests--characters)
+ (let ((ch (car test))
+ (expected (cdr test))
+ (funcs '(upcase downcase capitalize)))
+ (while funcs
+ (let ((got (funcall (car funcs) ch)))
+ (unless (equal (car expected) got)
+ (push (format "\n%c %s; expected: %s but got: %s"
+ ch (car funcs) (car expected) got)
+ errors)))
+ (setq funcs (cdr funcs) expected (cdr expected)))))
+ (when errors
+ (mapconcat (lambda (line) line) (nreverse errors) "")))))
+
+
+(ert-deftest casefiddle-tests-casing-word ()
+ (with-temp-buffer
+ (dolist (test '((upcase-word . "FOO Bar")
+ (downcase-word . "foo Bar")
+ (capitalize-word . "Foo Bar")))
+ (dolist (back '(nil t))
+ (delete-region (point-min) (point-max))
+ (insert "foO Bar")
+ (goto-char (+ (if back 4 0) (point-min)))
+ (funcall (car test) (if back -1 1))
+ (should (string-equal (cdr test) (buffer-string)))
+ (should (equal (+ (if back 4 3) (point-min)) (point)))))))
+
+
+(defun casefiddle-tests--test-casing (tests)
+ (nreverse
+ (cl-reduce
+ (lambda (errors test)
+ (let* ((input (car test))
+ (expected (cdr test))
+ (func-pairs '((upcase upcase-region)
+ (downcase downcase-region)
+ (capitalize capitalize-region)
+ (upcase-initials upcase-initials-region)))
+ (get-string (lambda (func) (funcall func input)))
+ (get-region (lambda (func)
+ (delete-region (point-min) (point-max))
+ (unwind-protect
+ (progn
+ (unless (multibyte-string-p input)
+ (toggle-enable-multibyte-characters))
+ (insert input)
+ (funcall func (point-min) (point-max))
+ (buffer-string))
+ (unless (multibyte-string-p input)
+ (toggle-enable-multibyte-characters)))))
+ (fmt-str (lambda (str)
+ (format "%s (%sbyte; %d chars; %d bytes)"
+ str
+ (if (multibyte-string-p str) "multi" "uni")
+ (length str) (string-bytes str))))
+ funcs getters)
+ (while (and func-pairs expected)
+ (setq funcs (car func-pairs)
+ getters (list get-string get-region))
+ (while (and funcs getters)
+ (let ((got (funcall (car getters) (car funcs))))
+ (unless (string-equal got (car expected))
+ (let ((fmt (length (symbol-name (car funcs)))))
+ (setq fmt (format "\n%%%ds: %%s" (max fmt 8)))
+ (push (format (concat fmt fmt fmt)
+ (car funcs) (funcall fmt-str input)
+ "expected" (funcall fmt-str (car expected))
+ "but got" (funcall fmt-str got))
+ errors))))
+ (setq funcs (cdr funcs) getters (cdr getters)))
+ (setq func-pairs (cdr func-pairs) expected (cdr expected))))
+ errors)
+ (cons () tests))))
+
+(ert-deftest casefiddle-tests-casing ()
+ (should-not
+ (with-temp-buffer
+ (casefiddle-tests--test-casing
+ ;; input upper lower capitalize up-initials
+ '(("Foo baR" "FOO BAR" "foo bar" "Foo Bar" "Foo BaR")
+ ("Ⅷ ⅷ" "Ⅷ Ⅷ" "ⅷ ⅷ" "Ⅷ Ⅷ" "Ⅷ Ⅷ")
+ ;; FIXME: Everything below is broken at the moment. Here’s what
+ ;; should happen:
+ ;;("DŽUNGLA" "DŽUNGLA" "džungla" "Džungla" "DžUNGLA")
+ ;;("Džungla" "DŽUNGLA" "džungla" "Džungla" "Džungla")
+ ;;("džungla" "DŽUNGLA" "džungla" "Džungla" "Džungla")
+ ;;("define" "DEFINE" "define" "Define" "Define")
+ ;;("fish" "FIsh" "fish" "Fish" "Fish")
+ ;;("Straße" "STRASSE" "straße" "Straße" "Straße")
+ ;;("ΌΣΟΣ" "ΌΣΟΣ" "όσος" "Όσος" "Όσος")
+ ;;("όσος" "ΌΣΟΣ" "όσος" "Όσος" "Όσος")
+ ;; And here’s what is actually happening:
+ ("DŽUNGLA" "DŽUNGLA" "džungla" "DŽungla" "DŽUNGLA")
+ ("Džungla" "DžUNGLA" "džungla" "Džungla" "Džungla")
+ ("džungla" "DŽUNGLA" "džungla" "DŽungla" "DŽungla")
+ ("define" "DEfiNE" "define" "Define" "Define")
+ ("fish" "fiSH" "fish" "fish" "fish")
+ ("Straße" "STRAßE" "straße" "Straße" "Straße")
+ ("ΌΣΟΣ" "ΌΣΟΣ" "όσοσ" "Όσοσ" "ΌΣΟΣ")
+ ("όσος" "ΌΣΟς" "όσος" "Όσος" "Όσος"))))))
+
+(ert-deftest casefiddle-tests-casing-byte8 ()
+ (should-not
+ (with-temp-buffer
+ (casefiddle-tests--test-casing
+ '(("\xff Foo baR \xff"
+ "\xff FOO BAR \xff"
+ "\xff foo bar \xff"
+ "\xff Foo Bar \xff"
+ "\xff Foo BaR \xff")
+ ("\xff Zażółć gĘŚlą \xff"
+ "\xff ZAŻÓŁĆ GĘŚLĄ \xff"
+ "\xff zażółć gęślą \xff"
+ "\xff Zażółć Gęślą \xff"
+ "\xff Zażółć GĘŚlą \xff"))))))
+
+(ert-deftest casefiddle-tests-casing-byte8-with-changes ()
+ (let ((tab (make-char-table 'case-table))
+ (std (standard-case-table))
+ (test '("\xff\xff\xef Foo baR \xcf\xcf"
+ "\xef\xef\xef FOO BAR \xcf\xcf"
+ "\xff\xff\xff foo bar \xcf\xcf"
+ "\xef\xff\xff Foo Bar \xcf\xcf"
+ "\xef\xff\xef Foo BaR \xcf\xcf"))
+ (byte8 #x3FFF00))
+ (should-not
+ (with-temp-buffer
+ (set-case-table tab)
+ (set-char-table-parent tab std)
+ (set-char-table-extra-slot tab 0 (make-char-table 'upcase))
+ (set-char-table-parent (char-table-extra-slot tab 0)
+ (char-table-extra-slot std 0))
+ (set-case-syntax-pair (+ byte8 #xef) (+ byte8 #xff) tab)
+ (casefiddle-tests--test-casing
+ (list test
+ (mapcar (lambda (str) (decode-coding-string str 'binary)) test)
+ '("\xff\xff\xef Zażółć gĘŚlą \xcf\xcf"
+ "\xef\xef\xef ZAŻÓŁĆ GĘŚLĄ \xcf\xcf"
+ "\xff\xff\xff zażółć gęślą \xcf\xcf"
+ "\xef\xff\xff Zażółć Gęślą \xcf\xcf"
+ "\xef\xff\xef Zażółć GĘŚlą \xcf\xcf")))))))
+
+
+;;; casefiddle-tests.el ends here
--
2.8.0.rc3.226.g39d4020
next prev parent reply other threads:[~2016-10-17 22:03 UTC|newest]
Thread overview: 89+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-10-04 1:05 bug#24603: [RFC 00/18] Improvement to casing Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 01/18] Add tests for casefiddle.c Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 02/18] Generate upcase and downcase tables from Unicode data Michal Nazarewicz
2016-10-04 7:27 ` Eli Zaretskii
2016-10-04 14:54 ` Michal Nazarewicz
2016-10-04 15:06 ` Eli Zaretskii
2016-10-04 16:57 ` Michal Nazarewicz
2016-10-04 17:27 ` Eli Zaretskii
2016-10-04 17:44 ` Eli Zaretskii
2016-10-06 20:29 ` Michal Nazarewicz
2016-10-07 6:52 ` Eli Zaretskii
2016-10-04 1:10 ` bug#24603: [RFC 03/18] Don’t assume character can be either upper- or lower-case when casing Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 04/18] Split casify_object into multiple functions Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 05/18] Introduce case_character function Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 06/18] Add support for title-casing letters Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 07/18] Split up casify_region function Michal Nazarewicz
2016-10-04 7:17 ` Eli Zaretskii
2016-10-18 2:27 ` Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 08/18] Support casing characters which map into multiple code points Michal Nazarewicz
2016-10-04 7:38 ` Eli Zaretskii
2016-10-06 21:40 ` Michal Nazarewicz
2016-10-07 7:46 ` Eli Zaretskii
2017-01-28 23:48 ` Michal Nazarewicz
2017-02-10 9:12 ` Eli Zaretskii
2016-10-04 1:10 ` bug#24603: [RFC 09/18] Implement special sigma casing rule Michal Nazarewicz
2016-10-04 7:22 ` Eli Zaretskii
2016-10-04 1:10 ` bug#24603: [RFC 10/18] Implement Turkic dotless and dotted i handling when casing strings Michal Nazarewicz
2016-10-04 7:12 ` Eli Zaretskii
2016-10-04 1:10 ` bug#24603: [RFC 11/18] Implement casing rules for Lithuanian Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 12/18] Implement rules for title-casing Dutch ij ‘letter’ Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 13/18] Add some tricky Unicode characters to regex test Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 14/18] Factor out character category lookup to separate function Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 15/18] Base lower- and upper-case tests on Unicode properties Michal Nazarewicz
2016-10-04 6:54 ` Eli Zaretskii
2016-10-04 1:10 ` bug#24603: [RFC 16/18] Refactor character class checking; optimise ASCII case Michal Nazarewicz
2016-10-04 7:48 ` Eli Zaretskii
2016-10-17 13:22 ` Michal Nazarewicz
2016-11-06 19:26 ` Michal Nazarewicz
2016-11-06 19:44 ` Eli Zaretskii
2016-12-20 14:32 ` Michal Nazarewicz
2016-12-20 16:39 ` Eli Zaretskii
2016-12-22 14:02 ` Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 17/18] Optimise character class matching in regexes Michal Nazarewicz
2016-10-04 1:10 ` bug#24603: [RFC 18/18] Fix case-fold-search character class matching Michal Nazarewicz
2016-10-17 22:03 ` bug#24603: [PATCH 0/3] Case table updates Michal Nazarewicz
2016-10-17 22:03 ` Michal Nazarewicz [this message]
2016-10-17 22:03 ` bug#24603: [PATCH 2/3] Generate upcase and downcase tables from Unicode data Michal Nazarewicz
2016-10-17 22:03 ` bug#24603: [PATCH 3/3] Don’t generate ‘X maps to X’ entries in case tables Michal Nazarewicz
2016-10-18 6:36 ` bug#24603: [PATCH 0/3] Case table updates Eli Zaretskii
2016-10-24 15:11 ` Michal Nazarewicz
2016-10-24 15:33 ` Eli Zaretskii
2017-03-09 21:51 ` bug#24603: [PATCHv5 00/11] Casing improvements Michal Nazarewicz
2017-03-09 21:51 ` bug#24603: [PATCHv5 01/11] Split casify_object into multiple functions Michal Nazarewicz
2017-03-10 9:00 ` Andreas Schwab
2017-03-09 21:51 ` bug#24603: [PATCHv5 02/11] Introduce case_character function Michal Nazarewicz
2017-03-09 21:51 ` bug#24603: [PATCHv5 03/11] Add support for title-casing letters (bug#24603) Michal Nazarewicz
2017-03-11 9:03 ` Eli Zaretskii
2017-03-09 21:51 ` bug#24603: [PATCHv5 04/11] Split up casify_region function (bug#24603) Michal Nazarewicz
2017-03-09 21:51 ` bug#24603: [PATCHv5 05/11] Support casing characters which map into multiple code points (bug#24603) Michal Nazarewicz
2017-03-11 9:14 ` Eli Zaretskii
2017-03-21 2:09 ` Michal Nazarewicz
2017-03-09 21:51 ` bug#24603: [PATCHv5 06/11] Implement special sigma casing rule (bug#24603) Michal Nazarewicz
2017-03-09 21:51 ` bug#24603: [PATCHv5 07/11] Introduce ‘buffer-language’ buffer-locar variable Michal Nazarewicz
2017-03-11 9:29 ` Eli Zaretskii
2017-03-09 21:51 ` bug#24603: [PATCHv5 08/11] Implement rules for title-casing Dutch ij ‘letter’ (bug#24603) Michal Nazarewicz
2017-03-11 9:40 ` Eli Zaretskii
2017-03-16 21:30 ` Michal Nazarewicz
2017-03-17 13:43 ` Eli Zaretskii
2017-03-09 21:51 ` bug#24603: [PATCHv5 09/11] Implement Turkic dotless and dotted i casing rules (bug#24603) Michal Nazarewicz
2017-03-09 21:51 ` bug#24603: [PATCHv5 10/11] Implement casing rules for Lithuanian (bug#24603) Michal Nazarewicz
2017-03-09 21:51 ` bug#24603: [PATCHv5 11/11] Implement Irish casing rules (bug#24603) Michal Nazarewicz
2017-03-11 9:44 ` Eli Zaretskii
2017-03-16 22:16 ` Michal Nazarewicz
2017-03-17 8:20 ` Eli Zaretskii
2017-03-11 10:00 ` bug#24603: [PATCHv5 00/11] Casing improvements Eli Zaretskii
2017-03-21 1:27 ` bug#24603: [PATCHv6 0/6] Casing improvements, language-independent part Michal Nazarewicz
2017-03-21 1:27 ` bug#24603: [PATCHv6 1/6] Split casify_object into multiple functions Michal Nazarewicz
2017-03-21 1:27 ` bug#24603: [PATCHv6 2/6] Introduce case_character function Michal Nazarewicz
2017-03-21 1:27 ` bug#24603: [PATCHv6 3/6] Add support for title-casing letters (bug#24603) Michal Nazarewicz
2017-03-21 1:27 ` bug#24603: [PATCHv6 4/6] Split up casify_region function (bug#24603) Michal Nazarewicz
2017-03-21 1:27 ` bug#24603: [PATCHv6 5/6] Support casing characters which map into multiple code points (bug#24603) Michal Nazarewicz
2017-03-22 16:06 ` Eli Zaretskii
2017-04-03 9:01 ` Michal Nazarewicz
2017-04-03 14:52 ` Eli Zaretskii
2019-06-25 0:09 ` Lars Ingebrigtsen
2019-06-25 0:29 ` Michał Nazarewicz
2020-08-11 13:46 ` Lars Ingebrigtsen
2021-05-10 11:51 ` bug#24603: [RFC 00/18] Improvement to casing Lars Ingebrigtsen
2017-03-21 1:27 ` bug#24603: [PATCHv6 6/6] Implement special sigma casing rule (bug#24603) Michal Nazarewicz
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=1476741825-32172-2-git-send-email-mina86@mina86.com \
--to=mina86@mina86.com \
--cc=24603@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).