test/manual/scroll-tests.el

   1 ;;; scroll-tests.el -- tests for scrolling -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2017 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; This program 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 ;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; These are mostly automated ert tests, but they don't work in batch
  23 ;; mode which is why they are under test/manual.
  24
  25 ;;; Code:
  26
  27 (require 'ert)
  28 (eval-when-compile (require 'cl-lib))
  29
  30 (defun scroll-tests-up-and-down (margin &optional effective-margin)
  31   (unless effective-margin
  32     (setq effective-margin margin))
  33   (erase-buffer)
  34   (insert (mapconcat #'number-to-string
  35                      (number-sequence 1 200) "\n"))
  36   (goto-char 1)
  37   (sit-for 0)
  38   (let ((scroll-margin margin)
  39         (wstart (window-start)))
  40     ;; Stopping before `scroll-margin' so we shouldn't have
  41     ;; scrolled.
  42     (let ((current-prefix-arg (- (window-text-height) 1 effective-margin)))
  43       (call-interactively 'next-line))
  44     (sit-for 0)
  45     (should (= wstart (window-start)))
  46     ;; Passing `scroll-margin' should trigger scrolling.
  47     (call-interactively 'next-line)
  48     (sit-for 0)
  49     (should (/= wstart (window-start)))
  50     ;; Scroll back to top.
  51     (let ((current-prefix-arg (window-start)))
  52       (call-interactively 'scroll-down-command))
  53     (sit-for 0)
  54     (should (= 1 (window-start)))))
  55
  56 (defun scroll-tests-display-buffer-with-height (buffer alist)
  57   (let ((height (alist-get 'window-height alist)))
  58     (when height
  59       (let* ((window (or (get-buffer-window buffer) (selected-window)))
  60              (lines (floor height))
  61              (partial (round (* (- height lines) (default-line-height)))))
  62         (setq window (cond ((window-in-direction 'above window nil +1))
  63                            ((or (window-in-direction 'below window nil -1)
  64                                 (split-window-below lines))
  65                             window)))
  66         (set-window-buffer window buffer)
  67         (set-window-text-height window lines)
  68         (adjust-window-trailing-edge window partial nil t)
  69         window))))
  70
  71 (defmacro scroll-tests-with-buffer-window (&optional height &rest body)
  72   (declare (debug t) (indent defun))
  73   `(with-temp-buffer
  74      (with-selected-window (display-buffer (current-buffer)
  75                                            '(scroll-tests-display-buffer-with-height
  76                                              . ,(if (numberp height)
  77                                                     `((window-height . ,height))
  78                                                   (push height body)
  79                                                   nil)))
  80        ,@body)))
  81
  82 (ert-deftest scroll-tests-scroll-margin-0 ()
  83   (skip-unless (not noninteractive))
  84   (scroll-tests-with-buffer-window
  85     (scroll-tests-up-and-down 0)))
  86
  87 (ert-deftest scroll-tests-scroll-margin-negative ()
  88   "A negative `scroll-margin' should be the same as 0."
  89   (skip-unless (not noninteractive))
  90   (scroll-tests-with-buffer-window
  91     (scroll-tests-up-and-down -10 0)))
  92
  93 (ert-deftest scroll-tests-scroll-margin-max ()
  94   (skip-unless (not noninteractive))
  95   (scroll-tests-with-buffer-window
  96     (let ((max-margin (/ (window-text-height) 4)))
  97       (scroll-tests-up-and-down max-margin))))
  98
  99 (ert-deftest scroll-tests-scroll-margin-over-max ()
 100   "A `scroll-margin' more than max should be the same as max."
 101   (skip-unless (not noninteractive))
 102   (scroll-tests-with-buffer-window 7
 103     (let ((max-margin (/ (window-text-height) 4)))
 104       (scroll-tests-up-and-down (+ max-margin 1) max-margin)
 105       (scroll-tests-up-and-down (+ max-margin 2) max-margin))))
 106
 107 (ert-deftest scroll-tests-conservative-show-trailing-whitespace ()
 108   "Test for Bug#25792."
 109   ;; Note: requires partial line to trigger problem.
 110   (scroll-tests-with-buffer-window 20.5
 111     (let ((show-trailing-whitespace t)
 112           (scroll-conservatively 101)
 113           (scroll-margin 5))
 114       (insert (mapconcat #'number-to-string
 115                          (number-sequence 1 200) "\n"))
 116       (goto-char 1)
 117       (forward-line 15)
 118       (sit-for 0)
 119       (let ((window-line (count-lines (window-start) (window-point))))
 120         (dotimes (_ 10)
 121           (call-interactively 'next-line)
 122           (sit-for 0)
 123           (should (= window-line (count-lines (window-start)
 124                                               (window-point)))))))))
 125
 126 (defun scroll-tests--point-in-middle-of-window-p ()
 127   (= (count-lines (window-start) (window-point))
 128      (/ (1- (floor (window-screen-lines))) 2)))
 129
 130 (cl-defun scroll-tests--scroll-margin-whole-window (&key with-line-spacing)
 131   "Test `maximum-scroll-margin' at 0.5.
 132 With a high `scroll-margin', this should keep cursor in the
 133 middle of the window."
 134   (let  ((maximum-scroll-margin 0.5)
 135          (scroll-margin 100))
 136     ;; Choose an odd number of lines, so there is a middle line.
 137     (scroll-tests-with-buffer-window 7
 138       (setq-local line-spacing with-line-spacing)
 139       ;; `set-window-text-height' doesn't count `line-spacing'.
 140       (when with-line-spacing
 141         (window-resize nil (* line-spacing 8) nil nil 'pixels))
 142       (erase-buffer)
 143       (insert (mapconcat #'number-to-string
 144                          (number-sequence 1 200) "\n"))
 145       (goto-char 1)
 146       (sit-for 0)
 147       (call-interactively 'scroll-up-command)
 148       (sit-for 0)
 149       (should (scroll-tests--point-in-middle-of-window-p))
 150       (call-interactively 'scroll-up-command)
 151       (sit-for 0)
 152       (should (scroll-tests--point-in-middle-of-window-p))
 153       (call-interactively 'scroll-down-command)
 154       (sit-for 0)
 155       (should (scroll-tests--point-in-middle-of-window-p)))))
 156
 157 (ert-deftest scroll-tests-scroll-margin-whole-window ()
 158   (skip-unless (not noninteractive))
 159   (scroll-tests--scroll-margin-whole-window))
 160
 161 (ert-deftest scroll-tests-scroll-margin-whole-window-line-spacing ()
 162   ;; `line-spacing' has no effect on tty displays.
 163   (skip-unless (display-graphic-p))
 164   (scroll-tests--scroll-margin-whole-window :with-line-spacing 3))
 165
 166
 167 ;;; scroll-tests.el ends here