diff options
Diffstat (limited to 'test/lisp/emacs-lisp')
| -rw-r--r-- | test/lisp/emacs-lisp/backtrace-tests.el | 436 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/cl-print-tests.el | 178 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el | 9 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/edebug-tests.el | 29 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/ert-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/lisp-mode-tests.el | 23 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/package-tests.el | 31 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/subr-x-tests.el | 47 |
8 files changed, 736 insertions, 19 deletions
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el new file mode 100644 index 00000000000..edd45c770c5 --- /dev/null +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -0,0 +1,436 @@ +;;; backtrace-tests.el --- Tests for backtraces -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Gemini Lasswell + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'backtrace) +(require 'ert) +(require 'ert-x) +(require 'seq) + +;; Delay evaluation of the backtrace-creating functions until +;; load so that the backtraces are the same whether this file +;; is compiled or not. + +(eval-and-compile + (defconst backtrace-tests--uncompiled-functions + '(progn + (defun backtrace-tests--make-backtrace (arg) + (backtrace-tests--setup-buffer)) + + (defun backtrace-tests--setup-buffer () + "Set up the current buffer in backtrace mode." + (backtrace-mode) + (setq backtrace-frames (backtrace-get-frames)) + (let ((this-index)) + ;; Discard all past `backtrace-tests-make-backtrace'. + (dotimes (index (length backtrace-frames)) + (when (eq (backtrace-frame-fun (nth index backtrace-frames)) + 'backtrace-tests--make-backtrace) + (setq this-index index))) + (setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index)))) + (backtrace-print)))) + + (eval backtrace-tests--uncompiled-functions)) + +(defun backtrace-tests--backtrace-lines () + (if debugger-stack-frame-as-list + '(" (backtrace-get-frames)\n" + " (setq backtrace-frames (backtrace-get-frames))\n" + " (backtrace-tests--setup-buffer)\n" + " (backtrace-tests--make-backtrace %s)\n") + '(" backtrace-get-frames()\n" + " (setq backtrace-frames (backtrace-get-frames))\n" + " backtrace-tests--setup-buffer()\n" + " backtrace-tests--make-backtrace(%s)\n"))) + +(defconst backtrace-tests--line-count (length (backtrace-tests--backtrace-lines))) + +(defun backtrace-tests--backtrace-lines-with-locals () + (let ((lines (backtrace-tests--backtrace-lines)) + (locals '(" [no locals]\n" + " [no locals]\n" + " [no locals]\n" + " arg = %s\n"))) + (apply #'append (cl-mapcar #'list lines locals)))) + +(defun backtrace-tests--result (value) + (format (apply #'concat (backtrace-tests--backtrace-lines)) + (cl-prin1-to-string value))) + +(defun backtrace-tests--result-with-locals (value) + (let ((str (cl-prin1-to-string value))) + (format (apply #'concat (backtrace-tests--backtrace-lines-with-locals)) + str str))) + +;; TODO check that debugger-batch-max-lines still works + +(defconst backtrace-tests--header "Test header\n") +(defun backtrace-tests--insert-header () + (insert backtrace-tests--header)) + +;;; Tests + +(ert-deftest backtrace-tests--variables () + "Backtrace buffers can show and hide local variables." + (ert-with-test-buffer (:name "variables") + (let ((results (concat backtrace-tests--header + (backtrace-tests--result 'value))) + (last-frame (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) 'value)) + (last-frame-with-locals + (format (apply #'concat (nthcdr (* 2 (1- backtrace-tests--line-count)) + (backtrace-tests--backtrace-lines-with-locals))) + 'value 'value))) + (backtrace-tests--make-backtrace 'value) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Go to the last frame. + (goto-char (point-max)) + (forward-line -1) + ;; Turn on locals for that frame. + (backtrace-toggle-locals) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame-with-locals)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + (concat results + (format (car (last (backtrace-tests--backtrace-lines-with-locals))) + 'value)))) + ;; Turn off locals for that frame. + (backtrace-toggle-locals) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Turn all locals on. + (backtrace-toggle-locals '(4)) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame-with-locals)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + (concat backtrace-tests--header + (backtrace-tests--result-with-locals 'value)))) + ;; Turn all locals off. + (backtrace-toggle-locals '(4)) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length last-frame))) + last-frame)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + +(ert-deftest backtrace-tests--backward-frame () + "`backtrace-backward-frame' moves backward to the start of a frame." + (ert-with-test-buffer (:name "backward") + (let ((results (concat backtrace-tests--header + (backtrace-tests--result nil)))) + (backtrace-tests--make-backtrace nil) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + + ;; Try to move backward from header. + (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2))) + (let ((pos (point))) + (should-error (backtrace-backward-frame)) + (should (= pos (point)))) + + ;; Try to move backward from start of first line. + (forward-line) + (let ((pos (point))) + (should-error (backtrace-backward-frame)) + (should (= pos (point)))) + + ;; Move backward from middle of line. + (let ((start (point))) + (forward-char (/ (length (nth 0 (backtrace-tests--backtrace-lines))) 2)) + (backtrace-backward-frame) + (should (= start (point)))) + + ;; Move backward from end of buffer. + (goto-char (point-max)) + (backtrace-backward-frame) + (let* ((last (format (car (last (backtrace-tests--backtrace-lines))) nil)) + (len (length last))) + (should (string= (buffer-substring-no-properties (point) (+ (point) len)) + last))) + + ;; Move backward from start of line. + (backtrace-backward-frame) + (let* ((line (car (last (backtrace-tests--backtrace-lines) 2))) + (len (length line))) + (should (string= (buffer-substring-no-properties (point) (+ (point) len)) + line)))))) + +(ert-deftest backtrace-tests--forward-frame () + "`backtrace-forward-frame' moves forward to the start of a frame." + (ert-with-test-buffer (:name "forward") + (let* ((arg '(1 2 3)) + (results (concat backtrace-tests--header + (backtrace-tests--result arg))) + (first-line (nth 0 (backtrace-tests--backtrace-lines)))) + (backtrace-tests--make-backtrace arg) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Move forward from header. + (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2))) + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length first-line))) + first-line)) + + (let ((start (point)) + (offset (/ (length first-line) 2)) + (second-line (nth 1 (backtrace-tests--backtrace-lines)))) + ;; Move forward from start of first frame. + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length second-line))) + second-line)) + ;; Move forward from middle of first frame. + (goto-char (+ start offset)) + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length second-line))) + second-line))) + ;; Try to move forward from middle of last frame. + (goto-char (- (point-max) + (/ 2 (length (car (last (backtrace-tests--backtrace-lines))))))) + (should-error (backtrace-forward-frame)) + ;; Try to move forward from end of buffer. + (goto-char (point-max)) + (should-error (backtrace-forward-frame))))) + +(ert-deftest backtrace-tests--single-and-multi-line () + "Forms in backtrace frames can be on a single line or on multiple lines." + (ert-with-test-buffer (:name "single-multi-line") + (let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure. + (let ((number (1+ x))) + (+ x number)))) + (header-string "Test header: ") + (header (format "%s%s\n" header-string arg)) + (insert-header-function (lambda () + (insert header-string) + (insert (backtrace-print-to-string arg)) + (insert "\n"))) + (results (concat header (backtrace-tests--result arg))) + (last-line (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg)) + (last-line-locals (format (nth (1- (* 2 backtrace-tests--line-count)) + (backtrace-tests--backtrace-lines-with-locals)) + arg))) + + (backtrace-tests--make-backtrace arg) + (setq backtrace-insert-header-function insert-header-function) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Check pp and collapse for the form in the header. + (goto-char (point-min)) + (backtrace-tests--verify-single-and-multi-line header) + ;; Check pp and collapse for the last frame. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-tests--verify-single-and-multi-line last-line) + ;; Check pp and collapse for local variables in the last line. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-toggle-locals) + (forward-line) + (backtrace-tests--verify-single-and-multi-line last-line-locals)))) + +(defun backtrace-tests--verify-single-and-multi-line (line) + "Verify that `backtrace-single-line' and `backtrace-multi-line' work at point. +Point should be at the beginning of a line, and LINE should be a +string containing the text of the line at point. Assume that the +line contains the strings \"lambda\" and \"number\"." + (let ((pos (point))) + (backtrace-multi-line) + ;; Verify point is still at the start of the line. + (should (= pos (point)))) + + ;; Verify the form now spans multiple lines. + (let ((pos (point))) + (search-forward "number") + (should-not (= pos (point-at-bol)))) + ;; Collapse the form. + (backtrace-single-line) + ;; Verify that the form is now back on one line, + ;; and that point is at the same place. + (should (string= (backtrace-tests--get-substring + (- (point) 6) (point)) "number")) + (should-not (= (point) (point-at-bol))) + (should (string= (backtrace-tests--get-substring + (point-at-bol) (1+ (point-at-eol))) + line))) + +(ert-deftest backtrace-tests--print-circle () + "Backtrace buffers can toggle `print-circle' syntax." + (ert-with-test-buffer (:name "print-circle") + (let* ((print-circle nil) + (arg (let ((val (make-list 5 'a))) (nconc val val) val)) + (results (backtrace-tests--make-regexp + (backtrace-tests--result arg))) + (results-circle (regexp-quote (let ((print-circle t)) + (backtrace-tests--result arg)))) + (last-frame (backtrace-tests--make-regexp + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))) + (last-frame-circle (regexp-quote + (let ((print-circle t)) + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))))) + (backtrace-tests--make-backtrace arg) + (backtrace-print) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Go to the last frame. + (goto-char (point-max)) + (forward-line -1) + ;; Turn on print-circle for that frame. + (backtrace-toggle-print-circle) + (should (string-match-p last-frame-circle + (backtrace-tests--get-substring (point) (point-max)))) + ;; Turn off print-circle for the frame. + (backtrace-toggle-print-circle) + (should (string-match-p last-frame + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-circle on for the buffer. + (backtrace-toggle-print-circle '(4)) + (should (string-match-p last-frame-circle + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results-circle + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-circle off. + (backtrace-toggle-print-circle '(4)) + (should (string-match-p last-frame + (backtrace-tests--get-substring + (point) (+ (point) (length last-frame))))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max))))))) + +(defun backtrace-tests--make-regexp (str) + "Make regexp from STR for `backtrace-tests--print-circle'. +Used for results of printing circular objects without +`print-circle' on. Look for #n in string STR where n is any +digit and replace with #[0-9]." + (let ((regexp (regexp-quote str))) + (with-temp-buffer + (insert regexp) + (goto-char (point-min)) + (while (re-search-forward "#[0-9]" nil t) + (replace-match "#[0-9]"))) + (buffer-string))) + +(ert-deftest backtrace-tests--expand-ellipsis () + "Backtrace buffers ellipsify large forms as buttons which expand the ellipses." + ;; make a backtrace with an ellipsis + ;; expand the ellipsis + (ert-with-test-buffer (:name "variables") + (let* ((print-level nil) + (print-length nil) + (backtrace-line-length 300) + (arg (make-list 40 (make-string 10 ?a))) + (results (backtrace-tests--result arg))) + (backtrace-tests--make-backtrace arg) + (backtrace-print) + + ;; There should be an ellipsis. Find and expand it. + (goto-char (point-min)) + (search-forward "...") + (backward-char) + (push-button) + + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + +(ert-deftest backtrace-tests--expand-ellipses () + "Backtrace buffers ellipsify large forms and can expand the ellipses." + (ert-with-test-buffer (:name "variables") + (let* ((print-level nil) + (print-length nil) + (backtrace-line-length 300) + (arg (let ((outer (make-list 40 (make-string 10 ?a))) + (nested (make-list 40 (make-string 10 ?b)))) + (setf (nth 39 nested) (make-list 40 (make-string 10 ?c))) + (setf (nth 39 outer) nested) + outer)) + (results (backtrace-tests--result-with-locals arg))) + + ;; Make a backtrace with local variables visible. + (backtrace-tests--make-backtrace arg) + (backtrace-print) + (backtrace-toggle-locals '(4)) + + ;; There should be two ellipses. + (goto-char (point-min)) + (should (search-forward "...")) + (should (search-forward "...")) + (should-error (search-forward "...")) + + ;; Expanding the last frame without argument should expand both + ;; ellipses, but the expansions will contain one ellipsis each. + (let ((buffer-len (- (point-max) (point-min)))) + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-expand-ellipses) + (should (> (- (point-max) (point-min)) buffer-len)) + (goto-char (point-min)) + (should (search-forward "...")) + (should (search-forward "...")) + (should-error (search-forward "..."))) + + ;; Expanding with argument should remove all ellipses. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-expand-ellipses '(4)) + (goto-char (point-min)) + + (should-error (search-forward "...")) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + + +(ert-deftest backtrace-tests--to-string () + "Backtraces can be produced as strings." + (let ((frames (ert-with-test-buffer (:name nil) + (backtrace-tests--make-backtrace "string") + backtrace-frames))) + (should (string= (backtrace-to-string frames) + (backtrace-tests--result "string"))))) + +(defun backtrace-tests--get-substring (beg end) + "Return the visible text between BEG and END. +Strip the string properties because it makes failed test results +easier to read." + (substring-no-properties (filter-buffer-substring beg end))) + +(provide 'backtrace-tests) + +;;; backtrace-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el index 404d323d0c1..a469b5526c0 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -56,19 +56,30 @@ (let ((long-list (make-list 5 'a)) (long-vec (make-vector 5 'b)) (long-struct (cl-print-tests-con)) + (long-string (make-string 5 ?a)) (print-length 4)) (should (equal "(a a a a ...)" (cl-prin1-to-string long-list))) (should (equal "[b b b b ...]" (cl-prin1-to-string long-vec))) (should (equal "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)" - (cl-prin1-to-string long-struct))))) + (cl-prin1-to-string long-struct))) + (should (equal "\"aaaa...\"" (cl-prin1-to-string long-string))))) (ert-deftest cl-print-tests-4 () "CL printing observes `print-level'." - (let ((deep-list '(a (b (c (d (e)))))) - (deep-struct (cl-print-tests-con)) - (print-level 4)) + (let* ((deep-list '(a (b (c (d (e)))))) + (buried-vector '(a (b (c (d [e]))))) + (deep-struct (cl-print-tests-con)) + (buried-struct `(a (b (c (d ,deep-struct))))) + (buried-string '(a (b (c (d #("hello" 0 5 (cl-print-test t))))))) + (buried-simple-string '(a (b (c (d "hello"))))) + (print-level 4)) (setf (cl-print-tests-struct-a deep-struct) deep-list) (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string deep-list))) + (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-vector))) + (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-struct))) + (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-string))) + (should (equal "(a (b (c (d \"hello\"))))" + (cl-prin1-to-string buried-simple-string))) (should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)" (cl-prin1-to-string deep-struct))))) @@ -82,6 +93,129 @@ (should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))" (cl-prin1-to-string quoted-stuff)))))) +(ert-deftest cl-print-tests-strings () + "CL printing prints strings and propertized strings." + (let* ((str1 "abcdefghij") + (str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t))) + (str3 #("abcdefghij" 0 10 (test t))) + (obj '(a b)) + ;; Since the byte compiler reuses string literals, + ;; and the put-text-property call is destructive, use + ;; copy-sequence to make a new string. + (str4 (copy-sequence "abcdefghij"))) + (put-text-property 0 5 'test obj str4) + (put-text-property 7 10 'test obj str4) + + (should (equal "\"abcdefghij\"" (cl-prin1-to-string str1))) + (should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))" + (cl-prin1-to-string str2))) + (should (equal "#(\"abcdefghij\" 0 10 (test t))" + (cl-prin1-to-string str3))) + (let ((print-circle nil)) + (should + (equal + "#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))" + (cl-prin1-to-string str4)))) + (let ((print-circle t)) + (should + (equal + "#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))" + (cl-prin1-to-string str4)))))) + +(ert-deftest cl-print-tests-ellipsis-cons () + "Ellipsis expansion works in conses." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + '(0 1 2 3 4 5) "(0 1 2 3 ...)" "4 5") + (cl-print-tests-check-ellipsis-expansion + '(0 1 2 3 4 5 6 7 8 9) "(0 1 2 3 ...)" "4 5 6 7 ...") + (cl-print-tests-check-ellipsis-expansion + '(a (b (c (d (e))))) "(a (b (c ...)))" "(d (e))") + (cl-print-tests-check-ellipsis-expansion + (let ((x (make-list 6 'b))) + (setf (nthcdr 6 x) 'c) + x) + "(b b b b ...)" "b b . c"))) + +(ert-deftest cl-print-tests-ellipsis-vector () + "Ellipsis expansion works in vectors." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + [0 1 2 3 4 5] "[0 1 2 3 ...]" "4 5") + (cl-print-tests-check-ellipsis-expansion + [0 1 2 3 4 5 6 7 8 9] "[0 1 2 3 ...]" "4 5 6 7 ...") + (cl-print-tests-check-ellipsis-expansion + [a [b [c [d [e]]]]] "[a [b [c ...]]]" "[d [e]]"))) + +(ert-deftest cl-print-tests-ellipsis-string () + "Ellipsis expansion works in strings." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + "abcdefg" "\"abcd...\"" "efg") + (cl-print-tests-check-ellipsis-expansion + "abcdefghijk" "\"abcd...\"" "efgh...") + (cl-print-tests-check-ellipsis-expansion + '(1 (2 (3 #("abcde" 0 5 (test t))))) + "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))") + (cl-print-tests-check-ellipsis-expansion + #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t)) + "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ..."))) + +(ert-deftest cl-print-tests-ellipsis-struct () + "Ellipsis expansion works in structures." + (let ((print-length 4) + (print-level 3) + (struct (cl-print-tests-con))) + (cl-print-tests-check-ellipsis-expansion + struct "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)" ":e nil") + (let ((print-length 2)) + (cl-print-tests-check-ellipsis-expansion + struct "#s(cl-print-tests-struct :a nil :b nil ...)" ":c nil :d nil ...")) + (cl-print-tests-check-ellipsis-expansion + `(a (b (c ,struct))) + "(a (b (c ...)))" + "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"))) + +(ert-deftest cl-print-tests-ellipsis-circular () + "Ellipsis expansion works with circular objects." + (let ((wide-obj (list 0 1 2 3 4)) + (deep-obj `(0 (1 (2 (3 (4)))))) + (print-length 4) + (print-level 3)) + (setf (nth 4 wide-obj) wide-obj) + (setf (car (cadadr (cadadr deep-obj))) deep-obj) + (let ((print-circle nil)) + (cl-print-tests-check-ellipsis-expansion-rx + wide-obj (regexp-quote "(0 1 2 3 ...)") "\\`#[0-9]\\'") + (cl-print-tests-check-ellipsis-expansion-rx + deep-obj (regexp-quote "(0 (1 (2 ...)))") "\\`(3 (#[0-9]))\\'")) + (let ((print-circle t)) + (cl-print-tests-check-ellipsis-expansion + wide-obj "#1=(0 1 2 3 ...)" "#1#") + (cl-print-tests-check-ellipsis-expansion + deep-obj "#1=(0 (1 (2 ...)))" "(3 (#1#))")))) + +(defun cl-print-tests-check-ellipsis-expansion (obj expected expanded) + (let* ((result (cl-prin1-to-string obj)) + (pos (next-single-property-change 0 'cl-print-ellipsis result)) + value) + (should pos) + (setq value (get-text-property pos 'cl-print-ellipsis result)) + (should (equal expected result)) + (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis + value nil)))))) + +(defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded) + (let* ((result (cl-prin1-to-string obj)) + (pos (next-single-property-change 0 'cl-print-ellipsis result)) + (value (get-text-property pos 'cl-print-ellipsis result))) + (should (string-match expected result)) + (should (string-match expanded (with-output-to-string + (cl-print-expand-ellipsis value nil)))))) + (ert-deftest cl-print-circle () (let ((x '(#1=(a . #1#) #1#))) (let ((print-circle nil)) @@ -99,5 +233,41 @@ (let ((print-circle t)) (should (equal "(0 . #1=(0 . #1#))" (cl-prin1-to-string x)))))) +(ert-deftest cl-print-tests-print-to-string-with-limit () + (let* ((thing10 (make-list 10 'a)) + (thing100 (make-list 100 'a)) + (thing10x10 (make-list 10 thing10)) + (nested-thing (let ((val 'a)) + (dotimes (_i 20) + (setq val (list val))) + val)) + ;; Make a consistent environment for this test. + (print-circle nil) + (print-level nil) + (print-length nil)) + + ;; Print something that fits in the space given. + (should (string= (cl-prin1-to-string thing10) + (cl-print-to-string-with-limit #'cl-prin1 thing10 100))) + + ;; Print something which needs to be abbreviated and which can be. + (should (< (length (cl-print-to-string-with-limit #'cl-prin1 thing100 100)) + 100 + (length (cl-prin1-to-string thing100)))) + + ;; Print something resistant to easy abbreviation. + (should (string= (cl-prin1-to-string thing10x10) + (cl-print-to-string-with-limit #'cl-prin1 thing10x10 100))) + + ;; Print something which should be abbreviated even if the limit is large. + (should (< (length (cl-print-to-string-with-limit #'cl-prin1 nested-thing 1000)) + (length (cl-prin1-to-string nested-thing)))) + + ;; Print with no limits. + (dolist (thing (list thing10 thing100 thing10x10 nested-thing)) + (let ((rep (cl-prin1-to-string thing))) + (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing 0))) + (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing nil))))))) + ;;; cl-print-tests.el ends here. diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index e86c2f1c1e7..97dead057a9 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -41,7 +41,7 @@ (defun edebug-test-code-range (num) !start!(let ((index 0) (result nil)) - (while (< index num)!test! + (while !lt!(< index num)!test! (push index result)!loop! (cl-incf index))!end-loop! (nreverse result))) @@ -130,5 +130,12 @@ (let ((two 2) (three 3)) (cl-destructuring-bind (x . y) (cons two three) (+ x!x! y!y!)))) +(defun edebug-test-code-use-cl-macrolet (x) + (cl-macrolet ((wrap (func &rest args) + `(format "The result of applying %s to %s is %S" + ',func!func! ',args + ,(cons func args)))) + (wrap + 1 x))) + (provide 'edebug-test-code) ;;; edebug-test-code.el ends here diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 85f6bd47db2..7880aaf95bc 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -432,9 +432,11 @@ test and possibly others should be updated." (verify-keybinding "P" 'edebug-view-outside) ;; same as v (verify-keybinding "W" 'edebug-toggle-save-windows) (verify-keybinding "?" 'edebug-help) - (verify-keybinding "d" 'edebug-backtrace) + (verify-keybinding "d" 'edebug-pop-to-backtrace) (verify-keybinding "-" 'negative-argument) - (verify-keybinding "=" 'edebug-temp-display-freq-count))) + (verify-keybinding "=" 'edebug-temp-display-freq-count) + (should (eq (lookup-key backtrace-mode-map "n") 'backtrace-forward-frame)) + (should (eq (lookup-key backtrace-mode-map "s") 'backtrace-goto-source)))) (ert-deftest edebug-tests-stop-point-at-start-of-first-instrumented-function () "Edebug stops at the beginning of an instrumented function." @@ -913,5 +915,28 @@ test and possibly others should be updated." "g" (should (equal edebug-tests-@-result 5))))) +(ert-deftest edebug-tests-cl-macrolet () + "Edebug can instrument `cl-macrolet' expressions. (Bug#29919)" + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "use-cl-macrolet" '(10) t) + (edebug-tests-run-kbd-macro + "@ SPC SPC" + (edebug-tests-should-be-at "use-cl-macrolet" "func") + (edebug-tests-should-match-result-in-messages "+") + "g" + (should (equal edebug-tests-@-result "The result of applying + to (1 x) is 11"))))) + +(ert-deftest edebug-tests-backtrace-goto-source () + "Edebug can jump to instrumented source from its *Edebug-Backtrace* buffer." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "range" '(2) t) + (edebug-tests-run-kbd-macro + "@ SPC SPC" + (edebug-tests-should-be-at "range" "lt") + "dns" ; Pop to backtrace, next frame, goto source. + (edebug-tests-should-be-at "range" "start") + "g" + (should (equal edebug-tests-@-result '(0 1)))))) + (provide 'edebug-tests) ;;; edebug-tests.el ends here diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index cb957bd9fd6..1fe5b79ef36 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -376,7 +376,7 @@ This macro is used to test if macroexpansion in `should' works." (test (make-ert-test :body test-body)) (result (ert-run-test test))) (should (ert-test-failed-p result)) - (should (eq (nth 1 (car (ert-test-failed-backtrace result))) + (should (eq (backtrace-frame-fun (car (ert-test-failed-backtrace result))) 'signal)))) (ert-deftest ert-test-messages () diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el index 8598d419788..30f606d3816 100644 --- a/test/lisp/emacs-lisp/lisp-mode-tests.el +++ b/test/lisp/emacs-lisp/lisp-mode-tests.el @@ -113,6 +113,29 @@ noindent\" 3 ;; we're indenting ends on the previous line. (should (equal (buffer-string) original))))) +(ert-deftest indent-sexp-go () + "Make sure `indent-sexp' doesn't stop after #s." + ;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31984. + (with-temp-buffer + (emacs-lisp-mode) + (insert "#s(foo\nbar)\n") + (goto-char (point-min)) + (indent-sexp) + (should (equal (buffer-string) "\ +#s(foo + bar)\n")))) + +(ert-deftest indent-sexp-cant-go () + "`indent-sexp' shouldn't error before a sexp." + ;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31984#32. + (with-temp-buffer + (emacs-lisp-mode) + (insert "(())") + (goto-char (1+ (point-min))) + ;; Paredit calls `indent-sexp' from this position. + (indent-sexp) + (should (equal (buffer-string) "(())")))) + (ert-deftest lisp-indent-region () "Test basics of `lisp-indent-region'." (with-temp-buffer diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index db6d103a2ef..f08bc92ff2a 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -112,7 +112,7 @@ upload-base) &rest body) "Set up temporary locations and variables for testing." - (declare (indent 1)) + (declare (indent 1) (debug (([&rest form]) body))) `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) (process-environment (cons (format "HOME=%s" package-test-user-dir) process-environment)) @@ -158,6 +158,7 @@ (defmacro with-fake-help-buffer (&rest body) "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." + (declare (debug body)) `(with-temp-buffer (help-mode) ;; Trick `help-buffer' into using the temp buffer. @@ -467,15 +468,23 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-signed () "Test verifying package signature." - (skip-unless (ignore-errors - (let ((homedir (make-temp-file "package-test" t))) - (unwind-protect - (let ((process-environment - (cons (format "HOME=%s" homedir) - process-environment))) - (epg-check-configuration - (epg-find-configuration 'OpenPGP))) - (delete-directory homedir t))))) + (skip-unless (let ((homedir (make-temp-file "package-test" t))) + (unwind-protect + (let ((process-environment + (cons (concat "HOME=" homedir) + process-environment))) + (epg-find-configuration + 'OpenPGP nil + ;; By default we require gpg2 2.1+ due to some + ;; practical problems with pinentry. But this + ;; test works fine with 2.0 as well. + (let ((prog-alist (copy-tree epg-config--program-alist))) + (setf (alist-get "gpg2" + (alist-get 'OpenPGP prog-alist) + nil nil #'equal) + "2.0") + prog-alist))) + (delete-directory homedir t)))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) (package-test-data-dir (expand-file-name "package-resources/signed" package-test-file-dir))) @@ -506,7 +515,7 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package 'signed-good) (goto-char (point-min)) - (should (re-search-forward "signed-good is an? \\(\\S-+\\) package." nil t)) + (should (re-search-forward "Package signed-good is \\(\\S-+\\)\\." nil t)) (should (string-equal (match-string-no-properties 1) "installed")) (should (re-search-forward "Status: Installed in ['`‘]signed-good-1.0/['’]." diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index f7f0ef384f6..81467bab2d4 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -532,6 +532,53 @@ (format "abs sum is: %s")) "abs sum is: 15"))) + +;; Substring tests + +(ert-deftest subr-x-test-string-trim-left () + "Test `string-trim-left' behavior." + (should (equal (string-trim-left "") "")) + (should (equal (string-trim-left " \t\n\r") "")) + (should (equal (string-trim-left " \t\n\ra") "a")) + (should (equal (string-trim-left "a \t\n\r") "a \t\n\r")) + (should (equal (string-trim-left "" "") "")) + (should (equal (string-trim-left "a" "") "a")) + (should (equal (string-trim-left "aa" "a*") "")) + (should (equal (string-trim-left "ba" "a*") "ba")) + (should (equal (string-trim-left "aa" "a*?") "aa")) + (should (equal (string-trim-left "aa" "a+?") "a"))) + +(ert-deftest subr-x-test-string-trim-right () + "Test `string-trim-right' behavior." + (should (equal (string-trim-right "") "")) + (should (equal (string-trim-right " \t\n\r") "")) + (should (equal (string-trim-right " \t\n\ra") " \t\n\ra")) + (should (equal (string-trim-right "a \t\n\r") "a")) + (should (equal (string-trim-right "" "") "")) + (should (equal (string-trim-right "a" "") "a")) + (should (equal (string-trim-right "aa" "a*") "")) + (should (equal (string-trim-right "ab" "a*") "ab")) + (should (equal (string-trim-right "aa" "a*?") ""))) + +(ert-deftest subr-x-test-string-remove-prefix () + "Test `string-remove-prefix' behavior." + (should (equal (string-remove-prefix "" "") "")) + (should (equal (string-remove-prefix "" "a") "a")) + (should (equal (string-remove-prefix "a" "") "")) + (should (equal (string-remove-prefix "a" "b") "b")) + (should (equal (string-remove-prefix "a" "a") "")) + (should (equal (string-remove-prefix "a" "aa") "a")) + (should (equal (string-remove-prefix "a" "ab") "b"))) + +(ert-deftest subr-x-test-string-remove-suffix () + "Test `string-remove-suffix' behavior." + (should (equal (string-remove-suffix "" "") "")) + (should (equal (string-remove-suffix "" "a") "a")) + (should (equal (string-remove-suffix "a" "") "")) + (should (equal (string-remove-suffix "a" "b") "b")) + (should (equal (string-remove-suffix "a" "a") "")) + (should (equal (string-remove-suffix "a" "aa") "a")) + (should (equal (string-remove-suffix "a" "ba") "b"))) (provide 'subr-x-tests) ;;; subr-x-tests.el ends here |