aboutsummaryrefslogtreecommitdiffstats
path: root/test
diff options
context:
space:
mode:
Diffstat (limited to 'test')
-rw-r--r--test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el130
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el903
-rw-r--r--test/lisp/emacs-lisp/subr-x-tests.el9
-rw-r--r--test/lisp/files-tests.el20
-rw-r--r--test/lisp/ibuffer-tests.el51
-rw-r--r--test/lisp/net/tramp-tests.el22
-rw-r--r--test/lisp/subr-tests.el6
-rw-r--r--test/lisp/textmodes/css-mode-tests.el21
-rw-r--r--test/lisp/vc/smerge-mode-tests.el34
-rw-r--r--test/lisp/xdg-tests.el3
-rw-r--r--test/src/data-tests.el6
-rw-r--r--test/src/editfns-tests.el8
-rw-r--r--test/src/fileio-tests.el2
-rw-r--r--test/src/lcms-tests.el41
14 files changed, 1211 insertions, 45 deletions
diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el
new file mode 100644
index 00000000000..f52a2b1896c
--- /dev/null
+++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el
@@ -0,0 +1,130 @@
1;;; edebug-test-code.el --- Sample code for the Edebug test suite
2
3;; Copyright (C) 2017 Free Software Foundation, Inc.
4
5;; Author: Gemini Lasswell
6
7;; This file is part of GNU Emacs.
8
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17;; General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with this program. If not, see <https://www.gnu.org/licenses/>.
21
22;;; Commentary:
23
24;; This file contains sample code used by edebug-tests.el.
25;; Before evaluation, it will be preprocessed by
26;; `edebug-tests-setup-code-file' which will remove all tags
27;; between !'s and save their positions for use by the tests.
28
29;;; Code:
30
31(defun edebug-test-code-fac (n)
32 !start!(if !step!(< 0 n)
33 (* n (edebug-test-code-fac (1- n)))!mult!
34 1))
35
36(defun edebug-test-code-concat (a b flag)
37 !start!(if flag!flag!
38 !then-start!(concat a!then-a! b!then-b!)!then-concat!
39 !else-start!(concat b!else-b! a!else-a!)!else-concat!)!if!)
40
41(defun edebug-test-code-range (num)
42 !start!(let ((index 0)
43 (result nil))
44 (while (< index num)!test!
45 (push index result)!loop!
46 (cl-incf index))!end-loop!
47 (nreverse result)))
48
49(defun edebug-test-code-choices (input)
50 !start!(cond
51 ((eq input 0) "zero")
52 ((eq input 7) 42)
53 (t !edebug!(edebug))))
54
55(defvar edebug-test-code-total nil)
56
57(defun edebug-test-code-multiply (times value)
58 !start!(setq edebug-test-code-total 0)
59 (cl-dotimes (index times)
60 (setq edebug-test-code-total (+ edebug-test-code-total value))!setq!)
61 edebug-test-code-total)
62
63(defun edebug-test-code-format-vector-node (node)
64 !start!(concat "["
65 (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply!
66 "]"))
67
68(defun edebug-test-code-format-list-node (node)
69 !start!(concat "{"
70 (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply!
71 "}"))
72
73(defun edebug-test-code-format-node (node)
74 !start!(cond
75 (!vectorp!(vectorp node!vnode!)!vtest! !vbefore!(edebug-test-code-format-vector-node node))
76 ((listp node) (edebug-test-code-format-list-node node))
77 (t (format "%s" node))))
78
79(defvar edebug-test-code-flavor "strawberry")
80
81(defmacro edebug-test-code-with-flavor (new-flavor &rest body)
82 (declare (debug (form body))
83 (indent 1))
84 `(let ((edebug-test-code-flavor ,new-flavor))
85 ,@body))
86
87(defun edebug-test-code-try-flavors ()
88 (let* (tried)
89 (push edebug-test-code-flavor tried)
90 !macro!(edebug-test-code-with-flavor "chocolate"
91 (push edebug-test-code-flavor tried))
92 tried)!end!)
93
94(unless (featurep 'edebug-tests-nutty)!nutty!
95 !setq!(setq edebug-test-code-flavor (car (edebug-test-code-try-flavors)))!end-setq!)!end-unless!
96
97(cl-defgeneric edebug-test-code-emphasize (x))
98(cl-defmethod edebug-test-code-emphasize ((x integer))
99 !start!(format "The number is not %s or %s, but %s!"
100 (1+ x) (1- x) x))
101(cl-defmethod edebug-test-code-emphasize ((x string))
102 !start!(format "***%s***" x))
103
104(defun edebug-test-code-use-methods ()
105 (list
106 !number!(edebug-test-code-emphasize 100)
107 !string!(edebug-test-code-emphasize "yes")))
108
109(defun edebug-test-code-make-lambda (n)
110 (lambda (x) (+ x!x! n)))
111
112(defun edebug-test-code-use-lambda ()
113 !start!(mapcar (edebug-test-code-make-lambda 10) '(1 2 3)))
114
115(defun edebug-test-code-circular-read-syntax ()
116 '(#1=a . #1#))
117
118(defun edebug-test-code-hash-read-syntax ()
119 !start!(list #("abcd" 1 3 (face italic))
120 #x01ff))
121
122(defun edebug-test-code-empty-string-list ()
123 !start!(list "")!step!)
124
125(defun edebug-test-code-current-buffer ()
126 !start!(with-current-buffer (get-buffer-create "*edebug-test-code-buffer*")
127 !body!(format "current-buffer: %s" (current-buffer))))
128
129(provide 'edebug-test-code)
130;;; edebug-test-code.el ends here
diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el
new file mode 100644
index 00000000000..02f4d1c5abe
--- /dev/null
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -0,0 +1,903 @@
1;;; edebug-tests.el --- Edebug test suite -*- lexical-binding:t -*-
2
3;; Copyright (C) 2017 Free Software Foundation, Inc.
4
5;; Author: Gemini Lasswell
6
7;; This file is part of GNU Emacs.
8
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17;; General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with this program. If not, see <https://www.gnu.org/licenses/>.
21
22;;; Commentary:
23
24;; These tests focus on Edebug's user interface for setting
25;; breakpoints, stepping through and tracing code, and evaluating
26;; values used by the code. In addition there are some tests of
27;; Edebug's reader. There are large parts of Edebug's functionality
28;; not covered by these tests, including coverage testing, macro
29;; specifications, and the eval list buffer.
30
31;;; Code:
32
33(require 'cl-lib)
34(require 'ert)
35(require 'ert-x)
36(require 'edebug)
37(require 'kmacro)
38
39;; Use `eval-and-compile' because this is used by the macro
40;; `edebug-tests-deftest'.
41(eval-and-compile
42 (defvar edebug-tests-sample-code-file
43 (expand-file-name
44 "edebug-resources/edebug-test-code.el"
45 (file-name-directory (or (bound-and-true-p byte-compile-current-file)
46 load-file-name
47 buffer-file-name)))
48 "Name of file containing code samples for Edebug tests."))
49
50(defvar edebug-tests-temp-file nil
51 "Name of temp file containing sample code stripped of stop point symbols.")
52(defvar edebug-tests-stop-points nil
53 "An alist of alists mapping function symbol -> stop point name -> marker.
54Used by the tests to refer to locations in `edebug-tests-temp-file'.")
55(defvar edebug-tests-messages nil
56 "Messages collected during execution of the current test.")
57
58(defvar edebug-tests-@-result 'no-result
59 "Return value of `edebug-tests-func', or no-result if there isn't one yet.")
60
61(defvar edebug-tests-failure-in-post-command nil
62 "An error trapped in `edebug-tests-post-command'.
63Since `should' failures which happen inside `post-command-hook' will
64be trapped by the command loop, this preserves them until we get
65back to the top level.")
66
67(defvar edebug-tests-keymap
68 (let ((map (make-sparse-keymap)))
69 (define-key map "@" 'edebug-tests-call-instrumented-func)
70 (define-key map "C-u" 'universal-argument)
71 (define-key map "C-p" 'previous-line)
72 (define-key map "C-n" 'next-line)
73 (define-key map "C-b" 'backward-char)
74 (define-key map "C-a" 'move-beginning-of-line)
75 (define-key map "C-e" 'move-end-of-line)
76 (define-key map "C-k" 'kill-line)
77 (define-key map "M-x" 'execute-extended-command)
78 (define-key map "C-M-x" 'eval-defun)
79 (define-key map "C-x X b" 'edebug-set-breakpoint)
80 (define-key map "C-x X w" 'edebug-where)
81 map)
82 "Keys used by the keyboard macros in Edebug's tests.")
83
84;;; Macros for defining tests:
85
86(defmacro edebug-tests-with-default-config (&rest body)
87 "Create a consistent environment for an Edebug test BODY to run in."
88 (declare (debug (body)))
89 `(cl-letf* (
90 ;; These defcustoms are set to their original value.
91 (edebug-setup-hook nil)
92 (edebug-all-defs nil)
93 (edebug-all-forms nil)
94 (edebug-eval-macro-args nil)
95 (edebug-save-windows t)
96 (edebug-save-displayed-buffer-points nil)
97 (edebug-initial-mode 'step)
98 (edebug-trace nil)
99 (edebug-test-coverage nil)
100 (edebug-print-length 50)
101 (edebug-print-level 50)
102 (edebug-print-circle t)
103 (edebug-unwrap-results nil)
104 (edebug-on-error t)
105 (edebug-on-quit t)
106 (edebug-global-break-condition nil)
107 (edebug-sit-for-seconds 1)
108
109 ;; sit-on interferes with keyboard macros.
110 (edebug-sit-on-break nil)
111 (edebug-continue-kbd-macro t))
112 ,@body))
113
114(defmacro edebug-tests-with-normal-env (&rest body)
115 "Set up the environment for an Edebug test BODY, run it, and clean up."
116 (declare (debug (body)))
117 `(edebug-tests-with-default-config
118 (let ((edebug-tests-failure-in-post-command nil)
119 (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el")))
120 (edebug-tests-setup-code-file edebug-tests-temp-file)
121 (ert-with-message-capture
122 edebug-tests-messages
123 (unwind-protect
124 (with-current-buffer (find-file edebug-tests-temp-file)
125 (read-only-mode)
126 (setq lexical-binding t)
127 (eval-buffer)
128 ,@body
129 (when edebug-tests-failure-in-post-command
130 (signal (car edebug-tests-failure-in-post-command)
131 (cdr edebug-tests-failure-in-post-command))))
132 (unload-feature 'edebug-test-code)
133 (with-current-buffer (find-file-noselect edebug-tests-temp-file)
134 (set-buffer-modified-p nil))
135 (ignore-errors (kill-buffer (find-file-noselect
136 edebug-tests-temp-file)))
137 (ignore-errors (delete-file edebug-tests-temp-file)))))))
138
139;; The following macro and its support functions implement an extension
140;; to keyboard macros to allow interleaving of keyboard macro
141;; events with evaluation of Lisp expressions. The Lisp expressions
142;; are called from within `post-command-hook', which is a strategy
143;; inspired by `kmacro-step-edit-macro'.
144
145;; Some of the details necessary to get this to work with Edebug are:
146;; -- ERT's `should' macros raise errors, and errors within
147;; `post-command-hook' are trapped by the command loop. The
148;; workaround is to trap and save an error inside the hook
149;; function and reraise it after the macro exits.
150;; -- `edebug-continue-kbd-macro' must be non-nil.
151;; -- Edebug calls `exit-recursive-edit' which turns off keyboard
152;; macro execution. Solved with an advice wrapper for
153;; `exit-recursive-edit' which preserves the keyboard macro state.
154
155(defmacro edebug-tests-run-kbd-macro (&rest macro)
156 "Run a MACRO consisting of both keystrokes and test assertions.
157MACRO should be a list, where each item is either a keyboard
158macro segment (in string or vector form) or a Lisp expression.
159Convert the macro segments into keyboard macros and execute them.
160After the execution of the last event of each segment, evaluate
161the Lisp expressions following the segment."
162 (let ((prepared (edebug-tests-prepare-macro macro)))
163 `(edebug-tests-run-macro ,@prepared)))
164
165;; Make support functions for edebug-tests-run-kbd-macro
166;; available at compile time.
167(eval-and-compile
168 (defun edebug-tests-prepare-macro (macro)
169 "Prepare a MACRO for execution.
170MACRO should be a list containing strings, vectors, and Lisp
171forms. Convert the strings and vectors to keyboard macros in
172vector representation and concatenate them to make a single
173keyboard macro. Also build a list of the same length as the
174number of events in the keyboard macro. Each item in that list
175will contain the code to evaluate after the corresponding event
176in the keyboard macro, either nil or a thunk built from the forms
177in the original list. Return a list containing the keyboard
178macro as the first item, followed by the list of thunks and/or
179nils."
180 (cl-loop
181 for item = (pop macro)
182 while item
183 for segment = (read-kbd-macro item)
184 for thunk = (edebug-tests-wrap-thunk
185 (cl-loop
186 for form in macro
187 until (or (stringp form) (vectorp form))
188 collect form
189 do (pop macro)))
190 vconcat segment into segments
191 append (edebug-tests-pad-thunk-list (length segment) thunk)
192 into thunk-list
193
194 finally return (cons segments thunk-list)))
195
196 (defun edebug-tests-wrap-thunk (body)
197 "If BODY is non-nil, wrap it with a lambda form."
198 (when body
199 `(lambda () ,@body)))
200
201 (defun edebug-tests-pad-thunk-list (length thunk)
202 "Return a list with LENGTH elements with THUNK in the last position.
203All other elements will be nil."
204 (let ((thunk-seg (make-list length nil)))
205 (setf (car (last thunk-seg)) thunk)
206 thunk-seg)))
207
208;;; Support for test execution:
209
210(defvar edebug-tests-thunks nil
211 "List containing thunks to run after each command in a keyboard macro.")
212(defvar edebug-tests-kbd-macro-index nil
213 "Index into `edebug-tests-run-unpacked-kbd-macro's current keyboard macro.")
214
215(defun edebug-tests-run-macro (kbdmac &rest thunks)
216 "Run a keyboard macro and execute a thunk after each command in it.
217KBDMAC should be a vector of events and THUNKS a list of the
218same length containing thunks and/or nils. Run the macro, and
219after the execution of every command in the macro (which may not
220be the same as every keystroke) execute the thunk at the same
221index."
222 (let* ((edebug-tests-thunks thunks)
223 (edebug-tests-kbd-macro-index 0)
224 saved-local-map)
225 (with-current-buffer (find-file-noselect edebug-tests-temp-file)
226 (setq saved-local-map overriding-local-map)
227 (setq overriding-local-map edebug-tests-keymap)
228 (add-hook 'post-command-hook 'edebug-tests-post-command))
229 (advice-add 'exit-recursive-edit
230 :around 'edebug-tests-preserve-keyboard-macro-state)
231 (unwind-protect
232 (kmacro-call-macro nil nil nil kbdmac)
233 (advice-remove 'exit-recursive-edit
234 'edebug-tests-preserve-keyboard-macro-state)
235 (with-current-buffer (find-file-noselect edebug-tests-temp-file)
236 (setq overriding-local-map saved-local-map)
237 (remove-hook 'post-command-hook 'edebug-tests-post-command)))))
238
239(defun edebug-tests-preserve-keyboard-macro-state (orig &rest args)
240 "Call ORIG with ARGS preserving the value of `executing-kbd-macro'.
241Useful to prevent `exit-recursive-edit' from stopping the current
242keyboard macro."
243 (let ((executing-kbd-macro executing-kbd-macro))
244 (apply orig args)))
245
246(defun edebug-tests-post-command ()
247 "Run the thunk from `edebug-tests-thunks' matching the keyboard macro index."
248 (when (and edebug-tests-kbd-macro-index
249 (> executing-kbd-macro-index edebug-tests-kbd-macro-index))
250 (let ((thunk (nth (1- executing-kbd-macro-index) edebug-tests-thunks)))
251 (when thunk
252 (condition-case err
253 (funcall thunk)
254 (error
255 (setq edebug-tests-failure-in-post-command err)
256 (signal (car err) (cdr err)))))
257 (setq edebug-tests-kbd-macro-index executing-kbd-macro-index))))
258
259(defvar edebug-tests-func nil
260 "Instrumented function used to launch Edebug.")
261(defvar edebug-tests-args nil
262 "Arguments for `edebug-tests-func'.")
263
264(defun edebug-tests-setup-@ (def-name args edebug-it)
265 "Set up the binding for @ in `edebug-tests-keymap'.
266Find a definition for DEF-NAME in the current buffer and evaluate it.
267Set globals so that `edebug-tests-call-instrumented-func' which
268is bound to @ for edebug-tests' keyboard macros will call it with
269ARGS. EDEBUG-IT is passed through to `eval-defun'."
270 (edebug-tests-locate-def def-name)
271 (eval-defun edebug-it)
272 (let* ((full-name (concat "edebug-test-code-" def-name))
273 (sym (intern-soft full-name)))
274 (should (and sym (fboundp sym)))
275 (setq edebug-tests-func sym
276 edebug-tests-args args)
277 (setq edebug-tests-@-result 'no-result)))
278
279(defun edebug-tests-call-instrumented-func ()
280 "Call `edebug-tests-func' with `edebug-tests-args' and save the results."
281 (interactive)
282 (let ((result (apply edebug-tests-func edebug-tests-args)))
283 (should (eq edebug-tests-@-result 'no-result))
284 (setq edebug-tests-@-result result)))
285
286(defun edebug-tests-should-be-at (def-name point-name)
287 "Require that point be at the location in DEF-NAME named POINT-NAME.
288DEF-NAME should be the suffix of a definition in the code samples
289file (the part after \"edebug-tests\")."
290 (let ((stop-point (edebug-tests-get-stop-point def-name point-name)))
291 (should (eq (current-buffer) (find-file-noselect edebug-tests-temp-file)))
292 (should (eql (point) stop-point))))
293
294(defun edebug-tests-get-stop-point (def-name point-name)
295 "Return the position in DEF-NAME of the stop point named POINT-NAME.
296DEF-NAME should be the suffix of a definition in the code samples
297file (the part after \"edebug-tests\")."
298 (let* ((full-name (concat "edebug-test-code-" def-name))(stop-point
299 (cdr (assoc point-name
300 (cdr (assoc full-name edebug-tests-stop-points))))))
301 (unless stop-point
302 (ert-fail (format "%s not found in %s" point-name full-name)))
303 stop-point))
304
305(defun edebug-tests-should-match-result-in-messages (value)
306 "Require that VALUE (a string) match an Edebug result in *Messages*.
307Then clear edebug-tests' saved messages."
308 (should (string-match-p (concat "Result: " (regexp-quote value) "$")
309 edebug-tests-messages))
310 (setq edebug-tests-messages ""))
311
312(defun edebug-tests-locate-def (def-name)
313 "Search for a definition of DEF-NAME from the start of the current buffer.
314Place point at the end of DEF-NAME in the buffer."
315 (goto-char (point-min))
316 (re-search-forward (concat "def\\S-+ edebug-test-code-" def-name)))
317
318(defconst edebug-tests-start-of-next-def-regexp "^(\\S-*def\\S-+ \\(\\S-+\\)"
319 "Regexp used to match the start of a definition.")
320(defconst edebug-tests-stop-point-regexp "!\\(\\S-+?\\)!"
321 "Regexp used to match a stop point annotation in the sample code.")
322
323;;; Set up buffer containing code samples:
324
325(defmacro edebug-tests-deduplicate (name names-and-numbers)
326 "Return a unique variation on NAME.
327NAME should be a string and NAMES-AND-NUMBERS an alist which can
328be used by this macro to retain state. If NAME for example is
329\"symbol\" then the first and subsequent uses of this macro will
330evaluate to \"symbol\", \"symbol-1\", \"symbol-2\", etc."
331 (let ((g-name (gensym))
332 (g-duplicate (gensym)))
333 `(let* ((,g-name ,name)
334 (,g-duplicate (assoc ,g-name ,names-and-numbers)))
335 (if (null ,g-duplicate)
336 (progn
337 (push (cons ,g-name 0) ,names-and-numbers)
338 ,g-name)
339 (cl-incf (cdr ,g-duplicate))
340 (format "%s-%s" ,g-name (cdr ,g-duplicate))))))
341
342(defun edebug-tests-setup-code-file (tmpfile)
343 "Extract stop points and loadable code from the sample code file.
344Write the loadable code to a buffer for TMPFILE, and set
345`edebug-tests-stop-points' to a map from defined symbols to stop
346point names to positions in the file."
347 (with-current-buffer (find-file-noselect edebug-tests-sample-code-file)
348 (let ((marked-up-code (buffer-string)))
349 (with-temp-file tmpfile
350 (insert marked-up-code))))
351
352 (with-current-buffer (find-file-noselect tmpfile)
353 (let ((stop-points
354 ;; Delete all the !name! annotations from the code, but remember
355 ;; their names and where they were in an alist.
356 (cl-loop
357 initially (goto-char (point-min))
358 while (re-search-forward edebug-tests-stop-point-regexp nil t)
359 for name = (match-string-no-properties 1)
360 do (replace-match "")
361 collect (cons name (point))))
362 names-and-numbers)
363
364 ;; Now build an alist mapping definition names to annotation
365 ;; names and positions.
366 ;; If duplicate symbols exist in the file, enter them in the
367 ;; alist as symbol, symbol-1, symbol-2 etc.
368 (setq edebug-tests-stop-points
369 (cl-loop
370 initially (goto-char (point-min))
371 while (re-search-forward edebug-tests-start-of-next-def-regexp
372 nil t)
373 for name =
374 (edebug-tests-deduplicate (match-string-no-properties 1)
375 names-and-numbers)
376 for end-of-def =
377 (save-match-data
378 (save-excursion
379 (re-search-forward edebug-tests-start-of-next-def-regexp
380 nil 0)
381 (point)))
382 collect (cons name
383 (cl-loop
384 while (and stop-points
385 (< (cdar stop-points) end-of-def))
386 collect (pop stop-points))))))))
387
388;;; Tests
389
390(ert-deftest edebug-tests-check-keymap ()
391 "Verify that `edebug-mode-map' is compatible with these tests.
392If this test fails, one of two things is true. Either your
393customizations modify `edebug-mode-map', in which case starting
394Emacs with the -Q flag should fix the problem, or
395`edebug-mode-map' has changed in edebug.el, in which case this
396test and possibly others should be updated."
397 ;; The reason verify-keybinding is a macro instead of a function is
398 ;; that in the event of a failure, it makes the keybinding that
399 ;; failed show up in ERT's output.
400 (cl-macrolet ((verify-keybinding (key binding)
401 `(should (eq (lookup-key edebug-mode-map ,key)
402 ,binding))))
403 (verify-keybinding " " 'edebug-step-mode)
404 (verify-keybinding "n" 'edebug-next-mode)
405 (verify-keybinding "g" 'edebug-go-mode)
406 (verify-keybinding "G" 'edebug-Go-nonstop-mode)
407 (verify-keybinding "t" 'edebug-trace-mode)
408 (verify-keybinding "T" 'edebug-Trace-fast-mode)
409 (verify-keybinding "c" 'edebug-continue-mode)
410 (verify-keybinding "C" 'edebug-Continue-fast-mode)
411 (verify-keybinding "f" 'edebug-forward-sexp)
412 (verify-keybinding "h" 'edebug-goto-here)
413 (verify-keybinding "I" 'edebug-instrument-callee)
414 (verify-keybinding "i" 'edebug-step-in)
415 (verify-keybinding "o" 'edebug-step-out)
416 (verify-keybinding "q" 'top-level)
417 (verify-keybinding "Q" 'edebug-top-level-nonstop)
418 (verify-keybinding "a" 'abort-recursive-edit)
419 (verify-keybinding "S" 'edebug-stop)
420 (verify-keybinding "b" 'edebug-set-breakpoint)
421 (verify-keybinding "u" 'edebug-unset-breakpoint)
422 (verify-keybinding "B" 'edebug-next-breakpoint)
423 (verify-keybinding "x" 'edebug-set-conditional-breakpoint)
424 (verify-keybinding "X" 'edebug-set-global-break-condition)
425 (verify-keybinding "r" 'edebug-previous-result)
426 (verify-keybinding "e" 'edebug-eval-expression)
427 (verify-keybinding "\C-x\C-e" 'edebug-eval-last-sexp)
428 (verify-keybinding "E" 'edebug-visit-eval-list)
429 (verify-keybinding "w" 'edebug-where)
430 (verify-keybinding "v" 'edebug-view-outside) ;; maybe obsolete??
431 (verify-keybinding "p" 'edebug-bounce-point)
432 (verify-keybinding "P" 'edebug-view-outside) ;; same as v
433 (verify-keybinding "W" 'edebug-toggle-save-windows)
434 (verify-keybinding "?" 'edebug-help)
435 (verify-keybinding "d" 'edebug-backtrace)
436 (verify-keybinding "-" 'negative-argument)
437 (verify-keybinding "=" 'edebug-temp-display-freq-count)))
438
439(ert-deftest edebug-tests-stop-point-at-start-of-first-instrumented-function ()
440 "Edebug stops at the beginning of an instrumented function."
441 (edebug-tests-with-normal-env
442 (edebug-tests-setup-@ "fac" '(0) t)
443 (edebug-tests-run-kbd-macro
444 "@" (edebug-tests-should-be-at "fac" "start")
445 "SPC" (edebug-tests-should-be-at "fac" "step")
446 "g" (should (equal edebug-tests-@-result 1)))))
447
448(ert-deftest edebug-tests-step-showing-evaluation-results ()
449 "Edebug prints expression evaluation results to the echo area."
450 (edebug-tests-with-normal-env
451 (edebug-tests-setup-@ "concat" '("x" "y" nil) t)
452 (edebug-tests-run-kbd-macro
453 "@" (edebug-tests-should-be-at "concat" "start")
454 "SPC" (edebug-tests-should-be-at "concat" "flag")
455 (edebug-tests-should-match-result-in-messages "nil")
456 "SPC" (edebug-tests-should-be-at "concat" "else-start")
457 "SPC" (edebug-tests-should-be-at "concat" "else-b")
458 (edebug-tests-should-match-result-in-messages "\"y\"")
459 "SPC" (edebug-tests-should-be-at "concat" "else-a")
460 (edebug-tests-should-match-result-in-messages "\"x\"")
461 "SPC" (edebug-tests-should-be-at "concat" "else-concat")
462 (edebug-tests-should-match-result-in-messages "\"yx\"")
463 "SPC" (edebug-tests-should-be-at "concat" "if")
464 (edebug-tests-should-match-result-in-messages "\"yx\"")
465 "SPC" (should (equal edebug-tests-@-result "yx")))))
466
467(ert-deftest edebug-tests-set-breakpoint-at-point ()
468 "Edebug can set a breakpoint at point."
469 (edebug-tests-with-normal-env
470 (edebug-tests-setup-@ "concat" '("x" "y" t) t)
471 (edebug-tests-run-kbd-macro
472 "@" (edebug-tests-should-be-at "concat" "start")
473 "C-n C-e b C-n" ; Move down, set a breakpoint and move away.
474 "g" (edebug-tests-should-be-at "concat" "then-concat")
475 (edebug-tests-should-match-result-in-messages "\"xy\"")
476 "g" (should (equal edebug-tests-@-result "xy")))))
477
478(ert-deftest edebug-tests-set-temporary-breakpoint-at-point ()
479 "Edebug can set a temporary breakpoint at point."
480 (edebug-tests-with-normal-env
481 (edebug-tests-setup-@ "range" '(3) t)
482 (edebug-tests-run-kbd-macro
483 "@" (edebug-tests-should-be-at "range" "start")
484 "C-n C-n C-n C-e" ; Move down to the end of a sexp in the loop.
485 "C-u b" ; Set a temporary breakpoint.
486 "C-n" ; Move away.
487 "g" (edebug-tests-should-be-at "range" "loop")
488 (edebug-tests-should-match-result-in-messages "(0)")
489 "g" (should (equal edebug-tests-@-result '(0 1 2))))))
490
491(ert-deftest edebug-tests-clear-breakpoint ()
492 "Edebug can clear a breakpoint."
493 (edebug-tests-with-normal-env
494 (edebug-tests-setup-@ "range" '(3) t)
495 (edebug-tests-run-kbd-macro
496 "@"
497 (message "after @")
498 (edebug-tests-should-be-at "range" "start")
499 "C-n C-n C-n C-e b C-n" ; Move down, set a breakpoint and move away.
500 "g" (edebug-tests-should-be-at "range" "loop")
501 (edebug-tests-should-match-result-in-messages "(0)")
502 "g" (edebug-tests-should-be-at "range" "loop")
503 (edebug-tests-should-match-result-in-messages "(1 0)")
504 "u" ; Unset the breakpoint.
505 "g" (should (equal edebug-tests-@-result '(0 1 2))))))
506
507(ert-deftest edebug-tests-move-point-to-next-breakpoint ()
508 "Edebug can move point to the next breakpoint."
509 (edebug-tests-with-normal-env
510 (edebug-tests-setup-@ "concat" '("a" "b" nil) t)
511 (edebug-tests-run-kbd-macro
512 "@" (edebug-tests-should-be-at "concat" "start")
513 "C-n C-e b" ; Move down, set a breakpoint.
514 "C-n b" ; Set another breakpoint on the next line.
515 "C-p C-p C-p" ; Move back up.
516 "B" (edebug-tests-should-be-at "concat" "then-concat")
517 "B" (edebug-tests-should-be-at "concat" "else-concat")
518 "G" (should (equal edebug-tests-@-result "ba")))))
519
520(ert-deftest edebug-tests-move-point-back-to-stop-point ()
521 "Edebug can move point back to a stop point."
522 (edebug-tests-with-normal-env
523 (let ((test-buffer (get-buffer-create "edebug-tests-temp")))
524 (edebug-tests-setup-@ "fac" '(4) t)
525 (edebug-tests-run-kbd-macro
526 "@" (edebug-tests-should-be-at "fac" "start")
527 "C-n w" (edebug-tests-should-be-at "fac" "start")
528 (pop-to-buffer test-buffer)
529 "C-x X w" (edebug-tests-should-be-at "fac" "start")
530 "g" (should (equal edebug-tests-@-result 24)))
531 (ignore-errors (kill-buffer test-buffer)))))
532
533(ert-deftest edebug-tests-jump-to-point ()
534 "Edebug can stop at a temporary breakpoint at point."
535 (edebug-tests-with-normal-env
536 (edebug-tests-setup-@ "range" '(3) t)
537 (edebug-tests-run-kbd-macro
538 "@" (edebug-tests-should-be-at "range" "start")
539 "C-n C-n C-n C-e" ; Move down to the end of a sexp in the loop.
540 "h" (edebug-tests-should-be-at "range" "loop")
541 (edebug-tests-should-match-result-in-messages "(0)")
542 "g" (should (equal edebug-tests-@-result '(0 1 2))))))
543
544(ert-deftest edebug-tests-jump-forward-one-sexp ()
545 "Edebug can run the program for one expression."
546 (edebug-tests-with-normal-env
547 (edebug-tests-setup-@ "range" '(3) t)
548 (edebug-tests-run-kbd-macro
549 "@" (edebug-tests-should-be-at "range" "start")
550 "SPC SPC f" (edebug-tests-should-be-at "range" "test")
551 "g" (should (equal edebug-tests-@-result '(0 1 2))))))
552
553(ert-deftest edebug-tests-run-out-of-containing-sexp ()
554 "Edebug can run the program until the end of the containing sexp."
555 (edebug-tests-with-normal-env
556 (edebug-tests-setup-@ "range" '(3) t)
557 (edebug-tests-run-kbd-macro
558 "@" (edebug-tests-should-be-at "range" "start")
559 "SPC SPC f" (edebug-tests-should-be-at "range" "test")
560 "o" (edebug-tests-should-be-at "range" "end-loop")
561 (edebug-tests-should-match-result-in-messages "nil")
562 "g" (should (equal edebug-tests-@-result '(0 1 2))))))
563
564(ert-deftest edebug-tests-observe-breakpoint-in-source ()
565 "Edebug will stop at a breakpoint embedded in source code."
566 (edebug-tests-with-normal-env
567 (edebug-tests-setup-@ "choices" '(8) t)
568 (edebug-tests-run-kbd-macro
569 "@" (edebug-tests-should-be-at "choices" "start")
570 "g" (edebug-tests-should-be-at "choices" "edebug")
571 "g" (should (equal edebug-tests-@-result nil)))))
572
573(ert-deftest edebug-tests-set-conditional-breakpoint ()
574 "Edebug can set and observe a conditional breakpoint."
575 (edebug-tests-with-normal-env
576 (edebug-tests-setup-@ "fac" '(5) t)
577 (edebug-tests-run-kbd-macro
578 "@" (edebug-tests-should-be-at "fac" "start")
579 ;; Set conditional breakpoint at end of next line.
580 "C-n C-e x (eql SPC n SPC 3) RET"
581 "g" (edebug-tests-should-be-at "fac" "mult")
582 (edebug-tests-should-match-result-in-messages "6 (#o6, #x6, ?\\C-f)")
583 "g" (should (equal edebug-tests-@-result 120)))))
584
585(ert-deftest edebug-tests-error-trying-to-set-breakpoint-in-uninstrumented-code
586 ()
587 "Edebug refuses to set a breakpoint in uninstrumented code."
588 (edebug-tests-with-normal-env
589 (edebug-tests-setup-@ "fac" '(5) t)
590 (let* ((debug-on-error nil)
591 (edebug-on-error nil)
592 error-message
593 (command-error-function (lambda (&rest args)
594 (setq error-message (cadar args)))))
595 (edebug-tests-run-kbd-macro
596 "@" (edebug-tests-should-be-at "fac" "start")
597 "C-u 10 C-n" ; Move down and out of instrumented function.
598 "b" (should (string-match-p "Not inside instrumented form"
599 error-message))
600 ;; The error stopped the keyboard macro. Start it again.
601 (should-not executing-kbd-macro)
602 (setq executing-kbd-macro t)
603 "g"))))
604
605(ert-deftest edebug-tests-set-and-break-on-global-condition ()
606 "Edebug can break when a global condition becomes true."
607 (edebug-tests-with-normal-env
608 (edebug-tests-setup-@ "multiply" '(5 3) t)
609 (edebug-tests-run-kbd-macro
610 "@" (edebug-tests-should-be-at "multiply" "start")
611 "X (> SPC edebug-test-code-total SPC 10) RET"
612 (should edebug-global-break-condition)
613 "g" (edebug-tests-should-be-at "multiply" "setq")
614 (should (eql (symbol-value 'edebug-test-code-total) 12))
615 "X C-a C-k nil RET" ; Remove suggestion before entering nil.
616 "g" (should (equal edebug-tests-@-result 15)))))
617
618(ert-deftest edebug-tests-trace-showing-results-at-stop-points ()
619 "Edebug can trace execution, showing results at stop points."
620 (edebug-tests-with-normal-env
621 (edebug-tests-setup-@ "concat" '("x" "y" nil) t)
622 (edebug-tests-run-kbd-macro
623 "@" (edebug-tests-should-be-at "concat" "start")
624 "T" (should (string-match-p
625 (concat "Result: nil\n.*?"
626 "Result: \"y\"\n.*?"
627 "Result: \"x\"\n.*?"
628 "Result: \"yx\"\n.*?"
629 "Result: \"yx\"\n")
630 edebug-tests-messages))
631 (should (equal edebug-tests-@-result "yx")))))
632
633(ert-deftest edebug-tests-trace-showing-results-at-breakpoints ()
634 "Edebug can trace execution, showing results at breakpoints."
635 (edebug-tests-with-normal-env
636 (edebug-tests-locate-def "format-vector-node")
637 (edebug-tests-run-kbd-macro "C-u C-M-x C-n C-n C-e C-x X b")
638 (edebug-tests-locate-def "format-list-node")
639 (edebug-tests-run-kbd-macro "C-u C-M-x C-n C-n C-e C-x X b")
640 (edebug-tests-setup-@ "format-node" '(([a b] [c d])) t)
641 (edebug-tests-run-kbd-macro
642 "@" (edebug-tests-should-be-at "format-node" "start")
643 "C" (should (string-match-p
644 (concat "Result: \"ab\"\n.*?"
645 "Result: \"cd\"\n.*?"
646 "Result: \"\\[ab]\\[cd]\"\n")
647 edebug-tests-messages))
648 (should (equal edebug-tests-@-result "{[ab][cd]}")))))
649
650(ert-deftest edebug-tests-trace-function-call-and-return ()
651 "Edebug can create a trace of function calls and returns."
652 (edebug-tests-with-normal-env
653 (edebug-tests-locate-def "format-vector-node")
654 (eval-defun t)
655 (edebug-tests-locate-def "format-list-node")
656 (eval-defun t)
657 (edebug-tests-setup-@ "format-node" '((a [b])) t)
658 (let ((edebug-trace t)
659 (trace-start (with-current-buffer
660 (get-buffer-create edebug-trace-buffer) (point-max))))
661 (edebug-tests-run-kbd-macro
662 "@" (edebug-tests-should-be-at "format-node" "start")
663 "g" (should (equal edebug-tests-@-result "{a[b]}")))
664 (with-current-buffer edebug-trace-buffer
665 (should (string=
666 "{ edebug-test-code-format-node args: ((a [b]))
667:{ edebug-test-code-format-list-node args: ((a [b]))
668::{ edebug-test-code-format-node args: (a)
669::} edebug-test-code-format-node result: a
670::{ edebug-test-code-format-node args: ([b])
671:::{ edebug-test-code-format-vector-node args: ([b])
672::::{ edebug-test-code-format-node args: (b)
673::::} edebug-test-code-format-node result: b
674:::} edebug-test-code-format-vector-node result: [b]
675::} edebug-test-code-format-node result: [b]
676:} edebug-test-code-format-list-node result: {a[b]}
677} edebug-test-code-format-node result: {a[b]}
678" (buffer-substring trace-start (point-max))))))))
679
680(ert-deftest edebug-tests-evaluate-expressions ()
681 "Edebug can evaluate an expression in the context outside of itself."
682 (edebug-tests-with-normal-env
683 (edebug-tests-setup-@ "range" '(2) t)
684 (edebug-tests-run-kbd-macro
685 "@" (edebug-tests-should-be-at "range" "start")
686 "SPC SPC f" (edebug-tests-should-be-at "range" "test")
687 (edebug-tests-should-match-result-in-messages "t")
688 "e (- SPC num SPC index) RET"
689 ;; Edebug just prints the result without "Result:"
690 (should (string-match-p
691 (regexp-quote "2 (#o2, #x2, ?\\C-b)")
692 edebug-tests-messages))
693 "g" (should (equal edebug-tests-@-result '(0 1))))
694
695 ;; Do it again with lexical-binding turned off.
696 (setq lexical-binding nil)
697 (eval-buffer)
698 (should-not lexical-binding)
699 (edebug-tests-setup-@ "range" '(2) t)
700 (edebug-tests-run-kbd-macro
701 "@" (edebug-tests-should-be-at "range" "start")
702 "SPC SPC f" (edebug-tests-should-be-at "range" "test")
703 (edebug-tests-should-match-result-in-messages "t")
704 "e (- SPC num SPC index) RET"
705 ;; Edebug just prints the result without "Result:"
706 (should (string-match-p
707 (regexp-quote "2 (#o2, #x2, ?\\C-b)")
708 edebug-tests-messages))
709 "g" (should (equal edebug-tests-@-result '(0 1))))))
710
711(ert-deftest edebug-tests-step-into-function ()
712 "Edebug can step into a function."
713 (edebug-tests-with-normal-env
714 (edebug-tests-setup-@ "format-node" '([b]) t)
715 (edebug-tests-run-kbd-macro
716 "@" (edebug-tests-should-be-at "format-node" "start")
717 "SPC SPC SPC SPC"
718 (edebug-tests-should-be-at "format-node" "vbefore")
719 "i" (edebug-tests-should-be-at "format-vector-node" "start")
720 "g" (should (equal edebug-tests-@-result "[b]")))))
721
722(ert-deftest edebug-tests-error-stepping-into-subr ()
723 "Edebug refuses to step into a C function."
724 (edebug-tests-with-normal-env
725 (edebug-tests-setup-@ "format-node" '([b]) t)
726 (let* ((debug-on-error nil)
727 (edebug-on-error nil)
728 error-message
729 (command-error-function (lambda (&rest args)
730 (setq error-message (cl-cadar args)))))
731 (edebug-tests-run-kbd-macro
732 "@" (edebug-tests-should-be-at "format-node" "start")
733 "SPC" (edebug-tests-should-be-at "format-node" "vectorp")
734 "i" (should (string-match-p "vectorp is a built-in function"
735 error-message))
736 ;; The error stopped the keyboard macro. Start it again.
737 (should-not executing-kbd-macro)
738 (setq executing-kbd-macro t)
739 "g" (should (equal edebug-tests-@-result "[b]"))))))
740
741(ert-deftest edebug-tests-step-into-macro-error ()
742 "Edebug gives an error on trying to step into a macro (Bug#26847)."
743 :expected-result :failed
744 (ert-fail "Forcing failure because letting this test run aborts the others.")
745 (edebug-tests-with-normal-env
746 (edebug-tests-setup-@ "try-flavors" nil t)
747 (let* ((debug-on-error nil)
748 (edebug-on-error nil)
749 (error-message "")
750 (command-error-function (lambda (&rest args)
751 (setq error-message (cl-cadar args)))))
752 (edebug-tests-run-kbd-macro
753 "@ SPC SPC SPC SPC SPC"
754 (edebug-tests-should-be-at "try-flavors" "macro")
755 "i" (should (string-match-p "edebug-test-code-try-flavors is a macro"
756 error-message))
757 ;; The error stopped the keyboard macro. Start it again.
758 (should-not executing-kbd-macro)
759 (setq executing-kbd-macro t)
760 "g" (should (equal edebug-tests-@-result
761 '("chocolate" "strawberry")))))))
762
763(ert-deftest edebug-tests-step-into-generic-method ()
764 "Edebug can step into a generic method (Bug#22294)."
765 (edebug-tests-with-normal-env
766 (edebug-tests-setup-@ "use-methods" nil t)
767 (edebug-tests-run-kbd-macro
768 "@ SPC" (edebug-tests-should-be-at "use-methods" "number")
769 "i" (edebug-tests-should-be-at "emphasize-1" "start")
770 "gg" (should (equal edebug-tests-@-result
771 '("The number is not 101 or 99, but 100!"
772 "***yes***"))))))
773
774(ert-deftest edebug-tests-break-in-lambda-out-of-defining-context ()
775 "Edebug observes a breakpoint in a lambda executed out of defining context."
776 (edebug-tests-with-normal-env
777 (edebug-tests-locate-def "make-lambda")
778 (eval-defun t)
779 (goto-char (edebug-tests-get-stop-point "make-lambda" "x"))
780 (edebug-set-breakpoint t)
781 (edebug-tests-setup-@ "use-lambda" nil t)
782 (edebug-tests-run-kbd-macro
783 "@g" (edebug-tests-should-be-at "make-lambda" "x")
784 (edebug-tests-should-match-result-in-messages "1 (#o1, #x1, ?\\C-a)")
785 "g" (should (equal edebug-tests-@-result '(11 12 13))))))
786
787(ert-deftest edebug-tests-respects-initial-mode ()
788 "Edebug can stop first at breakpoint instead of first instrumented function."
789 (edebug-tests-with-normal-env
790 (edebug-tests-setup-@ "fac" '(4) t)
791 (goto-char (edebug-tests-get-stop-point "fac" "mult"))
792 (edebug-set-breakpoint t)
793 (setq edebug-initial-mode 'go)
794 (edebug-tests-run-kbd-macro
795 "@" (edebug-tests-should-be-at "fac" "mult")
796 (edebug-tests-should-match-result-in-messages "1 (#o1, #x1, ?\\C-a)")
797 "G" (should (equal edebug-tests-@-result 24)))))
798
799(ert-deftest edebug-tests-step-through-non-definition ()
800 "Edebug can step through a non-defining form."
801 (edebug-tests-with-normal-env
802 (goto-char (edebug-tests-get-stop-point "try-flavors" "end-unless"))
803 (edebug-tests-run-kbd-macro
804 "C-u C-M-x"
805 "SPC SPC" (edebug-tests-should-be-at "try-flavors" "nutty")
806 (edebug-tests-should-match-result-in-messages "nil")
807 "SPC" (edebug-tests-should-be-at "try-flavors" "setq")
808 "f" (edebug-tests-should-be-at "try-flavors" "end-setq")
809 (edebug-tests-should-match-result-in-messages "\"chocolate\"")
810 "g")))
811
812(ert-deftest edebug-tests-conditional-breakpoints-can-use-lexical-variables ()
813 "Edebug can set a conditional breakpoint using a lexical variable. Bug#12685"
814 (edebug-tests-with-normal-env
815 (should lexical-binding)
816 (edebug-tests-setup-@ "fac" '(5) t)
817 (edebug-tests-run-kbd-macro
818 "@" (edebug-tests-should-be-at "fac" "start")
819 ;; Set conditional breakpoint at end of next line.
820 "C-n C-e x (eql SPC n SPC 3) RET"
821 "g" (edebug-tests-should-be-at "fac" "mult")
822 (edebug-tests-should-match-result-in-messages
823 "6 (#o6, #x6, ?\\C-f)"))))
824
825(ert-deftest edebug-tests-writable-buffer-state-is-preserved ()
826 "On Edebug exit writable buffers are still writable (Bug#14144)."
827 (edebug-tests-with-normal-env
828 (edebug-tests-setup-@ "choices" '(0) t)
829 (read-only-mode -1)
830 (edebug-tests-run-kbd-macro
831 "@g" (should (equal edebug-tests-@-result "zero")))
832 (barf-if-buffer-read-only)))
833
834(ert-deftest edebug-tests-list-containing-empty-string-result-printing ()
835 "Edebug correctly prints a list containing only an empty string (Bug#17934)."
836 (edebug-tests-with-normal-env
837 (edebug-tests-setup-@ "empty-string-list" nil t)
838 (edebug-tests-run-kbd-macro
839 "@ SPC" (edebug-tests-should-be-at
840 "empty-string-list" "step")
841 (edebug-tests-should-match-result-in-messages "(\"\")")
842 "g")))
843
844(ert-deftest edebug-tests-evaluation-of-current-buffer-bug-19611 ()
845 "Edebug can evaluate `current-buffer' in correct context. (Bug#19611)."
846 (edebug-tests-with-normal-env
847 (edebug-tests-setup-@ "current-buffer" nil t)
848 (edebug-tests-run-kbd-macro
849 "@" (edebug-tests-should-be-at
850 "current-buffer" "start")
851 "SPC SPC SPC" (edebug-tests-should-be-at
852 "current-buffer" "body")
853 "e (current-buffer) RET"
854 ;; Edebug just prints the result without "Result:"
855 (should (string-match-p
856 (regexp-quote "*edebug-test-code-buffer*")
857 edebug-tests-messages))
858 "g" (should (equal edebug-tests-@-result
859 "current-buffer: *edebug-test-code-buffer*")))))
860
861(ert-deftest edebug-tests-trivial-backquote ()
862 "Edebug can instrument a trivial backquote expression (Bug#23651)."
863 (edebug-tests-with-normal-env
864 (read-only-mode -1)
865 (delete-region (point-min) (point-max))
866 (insert "`1")
867 (read-only-mode)
868 (edebug-eval-defun nil)
869 (should (string-match-p (regexp-quote "1 (#o1, #x1, ?\\C-a)")
870 edebug-tests-messages))
871 (setq edebug-tests-messages "")
872
873 (setq edebug-initial-mode 'go)
874 ;; In Bug#23651 Edebug would hang reading `1.
875 (edebug-eval-defun t)))
876
877(ert-deftest edebug-tests-trivial-comma ()
878 "Edebug can read a trivial comma expression (Bug#23651)."
879 (edebug-tests-with-normal-env
880 (read-only-mode -1)
881 (delete-region (point-min) (point-max))
882 (insert ",1")
883 (read-only-mode)
884 (should-error (edebug-eval-defun t))))
885
886(ert-deftest edebug-tests-circular-read-syntax ()
887 "Edebug can instrument code using circular read object syntax (Bug#23660)."
888 (edebug-tests-with-normal-env
889 (edebug-tests-setup-@ "circular-read-syntax" nil t)
890 (edebug-tests-run-kbd-macro
891 "@" (should (eql (car edebug-tests-@-result)
892 (cdr edebug-tests-@-result))))))
893
894(ert-deftest edebug-tests-hash-read-syntax ()
895 "Edebug can instrument code which uses # read syntax (Bug#25068)."
896 (edebug-tests-with-normal-env
897 (edebug-tests-setup-@ "hash-read-syntax" nil t)
898 (edebug-tests-run-kbd-macro
899 "@g" (should (equal edebug-tests-@-result
900 '(#("abcd" 1 3 (face italic)) 511))))))
901
902(provide 'edebug-tests)
903;;; edebug-tests.el ends here
diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el
index 2c6740a96cf..0e8871d9a9c 100644
--- a/test/lisp/emacs-lisp/subr-x-tests.el
+++ b/test/lisp/emacs-lisp/subr-x-tests.el
@@ -397,9 +397,14 @@
397 (should (equal 1 (let ((x 1)) (and-let* (x))))) 397 (should (equal 1 (let ((x 1)) (and-let* (x)))))
398 (should (equal nil (and-let* ((x nil))))) 398 (should (equal nil (and-let* ((x nil)))))
399 (should (equal 1 (and-let* ((x 1))))) 399 (should (equal 1 (and-let* ((x 1)))))
400 (should-error (and-let* (nil (x 1))) :type 'setting-constant) 400 ;; The error doesn't trigger when compiled: the compiler will give
401 ;; a warning and then drop the erroneous code. Therefore, use
402 ;; `eval' to avoid compilation.
403 (should-error (eval '(and-let* (nil (x 1))) lexical-binding)
404 :type 'setting-constant)
401 (should (equal nil (and-let* ((nil) (x 1))))) 405 (should (equal nil (and-let* ((nil) (x 1)))))
402 (should-error (and-let* (2 (x 1))) :type 'wrong-type-argument) 406 (should-error (eval (and-let* (2 (x 1))) lexical-binding)
407 :type 'wrong-type-argument)
403 (should (equal 1 (and-let* ((2) (x 1))))) 408 (should (equal 1 (and-let* ((2) (x 1)))))
404 (should (equal 2 (and-let* ((x 1) (2))))) 409 (should (equal 2 (and-let* ((x 1) (2)))))
405 (should (equal nil (let ((x nil)) (and-let* (x) x)))) 410 (should (equal nil (let ((x nil)) (and-let* (x) x))))
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index ef216c3f34a..285a884b695 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -363,7 +363,8 @@ be invoked with the right arguments."
363 (should-not (make-directory subdir1)) 363 (should-not (make-directory subdir1))
364 (should-not (make-directory subdir2 t)) 364 (should-not (make-directory subdir2 t))
365 (should-error (make-directory a/b)) 365 (should-error (make-directory a/b))
366 (should-not (make-directory a/b t)))) 366 (should-not (make-directory a/b t))
367 (delete-directory dir 'recursive)))
367 368
368(ert-deftest files-test-no-file-write-contents () 369(ert-deftest files-test-no-file-write-contents ()
369 "Test that `write-contents-functions' permits saving a file. 370 "Test that `write-contents-functions' permits saving a file.
@@ -393,5 +394,22 @@ name (Bug#28412)."
393 (should (null (save-buffer))) 394 (should (null (save-buffer)))
394 (should (eq (buffer-size) 1)))))) 395 (should (eq (buffer-size) 1))))))
395 396
397(ert-deftest files-tests--copy-directory ()
398 (let* ((dir (make-temp-file "files-mkdir-test" t))
399 (dirname (file-name-as-directory dir))
400 (source (concat dirname "source"))
401 (dest (concat dirname "dest/new/directory/"))
402 (file (concat (file-name-as-directory source) "file"))
403 (source2 (concat dirname "source2"))
404 (dest2 (concat dirname "dest/new2")))
405 (make-directory source)
406 (write-region "" nil file)
407 (copy-directory source dest t t t)
408 (should (file-exists-p (concat dest "file")))
409 (make-directory (concat (file-name-as-directory source2) "a") t)
410 (copy-directory source2 dest2)
411 (should (file-directory-p (concat (file-name-as-directory dest2) "a")))
412 (delete-directory dir 'recursive)))
413
396(provide 'files-tests) 414(provide 'files-tests)
397;;; files-tests.el ends here 415;;; files-tests.el ends here
diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el
index d65acf60712..35605ca28dc 100644
--- a/test/lisp/ibuffer-tests.el
+++ b/test/lisp/ibuffer-tests.el
@@ -456,11 +456,14 @@
456 (funcall create-non-file-buffer "ibuf-test-8a" 456 (funcall create-non-file-buffer "ibuf-test-8a"
457 :mode #'artist-mode)) 457 :mode #'artist-mode))
458 (bufB (funcall create-non-file-buffer "*ibuf-test-8b*" :size 32)) 458 (bufB (funcall create-non-file-buffer "*ibuf-test-8b*" :size 32))
459 (bufC (funcall create-file-buffer "ibuf-test8c" :suffix "*" 459 (bufC (or (memq system-type '(ms-dos windows-nt))
460 :size 64)) 460 (funcall create-file-buffer "ibuf-test8c" :suffix "*"
461 (bufD (funcall create-file-buffer "*ibuf-test8d" :size 128)) 461 :size 64)))
462 (bufE (funcall create-file-buffer "*ibuf-test8e" :suffix "*<2>" 462 (bufD (or (memq system-type '(ms-dos windows-nt))
463 :size 16)) 463 (funcall create-file-buffer "*ibuf-test8d" :size 128)))
464 (bufE (or (memq system-type '(ms-dos windows-nt))
465 (funcall create-file-buffer "*ibuf-test8e"
466 :suffix "*<2>" :size 16)))
464 (bufF (and (funcall create-non-file-buffer "*ibuf-test8f*") 467 (bufF (and (funcall create-non-file-buffer "*ibuf-test8f*")
465 (funcall create-non-file-buffer "*ibuf-test8f*" 468 (funcall create-non-file-buffer "*ibuf-test8f*"
466 :size 8)))) 469 :size 8))))
@@ -479,22 +482,28 @@
479 (name . "test.*8b") 482 (name . "test.*8b")
480 (size-gt . 31) 483 (size-gt . 31)
481 (not visiting-file))))) 484 (not visiting-file)))))
482 (should (ibuffer-included-in-filters-p 485 ;; MS-DOS and MS-Windows don't allow "*" in file names.
483 bufC '((and (not (starred-name)) 486 (or (memq system-type '(ms-dos windows-nt))
484 (visiting-file) 487 (should (ibuffer-included-in-filters-p
485 (name . "8c[^*]*\\*") 488 bufC '((and (not (starred-name))
486 (size-lt . 65))))) 489 (visiting-file)
487 (should (ibuffer-included-in-filters-p 490 (name . "8c[^*]*\\*")
488 bufD '((and (not (starred-name)) 491 (size-lt . 65))))))
489 (visiting-file) 492 ;; MS-DOS and MS-Windows don't allow "*" in file names.
490 (name . "\\`\\*.*test8d") 493 (or (memq system-type '(ms-dos windows-nt))
491 (size-lt . 129) 494 (should (ibuffer-included-in-filters-p
492 (size-gt . 127))))) 495 bufD '((and (not (starred-name))
493 (should (ibuffer-included-in-filters-p 496 (visiting-file)
494 bufE '((and (starred-name) 497 (name . "\\`\\*.*test8d")
495 (visiting-file) 498 (size-lt . 129)
496 (name . "8e.*?\\*<[[:digit:]]+>") 499 (size-gt . 127))))))
497 (size-gt . 10))))) 500 ;; MS-DOS and MS-Windows don't allow "*" in file names.
501 (or (memq system-type '(ms-dos windows-nt))
502 (should (ibuffer-included-in-filters-p
503 bufE '((and (starred-name)
504 (visiting-file)
505 (name . "8e.*?\\*<[[:digit:]]+>")
506 (size-gt . 10))))))
498 (should (ibuffer-included-in-filters-p 507 (should (ibuffer-included-in-filters-p
499 bufF '((and (starred-name) 508 bufF '((and (starred-name)
500 (not (visiting-file)) 509 (not (visiting-file))
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index e8515302c00..bfdc3017804 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -2653,8 +2653,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
2653 (tmp-name1 (tramp--test-make-temp-name nil quoted)) 2653 (tmp-name1 (tramp--test-make-temp-name nil quoted))
2654 (tmp-name2 (tramp--test-make-temp-name nil quoted)) 2654 (tmp-name2 (tramp--test-make-temp-name nil quoted))
2655 (tmp-name3 (tramp--test-make-temp-name 'local quoted)) 2655 (tmp-name3 (tramp--test-make-temp-name 'local quoted))
2656 (tmp-name4 (tramp--test-make-temp-name nil quoted))) 2656 (tmp-name4 (tramp--test-make-temp-name nil quoted))
2657 2657 (tmp-name5
2658 (expand-file-name (file-name-nondirectory tmp-name1) tmp-name4)))
2658 ;; Check `make-symbolic-link'. 2659 ;; Check `make-symbolic-link'.
2659 (unwind-protect 2660 (unwind-protect
2660 (tramp--test-ignore-make-symbolic-link-error 2661 (tramp--test-ignore-make-symbolic-link-error
@@ -2716,9 +2717,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
2716 (funcall 2717 (funcall
2717 (if quoted 'tramp-compat-file-name-unquote 'identity) 2718 (if quoted 'tramp-compat-file-name-unquote 'identity)
2718 (file-remote-p tmp-name1 'localname)) 2719 (file-remote-p tmp-name1 'localname))
2719 (file-symlink-p 2720 (file-symlink-p tmp-name5)))
2720 (expand-file-name 2721 ;; `smbclient' does not show symlinks in directories, so
2721 (file-name-nondirectory tmp-name1) tmp-name4))))) 2722 ;; we cannot delete a non-empty directory. We delete the
2723 ;; file explicitely.
2724 (delete-file tmp-name5))
2722 2725
2723 ;; Cleanup. 2726 ;; Cleanup.
2724 (ignore-errors 2727 (ignore-errors
@@ -2737,7 +2740,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
2737 (should-error 2740 (should-error
2738 (add-name-to-file tmp-name1 tmp-name2) 2741 (add-name-to-file tmp-name1 tmp-name2)
2739 :type 'file-already-exists) 2742 :type 'file-already-exists)
2740 ;; number means interactive case. 2743 ;; A number means interactive case.
2741 (cl-letf (((symbol-function 'yes-or-no-p) 'ignore)) 2744 (cl-letf (((symbol-function 'yes-or-no-p) 'ignore))
2742 (should-error 2745 (should-error
2743 (add-name-to-file tmp-name1 tmp-name2 0) 2746 (add-name-to-file tmp-name1 tmp-name2 0)
@@ -3193,15 +3196,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
3193 (should (processp proc)) 3196 (should (processp proc))
3194 (should (process-live-p proc)) 3197 (should (process-live-p proc))
3195 (should (equal (process-status proc) 'run)) 3198 (should (equal (process-status proc) 'run))
3199 (should (numberp (process-get proc 'remote-pid)))
3196 (should (interrupt-process proc)) 3200 (should (interrupt-process proc))
3197 ;; Let the process accept the interrupt. 3201 ;; Let the process accept the interrupt.
3198 (accept-process-output proc 1 nil 0) 3202 (accept-process-output proc 1 nil 0)
3199 (should-not (process-live-p proc)) 3203 (should-not (process-live-p proc))
3200 (should (equal (process-status proc) 'signal))
3201 ;; An interrupted process cannot be interrupted, again. 3204 ;; An interrupted process cannot be interrupted, again.
3202 ;; Does not work reliable. 3205 (should-error (interrupt-process proc) :type 'error))
3203 ;; (should-error (interrupt-process proc) :type 'error))
3204 )
3205 3206
3206 ;; Cleanup. 3207 ;; Cleanup.
3207 (ignore-errors (delete-process proc))))) 3208 (ignore-errors (delete-process proc)))))
@@ -3477,7 +3478,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
3477 (skip-unless (tramp--test-enabled)) 3478 (skip-unless (tramp--test-enabled))
3478 (skip-unless (tramp--test-sh-p)) 3479 (skip-unless (tramp--test-sh-p))
3479 3480
3480 ;; TODO: This test fails.
3481 (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) 3481 (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
3482 (let* ((default-directory tramp-test-temporary-file-directory) 3482 (let* ((default-directory tramp-test-temporary-file-directory)
3483 (tmp-name1 (tramp--test-make-temp-name nil quoted)) 3483 (tmp-name1 (tramp--test-make-temp-name nil quoted))
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index ac9e2df603c..a68688eba7a 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -300,6 +300,12 @@ cf. Bug#25477."
300 (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default ""))) 300 (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default "")))
301 (should (string= default res))))) 301 (should (string= default res)))))
302 302
303(ert-deftest subr-tests--gensym ()
304 "Test `gensym' behavior."
305 (should (equal (symbol-name (let ((gensym-counter 0)) (gensym)))
306 "g0"))
307 (should (eq (string-to-char (symbol-name (gensym))) ?g))
308 (should (eq (string-to-char (symbol-name (gensym "X"))) ?X)))
303 309
304(provide 'subr-tests) 310(provide 'subr-tests)
305;;; subr-tests.el ends here 311;;; subr-tests.el ends here
diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el
index f93fdbbc5af..47cf5f9244b 100644
--- a/test/lisp/textmodes/css-mode-tests.el
+++ b/test/lisp/textmodes/css-mode-tests.el
@@ -80,6 +80,27 @@
80 (equal (seq-sort #'string-lessp (css--value-class-lookup 'position)) 80 (equal (seq-sort #'string-lessp (css--value-class-lookup 'position))
81 '("bottom" "calc()" "center" "left" "right" "top")))) 81 '("bottom" "calc()" "center" "left" "right" "top"))))
82 82
83(ert-deftest css-test-current-defun-name ()
84 (with-temp-buffer
85 (insert "body { top: 0; }")
86 (goto-char 7)
87 (should (equal (css-current-defun-name) "body"))
88 (goto-char 18)
89 (should (equal (css-current-defun-name) "body"))))
90
91(ert-deftest css-test-current-defun-name-nested ()
92 (with-temp-buffer
93 (insert "body > .main a { top: 0; }")
94 (goto-char 20)
95 (should (equal (css-current-defun-name) "body > .main a"))))
96
97(ert-deftest css-test-current-defun-name-complex ()
98 (with-temp-buffer
99 (insert "input[type=submit]:hover { color: red; }")
100 (goto-char 30)
101 (should (equal (css-current-defun-name)
102 "input[type=submit]:hover"))))
103
83;;; Completion 104;;; Completion
84 105
85(defun css-mode-tests--completions () 106(defun css-mode-tests--completions ()
diff --git a/test/lisp/vc/smerge-mode-tests.el b/test/lisp/vc/smerge-mode-tests.el
new file mode 100644
index 00000000000..10d090632da
--- /dev/null
+++ b/test/lisp/vc/smerge-mode-tests.el
@@ -0,0 +1,34 @@
1;; Copyright (C) 2017 Free Software Foundation, Inc
2
3;; Maintainer: emacs-devel@gnu.org
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Code:
21
22(require 'smerge-mode)
23
24(ert-deftest smerge-mode-test-empty-hunk ()
25 "Regression test for bug #25555"
26 (with-temp-buffer
27 (insert "<<<<<<< one\n")
28 (save-excursion
29 (insert "=======\nLLL\n>>>>>>> end\n"))
30 (smerge-mode)
31 (smerge-keep-current)
32 (should (equal (buffer-substring (point-min) (point-max)) ""))))
33
34(provide 'smerge-mode-tests)
diff --git a/test/lisp/xdg-tests.el b/test/lisp/xdg-tests.el
index e3c9a743e44..b80f5e85524 100644
--- a/test/lisp/xdg-tests.el
+++ b/test/lisp/xdg-tests.el
@@ -42,9 +42,6 @@
42 (should (equal "frobnicate" (gethash "Exec" tab2)))) 42 (should (equal "frobnicate" (gethash "Exec" tab2))))
43 (should-error 43 (should-error
44 (xdg-desktop-read-file 44 (xdg-desktop-read-file
45 (expand-file-name "wrong.desktop" xdg-tests-data-dir)))
46 (should-error
47 (xdg-desktop-read-file
48 (expand-file-name "malformed.desktop" xdg-tests-data-dir))) 45 (expand-file-name "malformed.desktop" xdg-tests-data-dir)))
49 (let ((tab (xdg-desktop-read-file 46 (let ((tab (xdg-desktop-read-file
50 (expand-file-name "l10n.desktop" xdg-tests-data-dir))) 47 (expand-file-name "l10n.desktop" xdg-tests-data-dir)))
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 5dc26348a6f..8de8c145d40 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -101,7 +101,11 @@
101 (should (= 3 (apply #'min '(3 8 3)))) 101 (should (= 3 (apply #'min '(3 8 3))))
102 (should-error (min 9 8 'foo)) 102 (should-error (min 9 8 'foo))
103 (should-error (min (make-marker))) 103 (should-error (min (make-marker)))
104 (should (eql 1 (min (point-min-marker) 1)))) 104 (should (eql 1 (min (point-min-marker) 1)))
105 (should (isnan (min 0.0e+NaN)))
106 (should (isnan (min 0.0e+NaN 1 2)))
107 (should (isnan (min 1.0 0.0e+NaN)))
108 (should (isnan (min 1.0 0.0e+NaN 1.1))))
105 109
106;; Bool vector tests. Compactly represent bool vectors as hex 110;; Bool vector tests. Compactly represent bool vectors as hex
107;; strings. 111;; strings.
diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el
index 1c3fde888f6..70dc9372fad 100644
--- a/test/src/editfns-tests.el
+++ b/test/src/editfns-tests.el
@@ -166,6 +166,14 @@
166 (should (string-equal 166 (should (string-equal
167 (format-time-string format look '(-28800 "PST")) 167 (format-time-string format look '(-28800 "PST"))
168 "1972-06-30 15:59:59.999 -0800 (PST)")) 168 "1972-06-30 15:59:59.999 -0800 (PST)"))
169 ;; Negative UTC offset, as a Lisp integer.
170 (should (string-equal
171 (format-time-string format look -28800)
172 ;; MS-Windows build replaces unrecognizable TZ values,
173 ;; such as "-08", with "ZZZ".
174 (if (eq system-type 'windows-nt)
175 "1972-06-30 15:59:59.999 -0800 (ZZZ)"
176 "1972-06-30 15:59:59.999 -0800 (-08)")))
169 ;; Positive UTC offset that is not an hour multiple, as a string. 177 ;; Positive UTC offset that is not an hour multiple, as a string.
170 (should (string-equal 178 (should (string-equal
171 (format-time-string format look "IST-5:30") 179 (format-time-string format look "IST-5:30")
diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el
index a56fb4474d6..01c280d2752 100644
--- a/test/src/fileio-tests.el
+++ b/test/src/fileio-tests.el
@@ -35,6 +35,8 @@
35 (char 0)) 35 (char 0))
36 (while (and (not failure) (< char 127)) 36 (while (and (not failure) (< char 127))
37 (setq char (1+ char)) 37 (setq char (1+ char))
38 (when (and (eq system-type 'cygwin) (eq char 92))
39 (setq char (1+ char)))
38 (setq failure (try-link (string char) link))) 40 (setq failure (try-link (string char) link)))
39 (or failure 41 (or failure
40 (try-link "/:" link))) 42 (try-link "/:" link)))
diff --git a/test/src/lcms-tests.el b/test/src/lcms-tests.el
index e176cff2dc6..d6d1d16b9ad 100644
--- a/test/src/lcms-tests.el
+++ b/test/src/lcms-tests.el
@@ -1,6 +1,6 @@
1;;; lcms-tests.el --- tests for Little CMS interface -*- lexical-binding: t -*- 1;;; lcms-tests.el --- tests for Little CMS interface -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2017 Free Software Foundation, Inc. 3;; Copyright (C) 2017 Free Software Foundation, Inc.
4 4
5;; Maintainer: emacs-devel@gnu.org 5;; Maintainer: emacs-devel@gnu.org
6 6
@@ -21,9 +21,11 @@
21 21
22;;; Commentary: 22;;; Commentary:
23 23
24;; Some "exact" values computed using the colorspacious python library 24;; Some reference values computed using the colorspacious python
25;; written by Nathaniel J. Smith. See 25;; library, assimilated from its test suite, or adopted from its
26;; https://colorspacious.readthedocs.io/en/v1.1.0/ 26;; aggregation of gold values.
27;; See https://colorspacious.readthedocs.io/en/v1.1.0/ and
28;; https://github.com/njsmith/colorspacious
27 29
28;; Other references: 30;; Other references:
29;; http://www.babelcolor.com/index_htm_files/A%20review%20of%20RGB%20color%20spaces.pdf 31;; http://www.babelcolor.com/index_htm_files/A%20review%20of%20RGB%20color%20spaces.pdf
@@ -49,14 +51,20 @@ B is considered the exact value."
49 (lcms-approx-p a2 b2 delta) 51 (lcms-approx-p a2 b2 delta)
50 (lcms-approx-p a3 b3 delta)))) 52 (lcms-approx-p a3 b3 delta))))
51 53
54(defun lcms-rgb255->xyz (rgb)
55 "Return XYZ tristimulus values corresponding to RGB."
56 (let ((rgb1 (mapcar (lambda (x) (/ x 255.0)) rgb)))
57 (apply #'color-srgb-to-xyz rgb1)))
58
52(ert-deftest lcms-cri-cam02-ucs () 59(ert-deftest lcms-cri-cam02-ucs ()
53 "Test use of `lcms-cam02-ucs'." 60 "Test use of `lcms-cam02-ucs'."
61 (skip-unless (featurep 'lcms2))
54 (should-error (lcms-cam02-ucs '(0 0 0) '(0 0 0) "error")) 62 (should-error (lcms-cam02-ucs '(0 0 0) '(0 0 0) "error"))
55 (should-error (lcms-cam02-ucs '(0 0 0) 'error)) 63 (should-error (lcms-cam02-ucs '(0 0 0) 'error))
56 (should-not 64 (should-not
57 (lcms-approx-p 65 (lcms-approx-p
58 (let ((lcms-d65-xyz '(0.44757 1.0 0.40745))) 66 (let ((wp '(0.44757 1.0 0.40745)))
59 (lcms-cam02-ucs '(0.5 0.5 0.5) '(0 0 0))) 67 (lcms-cam02-ucs '(0.5 0.5 0.5) '(0 0 0) wp))
60 (lcms-cam02-ucs '(0.5 0.5 0.5) '(0 0 0)))) 68 (lcms-cam02-ucs '(0.5 0.5 0.5) '(0 0 0))))
61 (should (eql 0.0 (lcms-cam02-ucs '(0.5 0.5 0.5) '(0.5 0.5 0.5)))) 69 (should (eql 0.0 (lcms-cam02-ucs '(0.5 0.5 0.5) '(0.5 0.5 0.5))))
62 (should 70 (should
@@ -67,6 +75,7 @@ B is considered the exact value."
67 75
68(ert-deftest lcms-whitepoint () 76(ert-deftest lcms-whitepoint ()
69 "Test use of `lcms-temp->white-point'." 77 "Test use of `lcms-temp->white-point'."
78 (skip-unless (featurep 'lcms2))
70 (should-error (lcms-temp->white-point 3999)) 79 (should-error (lcms-temp->white-point 3999))
71 (should-error (lcms-temp->white-point 25001)) 80 (should-error (lcms-temp->white-point 25001))
72 ;; D55 81 ;; D55
@@ -85,4 +94,24 @@ B is considered the exact value."
85 (apply #'color-xyz-to-xyy (lcms-temp->white-point 7504)) 94 (apply #'color-xyz-to-xyy (lcms-temp->white-point 7504))
86 '(0.29902 0.31485 1.0)))) 95 '(0.29902 0.31485 1.0))))
87 96
97(ert-deftest lcms-dE-cam02-ucs-silver ()
98 "Test CRI-CAM02-UCS deltaE metric values from colorspacious."
99 (skip-unless (featurep 'lcms2))
100 (should
101 (lcms-approx-p
102 (lcms-cam02-ucs (lcms-rgb255->xyz '(173 52 52))
103 (lcms-rgb255->xyz '(59 120 51))
104 lcms-colorspacious-d65
105 (list 20 (/ 64 float-pi 5) 1 1))
106 44.698469808449964
107 0.03))
108 (should
109 (lcms-approx-p
110 (lcms-cam02-ucs (lcms-rgb255->xyz '(69 100 52))
111 (lcms-rgb255->xyz '(59 120 51))
112 lcms-colorspacious-d65
113 (list 20 (/ 64 float-pi 5) 1 1))
114 8.503323264883667
115 0.04)))
116
88;;; lcms-tests.el ends here 117;;; lcms-tests.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-25 18:27:25 +0000