test/manual/redisplay-testsuite.el

   1 ;;; redisplay-testsuite.el --- Test suite for redisplay.
   2
   3 ;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Chong Yidong <cyd@stupidchicken.com>
   6 ;; Keywords:       internal
   7 ;; Human-Keywords: internal
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Type M-x test-redisplay RET to generate the test buffer.
  27
  28 ;;; Code:
  29
  30 (defun test-insert-overlay (text &rest props)
  31   (let ((opoint (point))
  32         overlay)
  33     (insert text)
  34     (setq overlay (make-overlay opoint (point)))
  35     (while props
  36       (overlay-put overlay (car props) (cadr props))
  37       (setq props (cddr props)))
  38     overlay))
  39
  40 (defun test-redisplay-1 ()
  41   (insert "Test 1: Displaying adjacent and overlapping overlays:\n\n")
  42   (insert "  Expected: gnu emacs\n")
  43   (insert "  Results:  ")
  44   (test-insert-overlay "n" 'before-string "g" 'after-string  "u ")
  45   (test-insert-overlay "ma" 'before-string "e" 'after-string  "cs")
  46   (insert "\n\n")
  47   (insert "  Expected: gnu emacs\n")
  48   (insert "  Results:  ")
  49   (test-insert-overlay "u" 'before-string "gn")
  50   (test-insert-overlay "ma" 'before-string " e" 'after-string  "cs")
  51   (insert "\n\n")
  52   (insert "  Expected: gnu emacs\n")
  53   (insert "  Results:  ")
  54   (test-insert-overlay "XXX" 'display "u "
  55                        'before-string "gn" 'after-string  "em")
  56   (test-insert-overlay "a" 'after-string  "cs")
  57   (insert "\n\n")
  58   (insert "  Expected: gnu emacs\n")
  59   (insert "  Results:  ")
  60   (test-insert-overlay "u " 'before-string "gn" 'after-string  "em")
  61   (test-insert-overlay "XXX" 'display "a" 'after-string  "cs")
  62   (insert "\n\n"))
  63
  64 (defun test-redisplay-2 ()
  65   (insert "Test 2: Mouse highlighting.  Move your mouse over the letters XXX:\n\n")
  66   (insert "  Expected: "
  67           (propertize "xxxXXXxxx" 'face 'highlight)
  68           "...---...\n  Test:     ")
  69   (test-insert-overlay "XXX" 'before-string "xxx" 'after-string  "xxx"
  70                        'mouse-face 'highlight )
  71   (test-insert-overlay "---" 'before-string "..." 'after-string  "...")
  72   (insert "\n\n  Expected: "
  73           (propertize "xxxXXX" 'face 'highlight)
  74           "...---...\n  Test:     ")
  75   (test-insert-overlay "XXX" 'before-string "xxx" 'mouse-face 'highlight)
  76   (test-insert-overlay "---" 'before-string "..." 'after-string  "...")
  77   (insert "\n\n  Expected: "
  78           (propertize "XXX" 'face 'highlight)
  79           "...---...\n  Test:     ")
  80   (test-insert-overlay "..." 'display "XXX" 'mouse-face 'highlight)
  81   (test-insert-overlay "---" 'before-string "..." 'after-string  "...")
  82   (insert "\n\n  Expected: "
  83           (propertize "XXXxxx" 'face 'highlight)
  84           "...\n  Test:     ")
  85   (test-insert-overlay "..." 'display "XXX" 'after-string "xxx"
  86                        'mouse-face 'highlight)
  87   (test-insert-overlay "error" 'display "...")
  88   (insert "\n\n  Expected: "
  89           "---..."
  90           (propertize "xxxXXX" 'face 'highlight)
  91           "\n  Test:     ")
  92   (test-insert-overlay "xxx" 'display "---" 'after-string "...")
  93   (test-insert-overlay "error" 'before-string "xxx" 'display "XXX"
  94                        'mouse-face 'highlight)
  95   (insert "\n\n  Expected: "
  96           "...---..."
  97           (propertize "xxxXXXxxx" 'face 'highlight)
  98           "\n  Test:     ")
  99   (test-insert-overlay "---" 'before-string "..." 'after-string  "...")
 100   (test-insert-overlay "XXX" 'before-string "xxx" 'after-string  "xxx"
 101                        'mouse-face 'highlight)
 102   (insert "\n\n  Expected: "
 103           "..."
 104           (propertize "XXX" 'face 'highlight)
 105           "...\n  Test:     ")
 106   (test-insert-overlay "---"
 107                        'display (propertize "XXX" 'mouse-face 'highlight)
 108                        'before-string "..."
 109                        'after-string  "...")
 110   (insert "\n\n  Expected: "
 111           (propertize "XXX\n" 'face 'highlight)
 112           "\n  Test:     ")
 113   (test-insert-overlay "XXX\n" 'mouse-face 'highlight)
 114   (insert "\n\n"))
 115
 116 (defun test-redisplay-3 ()
 117   (insert "Test 3: Overlay with strings and images:\n\n")
 118   (let ((img-data "#define x_width 8
 119 #define x_height 8
 120 static unsigned char x_bits[] = {0xff, 0x81, 0xbd, 0xa5, 0xa5, 0xbd, 0x81, 0xff };"))
 121     ;; Control
 122     (insert "  Expected: AB"
 123             (propertize "X" 'display `(image :data ,img-data :type xbm))
 124             "CD\n")
 125
 126     ;; Overlay with before, after, and image display string.
 127     (insert "  Result 1: ")
 128     (let ((opoint (point)))
 129       (insert "AXD\n")
 130       (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 131         (overlay-put ov 'before-string "B")
 132         (overlay-put ov 'after-string "C")
 133         (overlay-put ov 'display
 134                      `(image :data ,img-data :type xbm))))
 135
 136     ;; Overlay with before and after string, and image text prop.
 137     (insert "  Result 2: ")
 138     (let ((opoint (point)))
 139       (insert "AXD\n")
 140       (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 141         (overlay-put ov 'before-string "B")
 142         (overlay-put ov 'after-string "C")
 143         (put-text-property (1+ opoint) (+ 2 opoint) 'display
 144                            `(image :data ,img-data :type xbm))))
 145
 146     ;; Overlays with adjacent before and after strings, and image text
 147     ;; prop.
 148     (insert "  Result 3: ")
 149     (let ((opoint (point)))
 150       (insert "AXD\n")
 151       (let ((ov1 (make-overlay opoint (1+ opoint)))
 152             (ov2 (make-overlay (+ 2 opoint) (+ 3 opoint))))
 153         (overlay-put ov1 'after-string "B")
 154         (overlay-put ov2 'before-string "C")
 155         (put-text-property (1+ opoint) (+ 2 opoint) 'display
 156                            `(image :data ,img-data :type xbm))))
 157
 158     ;; Three overlays.
 159     (insert "  Result 4: ")
 160     (let ((opoint (point)))
 161       (insert "AXD\n\n")
 162       (let ((ov1 (make-overlay opoint (1+ opoint)))
 163             (ov2 (make-overlay (+ 2 opoint) (+ 3 opoint)))
 164             (ov3 (make-overlay (1+ opoint) (+ 2 opoint))))
 165         (overlay-put ov1 'after-string "B")
 166         (overlay-put ov2 'before-string "C")
 167         (overlay-put ov3 'display `(image :data ,img-data :type xbm))))))
 168
 169 (defun test-redisplay-4 ()
 170   (insert "Test 4: Overlay strings and invisibility:\n\n")
 171   ;; Before and after strings with non-nil `invisibility'.
 172   (insert "  Expected: ABC\n")
 173   (insert "    Result: ")
 174   (let ((opoint (point)))
 175     (insert "ABC\n")
 176     (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 177       (overlay-put ov 'before-string
 178                    (propertize "XX" 'invisible
 179                                'test-redisplay--simple-invis))
 180       (overlay-put ov 'after-string
 181                    (propertize "XX" 'invisible
 182                                'test-redisplay--simple-invis))))
 183
 184   ;; Before and after strings bogus `invisibility' property (value is
 185   ;; not listed in `buffer-invisibility-spec').
 186   (insert "\n  Expected: ABC")
 187   (insert "\n    Result: ")
 188   (let ((opoint (point)))
 189     (insert "B\n")
 190     (let ((ov (make-overlay opoint (1+ opoint))))
 191       (overlay-put ov 'before-string
 192                    (propertize "A" 'invisible 'bogus-invis-spec))
 193       (overlay-put ov 'after-string
 194                    (propertize "C" 'invisible 'bogus-invis-spec))))
 195
 196   ;; Before/after string with ellipsis `invisibility' property.
 197   (insert "\n  Expected: ...B...")
 198   (insert "\n    Result: ")
 199   (let ((opoint (point)))
 200     (insert "B\n")
 201     (let ((ov (make-overlay opoint (1+ opoint))))
 202       (overlay-put ov 'before-string
 203                    (propertize "A" 'invisible 'test-redisplay--ellipsis-invis))
 204       (overlay-put ov 'after-string
 205                    (propertize "C" 'invisible 'test-redisplay--ellipsis-invis))))
 206
 207   ;; Before/after string with partial ellipsis `invisibility' property.
 208   (insert "\n  Expected: A...ABC...C")
 209   (insert "\n    Result: ")
 210   (let ((opoint (point)))
 211     (insert "B\n")
 212     (let ((ov (make-overlay opoint (1+ opoint)))
 213           (a "AAA")
 214           (c "CCC"))
 215       (put-text-property 1 2 'invisible 'test-redisplay--ellipsis-invis a)
 216       (put-text-property 1 2 'invisible 'test-redisplay--ellipsis-invis c)
 217       (overlay-put ov 'before-string a)
 218       (overlay-put ov 'after-string  c)))
 219
 220   ;; Display string with `invisibility' property.
 221   (insert "\n  Expected: ABC")
 222   (insert "\n    Result: ")
 223   (let ((opoint (point)))
 224     (insert "AYBC\n")
 225     (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 226       (overlay-put ov 'display
 227                    (propertize "XX" 'invisible
 228                                'test-redisplay--simple-invis))))
 229   ;; Display string with bogus `invisibility' property.
 230   (insert "\n  Expected: ABC")
 231   (insert "\n    Result: ")
 232   (let ((opoint (point)))
 233     (insert "AXC\n")
 234     (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 235       (overlay-put ov 'display
 236                    (propertize "B" 'invisible 'bogus-invis-spec))))
 237   ;; Display string with ellipsis `invisibility' property.
 238   (insert "\n  Expected: A...C")
 239   (insert "\n    Result: ")
 240   (let ((opoint (point)))
 241     (insert "AXC\n")
 242     (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 243       (overlay-put ov 'display
 244                    (propertize "B" 'invisible
 245                                'test-redisplay--ellipsis-invis))))
 246   ;; Display string with partial `invisibility' property.
 247   (insert "\n  Expected: A...C")
 248   (insert "\n    Result: ")
 249   (let ((opoint (point)))
 250     (insert "X\n")
 251     (let ((ov  (make-overlay opoint (1+ opoint)))
 252           (str "ABC"))
 253       (put-text-property 1 2 'invisible 'test-redisplay--ellipsis-invis str)
 254       (overlay-put ov 'display str)))
 255   ;; Overlay string over invisible text and non-default face.
 256   (insert "\n  Expected: ..." (propertize "ABC" 'face 'highlight) "XYZ")
 257   (insert "\n    Result: ")
 258   (insert (propertize "foo" 'invisible 'test-redisplay--ellipsis-invis))
 259   (let ((ov (make-overlay (point) (point))))
 260     (overlay-put ov 'invisible t)
 261     (overlay-put ov 'window (selected-window))
 262     (overlay-put ov 'after-string
 263                  (propertize "ABC" 'face 'highlight)))
 264   (insert "XYZ\n")
 265   ;; Overlay strings with partial `invisibility' property and with a
 266   ;; display property on the before-string.
 267   (insert "\n  Expected: ..."
 268           (propertize "DEF" 'display '(image :type xpm :file "close.xpm"))
 269           (propertize "ABC" 'face 'highlight) "XYZ")
 270   (insert "\n    Result: ")
 271   (insert (propertize "foo" 'invisible 'test-redisplay--ellipsis-invis))
 272   (let ((ov (make-overlay (point) (point))))
 273     (overlay-put ov 'invisible t)
 274     (overlay-put ov 'window (selected-window))
 275     (overlay-put ov 'after-string
 276                  (propertize "ABC" 'face 'highlight))
 277     (overlay-put ov 'before-string
 278                  (propertize "DEF"
 279                              'display '(image :type xpm :file "close.xpm"))))
 280   (insert "XYZ\n")
 281
 282   ;; Overlay string with 2 adjacent and different invisible
 283   ;; properties.  This caused an infloop before Emacs 25.
 284   (insert "\n  Expected: ABC")
 285   (insert "\n    Result: ")
 286   (let ((opoint (point)))
 287     (insert "ABC\n")
 288     (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))
 289           (str (concat (propertize "X"
 290                                    'invisible 'test-redisplay--simple-invis)
 291                        (propertize "Y"
 292                                    'invisible 'test-redisplay--simple-invis2))))
 293       (overlay-put ov 'after-string str)))
 294
 295   (insert "\n"))
 296
 297 (defvar test-redisplay-5a-expected-overlay nil)
 298 (defvar test-redisplay-5a-result-overlay nil)
 299 (defvar test-redisplay-5b-expected-overlay nil)
 300 (defvar test-redisplay-5b-result-overlay nil)
 301
 302 (defun test-redisplay-5-toggle (_event)
 303   (interactive "e")
 304   (setq display-raw-bytes-as-hex (not display-raw-bytes-as-hex))
 305   (let ((label (if display-raw-bytes-as-hex "\\x80" "\\200")))
 306     (overlay-put test-redisplay-5a-expected-overlay 'display
 307                  (propertize label 'face 'escape-glyph)))
 308   (let ((label (if display-raw-bytes-as-hex "\\x3fffc" "\\777774")))
 309     (overlay-put test-redisplay-5b-expected-overlay 'display
 310                  (propertize label 'face 'escape-glyph))))
 311
 312 (defun test-redisplay-5 ()
 313   (insert "Test 5: Display of raw bytes:\n\n")
 314   (insert "  Expected: ")
 315   (setq test-redisplay-5a-expected-overlay
 316         (test-insert-overlay " " 'display
 317                              (propertize "\\200" 'face 'escape-glyph)))
 318   (insert "\n    Result: ")
 319   (setq test-redisplay-5a-result-overlay
 320         (test-insert-overlay " " 'display "\200"))
 321   (insert "\n\n")
 322   (insert "  Expected: ")
 323   ;; This tests a large codepoint, to make sure the internal buffer we
 324   ;; use to produce the representation is large enough.
 325   (aset printable-chars #x3fffc nil)
 326   (setq test-redisplay-5b-expected-overlay
 327         (test-insert-overlay " " 'display
 328                              (propertize "\\777774" 'face 'escape-glyph)))
 329   (insert "\n    Result: ")
 330   (setq test-redisplay-5b-result-overlay
 331         (test-insert-overlay " " 'display (char-to-string #x3fffc)))
 332   (insert "\n\n")
 333   (insert-button "Toggle between octal and hex display"
 334                  'action 'test-redisplay-5-toggle))
 335
 336 (defun test-redisplay ()
 337   (interactive)
 338   (let ((buf (get-buffer "*Redisplay Test*")))
 339     (if buf
 340         (kill-buffer buf))
 341     (switch-to-buffer (get-buffer-create "*Redisplay Test*"))
 342     (erase-buffer)
 343     (setq buffer-invisibility-spec
 344           '(test-redisplay--simple-invis
 345             test-redisplay--simple-invis2
 346             (test-redisplay--ellipsis-invis . t)))
 347     (test-redisplay-1)
 348     (test-redisplay-2)
 349     (test-redisplay-3)
 350     (test-redisplay-4)
 351     (test-redisplay-5)
 352     (goto-char (point-min))))