branch: elpa/popup
commit 25e2e7fa848f866cc78b1608b0d726428c5b77a6
Merge: 6e467e2 7fda072
Author: yuuki arisawa <yuuki....@gmail.com>
Commit: yuuki arisawa <yuuki....@gmail.com>
Merge pull request #17 from uk-ar/feature
Port test from popup-interactive-test.el(10/20)
---
tests/popup-test.el | 245 ++++++++++++++++++++++++++++++++++++++++++++++++++--
1 file changed, 240 insertions(+), 5 deletions(-)
diff --git a/tests/popup-test.el b/tests/popup-test.el
index e51e01f..53ce80b 100644
--- a/tests/popup-test.el
+++ b/tests/popup-test.el
@@ -1,18 +1,253 @@
(require 'ert)
(require 'popup)
+;; for "every" function
+(require 'cl)
-(defmacro popup-test-with-common-setup (&rest body)
+(when (< (frame-width) (length "long long long long line"))
+ (set-frame-size (selected-frame) 80 35))
+
+(defmacro popup-test-with-create-popup (&rest body)
+ (declare (indent 0) (debug t))
+ `(let ((popup (popup-create (point) 10 10)))
+ (unwind-protect
+ (progn ,@body)
+ (when popup
+ (popup-delete popup)))
+ ))
+
+(defmacro popup-test-with-temp-buffer (&rest body)
(declare (indent 0) (debug t))
`(save-excursion
(with-temp-buffer
+ (switch-to-buffer (current-buffer))
+ (delete-other-windows)
(erase-buffer)
- (let ((popup (popup-create (point) 10 10)))
- ,@body
- (popup-delete popup)))))
+ ,@body
+ )))
+
+(defmacro popup-test-with-common-setup (&rest body)
+ (declare (indent 0) (debug t))
+ `(popup-test-with-temp-buffer
+ (popup-test-with-create-popup ,@body)))
+
+(defun popup-test-helper-get-overlays-buffer ()
+ "Create a new buffer called *text* containing the visible text
+of the current buffer, ie. it converts overlays containing text
+into real text. Return *text* buffer"
+ (interactive)
+ (let ((tb (get-buffer-create "*text*"))
+ (s (point-min))
+ (os (overlays-in (point-min) (point-max))))
+ (with-current-buffer tb
+ (erase-buffer))
+ (setq os (sort os (lambda (o1 o2)
+ (< (overlay-start o1)
+ (overlay-start o2)))))
+ (mapc (lambda (o)
+ (let ((bt (buffer-substring-no-properties s (overlay-start o)))
+ (b (overlay-get o 'before-string))
+ (text (or (overlay-get o 'display)
+ (buffer-substring-no-properties (overlay-start o)
(overlay-end o))))
+ (a (overlay-get o 'after-string))
+ (inv (overlay-get o 'invisible)))
+ (with-current-buffer tb
+ (insert bt)
+ (unless inv
+ (when b (insert b))
+ (insert text)
+ (when a (insert a))))
+ (setq s (overlay-end o))))
+ os)
+ (let ((x (buffer-substring-no-properties s (point-max))))
+ (with-current-buffer tb
+ (insert x)
+ tb))))
+(defun popup-test-helper-match-points (strings)
+ "Return list of start of first match"
+ (when (listp strings)
+ (let ((text (buffer-string)))
+ (mapcar
+ (lambda (content)
+ (let ((pos (string-match (regexp-quote content) text)))
+ (if (null pos) pos (1+ pos))))
+ strings))))
+
+(defun popup-test-helper-points-to-columns (points)
+ "Return list of colum"
+ (mapcar
+ (lambda (point)
+ (save-excursion (goto-char point) (current-column)))
+ points))
+
+(defun popup-test-helper-same-all-p (seq)
+ "Return first element if `eq' every element of SEQ.If not, return nil."
+ (reduce #'(lambda (x y) (if (eq x y) x nil)) seq))
+
+(defun popup-test-helper-input (key)
+ (push key unread-command-events))
+
+;; Test for helper method
+(ert-deftest popup-test-test-helper ()
+ (should (eq (popup-test-helper-same-all-p '(0 0 0)) 0))
+ (should (eq (popup-test-helper-same-all-p '(1 1 1)) 1))
+ (should (eq (popup-test-helper-same-all-p '(0 1 1)) nil))
+ )
+
+;; Test for popup-el
(ert-deftest popup-test-simple ()
(popup-test-with-common-setup
(popup-set-list popup '("foo" "bar" "baz"))
(popup-draw popup)
- (should (equal (popup-list popup) '("foo" "bar" "baz")))))
+ (should (equal (popup-list popup) '("foo" "bar" "baz")))
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points '("foo" "bar" "baz"))))
+ (should (every #'identity points))
+ (should (equal (popup-test-helper-points-to-columns points) '(0 0 0)))
+ (should (eq (popup-test-helper-same-all-p
+ (popup-test-helper-points-to-columns points)) 0))))))
+
+(ert-deftest popup-test-delete ()
+ (popup-test-with-common-setup
+ (popup-delete popup)
+ (should-not (popup-live-p popup))))
+
+(ert-deftest popup-test-hide ()
+ (popup-test-with-common-setup
+ (popup-set-list popup '("foo" "bar" "baz"))
+ (popup-draw popup)
+ (popup-hide popup)
+ (should (equal (popup-list popup) '("foo" "bar" "baz")))
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (should-not (every #'identity
+ (popup-test-helper-match-points '("foo" "bar"
"baz")))))
+ ))
+
+(ert-deftest popup-test-tip ()
+ (popup-test-with-temp-buffer
+ (popup-tip
+ "Start isearch on POPUP. This function is synchronized, meaning
+event loop waits for quiting of isearch.
+
+CURSOR-COLOR is a cursor color during isearch. The default value
+is `popup-isearch-cursor-color'.
+
+KEYMAP is a keymap which is used when processing events during
+event loop. The default value is `popup-isearch-keymap'.
+
+CALLBACK is a function taking one argument. `popup-isearch' calls
+CALLBACK, if specified, after isearch finished or isearch
+canceled. The arguments is whole filtered list of items.
+
+HELP-DELAY is a delay of displaying helps."
+ :nowait t)
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points
+ '("CURSOR-COLOR is a cursor color during isearch"
+ "KEYMAP is a keymap"))))
+ (should (every #'identity points))
+ (should (eq (popup-test-helper-same-all-p
+ (popup-test-helper-points-to-columns points)) 0)))
+ )))
+
+(ert-deftest popup-test-culumn ()
+ (popup-test-with-temp-buffer
+ (insert " ")
+ (popup-test-with-create-popup
+ (popup-set-list popup '("foo" "bar" "baz"))
+ (popup-draw popup)
+ (should (equal (popup-list popup) '("foo" "bar" "baz")))
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points '("foo" "bar" "baz"))))
+ (should (every #'identity points))
+ (should (equal (popup-test-helper-points-to-columns points)
+ '(1 1 1)))
+ )
+ ))))
+
+(ert-deftest popup-test-folding-long-line-right-top ()
+ (popup-test-with-temp-buffer
+ ;; To use window-width because Emacs 23 does not have window-body-width
+ (insert (make-string (- (window-width) 3) ? ))
+ (popup-tip "long long long long line" :nowait t)
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points
+ '("long long long long line"))))
+ (should (every #'identity points))
+ (should (eq (line-number-at-pos (car points)) 2))
+ ))))
+
+(ert-deftest popup-test-folding-long-line-left-bottom ()
+ (popup-test-with-temp-buffer
+ (insert (make-string (- (window-body-height) 1) ?\n))
+ (popup-tip "long long long long line" :nowait t)
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points
+ '("long long long long line"))))
+ (should (every #'identity points))
+ (should (eq (line-number-at-pos (car points))
+ (- (window-body-height) 1)))
+ ))))
+
+(ert-deftest popup-test-folding-long-line-right-bottom ()
+ (popup-test-with-temp-buffer
+ (insert (make-string (- (window-body-height) 1) ?\n))
+ (insert (make-string (- (window-width) 3) ? ))
+ (popup-tip "long long long long line" :nowait t)
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points
+ '("long long long long line"))))
+ (should (every #'identity points))
+ (should (eq (line-number-at-pos (car points))
+ (- (window-body-height) 1))))
+ )))
+
+(ert-deftest popup-test-folding-short-line-right-top ()
+ (popup-test-with-temp-buffer
+ (insert (make-string (- (window-width) 3) ? ))
+ (popup-tip "bla\nbla\nbla\nbla\nbla" :nowait t)
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points
+ '("bla"))))
+ (should (every #'identity points))
+ (should (eq (line-number-at-pos (car points)) 2))
+ ))))
+
+(ert-deftest popup-test-folding-short-line-left-bottom ()
+ (popup-test-with-temp-buffer
+ (insert (make-string (- (window-body-height) 1) ?\n))
+ (popup-tip "bla\nbla\nbla\nbla\nbla" :nowait t)
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points
+ '("bla"))))
+ (should (every #'identity points))
+ (should (eq (popup-test-helper-same-all-p
+ (popup-test-helper-points-to-columns points)) 0))
+ (should (eq (line-number-at-pos (car points))
+ (- (window-body-height) 5)))
+ ))))
+
+(ert-deftest popup-test-folding-short-line-right-bottom ()
+ (popup-test-with-temp-buffer
+ (insert (make-string (- (window-body-height) 1) ?\n))
+ (insert (make-string (- (window-width) 3) ? ))
+ (popup-tip "bla\nbla\nbla\nbla\nbla" :nowait t)
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points
+ '("bla"))))
+ (should (every #'identity points))
+ (should (eq (line-number-at-pos (car points))
+ (- (window-body-height) 5))))
+ )))
+
+(ert-deftest popup-test-margin-at-middle ()
+ (popup-test-with-temp-buffer
+ (insert " ")
+ (let ((popup (popup-tip "Margin?" :nowait t :margin t)))
+ (with-current-buffer (popup-test-helper-get-overlays-buffer)
+ (let ((points (popup-test-helper-match-points '(" Margin? "))))
+ (should (every #'identity points))
+ (should (equal (car (popup-test-helper-points-to-columns points))
+ 0))
+ )))))
