From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Michal Nazarewicz Newsgroups: gmane.emacs.bugs Subject: bug#24603: [PATCH 1/3] Add tests for casefiddle.c Date: Tue, 18 Oct 2016 00:03:43 +0200 Message-ID: <1476741825-32172-2-git-send-email-mina86@mina86.com> References: <1476741825-32172-1-git-send-email-mina86@mina86.com> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Trace: blaine.gmane.org 1476741919 23850 195.159.176.226 (17 Oct 2016 22:05:19 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Mon, 17 Oct 2016 22:05:19 +0000 (UTC) To: 24603@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Tue Oct 18 00:05:13 2016 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bwG1f-0003na-TH for geb-bug-gnu-emacs@m.gmane.org; Tue, 18 Oct 2016 00:04:56 +0200 Original-Received: from localhost ([::1]:36280 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bwG1i-0001Zk-4x for geb-bug-gnu-emacs@m.gmane.org; Mon, 17 Oct 2016 18:04:58 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:38069) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bwG0s-00014r-ML for bug-gnu-emacs@gnu.org; Mon, 17 Oct 2016 18:04:08 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1bwG0p-0007XF-GI for bug-gnu-emacs@gnu.org; Mon, 17 Oct 2016 18:04:06 -0400 Original-Received: from debbugs.gnu.org ([208.118.235.43]:59190) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1bwG0p-0007Wy-DJ for bug-gnu-emacs@gnu.org; Mon, 17 Oct 2016 18:04:03 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1bwG0p-0000JG-5X for bug-gnu-emacs@gnu.org; Mon, 17 Oct 2016 18:04:03 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Michal Nazarewicz Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Mon, 17 Oct 2016 22:04:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 24603 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 24603-submit@debbugs.gnu.org id=B24603.14767418381159 (code B ref 24603); Mon, 17 Oct 2016 22:04:03 +0000 Original-Received: (at 24603) by debbugs.gnu.org; 17 Oct 2016 22:03:58 +0000 Original-Received: from localhost ([127.0.0.1]:37144 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bwG0k-0000IX-At for submit@debbugs.gnu.org; Mon, 17 Oct 2016 18:03:58 -0400 Original-Received: from mail-lf0-f46.google.com ([209.85.215.46]:35735) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bwG0g-0000Hk-C0 for 24603@debbugs.gnu.org; Mon, 17 Oct 2016 18:03:55 -0400 Original-Received: by mail-lf0-f46.google.com with SMTP id l131so261734169lfl.2 for <24603@debbugs.gnu.org>; Mon, 17 Oct 2016 15:03:54 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=20120113; h=sender:from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=vt5BfZy7ipsaOTlqFHpc8ST6Y4MipYcqnBqkR25MgSc=; b=YLohY5eIBSjoY8nI8Rne9wEQLIR4X82bnK35pxNyz94A1nmbt36hLmk2aHS593iC6D Rd6onva3NN5JQq7F0ANp7Io/AgkSfA6Nu1kj6saTQKsSqZEvLg/osfmjQyaoRNEk+hX1 kvrOZq09AkKmCNCCbjgyQ6f5nyblNGHuMPxZcr5hDLW78tsFUVZRPb+H5cf6uQJXWhJ4 WfcZ7ShRg8L1hAF+3sVk9H4iRBvCwGdEyDE1T1LxK+smcFOoXnhpbvIFRr7Z/1IzgxBQ FmqpTnrcOCkkeYx6AGJCdjniPH2ZMr3mJugxHBXQC8PhpHU7JbA53Q81fZ8jDW5wszCq IsdQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20130820; h=x-gm-message-state:sender:from:to:cc:subject:date:message-id :in-reply-to:references:mime-version:content-transfer-encoding; bh=vt5BfZy7ipsaOTlqFHpc8ST6Y4MipYcqnBqkR25MgSc=; b=g9kpjV8FdGkJ8MeWTGfS0JbsSeChwgnXfb9VxAqad/59vLrb7Z9aU8lOPjzvgZOVAG VUL/tpOlRx2xGdW6Wtz65GaWHwgsJgypcJISJX0hnjxQcBkUF84WQ1BzrcZcafYaV1on o6/mS9QvkCYUKGmyt7ZQ2vu2cErvgiKBlF/AJG5lNl79KF7nbDSdqdhEYYkt1TtxJYRI MYrrNeCaBd5sH6cHYpuBCe8QWHi0Ufuu0aC8Pv/sR7zy6jMcdyhIFoXkrjE8Lz9K2qjo MPJEjAtUWqyF5JPSB1OndbAmQ50+uUDFL/vn/4r8id2on0CPJS3osue+kxkagy+GWIBv Ac1g== X-Gm-Message-State: AA6/9RkzV/INr0GpZssYnEPYRejPw0nEuxIgT6d8eNfSlpjMAYtoxbssJXtt4ag1Oda3hwp7 X-Received: by 10.28.62.73 with SMTP id l70mr9238627wma.133.1476741828400; Mon, 17 Oct 2016 15:03:48 -0700 (PDT) Original-Received: from mpn.zrh.corp.google.com ([172.16.113.135]) by smtp.gmail.com with ESMTPSA id pe5sm56610394wjb.15.2016.10.17.15.03.47 (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Mon, 17 Oct 2016 15:03:47 -0700 (PDT) Original-Received: by mpn.zrh.corp.google.com (Postfix, from userid 126942) id 96D481E02AB; Tue, 18 Oct 2016 00:03:46 +0200 (CEST) X-Mailer: git-send-email 2.8.0.rc3.226.g39d4020 In-Reply-To: <1476741825-32172-1-git-send-email-mina86@mina86.com> X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:124609 Archived-At: 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 . + +;;; 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