;;; compat-tests.el --- Tests for Compat -*- lexical-binding: t; no-byte-compile: t; -*-
;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
;; This program 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.
;; This program 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 this program. If not, see ")
(buttonize-region 2 7 'c 'd 'h)
(should-not (get-text-property 1 'action))
(should-not (get-text-property 7 'action))
(should-equal 'c (get-text-property 2 'action))
(should-equal 'c (get-text-property 6 'action))
(should-equal 'd (get-text-property 2 'button-data))
(should-equal 'd (get-text-property 6 'button-data))
(should-equal 'h (get-text-property 2 'help-echo))
(should-equal 'h (get-text-property 6 'help-echo))))
(ert-deftest with-narrowing ()
(with-temp-buffer
(insert "abc")
(with-narrowing 2 3 :locked 'foo
(should-equal "b" (buffer-string)))
(should-equal "abc" (buffer-string))
(with-narrowing 2 3
(should-equal "b" (buffer-string)))
(should-equal "abc" (buffer-string))))
(ert-deftest with-memoization ()
(let ((x (cons nil nil)) y computed)
(with-memoization (car x)
(setq computed 'a))
(should-equal (car x) 'a)
(should-equal computed 'a)
(with-memoization (car x)
(setq computed 'b))
(should-equal (car x) 'a)
(should-equal computed 'a)
(with-memoization (cdr x)
(setq computed 'c))
(should-equal (cdr x) 'c)
(should-equal computed 'c)
(with-memoization (cdr x)
(setq computed 'd))
(should-equal (cdr x) 'c)
(should-equal computed 'c)
(with-memoization y
(setq computed 'e))
(should-equal y 'e)
(should-equal computed 'e)
(with-memoization y
(setq computed 'f))
(should-equal y 'e)
(should-equal computed 'e)))
(ert-deftest make-separator-line ()
(should-equal (length (make-separator-line 10)) 11)
(should (string-suffix-p "\n" (make-separator-line 10)))
(should (string-suffix-p "\n" (make-separator-line)))
(should-equal (replace-regexp-in-string "[^\n]" "" (make-separator-line)) "\n"))
(ert-deftest pos-bol ()
(with-temp-buffer
(insert (propertize "one" 'field 1)
(propertize "two" 'field 2)
(propertize "tri" 'field 3)
"\n")
(insert (propertize "one" 'field 1)
(propertize "two" 'field 2)
(propertize "tri" 'field 3)
"\n")
(goto-char 5)
(should-equal (line-beginning-position) 4)
(should-equal (line-end-position) 7)
(should-equal (pos-bol) 1)
(should-equal (pos-eol) 10)
(should-equal (line-beginning-position 1) 4)
(should-equal (line-end-position 1) 7)
(should-equal (pos-bol 1) 1)
(should-equal (pos-eol 1) 10)
(should-equal (line-beginning-position 2) 11)
(should-equal (line-end-position 2) 20)
(should-equal (pos-bol 2) 11)
(should-equal (pos-eol 2) 20)
(goto-char 15)
(should-equal (line-beginning-position) 14)
(should-equal (line-end-position) 17)
(should-equal (pos-bol) 11)
(should-equal (pos-eol) 20)
(should-equal (line-beginning-position 1) 14)
(should-equal (line-end-position 1) 17)
(should-equal (pos-bol 1) 11)
(should-equal (pos-eol 1) 20)
(should-equal (line-beginning-position 0) 1)
(should-equal (line-end-position 0) 10)
(should-equal (pos-bol 0) 1)
(should-equal (pos-eol 0) 10)))
(ert-deftest image-property ()
(let ((image (list 'image)))
;; Add properties.
(setf (image-property image :scale) 1)
(should-equal image '(image :scale 1))
(setf (image-property image :width) 8)
(should-equal image '(image :scale 1 :width 8))
(setf (image-property image :height) 16)
(should-equal image '(image :scale 1 :width 8 :height 16))
;; Delete properties.
(setf (image-property image :type) nil)
(should-equal image '(image :scale 1 :width 8 :height 16))
(setf (image-property image :scale) nil)
(should-equal image '(image :width 8 :height 16))
(setf (image-property image :height) nil)
(should-equal image '(image :width 8))
(setf (image-property image :width) nil)
(should-equal image '(image))))
(ert-deftest read-multiple-choice ()
(let ((orig-re (symbol-function #'read-event))
(orig-rc (symbol-function #'read-char))
(orig-cr completing-read-function))
(unwind-protect
(dolist (test '(("Choose"
(?a "first" "first description")
(?b "second" "second description")
(?c "third"))
("Do it?" (?y "yes") (?n "no"))))
(dolist (choice (cdr test))
(fset #'read-char (lambda (&rest _) (car choice)))
(fset #'read-event (lambda (&rest _) (car choice)))
(setq completing-read-function (lambda (&rest _) (cadr choice)))
(should-equal choice (compat-call read-multiple-choice (car test) (cdr test) nil nil 'long))
(should-equal choice (read-multiple-choice (car test) (cdr test)))))
(fset #'read-event orig-re)
(fset #'read-char orig-rc)
(setq completing-read-function orig-cr))))
(ert-deftest with-environment-variables ()
(let ((A "COMPAT_TESTS__VAR") (B "/foo/bar"))
(should-not (getenv A))
(with-environment-variables ((A B))
(should-equal (getenv A) B))
(should-not (getenv A))))
(ert-deftest with-window-non-dedicated ()
(unwind-protect
(progn
(should-not (window-dedicated-p))
(set-window-dedicated-p nil t)
(should (window-dedicated-p))
(with-window-non-dedicated nil
(should-not (window-dedicated-p)))
(should (window-dedicated-p)))
(set-window-dedicated-p nil nil)))
(ert-deftest count-windows ()
(should (fixnump (compat-call count-windows)))
(should (fixnump (compat-call count-windows t)))
(should (fixnump (compat-call count-windows t t))))
(ert-deftest recenter ()
(save-window-excursion
(set-window-buffer nil (current-buffer))
(compat-call recenter nil nil)
(compat-call recenter nil t)
(compat-call recenter 1 nil)
(compat-call recenter 1 t)))
(ert-deftest get-display-property ()
(with-temp-buffer
(insert (propertize "foo" 'face 'bold 'display '(height 2.0)))
(should-equal (get-display-property 2 'height) 2.0))
(with-temp-buffer
(insert (propertize "foo" 'face 'bold 'display '((height 2.0)
(space-width 2.0))))
(should-equal (get-display-property 2 'height) 2.0)
(should-equal (get-display-property 2 'space-width) 2.0))
(with-temp-buffer
(insert (propertize "foo bar" 'face 'bold
'display '[(height 2.0)
(space-width 20)]))
(should-equal (get-display-property 2 'height) 2.0)
(should-equal (get-display-property 2 'space-width) 20)))
(ert-deftest add-display-text-property ()
(with-temp-buffer
(insert "Foo bar zot gazonk")
(add-display-text-property 4 8 'height 2.0)
(add-display-text-property 2 12 'raise 0.5)
(should-equal (get-text-property 2 'display) '(raise 0.5))
(should-equal (get-text-property 5 'display)
'((raise 0.5) (height 2.0)))
(should-equal (get-text-property 9 'display) '(raise 0.5)))
(with-temp-buffer
(insert "Foo bar zot gazonk")
(put-text-property 4 8 'display [(height 2.0)])
(add-display-text-property 2 12 'raise 0.5)
(should-equal (get-text-property 2 'display) '(raise 0.5))
(should-equal (get-text-property 5 'display)
[(raise 0.5) (height 2.0)])
(should-equal (get-text-property 9 'display) '(raise 0.5)))
(with-temp-buffer
(should-equal (let ((str "some useless string"))
(add-display-text-property 4 8 'height 2.0 str)
(add-display-text-property 2 12 'raise 0.5 str)
str)
#("some useless string"
2 4 (display (raise 0.5))
4 8 (display ((raise 0.5) (height 2.0)))
8 12 (display (raise 0.5))))))
(ert-deftest line-number-at-pos ()
(with-temp-buffer
(insert "\n\n\n")
(narrow-to-region (1+ (point-min)) (point-max))
(should-equal 1 (compat-call line-number-at-pos (point-min)))
(should-equal 2 (compat-call line-number-at-pos (1+ (point-min))))
(should-equal 2 (compat-call line-number-at-pos (point-min) 'abs))
(should-equal 3 (compat-call line-number-at-pos (1+ (point-min)) 'abs))))
(defvar compat-tests--map-1
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-x C-f") #'find-file)
(define-key map (kbd "SPC") #'minibuffer-complete-word)
(define-key map (kbd "RET") #'exit-minibuffer)
(define-key map [remap exit-minibuffer] #'minibuffer-force-complete-and-exit)
(define-key map (kbd "C-c") mode-specific-map)
(define-key map (kbd "s-c") [?\C-c ?\C-c])
(define-key map [t] 'compat-default-command)
map))
(defvar compat-tests--map-2
(let ((map (make-sparse-keymap)))
(keymap-set map "C-x C-f" #'find-file)
(keymap-set map "SPC" #'minibuffer-complete-word)
(keymap-set map "RET" #'exit-minibuffer)
(keymap-set map " " #'minibuffer-force-complete-and-exit)
(keymap-set map "C-c" mode-specific-map)
(keymap-set map "s-c" "C-c C-c")
(keymap-set map "" 'compat-default-command)
map))
(defvar-keymap compat-tests--map-3
"C-x C-f" #'find-file
"SPC" #'minibuffer-complete-word
"RET" #'exit-minibuffer
" " #'minibuffer-force-complete-and-exit
"C-c" mode-specific-map
"s-c" "C-c C-c"
"" 'compat-default-command)
(defvar compat-tests--map-4
(define-keymap
"C-x C-f" #'find-file
"SPC" #'minibuffer-complete-word
"RET" #'exit-minibuffer
" " #'minibuffer-force-complete-and-exit
"C-c" mode-specific-map
"s-c" "C-c C-c"
"" 'compat-default-command))
(ert-deftest defvar-keymap ()
(should-equal compat-tests--map-1 compat-tests--map-2)
(should-equal compat-tests--map-1 compat-tests--map-3)
(should-equal compat-tests--map-1 compat-tests--map-4))
(ert-deftest keymap-set-after ()
(let ((map (make-sparse-keymap)))
(keymap-set-after map "d" 'd "a")
(keymap-set-after map "a" 'a)
(keymap-set-after map "b" 'b)
(keymap-set-after map "c" 'c)
(keymap-set-after map "d" 'd "b") ;; TODO the after argument has no effect?!
(should-equal map '(keymap (?a . a) (?b . b) (?c . c) (?d . d)))))
(ert-deftest keymap-substitute ()
(let ((map (define-keymap
"C-x C-f" #'find-file
"s-f" #'find-file
"C-x b" #'switch-to-buffer)))
(keymap-substitute map #'find-file 'ffap)
(should-equal (keymap-lookup map "C-x b") #'switch-to-buffer)
(should-equal (keymap-lookup map "C-x C-f") 'ffap)
(should-equal (keymap-lookup map "s-f") 'ffap)))
(ert-deftest key-parse ()
(should-equal (key-parse "f") [?f])
(should-equal (key-parse "X") [?X])
(should-equal (key-parse "X f") [?X ?f])
(should-equal (key-parse "") [F2])
(should-equal (key-parse " TAB") [f1 f2 ?\t])
(should-equal (key-parse " RET") [f1 ?\r])
(should-equal (key-parse " SPC") [f1 ?\s])
(should-equal (key-parse "") [f1])
(should-equal (key-parse "") [return])
;; ;; Modifiers:
(should-equal (key-parse "C-x") [?\C-x])
(should-equal (key-parse "C-x a") [?\C-x ?a])
(should-equal (key-parse "C-;") [67108923])
(should-equal (key-parse "C-a") [?\C-a])
(should-equal (key-parse "C-c SPC") [?\C-c ?\s])
(should-equal (key-parse "C-c TAB") [?\C-c ?\t])
(should-equal (key-parse "C-c c") [?\C-c ?c])
(should-equal (key-parse "C-x 4 C-f") [?\C-x ?4 ?\C-f])
(should-equal (key-parse "C-x C-f") [?\C-x ?\C-f])
(should-equal (key-parse "C-M-") [C-M-down])
(should-equal (key-parse "C-RET") [?\C-\r])
(should-equal (key-parse "C-SPC") [?\C-\s])
(should-equal (key-parse "C-TAB") [?\C-\t])
(should-equal (key-parse "C-") [C-down])
(should-equal (key-parse "C-c C-c C-c") [?\C-c ?\C-c ?\C-c])
(should-equal (key-parse "M-a") [?\M-a])
(should-equal (key-parse "M-") [?\M-\d])
(should-equal (key-parse "C-M-a") [?\C-\M-a])
(should-equal (key-parse "M-ESC") [?\M-\e])
(should-equal (key-parse "M-RET") [?\M-\r])
(should-equal (key-parse "M-SPC") [?\M-\s])
(should-equal (key-parse "M-TAB") [?\M-\t])
(should-equal (key-parse "M-x a") [?\M-x ?a])
(should-equal (key-parse "M-") [M-up])
(should-equal (key-parse "M-c M-c M-c") [?\M-c ?\M-c ?\M-c])
(should-equal (key-parse "s-SPC") [?\s-\s])
(should-equal (key-parse "s-a") [?\s-a])
(should-equal (key-parse "s-x a") [?\s-x ?a])
(should-equal (key-parse "s-c s-c s-c") [?\s-c ?\s-c ?\s-c])
(should-equal (key-parse "S-a") [?\S-a])
(should-equal (key-parse "S-x a") [?\S-x ?a])
(should-equal (key-parse "S-c S-c S-c") [?\S-c ?\S-c ?\S-c])
(should-equal (key-parse "H-") [?\H-\r])
(should-equal (key-parse "H-DEL") [?\H-\d])
(should-equal (key-parse "H-a") [?\H-a])
(should-equal (key-parse "H-x a") [?\H-x ?a])
(should-equal (key-parse "H-c H-c H-c") [?\H-\c ?\H-\c ?\H-\c])
(should-equal (key-parse "A-H-a") [?\A-\H-a])
(should-equal (key-parse "A-SPC") [?\A-\s])
(should-equal (key-parse "A-TAB") [?\A-\t])
(should-equal (key-parse "A-a") [?\A-a])
(should-equal (key-parse "A-c A-c A-c") [?\A-c ?\A-c ?\A-c])
(should-equal (key-parse "C-M-a") [?\C-\M-a])
(should-equal (key-parse "C-M-") [C-M-up])
;; ;; Special characters.
(should-equal (key-parse "DEL") [?\d])
(should-equal (key-parse "ESC C-a") [?\e ?\C-a])
(should-equal (key-parse "ESC") [?\e])
(should-equal (key-parse "LFD") [?\n])
(should-equal (key-parse "NUL") [?\0])
(should-equal (key-parse "RET") [?\r])
(should-equal (key-parse "SPC") [?\s])
(should-equal (key-parse "TAB") [?\t])
;; ;; Multibyte
(should-equal (key-parse "ñ") [?ñ])
(should-equal (key-parse "ü") [?ü])
(should-equal (key-parse "ö") [?ö])
(should-equal (key-parse "ğ") [?ğ])
(should-equal (key-parse "ա") [?ա])
(should-equal (key-parse "C-ü") [?\C-ü])
(should-equal (key-parse "M-ü") [?\M-ü])
(should-equal (key-parse "H-ü") [?\H-ü])
;; ;; Handle both new and old style key descriptions (bug#45536).
(should-equal (key-parse "s-") [s-return])
(should-equal (key-parse "C-M-") [C-M-return])
(should-equal (key-parse "") [mouse-1])
(should-equal (key-parse "") [Scroll_Lock]))
(ert-deftest keymap--check ()
(keymap--check "X")
(should-error (keymap--check ""))
(should-error (keymap--check " X")))
(ert-deftest key-valid-p ()
(should-not (key-valid-p ""))
(should (key-valid-p "f"))
(should (key-valid-p "X"))
(should-not (key-valid-p " X"))
(should (key-valid-p "X f"))
(should-not (key-valid-p "a b"))
(should-not (key-valid-p "foobar"))
(should-not (key-valid-p "return"))
(should (key-valid-p ""))
(should (key-valid-p " TAB"))
(should (key-valid-p " RET"))
(should (key-valid-p " SPC"))
(should (key-valid-p ""))
(should-not (key-valid-p "[f1]"))
(should (key-valid-p ""))
(should-not (key-valid-p "< right >"))
;; Modifiers:
(should (key-valid-p "C-x"))
(should (key-valid-p "C-x a"))
(should (key-valid-p "C-;"))
(should (key-valid-p "C-a"))
(should (key-valid-p "C-c SPC"))
(should (key-valid-p "C-c TAB"))
(should (key-valid-p "C-c c"))
(should (key-valid-p "C-x 4 C-f"))
(should (key-valid-p "C-x C-f"))
(should (key-valid-p "C-M-"))
(should-not (key-valid-p ""))
(should (key-valid-p "C-RET"))
(should (key-valid-p "C-SPC"))
(should (key-valid-p "C-TAB"))
(should (key-valid-p "C-"))
(should (key-valid-p "C-c C-c C-c"))
(should (key-valid-p "M-a"))
(should (key-valid-p "M-"))
(should-not (key-valid-p "M-C-a"))
(should (key-valid-p "C-M-a"))
(should (key-valid-p "M-ESC"))
(should (key-valid-p "M-RET"))
(should (key-valid-p "M-SPC"))
(should (key-valid-p "M-TAB"))
(should (key-valid-p "M-x a"))
(should (key-valid-p "M-"))
(should (key-valid-p "M-c M-c M-c"))
(should (key-valid-p "s-SPC"))
(should (key-valid-p "s-a"))
(should (key-valid-p "s-x a"))
(should (key-valid-p "s-c s-c s-c"))
(should-not (key-valid-p "S-H-a"))
(should (key-valid-p "S-a"))
(should (key-valid-p "S-x a"))
(should (key-valid-p "S-c S-c S-c"))
(should (key-valid-p "H-"))
(should (key-valid-p "H-DEL"))
(should (key-valid-p "H-a"))
(should (key-valid-p "H-x a"))
(should (key-valid-p "H-c H-c H-c"))
(should (key-valid-p "A-H-a"))
(should (key-valid-p "A-SPC"))
(should (key-valid-p "A-TAB"))
(should (key-valid-p "A-a"))
(should (key-valid-p "A-c A-c A-c"))
(should (key-valid-p "C-M-a"))
(should (key-valid-p "C-M-"))
;; Special characters.
(should (key-valid-p "DEL"))
(should (key-valid-p "ESC C-a"))
(should (key-valid-p "ESC"))
(should (key-valid-p "LFD"))
(should (key-valid-p "NUL"))
(should (key-valid-p "RET"))
(should (key-valid-p "SPC"))
(should (key-valid-p "TAB"))
(should-not (key-valid-p "\^i"))
(should-not (key-valid-p "^M"))
;; With numbers.
(should-not (key-valid-p "\177"))
(should-not (key-valid-p "\000"))
(should-not (key-valid-p "\\177"))
(should-not (key-valid-p "\\000"))
(should-not (key-valid-p "C-x \\150"))
;; Multibyte
(should (key-valid-p "ñ"))
(should (key-valid-p "ü"))
(should (key-valid-p "ö"))
(should (key-valid-p "ğ"))
(should (key-valid-p "ա"))
(should-not (key-valid-p "üüöö"))
(should (key-valid-p "C-ü"))
(should (key-valid-p "M-ü"))
(should (key-valid-p "H-ü"))
;; Handle both new and old style key descriptions (bug#45536).
(should (key-valid-p "s-"))
(should-not (key-valid-p ""))
(should (key-valid-p "C-M-"))
(should-not (key-valid-p ""))
(should (key-valid-p ""))
(should (key-valid-p ""))
(should-not (key-valid-p "c-x"))
(should-not (key-valid-p "C-xx"))
(should-not (key-valid-p "M-xx"))
(should-not (key-valid-p "M-x")))
(ert-deftest keymap-lookup ()
(should-not (keymap-lookup compat-tests--map-1 "C-x b"))
(should-equal (keymap-lookup compat-tests--map-1 "C-x C-f") #'find-file)
(should-equal (keymap-lookup compat-tests--map-1 "RET") #'exit-minibuffer)
(should-equal (keymap-lookup compat-tests--map-1 "C-c") mode-specific-map)
(should-equal (keymap-lookup compat-tests--map-1 "s-c") [?\C-c ?\C-c])
(should-not (keymap-lookup compat-tests--map-1 "x"))
(should-equal (keymap-lookup compat-tests--map-1 "x" t) 'compat-default-command))
(ert-deftest keymap-local-lookup ()
(let ((orig (current-local-map)))
(unwind-protect
(progn
(use-local-map compat-tests--map-1)
(should-not (keymap-local-lookup "C-x b"))
(should-equal (keymap-local-lookup "C-x C-f") #'find-file)
(should-equal (keymap-lookup compat-tests--map-1 "RET" nil t) #'exit-minibuffer)
(should-equal (keymap-local-lookup "RET") #'minibuffer-force-complete-and-exit)
(should-equal (keymap-local-lookup "C-c") mode-specific-map)
(should-equal (keymap-local-lookup "s-c") [?\C-c ?\C-c])
(should-not (keymap-local-lookup "x"))
(should-equal (keymap-local-lookup "x" t) 'compat-default-command))
(use-local-map orig))))
(ert-deftest keymap-local-set ()
(let ((orig (current-local-map)))
(unwind-protect
(progn
(use-local-map (make-sparse-keymap))
(should-not (keymap-local-lookup "s-c"))
(should-not (keymap-local-lookup "x"))
(keymap-local-set "s-c" 'test)
(keymap-local-set "" 'default)
(should-equal (keymap-local-lookup "s-c") 'test)
(should-equal (keymap-local-lookup "x" t) 'default)
(should-not (keymap-local-lookup "x")))
(use-local-map orig))
(should-not (keymap-local-lookup "s-c"))))
(ert-deftest keymap-global-set ()
(let ((orig (current-global-map)))
(unwind-protect
(progn
(use-global-map (make-sparse-keymap))
(should-not (keymap-global-lookup "s-c"))
(should-not (keymap-global-lookup "x"))
(keymap-global-set "s-c" 'test)
(keymap-global-set "" 'default)
(should-equal (keymap-global-lookup "s-c") 'test)
(should-equal (keymap-global-lookup "x" t) 'default)
(should-not (keymap-global-lookup "x")))
(use-global-map orig))
(should-not (keymap-global-lookup "s-c"))))
(ert-deftest keymap-global-lookup ()
(should-equal (keymap-global-lookup "C-x b") #'switch-to-buffer)
(should-equal (keymap-global-lookup "C-x C-f") #'find-file)
(should-equal (keymap-global-lookup "C-c") #'mode-specific-command-prefix))
(ert-deftest keymap-unset ()
(let ((map (make-sparse-keymap)))
(define-key map "\M-x" #'execute-extended-command)
(define-key map "\C-x\C-f" #'find-file)
(define-key map "\C-y" #'yank)
(keymap-unset map "M-x")
(keymap-unset map "C-x C-f")
(keymap-unset map "C-y")
(should-equal map '(keymap (25) (24 keymap (6)) (27 keymap (120)))))
(let ((map (make-sparse-keymap)))
(define-key map "\M-x" #'execute-extended-command)
(define-key map "\C-x\C-f" #'find-file)
(define-key map "\C-y" #'yank)
(keymap-unset map "M-x" t)
(keymap-unset map "C-x C-f" t)
(keymap-unset map "C-y" t)
(should-equal map '(keymap (24 keymap) (27 keymap)))))
(ert-deftest keymap-local-unset ()
(let ((map (make-sparse-keymap))
(orig (current-local-map)))
(unwind-protect
(progn
(use-local-map map)
(define-key map "\M-x" #'execute-extended-command)
(define-key map "\C-x\C-f" #'find-file)
(define-key map "\C-y" #'yank)
(keymap-local-unset "M-x")
(keymap-local-unset "C-x C-f" t)
(keymap-local-unset "C-y" t)
(should-equal (current-local-map) '(keymap (24 keymap) (27 keymap (120)))))
(use-local-map orig))))
(ert-deftest keymap-global-unset ()
(let ((map (make-sparse-keymap))
(orig (current-global-map)))
(unwind-protect
(progn
(use-global-map map)
(define-key map "\M-x" #'execute-extended-command)
(define-key map "\C-x\C-f" #'find-file)
(define-key map "\C-y" #'yank)
(keymap-global-unset "M-x")
(keymap-global-unset "C-x C-f" t)
(keymap-global-unset "C-y" t)
(should-equal (current-global-map) '(keymap (24 keymap) (27 keymap (120)))))
(use-global-map orig))))
(ert-deftest define-key ()
(let ((map (make-sparse-keymap)))
(define-key map "\M-x" #'execute-extended-command)
(define-key map "\C-x\C-f" #'find-file)
(define-key map "\C-y" #'yank)
(compat-call define-key map "\M-x" nil t)
(compat-call define-key map "\C-x\C-f" nil t)
(compat-call define-key map "\C-y" nil t)
(should-equal map '(keymap (24 keymap) (27 keymap)))))
(defun compat-tests--function-put ())
(ert-deftest function-put ()
(function-put #'compat-tests--function-put 'compat-test 42)
(should-equal 42 (function-get #'compat-tests--function-put 'compat-test)))
(ert-deftest function-alias-p ()
(defun compat-tests--alias-fun ())
(should-not (function-alias-p 1))
(should-not (function-alias-p 'compat-tests--alias-fun))
(defalias 'compat-tests--alias-a 'compat-tests--alias-b)
(defalias 'compat-tests--alias-b 'compat-tests--alias-c)
(should-equal (function-alias-p 'compat-tests--alias-a)
'(compat-tests--alias-b compat-tests--alias-c))
(defalias 'compat-tests--alias-d 'compat-tests--alias-e)
(defalias 'compat-tests--alias-e 'compat-tests--alias-d)
(should-error (function-alias-p 'compat-tests--alias-d))
(should-equal (function-alias-p 'compat-tests--alias-d 'noerror)
'(compat-tests--alias-e))
(should-equal (function-alias-p 'compat-tests--alias-d t)
'(compat-tests--alias-e)))
(ert-deftest ignore-error ()
(should-equal (ignore-error (end-of-file)
(read ""))
nil)
(should-equal (ignore-error end-of-file
(read ""))
nil)
(should-error (ignore-error foo
(read ""))))
(ert-deftest hash-table-empty-p ()
(should (hash-table-empty-p (make-hash-table)))
(let ((ht (make-hash-table)))
(puthash 'k 'v ht)
(should-not (hash-table-empty-p ht))))
(ert-deftest thread-first ()
(should-equal (thread-first (+ 40 2)) 42)
(should-equal (thread-first
5
(+ 20)
(/ 25)
-
(+ 40)) 39)
(should-equal (thread-first
"this-is-a-string"
(split-string "-")
(nbutlast 2)
(append (list "good")))
(list "this" "is" "good")))
(ert-deftest thread-last ()
(should-equal (thread-last (+ 40 2)) 42)
(should-equal (thread-last
5
(+ 20)
(/ 25)
-
(+ 40)) 39)
(should-equal (thread-last
(list 1 -2 3 -4 5)
(mapcar #'abs)
(cl-reduce #'+)
(format "abs sum is: %s"))
"abs sum is: 15"))
(ert-deftest ntake ()
(should-not (ntake 5 nil))
(should-equal '(1 2) (ntake 5 '(1 2)))
(should-equal '(1 2 3) (ntake 3 '(1 2 3 4))))
(ert-deftest take ()
(should-not (take 5 nil))
(should-equal '(1 2) (take 5 '(1 2)))
(should-equal '(1 2 3) (take 3 '(1 2 3 4))))
(ert-deftest format-message ()
(should-equal (format-message "a=%s b=%s" 1 2) "a=1 b=2"))
(defvar compat-tests--boundp)
(defvar compat-tests--global-boundp)
(ert-deftest buffer-local-boundp ()
(let ((buf (generate-new-buffer "boundp")))
(with-current-buffer buf
(setq-local compat-tests--boundp t))
(setq compat-tests--global-boundp t)
(should (buffer-local-boundp 'compat-tests--boundp buf))
(should-not (buffer-local-boundp 'test-not-boundp buf))
(should (buffer-local-boundp 'compat-tests--global-boundp buf))))
(defvar compat-tests--local-a nil)
(defvar compat-tests--local-b nil)
(defvar compat-tests--local-c nil)
(ert-deftest setq-local ()
(compat-call setq-local compat-tests--local-a 1 compat-tests--local-b 2 compat-tests--local-c 3)
(should-equal compat-tests--local-a 1)
(should-equal compat-tests--local-b 2)
(should-equal compat-tests--local-c 3))
(defvar compat-tests--global)
(defvar compat-tests--local)
(defvar compat-tests--unexist)
(ert-deftest buffer-local-set-state ()
(setq compat-tests--global 1)
(with-temp-buffer
(setq-local compat-tests--local 2)
(let ((state (buffer-local-set-state compat-tests--global 10
compat-tests--local 20
compat-tests--unexist 30)))
(should (= compat-tests--global 10))
(should (= compat-tests--local 20))
(should (= compat-tests--unexist 30))
(buffer-local-restore-state state)
(should (= compat-tests--global 1))
(should (= compat-tests--local 2))
(should-not (boundp 'compat-tests--unexist)))))
(ert-deftest gensym ()
(let ((orig gensym-counter))
(should (integerp gensym-counter))
(should (symbolp (gensym "compat")))
(should (string-prefix-p "compat" (symbol-name (gensym 'compat))))
(should (string-prefix-p "compat" (symbol-name (gensym "compat"))))
(should-equal gensym-counter (+ orig 3))))
(ert-deftest delete-line ()
(with-temp-buffer
(insert "first\nsecond\nthird\n")
(goto-char 7)
(delete-line)
(should-equal (buffer-string) "first\nthird\n")))
(ert-deftest list-of-strings-p ()
(should-not (list-of-strings-p 1))
(should (list-of-strings-p nil))
(should (list-of-strings-p '("a" "b")))
(should-not (list-of-strings-p ["a" "b"]))
(should-not (list-of-strings-p '("a" nil "b")))
(should-not (list-of-strings-p '("a" "b" . "c"))))
(ert-deftest plistp ()
(should (plistp '(:a a :b b)))
(should (plistp '(1 2 3 4)))
(should-not (plistp '(1 2 3)))
(should-not (plistp '(1 . 2)))
(should-not (plistp '(1 2 . 3)))
(should-not (let ((l (list 1 2 3)))
(setf (nthcdr 3 l) l)
(plistp l))))
(ert-deftest plist-get ()
(let (list)
(setq list (compat-call plist-put list 'first 1))
(setq list (compat-call plist-put list 'second 2))
(setq list (compat-call plist-put list 'first 10))
(should-equal (compat-call plist-get list 'first) 10)
(should-equal (compat-call plist-get list 'second) 2)
(should (compat-call plist-member list 'first))
(should-not (compat-call plist-member list 'third)))
(let (list)
(setq list (compat-call plist-put list "first" 1 #'string=))
(setq list (compat-call plist-put list "second" 2 #'string=))
(setq list (compat-call plist-put list "first" 10 #'string=))
(should-equal (compat-call plist-get list "first" #'string=) 10)
(should-equal (compat-call plist-get list "second" #'string=) 2)
(should (compat-call plist-member list "first" #'string=))
(should-not (compat-call plist-member list "third" #'string=))))
(ert-deftest garbage-collect-maybe ()
(garbage-collect-maybe 10))
(ert-deftest buffer-hash ()
(should-equal (sha1 "foo") "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33")
(should-equal (with-temp-buffer
(insert "foo")
(buffer-hash))
(sha1 "foo"))
;; This tests whether the presence of a gap in the middle of the
;; buffer is handled correctly.
(should-equal (with-temp-buffer
(insert "foo")
(goto-char 2)
(insert " ")
(backward-delete-char 1)
(buffer-hash))
(sha1 "foo")))
(ert-deftest with-buffer-unmodified-if-unchanged ()
(with-temp-buffer
(with-buffer-unmodified-if-unchanged
(insert "t"))
(should (buffer-modified-p)))
(with-temp-buffer
(with-buffer-unmodified-if-unchanged
(insert "t")
(delete-char -1))
(should-not (buffer-modified-p)))
;; Shouldn't error.
(should
(with-temp-buffer
(with-buffer-unmodified-if-unchanged
(insert "t")
(delete-char -1)
(kill-buffer))))
(with-temp-buffer
(let ((outer (current-buffer)))
(with-temp-buffer
(let ((inner (current-buffer)))
(with-buffer-unmodified-if-unchanged
(insert "t")
(delete-char -1)
(set-buffer outer))
(with-current-buffer inner
(should-not (buffer-modified-p))))))))
(ert-deftest insert-into-buffer ()
;; Without optional compat--arguments
(with-temp-buffer
(let ((other (current-buffer)))
(insert "abc")
(with-temp-buffer
(insert "def")
(insert-into-buffer other))
(should (string= (buffer-string) "abcdef"))))
;; With one optional argument
(with-temp-buffer
(let ((other (current-buffer)))
(insert "abc")
(with-temp-buffer
(insert "def")
(insert-into-buffer other 2))
(should (string= (buffer-string) "abcef"))))
;; With two optional arguments
(with-temp-buffer
(let ((other (current-buffer)))
(insert "abc")
(with-temp-buffer
(insert "def")
(insert-into-buffer other 2 3))
(should (string= (buffer-string) "abce")))))
(ert-deftest bool-vector ()
(should-equal (bool-vector) (bool-vector-not (bool-vector)))
(should-equal (bool-vector t) (bool-vector-not (bool-vector nil)))
(should-equal (bool-vector nil) (bool-vector-not (bool-vector t)))
(should-equal (bool-vector t t) (bool-vector-not (bool-vector nil nil)))
(should-equal (bool-vector t nil) (bool-vector-not (bool-vector nil t)))
(should-equal (bool-vector nil t) (bool-vector-not (bool-vector t nil)))
(should-equal (bool-vector nil nil) (bool-vector-not (bool-vector t t))))
(ert-deftest assoc ()
;; Fallback behaviour:
(should-not (compat-call assoc 1 nil)) ;empty list
(should-equal '(1) (compat-call assoc 1 '((1)))) ;single element list
(should-not (compat-call assoc 1 '(1)))
(should-equal '(2) (compat-call assoc 2 '((1) (2) (3)))) ;multiple element list
(should-not (compat-call assoc 2 '(1 2 3)))
(should-equal '(2) (compat-call assoc 2 '(1 (2) 3)))
(should-not (compat-call assoc 2 '((1) 2 (3))))
(should-equal '(1) (compat-call assoc 1 '((3) (2) (1))))
(should-equal '("a") (compat-call assoc "a" '(("a") ("b") ("c")))) ;non-primitive elements
(should-equal '("a" 0) (compat-call assoc "a" '(("c" . "a") "b" ("a" 0))))
;; With testfn:
(should-equal '(1) (compat-call assoc 3 '((10) (4) (1) (9)) #'<))
(should-equal '("a") (compat-call assoc "b" '(("c") ("a") ("b")) #'string-lessp))
(should-equal '("b") (compat-call assoc "a" '(("a") ("a") ("b"))
(lambda (s1 s2) (not (string= s1 s2)))))
(should-equal
'("\\.el\\'" . emacs-lisp-mode)
(compat-call assoc
"file.el"
'(("\\.c\\'" . c-mode)
("\\.p\\'" . pascal-mode)
("\\.el\\'" . emacs-lisp-mode)
("\\.awk\\'" . awk-mode))
#'string-match-p)))
(ert-deftest assoc-delete-all ()
(should-equal (list) (compat-call assoc-delete-all 0 (list)))
;; Test `eq'
(should-equal '((1 . one)) (compat-call assoc-delete-all 0 (list (cons 1 'one))))
(should-equal '((1 . one) a) (compat-call assoc-delete-all 0 (list (cons 1 'one) 'a)))
(should-equal '((1 . one)) (compat-call assoc-delete-all 0 (list (cons 0 'zero) (cons 1 'one))))
(should-equal '((1 . one)) (compat-call assoc-delete-all 0 (list (cons 0 'zero) (cons 0 'zero) (cons 1 'one))))
(should-equal '((1 . one)) (compat-call assoc-delete-all 0 (list (cons 0 'zero) (cons 1 'one) (cons 0 'zero))))
(should-equal '((1 . one) a) (compat-call assoc-delete-all 0 (list (cons 0 'zero) (cons 1 'one) 'a (cons 0 'zero))))
(should-equal '(a (1 . one)) (compat-call assoc-delete-all 0 (list 'a (cons 0 'zero) (cons 1 'one) (cons 0 'zero))))
;; Test `equal'
(should-equal '(("one" . one)) (compat-call assoc-delete-all "zero" (list (cons "one" 'one))))
(should-equal '(("one" . one) a) (compat-call assoc-delete-all "zero" (list (cons "one" 'one) 'a)))
(should-equal '(("one" . one)) (compat-call assoc-delete-all "zero" (list (cons "zero" 'zero) (cons "one" 'one))))
(should-equal '(("one" . one)) (compat-call assoc-delete-all "zero" (list (cons "zero" 'zero) (cons "zero" 'zero) (cons "one" 'one))))
(should-equal '(("one" . one)) (compat-call assoc-delete-all "zero" (list (cons "zero" 'zero) (cons "one" 'one) (cons "zero" 'zero))))
(should-equal '(("one" . one) a) (compat-call assoc-delete-all "zero" (list (cons "zero" 'zero) (cons "one" 'one) 'a (cons "zero" 'zero))))
(should-equal '(a ("one" . one)) (compat-call assoc-delete-all "zero" (list 'a (cons "zero" 'zero) (cons "one" 'one) (cons "zero" 'zero))))
;; Test custom predicate
(should-equal '() (compat-call assoc-delete-all 0 (list (cons 1 'one)) #'/=))
(should-equal '(a) (compat-call assoc-delete-all 0 (list (cons 1 'one) 'a) #'/=))
(should-equal '((0 . zero)) (compat-call assoc-delete-all 0 (list (cons 0 'zero) (cons 1 'one)) #'/=))
(should-equal '((0 . zero) (0 . zero)) (compat-call assoc-delete-all 0 (list (cons 0 'zero) (cons 0 'zero) (cons 1 'one)) #'/=))
(should-equal '((0 . zero) (0 . zero)) (compat-call assoc-delete-all 0 (list (cons 0 'zero) (cons 1 'one) (cons 0 'zero)) #'/=))
(should-equal '((0 . zero) a (0 . zero)) (compat-call assoc-delete-all 0 (list (cons 0 'zero) (cons 1 'one) 'a (cons 0 'zero)) #'/=))
(should-equal '(a (0 . zero) (0 . zero)) (compat-call assoc-delete-all 0 (list 'a (cons 0 'zero) (cons 1 'one) (cons 0 'zero)) #'/=)))
(ert-deftest derived-mode-p ()
(let ((one (make-symbol "1"))
(two (make-symbol "2"))
(three (make-symbol "3"))
(one.5 (make-symbol "1.5"))
(eins (make-symbol "𝟙")))
(put two 'derived-mode-parent one)
(put one.5 'derived-mode-parent one)
(put three 'derived-mode-parent two)
(should-equal one (provided-mode-derived-p one one))
(should-equal one (provided-mode-derived-p two one))
(should-equal one (provided-mode-derived-p three one))
(should-not (provided-mode-derived-p one eins))
(should-not (provided-mode-derived-p two eins))
(should-not (provided-mode-derived-p two one.5))
(should-equal one (provided-mode-derived-p two one.5 one))
(should-equal two (provided-mode-derived-p two one.5 two))
(should-equal one (provided-mode-derived-p three one.5 one))
(should-equal two (provided-mode-derived-p three one.5 one two))
(should-equal two (provided-mode-derived-p three one.5 two one))
(should-equal three (provided-mode-derived-p three one.5 two one three))
(should-equal three (provided-mode-derived-p three one.5 three two one))
(let ((major-mode three))
(should-equal one (derived-mode-p one))
(should-equal one (derived-mode-p one.5 one))
(should-equal two (derived-mode-p one.5 one two))
(should-equal two (derived-mode-p one.5 two one))
(should-equal three (derived-mode-p one.5 two one three))
(should-equal three (derived-mode-p one.5 three two one)))))
(ert-deftest format-prompt ()
(should-equal "Prompt: " (format-prompt "Prompt" nil))
(should-equal "Prompt: " (format-prompt "Prompt" ""))
(should-equal "Prompt (default ): " (format-prompt "Prompt" " "))
(should-equal "Prompt (default 3): " (format-prompt "Prompt" 3))
(should-equal "Prompt (default abc): " (format-prompt "Prompt" "abc"))
(should-equal "Prompt (default abc def): " (format-prompt "Prompt" "abc def"))
(should-equal "Prompt 10: " (format-prompt "Prompt %d" nil 10))
(should-equal "Prompt \"abc\" (default 3): " (format-prompt "Prompt %S" 3 "abc")))
(ert-deftest cXXXr ()
(let ((xxx '(((a . b) . (c . d)) . ((e . f) . (g . h)))))
(should-not (caaar ()))
(should-not (caadr ()))
(should-not (cadar ()))
(should-not (caddr ()))
(should-not (cdaar ()))
(should-not (cdadr ()))
(should-not (cddar ()))
(should-not (cdddr ()))
(should-equal 'a (caaar xxx))
(should-equal 'e (caadr xxx))
(should-equal 'c (cadar xxx))
(should-equal 'g (caddr xxx))
(should-equal 'b (cdaar xxx))
(should-equal 'f (cdadr xxx))
(should-equal 'd (cddar xxx))
(should-equal 'h (cdddr xxx))))
(ert-deftest cXXXXr ()
(let ((xxxx
'((((a . b) . (c . d)) . ((e . f) . (g . h))) .
(((i . j) . (k . l)) . ((m . j) . (o . p))))))
(should-not (caaaar ()))
(should-not (caaadr ()))
(should-not (caadar ()))
(should-not (caaddr ()))
(should-not (cadaar ()))
(should-not (cadadr ()))
(should-not (caddar ()))
(should-not (cadddr ()))
(should-not (cdaaar ()))
(should-not (cdaadr ()))
(should-not (cdadar ()))
(should-not (cdaddr ()))
(should-not (cddaar ()))
(should-not (cddadr ()))
(should-not (cdddar ()))
(should-equal 'a (caaaar xxxx))
(should-equal 'i (caaadr xxxx))
(should-equal 'e (caadar xxxx))
(should-equal 'm (caaddr xxxx))
(should-equal 'c (cadaar xxxx))
(should-equal 'k (cadadr xxxx))
(should-equal 'g (caddar xxxx))
(should-equal 'o (cadddr xxxx))
(should-equal 'b (cdaaar xxxx))
(should-equal 'j (cdaadr xxxx))
(should-equal 'f (cdadar xxxx))
(should-equal 'j (cdaddr xxxx))
(should-equal 'd (cddaar xxxx))
(should-equal 'l (cddadr xxxx))
(should-equal 'h (cdddar xxxx))))
(ert-deftest compiled-function-p ()
(should-not (compiled-function-p '(lambda (x) x)))
(should (compiled-function-p (symbol-function 'assq)))
(should (compiled-function-p (symbol-function 'identity))))
(ert-deftest subr-native-elisp-p ()
(should-not (subr-native-elisp-p (symbol-function 'identity))))
(ert-deftest subr-primitive-p ()
(should (subr-primitive-p (symbol-function 'identity))) ;function from fns.c
(when (< emacs-major-version 28)
(should-not (subr-primitive-p (symbol-function 'match-string)))) ;function from subr.el
(should-not (subr-primitive-p (symbol-function 'defun))) ;macro from subr.el
(should-not (subr-primitive-p nil)))
(ert-deftest mapcan ()
(should-not (mapcan #'identity nil))
(should-equal (list 1)
(mapcan #'identity
(list (list 1))))
(should-equal (list 1 2 3 4)
(mapcan #'identity
(list (list 1) (list 2 3) (list 4))))
(should-equal (list (list 1) (list 2 3) (list 4))
(mapcan #'list
(list (list 1) (list 2 3) (list 4))))
(should-equal (list 1 2 3 4)
(mapcan #'identity
(list (list 1) (list) (list 2 3) (list 4))))
(should-equal (list (list 1) (list) (list 2 3) (list 4))
(mapcan #'list
(list (list 1) (list) (list 2 3) (list 4))))
(should-equal (list)
(mapcan #'identity
(list (list) (list) (list) (list)))))
(ert-deftest xor ()
(should (xor t nil))
(should (xor nil t))
(should-not (xor nil nil))
(should-not (xor t t)))
(ert-deftest length= ()
(should (length= '() 0)) ;empty list
(should (length= '(1) 1)) ;single element
(should (length= '(1 2 3) 3)) ;multiple elements
(should-not (length= '(1 2 3) 2)) ;less than
(should-not (length= '(1) 0))
(should-not (length= '(1 2 3) 4)) ;more than
(should-not (length= '(1) 2))
(should-not (length= '() 1))
(should (length= [] 0)) ;empty vector
(should (length= [1] 1)) ;single element vector
(should (length= [1 2 3] 3)) ;multiple element vector
(should-not (length= [1 2 3] 2)) ;less than
(should-not (length= [1 2 3] 4)) ;more than
(should-error (length= 3 nil) :type 'wrong-type-argument))
(ert-deftest length< ()
(should-not (length< '(1) 0)) ;single element
(should-not (length< '(1 2 3) 2)) ;multiple elements
(should-not (length< '(1 2 3) 3)) ;equal length
(should-not (length< '(1) 1))
(should (length< '(1 2 3) 4)) ;more than
(should (length< '(1) 2))
(should (length< '() 1))
(should-not (length< [1] 0)) ;single element vector
(should-not (length< [1 2 3] 2)) ;multiple element vector
(should-not (length< [1 2 3] 3)) ;equal length
(should (length< [1 2 3] 4)) ;more than
(should-error (length< 3 nil) :type 'wrong-type-argument))
(ert-deftest length> ()
(should (length> '(1) 0)) ;single element
(should (length> '(1 2 3) 2)) ;multiple elements
(should-not (length> '(1 2 3) 3)) ;equal length
(should-not (length> '(1) 1))
(should-not (length> '(1 2 3) 4)) ;more than
(should-not (length> '(1) 2))
(should-not (length> '() 1))
(should (length> [1] 0)) ;single element vector
(should (length> [1 2 3] 2)) ;multiple element vector
(should-not (length> [1 2 3] 3)) ;equal length
(should-not (length> [1 2 3] 4)) ;more than
(should-error (length< 3 nil) :type 'wrong-type-argument))
(ert-deftest ensure-list ()
(should-not (ensure-list nil)) ;; empty list
(should-equal '(1) (ensure-list '(1))) ;; single element list
(should-equal '(1 2 3) (ensure-list '(1 2 3))) ;; multiple element list
(should-equal '(1) (ensure-list 1))) ;; atom
(ert-deftest proper-list-p ()
(should-equal 0 (proper-list-p ())) ;; empty list
(should-equal 1 (proper-list-p '(1))) ;; single element
(should-equal 3 (proper-list-p '(1 2 3))) ;; multiple elements
(should-not (proper-list-p '(1 . 2))) ;; cons
(should-not (proper-list-p '(1 2 . 3))) ;; dotted
(should-not (let ((l (list 1 2 3))) ;; circular
(setf (nthcdr 3 l) l)
(proper-list-p l)))
(should-not (proper-list-p 1)) ;; non-lists
(should-not (proper-list-p ""))
(should-not (proper-list-p "abc"))
(should-not (proper-list-p []))
(should-not (proper-list-p [1 2 3])))
(ert-deftest always ()
(should-equal t (always)) ;; no arguments
(should-equal t (always 1)) ;; single argument
(should-equal t (always 1 2 3 4))) ;; multiple arguments
(ert-deftest file-backup-file-names ()
(let ((file (make-temp-file "compat-tests")) backups)
(should-not (file-backup-file-names file))
(push (concat file "~") backups)
(make-empty-file (car backups))
(should-equal backups (file-backup-file-names file))
(push (concat file ".~1~") backups)
(make-empty-file (car backups))
(should-equal backups (sort (file-backup-file-names file) #'string<))))
(ert-deftest make-nearby-temp-file ()
(let ((file1 (make-nearby-temp-file "compat-tests"))
(file2 (make-nearby-temp-file "compat-tests" nil "suffix"))
(dir (make-nearby-temp-file "compat-tests" t)))
(should (string-suffix-p "suffix" file2))
(should (file-regular-p file1))
(should (file-regular-p file2))
(should (file-directory-p dir))
(should-equal (file-name-directory file1) temporary-file-directory)
(should-equal (file-name-directory file2) temporary-file-directory)
(should-equal (file-name-directory dir) temporary-file-directory)
(delete-file file1)
(delete-file file2)
(delete-directory dir))
;; Tramp test (mock protocol)
(let* ((default-directory "/mock::/")
(file (make-nearby-temp-file "compat-tests")))
(should (string-match-p "\\`/mock:.*:/tmp/compat-tests" file))
(delete-file file)))
(ert-deftest executable-find ()
(should (member (executable-find "sh") '("/usr/bin/sh" "/bin/sh")))
(should (member (executable-find "ls") '("/usr/bin/ls" "/bin/ls")))
;; Tramp test (mock protocol)
(let ((default-directory "/mock::/"))
(should (member (compat-call executable-find "sh" t) '("/usr/bin/sh" "/bin/sh")))
(should (member (compat-call executable-find "ls" t) '("/usr/bin/ls" "/bin/ls")))))
(ert-deftest exec-path ()
(should-equal (exec-path) exec-path)
;; Tramp test (mock protocol)
(let ((default-directory "/mock::/"))
(should (member "/bin" (exec-path)))))
(ert-deftest with-existing-directory ()
(let ((dir (make-temp-name "/tmp/not-exist-")))
(let ((default-directory dir))
(should-not (file-exists-p default-directory)))
(with-existing-directory
(should-not (equal dir default-directory))
(should (file-exists-p default-directory)))))
(ert-deftest temporary-file-directory ()
(should-equal (temporary-file-directory) temporary-file-directory)
(let ((default-directory "/mnt"))
(should-equal (temporary-file-directory) default-directory))
;; Tramp test (mock protocol)
(let ((default-directory "/mock::/"))
(should (string-match-p "\\`/mock:.*:/tmp/?\\'" (temporary-file-directory)))))
(ert-deftest directory-files ()
(should-not (compat-call directory-files "." nil nil nil 0))
(should (list-of-strings-p (compat-call directory-files "." nil nil nil 1)))
(should-equal 1 (length (compat-call directory-files "." nil nil nil 1)))
(should-equal 2 (length (compat-call directory-files "." nil nil nil 2))))
(ert-deftest directory-files-and-attributes ()
(should-not (compat-call directory-files-and-attributes "." nil nil nil nil 0))
(should (consp (car (compat-call directory-files-and-attributes "." nil nil nil nil 1))))
(should-equal 1 (length (compat-call directory-files-and-attributes "." nil nil nil nil 1)))
(should-equal 2 (length (compat-call directory-files-and-attributes "." nil nil nil nil 2))))
(ert-deftest directory-name-p ()
(should (directory-name-p "/"))
(should-not (directory-name-p "/file"))
(should-not (directory-name-p "/dir/file"))
(should (directory-name-p "/dir/"))
(should-not (directory-name-p "/dir"))
(should (directory-name-p "/dir/subdir/"))
(should-not (directory-name-p "/dir/subdir"))
(should (directory-name-p "dir/"))
(should-not (directory-name-p "file"))
(should-not (directory-name-p "dir/file"))
(should (directory-name-p "dir/subdir/"))
(should-not (directory-name-p "dir/subdir")))
(ert-deftest directory-empty-p ()
(let ((name (make-temp-name "/tmp/compat-tests")))
(make-directory name)
(should (directory-empty-p name))
(make-empty-file (file-name-concat name "file"))
(should-not (directory-empty-p name))
(delete-file (file-name-concat name "file"))
(delete-directory name)))
(ert-deftest make-empty-file ()
(let ((name (make-temp-name "/tmp/compat-tests")))
(should-not (file-exists-p name))
(make-empty-file name)
(should-equal 0 (file-attribute-size (file-attributes name)))
(should (file-exists-p name))
(delete-file name)))
(ert-deftest mounted-file-systems ()
(should-not (string-match-p mounted-file-systems "/etc/"))
(should (string-match-p mounted-file-systems "/mnt/")))
(ert-deftest make-lock-file-name ()
(should-equal (expand-file-name ".#") (make-lock-file-name ""))
(should-equal (expand-file-name ".#a") (make-lock-file-name "a"))
(should-equal (expand-file-name ".#foo") (make-lock-file-name "foo"))
(should-equal (expand-file-name ".#.") (make-lock-file-name "."))
(should-equal (expand-file-name ".#.#") (make-lock-file-name ".#"))
(should-equal (expand-file-name ".#.a") (make-lock-file-name ".a"))
(should-equal (expand-file-name ".#.#") (make-lock-file-name ".#"))
(should-equal (expand-file-name "a/.#") (make-lock-file-name "a/"))
(should-equal (expand-file-name "a/.#b") (make-lock-file-name "a/b"))
(should-equal (expand-file-name "a/.#.#") (make-lock-file-name "a/.#"))
(should-equal (expand-file-name "a/.#.") (make-lock-file-name "a/."))
(should-equal (expand-file-name "a/.#.b") (make-lock-file-name "a/.b"))
(should-equal (expand-file-name "a/.#foo") (make-lock-file-name "a/foo"))
(should-equal (expand-file-name "bar/.#b") (make-lock-file-name "bar/b"))
(should-equal (expand-file-name "bar/.#foo") (make-lock-file-name "bar/foo")))
(ert-deftest file-has-changed-p ()
(let ((name (make-temp-file "/tmp/compat-tests")))
(should (file-has-changed-p name))
(should-not (file-has-changed-p name))
(should-not (file-has-changed-p name))
(should (file-has-changed-p name 'tag1))
(should-not (file-has-changed-p name 'tag1))
(should-not (file-has-changed-p name 'tag1))
(with-temp-buffer
(insert "changed")
(write-region (point-min) (point-max) name))
(should (file-has-changed-p name))
(should-not (file-has-changed-p name))
(should-not (file-has-changed-p name))
(should (file-has-changed-p name 'tag1))
(should-not (file-has-changed-p name 'tag1))
(should-not (file-has-changed-p name 'tag1))
(should (file-has-changed-p name 'tag2))
(should-not (file-has-changed-p name 'tag2))
(should-not (file-has-changed-p name 'tag2))
(delete-file name)))
(ert-deftest file-attribute-getters ()
(let ((attrs '(type link-number user-id group-id access-time modification-time
status-change-time size modes unspecified inode-number device-number)))
(should-equal (file-attribute-file-identifier attrs) '(inode-number device-number))
(should-equal (file-attribute-type attrs) 'type)
(should-equal (file-attribute-link-number attrs) 'link-number)
(should-equal (file-attribute-user-id attrs) 'user-id)
(should-equal (file-attribute-group-id attrs) 'group-id)
(should-equal (file-attribute-access-time attrs) 'access-time)
(should-equal (file-attribute-modification-time attrs) 'modification-time)
(should-equal (file-attribute-status-change-time attrs) 'status-change-time)
(should-equal (file-attribute-size attrs) 'size)
(should-equal (file-attribute-modes attrs) 'modes)
(should-equal (file-attribute-inode-number attrs) 'inode-number)
(should-equal (file-attribute-device-number attrs) 'device-number)))
(ert-deftest file-attribute-collect ()
(let ((attrs '(t l u g a m s S m U i d)))
(should-equal (file-attribute-collect attrs 'group-id 'user-id) '(g u))
(should-equal (file-attribute-collect attrs 'size 'inode-number 'type) '(S i t))))
(ert-deftest file-size-human-readable ()
(should-equal "1000" (compat-call file-size-human-readable 1000))
(should-equal "1k" (compat-call file-size-human-readable 1024))
(should-equal "1M" (compat-call file-size-human-readable (* 1024 1024)))
(should-equal "1G" (compat-call file-size-human-readable (expt 1024 3)))
(should-equal "1T" (compat-call file-size-human-readable (expt 1024 4)))
(should-equal "1k" (compat-call file-size-human-readable 1000 'si))
(should-equal "1KiB" (compat-call file-size-human-readable 1024 'iec))
(should-equal "1KiB" (compat-call file-size-human-readable 1024 'iec))
(should-equal "1 KiB" (compat-call file-size-human-readable 1024 'iec " "))
(should-equal "1KiA" (compat-call file-size-human-readable 1024 'iec nil "A"))
(should-equal "1 KiA" (compat-call file-size-human-readable 1024 'iec " " "A"))
(should-equal "1kA" (compat-call file-size-human-readable 1000 'si nil "A"))
(should-equal "1 k" (compat-call file-size-human-readable 1000 'si " "))
(should-equal "1 kA" (compat-call file-size-human-readable 1000 'si " " "A")))
(ert-deftest with-file-modes ()
(let ((old (default-file-modes)))
(with-file-modes (1+ old)
(should-equal (default-file-modes) (1+ old)))
(should-equal (default-file-modes) old)))
(ert-deftest file-modes-number-to-symbolic ()
(should-equal "-rwx------" (file-modes-number-to-symbolic #o700))
(should-equal "-rwxrwx---" (file-modes-number-to-symbolic #o770))
(should-equal "-rwx---rwx" (file-modes-number-to-symbolic #o707))
(should-equal "-rw-r-xr--" (file-modes-number-to-symbolic #o654))
(should-equal "--wx-w---x" (file-modes-number-to-symbolic #o321))
(should-equal "drwx------" (file-modes-number-to-symbolic #o700 ?d))
(should-equal "?rwx------" (file-modes-number-to-symbolic #o700 ??))
(should-equal "lrwx------" (file-modes-number-to-symbolic #o120700))
(should-equal "prwx------" (file-modes-number-to-symbolic #o10700))
(should-equal "-rwx------" (file-modes-number-to-symbolic #o30700)))
(ert-deftest file-name-absolute-p () ;assuming unix
(should (file-name-absolute-p "/"))
(should (file-name-absolute-p "/a"))
(should-not (file-name-absolute-p "a"))
(should-not (file-name-absolute-p "a/b"))
(should-not (file-name-absolute-p "a/b/"))
(should (file-name-absolute-p "~"))
(when (version< "27.1" emacs-version)
(should (file-name-absolute-p "~/foo"))
(should-not (file-name-absolute-p "~foo"))
(should-not (file-name-absolute-p "~foo/")))
(should (file-name-absolute-p "~root"))
(should (file-name-absolute-p "~root/"))
(should (file-name-absolute-p "~root/file")))
(ert-deftest file-local-name ()
(should-equal "" (file-local-name ""))
(should-equal "foo" (file-local-name "foo"))
(should-equal "/bar/foo" (file-local-name "/bar/foo"))
;; NOTE: These tests fails prior to Emacs 26, because /ssh:foo was a valid
;; TRAMP path back then.
(when (>= emacs-major-version 26)
(should-equal "/ssh:foo" (file-local-name "/ssh:foo"))
(should-equal "/ssh:/bar/foo" (file-local-name "/ssh:/bar/foo")))
(should-equal "foo" (file-local-name "/ssh::foo"))
(should-equal "/bar/foo" (file-local-name "/ssh::/bar/foo"))
(should-equal ":foo" (file-local-name "/ssh:::foo"))
(should-equal ":/bar/foo" (file-local-name "/ssh:::/bar/foo")))
(ert-deftest file-name-quoted-p ()
(should-not (compat-call file-name-quoted-p ""))
(should (compat-call file-name-quoted-p "/:"))
(should-not (compat-call file-name-quoted-p "//:"))
(should (compat-call file-name-quoted-p "/::"))
(should-not (compat-call file-name-quoted-p "/ssh::"))
(should-not (compat-call file-name-quoted-p "/ssh::a"))
(should (compat-call file-name-quoted-p "/ssh::/:a"))
;; NOTE: These tests fails prior to Emacs 26, because /ssh:foo was a valid
;; TRAMP path back then.
(when (>= emacs-major-version 26)
(should-not (compat-call file-name-quoted-p "/ssh:/:a"))))
(ert-deftest file-name-quote ()
(should-equal "/:" (compat-call file-name-quote ""))
(should-equal "/::"(compat-call file-name-quote ":"))
(should-equal "/:/" (compat-call file-name-quote "/"))
(should-equal "/:" (compat-call file-name-quote "/:"))
(should-equal "/:a" (compat-call file-name-quote "a"))
(should-equal "/::a" (compat-call file-name-quote ":a"))
(should-equal "/:/a" (compat-call file-name-quote "/a"))
(should-equal "/:a" (compat-call file-name-quote "/:a"))
(should-equal (concat "/ssh:" (system-name) ":/:a") (compat-call file-name-quote "/ssh::a")))
(ert-deftest file-name-concat ()
(should-equal (file-name-concat "foo" "bar") "foo/bar")
(should-equal (file-name-concat "foo" "bar") "foo/bar")
(should-equal (file-name-concat "foo" "bar" "zot") "foo/bar/zot")
(should-equal (file-name-concat "foo/" "bar") "foo/bar")
(should-equal (file-name-concat "foo//" "bar") "foo//bar")
(should-equal (file-name-concat "foo/" "bar/" "zot") "foo/bar/zot")
(should-equal (file-name-concat "fóo" "bar") "fóo/bar")
(should-equal (file-name-concat "foo" "bár") "foo/bár")
(should-equal (file-name-concat "fóo" "bár") "fóo/bár")
(should-equal (file-name-concat "foo") "foo")
(should-equal (file-name-concat "foo/") "foo/")
(should-equal (file-name-concat "foo" "") "foo")
(should-equal (file-name-concat "foo" "" "" "" nil) "foo")
(should-equal (file-name-concat "" "bar") "bar")
(should-equal (file-name-concat "" "") ""))
(ert-deftest file-name-parent-directory ()
(should-equal (file-name-parent-directory "/foo/bar") "/foo/")
(should-equal (file-name-parent-directory "/foo/") "/")
(should-equal (file-name-parent-directory "foo/bar") "foo/")
(should-equal (file-name-parent-directory "foo") "./"))
(ert-deftest file-name-split ()
(should-equal (file-name-split "foo/bar") '("foo" "bar"))
(should-equal (file-name-split "/foo/bar") '("" "foo" "bar"))
(should-equal (file-name-split "/foo/bar/zot") '("" "foo" "bar" "zot"))
(should-equal (file-name-split "/foo/bar/") '("" "foo" "bar" ""))
(should-equal (file-name-split "foo/bar/") '("foo" "bar" "")))
(ert-deftest file-name-with-extension ()
(should-equal "file.ext" (file-name-with-extension "file" "ext"))
(should-equal "file.ext" (file-name-with-extension "file" ".ext"))
(should-equal "file.ext" (file-name-with-extension "file." ".ext"))
(should-equal "file..ext" (file-name-with-extension "file.." ".ext"))
(should-equal "file..ext" (file-name-with-extension "file." "..ext"))
(should-equal "file...ext" (file-name-with-extension "file.." "..ext"))
(should-equal "/abs/file.ext" (file-name-with-extension "/abs/file" "ext"))
(should-equal "/abs/file.ext" (file-name-with-extension "/abs/file" ".ext"))
(should-equal "/abs/file.ext" (file-name-with-extension "/abs/file." ".ext"))
(should-equal "/abs/file..ext" (file-name-with-extension "/abs/file.." ".ext"))
(should-equal "/abs/file..ext" (file-name-with-extension "/abs/file." "..ext"))
(should-equal "/abs/file...ext" (file-name-with-extension "/abs/file.." "..ext"))
(should-error (file-name-with-extension "file" "") :type 'error)
(should-error (file-name-with-extension "" "ext") :type 'error)
(should-error (file-name-with-extension "file" "") :type 'error)
(should-error (file-name-with-extension "rel/" "ext") :type 'error)
(should-error (file-name-with-extension "/abs/" "ext")) :type 'error)
(ert-deftest flatten-tree ()
;; Example from docstring:
(should-equal '(1 2 3 4 5 6 7) (flatten-tree '(1 (2 . 3) nil (4 5 (6)) 7)))
;; Trivial example
(should-not (flatten-tree ()))
;; Simple examples
(should-equal '(1) (flatten-tree '(1)))
(should-equal '(1 2) (flatten-tree '(1 2)))
(should-equal '(1 2 3) (flatten-tree '(1 2 3)))
;; Regular sublists
(should-equal '(1) (flatten-tree '((1))))
(should-equal '(1 2) (flatten-tree '((1) (2))))
(should-equal '(1 2 3) (flatten-tree '((1) (2) (3))))
;; Complex examples
(should-equal '(1) (flatten-tree '(((((1)))))))
(should-equal '(1 2 3 4) (flatten-tree '((1) nil 2 ((3 4)))))
(should-equal '(1 2 3 4) (flatten-tree '(((1 nil)) 2 (((3 nil nil) 4))))))
(ert-deftest sort ()
(should-equal (list 1 2 3) (sort (list 1 2 3) #'<))
(should-equal (list 1 2 3) (sort (list 1 3 2) #'<))
(should-equal (list 1 2 3) (sort (list 3 2 1) #'<))
(should-equal (list 1 2 3) (compat-call sort (list 1 2 3) #'<))
(should-equal (list 1 2 3) (compat-call sort (list 1 3 2) #'<))
(should-equal (list 1 2 3) (compat-call sort (list 3 2 1) #'<))
(should-equal [1 2 3] (compat-call sort [1 2 3] #'<))
(should-equal [1 2 3] (compat-call sort [1 3 2] #'<))
(should-equal [1 2 3] (compat-call sort [3 2 1] #'<))
;; Test side effect
(let ((vec [4 5 8 3 1 2 3 2 3 4]))
(compat-call sort vec #'>)
(should-equal vec [8 5 4 4 3 3 3 2 2 1])))
(ert-deftest replace-string-in-region ()
(with-temp-buffer
(insert "foo bar zot foobar")
(should (= (replace-string-in-region "foo" "new" (point-min) (point-max))
2))
(should-equal (buffer-string) "new bar zot newbar"))
(with-temp-buffer
(insert "foo bar zot foobar")
(should (= (replace-string-in-region "foo" "new" (point-min) 14)
1))
(should-equal (buffer-string) "new bar zot foobar"))
(with-temp-buffer
(insert "foo bar zot foobar")
(should-error (replace-string-in-region "foo" "new" (point-min) 30)))
(with-temp-buffer
(insert "Foo bar zot foobar")
(should (= (replace-string-in-region "Foo" "new" (point-min))
1))
(should-equal (buffer-string) "new bar zot foobar"))
;; There was a bug in the Emacs 28 implementation
;; Fixed in Emacs d8f392bccd46cdb238ec96964f220ffb9d81cc44
(unless (= emacs-major-version 28)
(with-temp-buffer
(insert "foo bar baz")
(should (= (replace-string-in-region "ba" "quux corge grault" (point-min))
2))
(should-equal (buffer-string)
"foo quux corge graultr quux corge graultz"))
(with-temp-buffer
(insert "foo bar bar")
(should (= (replace-string-in-region " bar" "" (point-min) 8)
1))
(should-equal (buffer-string)
"foo bar"))))
(ert-deftest replace-regexp-in-region ()
(with-temp-buffer
(insert "foo bar zot foobar")
(should (= (replace-regexp-in-region "fo+" "new" (point-min) (point-max))
2))
(should-equal (buffer-string) "new bar zot newbar"))
(with-temp-buffer
(insert "foo bar zot foobar")
(should (= (replace-regexp-in-region "fo+" "new" (point-min) 14)
1))
(should-equal (buffer-string) "new bar zot foobar"))
(with-temp-buffer
(insert "foo bar zot foobar")
(should-error (replace-regexp-in-region "fo+" "new" (point-min) 30)))
(with-temp-buffer
(insert "Foo bar zot foobar")
(should (= (replace-regexp-in-region "Fo+" "new" (point-min))
1))
(should-equal (buffer-string) "new bar zot foobar"))
;; There was a bug in the Emacs 28 implementation
;; Fixed in Emacs d8f392bccd46cdb238ec96964f220ffb9d81cc44
(unless (= emacs-major-version 28)
(with-temp-buffer
(insert "foo bar baz")
(should (= (replace-regexp-in-region "ba." "quux corge grault" (point-min))
2))
(should-equal (buffer-string)
"foo quux corge grault quux corge grault"))
(with-temp-buffer
(insert "foo bar bar")
(should (= (replace-regexp-in-region " bar" "" (point-min) 8)
1))
(should-equal (buffer-string)
"foo bar"))))
(ert-deftest string-split ()
(should-equal '("a" "b" "c") (split-string "a b c"))
(should-equal '("a" "b" "c") (string-split "a b c")))
(ert-deftest string-equal-ignore-case ()
(should (string-equal-ignore-case "abc" "abc"))
(should (string-equal-ignore-case "abc" "ABC"))
(should (string-equal-ignore-case "abc" "abC"))
(should-not (string-equal-ignore-case "abc" "abCD"))
(should (string-equal-ignore-case "S" "s")))
(ert-deftest string-greaterp ()
(should (string-greaterp "b" "a"))
(should-not (string-greaterp "a" "b"))
(should (string-greaterp "aaab" "aaaa"))
(should-not (string-greaterp "aaaa" "aaab")))
(ert-deftest string-clean-whitespace ()
(should-equal "a b c" (string-clean-whitespace "a b c"))
(should-equal "a b c" (string-clean-whitespace " a b c"))
(should-equal "a b c" (string-clean-whitespace "a b c "))
(should-equal "a b c" (string-clean-whitespace "a b c"))
(should-equal "a b c" (string-clean-whitespace "a b c"))
(should-equal "a b c" (string-clean-whitespace "a b c"))
(should-equal "a b c" (string-clean-whitespace " a b c"))
(should-equal "a b c" (string-clean-whitespace "a b c "))
(should-equal "a b c" (string-clean-whitespace " a b c "))
(should-equal "aa bb cc" (string-clean-whitespace "aa bb cc"))
(should-equal "aa bb cc" (string-clean-whitespace " aa bb cc"))
(should-equal "aa bb cc" (string-clean-whitespace "aa bb cc "))
(should-equal "aa bb cc" (string-clean-whitespace "aa bb cc"))
(should-equal "aa bb cc" (string-clean-whitespace "aa bb cc"))
(should-equal "aa bb cc" (string-clean-whitespace "aa bb cc"))
(should-equal "aa bb cc" (string-clean-whitespace " aa bb cc"))
(should-equal "aa bb cc" (string-clean-whitespace "aa bb cc "))
(should-equal "aa bb cc" (string-clean-whitespace " aa bb cc ")))
(ert-deftest string-fill ()
(should-equal "a a a a a" (string-fill "a a a a a" 9))
(should-equal "a a a a a" (string-fill "a a a a a" 10))
(should-equal "a a a a\na" (string-fill "a a a a a" 8))
(should-equal "a a a a\na" (string-fill "a a a a a" 8))
(should-equal "a a\na a\na" (string-fill "a a a a a" 4))
(should-equal "a\na\na\na\na" (string-fill "a a a a a" 2))
(should-equal "a\na\na\na\na" (string-fill "a a a a a" 1)))
(ert-deftest string-lines ()
(should-equal '("a" "b" "c") (string-lines "a\nb\nc"))
;; FIXME: Behavior changed on Emacs 30
(compat-tests--if (< emacs-major-version 29)
(should-equal '("a" "b" "c" "") (string-lines "a\nb\nc\n"))
(should-equal '("a" "b" "c") (string-lines "a\nb\nc\n"))
(should-equal '("a\n" "\n" "b\n" "c\n") (string-lines "a\n\nb\nc\n" nil t))
(should-equal '("a\n" "b\n" "c\n") (string-lines "a\n\nb\nc\n" t t))
(should-equal '("a\n" "b\n" "c\n") (string-lines "a\nb\nc\n" nil t)))
(should-equal '("a" "b" "c") (string-lines "a\nb\nc\n" t))
(should-equal '("a" "b" "c") (string-lines "a\nb\n\nc\n" t))
(should-equal '("abc" "bcd" "cde") (string-lines "abc\nbcd\ncde"))
(should-equal '(" abc" " bcd " "cde ") (string-lines " abc\n bcd \ncde ")))
(ert-deftest string-pad ()
(should-equal "a " (string-pad "a" 4))
(should-equal "aaaa" (string-pad "aaaa" 4))
(should-equal "aaaaaa" (string-pad "aaaaaa" 4))
(should-equal "a..." (string-pad "a" 4 ?.))
(should-equal " a" (string-pad "a" 4 nil t))
(should-equal "...a" (string-pad "a" 4 ?. t)))
(ert-deftest string-chop-newline ()
(should-equal "" (string-chop-newline ""))
(should-equal "" (string-chop-newline "\n"))
(should-equal "aaa" (string-chop-newline "aaa"))
(should-equal "aaa" (string-chop-newline "aaa\n"))
(should-equal "aaa\n" (string-chop-newline "aaa\n\n")))
(ert-deftest string-distance ()
(should-equal 3 (string-distance "kitten" "sitting")) ;from wikipedia
;; In Emacs 27, `string-distance' had a bug when comparing two empty
;; strings. This was fixed in the following commit:
;; https://git.savannah.gnu.org/cgit/emacs.git/commit/?id=c44190c
(when (/= emacs-major-version 27)
(should-equal 0 (string-distance "" "")))
(should-equal 0 (string-distance "a" "a"))
(should-equal 1 (string-distance "" "a"))
(should-equal 1 (string-distance "b" "a"))
(should-equal 2 (string-distance "aa" "bb"))
(should-equal 2 (string-distance "aa" "bba"))
(should-equal 2 (string-distance "aaa" "bba"))
(should-equal 3 (string-distance "a" "あ" t)) ;byte example
(should-equal 1 (string-distance "a" "あ")))
(ert-deftest string-width ()
(should-equal 0 (compat-call string-width ""))
(should-equal 3 (compat-call string-width "abc")) ;; no argument
(should-equal 5 (compat-call string-width "abcあ"))
(should-equal (1+ tab-width) (compat-call string-width "a "))
(should-equal 2 (compat-call string-width "abc" 1)) ;; with from
(should-equal 4 (compat-call string-width "abcあ" 1))
(should-equal tab-width (compat-call string-width "a " 1))
(should-equal 2 (compat-call string-width "abc" 0 2)) ;; with to
(should-equal 3 (compat-call string-width "abcあ" 0 3))
(should-equal 1 (compat-call string-width "a " 0 1))
(should-equal 1 (compat-call string-width "abc" 1 2)) ;; with from and to
(should-equal 2 (compat-call string-width "abcあ" 3 4))
(should-equal 0 (compat-call string-width "a " 1 1)))
(ert-deftest string-trim-left ()
(should-equal "a" (compat-call string-trim-left "---a" "-+")) ;; Additional regexp
(should-equal "" (compat-call string-trim-left "")) ;empty string
(should-equal "a" (compat-call string-trim-left "a")) ;"full" string
(should-equal "aaa" (compat-call string-trim-left "aaa"))
(should-equal "へっろ" (compat-call string-trim-left "へっろ"))
(should-equal "hello world" (compat-call string-trim-left "hello world"))
(should-equal "a " (compat-call string-trim-left "a ")) ;right trailing
(should-equal "aaa " (compat-call string-trim-left "aaa "))
(should-equal "a " (compat-call string-trim-left "a "))
(should-equal "a\t\t" (compat-call string-trim-left "a\t\t"))
(should-equal "a\n \t" (compat-call string-trim-left "a\n \t"))
(should-equal "a" (compat-call string-trim-left " a")) ;left trailing
(should-equal "aaa" (compat-call string-trim-left " aaa"))
(should-equal "a" (compat-call string-trim-left "a"))
(should-equal "a" (compat-call string-trim-left "\t\ta"))
(should-equal "a" (compat-call string-trim-left "\n \ta"))
(should-equal "a " (compat-call string-trim-left " a ")) ;both trailing
(should-equal "aaa " (compat-call string-trim-left " aaa "))
(should-equal "a\t\n" (compat-call string-trim-left "\t\ta\t\n"))
(should-equal "a \n" (compat-call string-trim-left "\n \ta \n")))
(ert-deftest string-trim-right ()
(should-equal "a" (compat-call string-trim-right "a---" "-+")) ;; Additional regexp
(should-equal "" (compat-call string-trim-right "")) ;empty string
(should-equal "a" (compat-call string-trim-right "a")) ;"full" string
(should-equal "aaa" (compat-call string-trim-right "aaa"))
(should-equal "へっろ" (compat-call string-trim-right "へっろ"))
(should-equal "hello world" (compat-call string-trim-right "hello world"))
(should-equal "a" (compat-call string-trim-right "a")) ;right trailing
(should-equal "aaa" (compat-call string-trim-right "aaa"))
(should-equal "a" (compat-call string-trim-right "a "))
(should-equal "a" (compat-call string-trim-right "a\t\t"))
(should-equal "a" (compat-call string-trim-right "a\n \t"))
(should-equal " a" (compat-call string-trim-right " a")) ;left trailing
(should-equal " aaa" (compat-call string-trim-right " aaa"))
(should-equal "a" (compat-call string-trim-right "a"))
(should-equal "\t\ta" (compat-call string-trim-right "\t\ta"))
(should-equal "\n \ta" (compat-call string-trim-right "\n \ta"))
(should-equal " a" (compat-call string-trim-right " a ")) ;both trailing
(should-equal " aaa" (compat-call string-trim-right " aaa"))
(should-equal "\t\ta" (compat-call string-trim-right "\t\ta\t\n"))
(should-equal "\n \ta" (compat-call string-trim-right "\n \ta \n")))
(ert-deftest string-trim ()
(should-equal "aaa" (compat-call string-trim "--aaa__" "-+" "_+")) ;; Additional regexp
(should-equal "" (compat-call string-trim "")) ;empty string
(should-equal "a" (compat-call string-trim "a")) ;"full" string
(should-equal "aaa" (compat-call string-trim "aaa"))
(should-equal "へっろ" (compat-call string-trim "へっろ"))
(should-equal "hello world" (compat-call string-trim "hello world"))
(should-equal "a" (compat-call string-trim "a ")) ;right trailing
(should-equal "aaa" (compat-call string-trim "aaa "))
(should-equal "a" (compat-call string-trim "a "))
(should-equal "a" (compat-call string-trim "a\t\t"))
(should-equal "a" (compat-call string-trim "a\n \t"))
(should-equal "a" (compat-call string-trim " a")) ;left trailing
(should-equal "aaa" (compat-call string-trim " aaa"))
(should-equal "a" (compat-call string-trim "a"))
(should-equal "a" (compat-call string-trim "\t\ta"))
(should-equal "a" (compat-call string-trim "\n \ta"))
(should-equal "a" (compat-call string-trim " a ")) ;both trailing
(should-equal "aaa" (compat-call string-trim " aaa "))
(should-equal "t\ta" (compat-call string-trim "t\ta\t\n"))
(should-equal "a" (compat-call string-trim "\n \ta \n")))
(defmacro compat-tests--string-to-multibyte (str)
;; On Emacs 26 `string-to-multibyte' was declared obsolete.
;; This obsoletion was reverted on Emacs 27.
(if (= emacs-major-version 26)
`(with-no-warnings (string-to-multibyte ,str))
`(string-to-multibyte ,str)))
(ert-deftest string-search ()
;; Find needle at the beginning of a haystack:
(should-equal 0 (string-search "a" "abb"))
;; Find needle at the begining of a haystack, with more potential
;; needles that could be found:
(should-equal 0 (string-search "a" "abba"))
;; Find needle with more than one charachter at the beginning of
;; a line:
(should-equal 0 (string-search "aa" "aabbb"))
;; Find a needle midstring:
(should-equal 1 (string-search "a" "bab"))
;; Find a needle at the end:
(should-equal 2 (string-search "a" "bba"))
;; Find a longer needle midstring:
(should-equal 1 (string-search "aa" "baab"))
;; Find a longer needle at the end:
(should-equal 2 (string-search "aa" "bbaa"))
;; Find a case-sensitive needle:
(should-equal 2 (string-search "a" "AAa"))
;; Find another case-sensitive needle:
(should-equal 2 (string-search "aa" "AAaa"))
;; Test regular expression quoting (1):
(should-equal 5 (string-search "." "abbbb.b"))
;; Test regular expression quoting (2):
(should-equal 5 (string-search ".*" "abbbb.*b"))
;; Attempt to find non-existent needle:
(should-not (string-search "a" "bbb"))
;; Attempt to find non-existent needle that has the form of a
;; regular expression:
(should-not (string-search "." "bbb"))
;; Handle empty string as needle:
(should-equal 0 (string-search "" "abc"))
;; Handle empty string as haystack:
(should-not (string-search "a" ""))
;; Handle empty string as needle and haystack:
(should-equal 0 (string-search "" ""))
;; Handle START argument:
(should-equal 3 (string-search "a" "abba" 1))
;; Additional test copied from:
(should-equal 6 (string-search "zot" "foobarzot"))
(should-equal 0 (string-search "foo" "foobarzot"))
(should-not (string-search "fooz" "foobarzot"))
(should-not (string-search "zot" "foobarzo"))
(should-equal 0 (string-search "ab" "ab"))
(should-not (string-search "ab\0" "ab"))
(should-equal 4 (string-search "ab" "abababab" 3))
(should-not (string-search "ab" "ababac" 3))
(should-not (string-search "aaa" "aa"))
;; The `make-string' calls with three arguments have been replaced
;; here with the result of their evaluation, to avoid issues with
;; older versions of Emacs that only support two arguments.
(should-equal 5
(string-search (make-string 2 130)
;; Per (concat "helló" (make-string 5 130 t) "bár")
"hellóbár"))
(should-equal 5
(string-search (make-string 2 127)
;; Per (concat "helló" (make-string 5 127 t) "bár")
"hellóbár"))
(should-equal 1 (string-search "\377" "a\377ø"))
(should-equal 1 (string-search "\377" "a\377a"))
(should-not (string-search (make-string 1 255) "a\377ø"))
(should-not (string-search (make-string 1 255) "a\377a"))
(should-equal 3 (string-search "fóo" "zotfóo"))
(should-not (string-search "\303" "aøb"))
(should-not (string-search "\270" "aøb"))
(should-not (string-search "ø" "\303\270"))
(should-not (string-search "ø" (make-string 32 ?a)))
(should-not (string-search "ø" (compat-tests--string-to-multibyte (make-string 32 ?a))))
(should-equal 14 (string-search "o" (compat-tests--string-to-multibyte
(apply #'string (number-sequence ?a ?z)))))
(should-equal 2 (string-search "a\U00010f98z" "a\U00010f98a\U00010f98z"))
(should-error (string-search "a" "abc" -1) :type '(args-out-of-range -1))
(should-error (string-search "a" "abc" 4) :type '(args-out-of-range 4))
(should-error (string-search "a" "abc" 100000000000) :type '(args-out-of-range 100000000000))
(should-not (string-search "a" "aaa" 3))
(should-not (string-search "aa" "aa" 1))
(should-not (string-search "\0" ""))
(should-equal 0 (string-search "" ""))
(should-error (string-search "" "" 1) :type '(args-out-of-range 1))
(should-equal 0 (string-search "" "abc"))
(should-equal 2 (string-search "" "abc" 2))
(should-equal 3 (string-search "" "abc" 3))
(should-error (string-search "" "abc" 4) :type '(args-out-of-range 4))
(should-error (string-search "" "abc" -1) :type '(args-out-of-range -1))
(should-not (string-search "ø" "foo\303\270"))
(should-not (string-search "\303\270" "ø"))
(should-not (string-search "\370" "ø"))
(should-not (string-search (compat-tests--string-to-multibyte "\370") "ø"))
(should-not (string-search "ø" "\370"))
(should-not (string-search "ø" (compat-tests--string-to-multibyte "\370")))
(should-not (string-search "\303\270" "\370"))
(should-not (string-search (compat-tests--string-to-multibyte "\303\270") "\370"))
(should-not (string-search "\303\270" (compat-tests--string-to-multibyte "\370")))
(should-not
(string-search (compat-tests--string-to-multibyte "\303\270")
(compat-tests--string-to-multibyte "\370")))
(should-not (string-search "\370" "\303\270"))
(should-not (string-search (compat-tests--string-to-multibyte "\370") "\303\270"))
(should-not (string-search "\370" (compat-tests--string-to-multibyte "\303\270")))
(should-not
(string-search (compat-tests--string-to-multibyte "\370")
(compat-tests--string-to-multibyte "\303\270")))
(should-equal 3 (string-search "\303\270" "foo\303\270"))
(when (version<= "27" emacs-version)
;; FIXME The commit a1f76adfb03c23bb4242928e8efe6193c301f0c1 in
;; emacs.git fixes the behaviour of regular expressions matching
;; raw bytes. The compatibility functions should updated to
;; backport this behaviour.
(should-equal 2 (string-search (compat-tests--string-to-multibyte "\377") "ab\377c"))
(should-equal 2
(string-search (compat-tests--string-to-multibyte "o\303\270")
"foo\303\270"))))
(ert-deftest string-replace ()
(should-equal "bba" (string-replace "aa" "bb" "aaa"))
(should-equal "AAA" (string-replace "aa" "bb" "AAA"))
;; Additional test copied from subr-tests.el:
(should-equal "zot" (string-replace "foo" "bar" "zot"))
(should-equal "barzot" (string-replace "foo" "bar" "foozot"))
(should-equal "barbarzot" (string-replace "foo" "bar" "barfoozot"))
(should-equal "barfoobar" (string-replace "zot" "bar" "barfoozot"))
(should-equal "barfoobarot" (string-replace "z" "bar" "barfoozot"))
(should-equal "zat" (string-replace "zot" "bar" "zat"))
(should-equal "zat" (string-replace "azot" "bar" "zat"))
(should-equal "bar" (string-replace "azot" "bar" "azot"))
(should-equal "foozotbar" (string-replace "azot" "bar" "foozotbar"))
(should-equal "labarbarbarzot" (string-replace "fo" "bar" "lafofofozot"))
(should-equal "axb" (string-replace "\377" "x" "a\377b"))
(should-equal "axø" (string-replace "\377" "x" "a\377ø"))
(when (version<= "27" emacs-version)
;; FIXME The commit a1f76adfb03c23bb4242928e8efe6193c301f0c1
;; in emacs.git fixes the behaviour of regular
;; expressions matching raw bytes. The compatibility
;; functions should updated to backport this
;; behaviour.
(should-equal "axb" (string-replace (compat-tests--string-to-multibyte "\377") "x" "a\377b"))
(should-equal "axø" (string-replace (compat-tests--string-to-multibyte "\377") "x" "a\377ø")))
(should-equal "ANAnas" (string-replace "ana" "ANA" "ananas"))
(should-equal "" (string-replace "a" "" ""))
(should-equal "" (string-replace "a" "" "aaaaa"))
(should-equal "" (string-replace "ab" "" "ababab"))
(should-equal "ccc" (string-replace "ab" "" "abcabcabc"))
(should-equal "aaaaaa" (string-replace "a" "aa" "aaa"))
(should-equal "defg" (string-replace "abc" "defg" "abc"))
(should-error (string-replace "" "x" "abc") :type 'wrong-length-argument))
(ert-deftest dlet ()
(should-not (boundp 'compat-tests--dlet1))
(should-not (boundp 'compat-tests--dlet2))
(dlet ((compat-tests--dlet1 1)
(compat-tests--dlet2 2))
(should-equal (symbol-value 'compat-tests--dlet1) 1)
(should-equal (symbol-value 'compat-tests--dlet2) 2))
(should-not (boundp 'compat-tests--dlet1))
(should-not (boundp 'compat-tests--dlet2)))
(ert-deftest while-let ()
(let ((list '(1 2 3 4)) rev)
(while-let ((x (pop list)))
(push x rev))
(should-equal '(4 3 2 1) rev))
(let ((first '(1 2 3 4)) (second '(a b c)) zipped)
(while-let ((x (pop first)) (y (pop second)))
(push (cons x y) zipped))
(should-equal '((3 . c) (2 . b) (1 . a)) zipped)))
(ert-deftest when-let* ()
(should-equal "second"
(when-let*
((x 3)
(y 2)
(z (+ x y))
((= z 5))
(true t))
"first" "second"))
(should-not
(when-let* (((= 5 6))) "first" "second")))
(ert-deftest if-let* ()
(should-equal "then"
(if-let*
((x 3)
(y 2)
(z (+ x y))
((= z 5))
(true t))
"then" "else"))
(should-equal "else"
(if-let* (((= 5 6))) "then" "else")))
(ert-deftest when-let ()
;; FIXME Broken on Emacs 25
(compat-tests--if (= emacs-major-version 25)
(should-equal "second"
(when-let
((x 3)
(y 2)
(z (+ x y))
;; ((= z 5)) ;; FIXME Broken on Emacs 25
(true t))
"first" "second"))
(should-equal "second"
(when-let
((x 3)
(y 2)
(z (+ x y))
((= z 5))
(true t))
"first" "second"))
(should-equal "then" (when-let (((= 5 5))) "then"))
(should-not (when-let (((= 5 6))) t)))
(should-equal "last"
(when-let (e (memq 0 '(1 2 3 0 5 6)))
"first" "last"))
(should-equal "last" (when-let ((e (memq 0 '(1 2 3 0 5 6))))
"first" "last"))
(should-not (when-let ((e (memq 0 '(1 2 3 5 6)))
(d (memq 0 '(1 2 3 0 5 6))))
"first" "last")))
(ert-deftest if-let ()
;; FIXME Broken on Emacs 25
(compat-tests--if (= emacs-major-version 25)
(should-equal "then"
(if-let
((x 3)
(y 2)
(z (+ x y))
;; ((= z 5)) ;; FIXME Broken on Emacs 25
(true t))
"then" "else"))
(should-equal "then"
(if-let
((x 3)
(y 2)
(z (+ x y))
((= z 5))
(true t))
"then" "else"))
(should-equal "else" (if-let (((= 5 6))) "then" "else"))
(should-not (if-let (((= 5 6))) t nil)))
(should (if-let (e (memq 0 '(1 2 3 0 5 6)))
e))
(should (if-let ((e (memq 0 '(1 2 3 0 5 6))))
e))
(should-not (if-let ((e (memq 0 '(1 2 3 5 6)))
(d (memq 0 '(1 2 3 0 5 6))))
t))
(should-not (if-let ((d (memq 0 '(1 2 3 0 5 6)))
(e (memq 0 '(1 2 3 5 6))))
t)))
(ert-deftest and-let* ()
(should ;trivial body
(and-let*
((x 3)
(y 2)
(z (+ x y))
((= z 5))
(true t))
true))
(should ;no body
(and-let*
((x 3)
(y 2)
(z (+ x y))
((= z 5))
(true t))))
(should-not
(and-let* (((= 5 6))) t)))
(ert-deftest named-let ()
(should (= (named-let l ((i 0)) (if (= i 8) i (l (1+ i))))
8))
(should (= (named-let l ((i 0)) (if (= i 100000) i (l (1+ i))))
100000))
(should (= (named-let l ((i 0))
(cond
((= i 100000) i)
((= (mod i 2) 0)
(l (+ i 2)))
((l (+ i 3)))))
100000))
(should (= (named-let l ((i 0) (x 1)) (if (= i 8) x (l (1+ i) (* x 2))))
(expt 2 8)))
(should (eq (named-let lop ((x 1))
(if (> x 0)
(condition-case nil
(lop (1- x))
(arith-error 'ok))
(/ 1 x)))
'ok))
(should (eq (named-let lop ((n 10000))
(if (> n 0)
(condition-case nil
(/ n 0)
(arith-error (lop (1- n))))
'ok))
'ok))
(should (eq (named-let lop ((x nil))
(cond (x)
(t 'ok)))
'ok))
(should (eq (named-let lop ((x 100000))
(cond ((= x 0) 'ok)
((lop (1- x)))))
'ok))
(should (eq (named-let lop ((x 100000))
(cond
((= x -1) nil)
((= x 0) 'ok)
((lop -1))
((lop (1- x)))))
'ok))
(should (eq (named-let lop ((x 10000))
(cond ((= x 0) 'ok)
((and t (lop (1- x))))))
'ok))
(should (eq (let ((b t))
(named-let lop ((i 0))
(cond ((null i) nil) ((= i 10000) 'ok)
((lop (and (setq b (not b)) (1+ i))))
((lop (and (setq b (not b)) (1+ i)))))))
'ok)))
(ert-deftest alist-get ()
;; Fallback behaviour:
(should-not (alist-get 1 nil)) ;empty list
(should-equal 'a (alist-get 1 '((1 . a)))) ;single element list
(should-not (alist-get 1 '(1)))
(should-equal 'b (alist-get 2 '((1 . a) (2 . b) (3 . c)))) ;multiple element list
(should-not (alist-get 2 '(1 2 3)))
(should-equal 'b (alist-get 2 '(1 (2 . b) 3)))
(should-not (alist-get 2 '((1 . a) 2 (3 . c))))
(should-equal 'a (alist-get 1 '((3 . c) (2 . b) (1 . a))))
(should-not (alist-get "a" '(("a" . 1) ("b" . 2) ("c" . 3)))) ;non-primitive elements
;; With testfn:
(should-equal 1 (compat-call alist-get "a" '(("a" . 1) ("b" . 2) ("c" . 3)) nil nil #'equal))
(should-equal 'd (compat-call alist-get "x" '(("a" . 1) ("b" . 2) ("c" . 3)) 'd nil #'equal))
(should-equal 1 (compat-call alist-get 3 '((10 . 10) (4 . 4) (1 . 1) (9 . 9)) nil nil #'<))
(should-equal '(a) (compat-call alist-get "b" '(("c" c) ("a" a) ("b" b)) nil nil #'string-lessp))
(should-equal 'c (compat-call alist-get "a" '(("a" . a) ("a" . b) ("b" . c)) nil nil
(lambda (s1 s2) (not (string= s1 s2)))))
(should-equal 'emacs-lisp-mode
(compat-call alist-get "file.el"
'(("\\.c\\'" . c-mode)
("\\.p\\'" . pascal-mode)
("\\.el\\'" . emacs-lisp-mode)
("\\.awk\\'" . awk-mode))
nil nil #'string-match-p))
(should-equal 'd (compat-call alist-get 0 '((1 . a) (2 . b) (3 . c)) 'd)) ;default value
(should-equal 'd (compat-call alist-get 2 '((1 . a) (2 . b) (3 . c)) 'd nil #'ignore)))
(ert-deftest alist-get-gv ()
(let ((alist (list (cons 1 "one")
(cons 2 "two")
(cons 3 "three"))))
(setf (alist-get 1 alist) "eins")
(should-equal (alist-get 1 alist) "eins")
(setf (alist-get 2 alist nil 'remove) nil)
(should-equal alist '((1 . "eins") (3 . "three"))))
(let ((alist (list (cons 1 "one")
(cons 2 "two")
(cons 3 "three"))))
(setf (compat-call alist-get 1 alist) "eins")
(should-equal (compat-call alist-get 1 alist) "eins")
(setf (compat-call alist-get 2 alist nil 'remove) nil)
(should-equal alist '((1 . "eins") (3 . "three"))))
(let ((alist (list (cons "one" 1)
(cons "two" 2)
(cons "three" 3))))
(setf (compat-call alist-get "one" alist nil nil #'string=) "eins")
(should-equal (compat-call alist-get "one" alist nil nil #'string=) "eins")
(should-equal alist '(("one" . "eins") ("two" . 2) ("three" . 3)))
(setf (compat-call alist-get "two" alist nil 'remove #'string=) nil)
(should-equal alist '(("one" . "eins") ("three" . 3)))))
(ert-deftest plist-get-gv ()
(let ((plist '(1 "one" 2 "two" 3 "three")))
(setf (plist-get plist 1) "eins")
(should-equal (plist-get plist 1) "eins")
(setf (plist-get plist 2) nil)
(should-equal plist '(1 "eins" 2 nil 3 "three")))
(let ((plist '(1 "one" 2 "two" 3 "three")))
(setf (compat-call plist-get plist 1) "eins")
(should-equal (compat-call plist-get plist 1) "eins")
(setf (compat-call plist-get plist 2) nil)
(should-equal plist '(1 "eins" 2 nil 3 "three")))
(let ((plist '("one" 1 "two" 2 "three" 3)))
(setf (compat-call plist-get plist "one" #'string=) "eins")
(should-equal (compat-call plist-get plist "one" #'string=) "eins")
(should-equal plist '("one" "eins" "two" 2 "three" 3))))
(ert-deftest prop-match ()
(should (prop-match-p (make-prop-match)))
(should (prop-match-p (make-prop-match :end 1)))
(should (prop-match-p (make-prop-match :beginning 1 :end 2 :value 3)))
(should-equal 1 (prop-match-beginning (make-prop-match :beginning 1 :end 2 :value 3)))
(should-equal 2 (prop-match-end (make-prop-match :beginning 1 :end 2 :value 3)))
(should-equal 3 (prop-match-value (make-prop-match :beginning 1 :end 2 :value 3)))
(should-not (prop-match-p nil))
(should-not (prop-match-p []))
(should-not (prop-match-p 'symbol))
(should-not (prop-match-p "string"))
(should-not (prop-match-p '(1 2 3))))
(ert-deftest text-property-search-forward ()
(with-temp-buffer
(insert "one "
(propertize "two " 'prop 'val)
"three "
(propertize "four " 'prop 'wert)
"five ")
(goto-char (point-min))
(let ((match (text-property-search-forward 'prop)))
(should (prop-match-p match))
(should-equal (prop-match-beginning match) 5)
(should-equal (prop-match-end match) 9)
(should-equal (prop-match-value match) 'val))
(let ((match (text-property-search-forward 'prop)))
(should (prop-match-p match))
(should-equal (prop-match-beginning match) 15)
(should-equal (prop-match-end match) 20)
(should-equal (prop-match-value match) 'wert))
(should-not (text-property-search-forward 'prop))
(goto-char (point-min))
(should-not (text-property-search-forward 'non-existant))))
(ert-deftest text-property-search-backward ()
(with-temp-buffer
(insert "one "
(propertize "two " 'prop 'val)
"three "
(propertize "four " 'prop 'wert)
"five ")
(goto-char (point-max))
(let ((match (text-property-search-backward 'prop)))
(should (prop-match-p match))
(should-equal (prop-match-beginning match) 15)
(should-equal (prop-match-end match) 20)
(should-equal (prop-match-value match) 'wert))
(let ((match (text-property-search-backward 'prop)))
(should (prop-match-p match))
(should-equal (prop-match-beginning match) 5)
(should-equal (prop-match-end match) 9)
(should-equal (prop-match-value match) 'val))
(should-not (text-property-search-backward 'prop))
(goto-char (point-max))
(should-not (text-property-search-backward 'non-existant))))
(ert-deftest color-dark-p ()
(should (color-dark-p '(0 0 0)))
(should (color-dark-p '(0.5 0.5 0.5)))
(should-not (color-dark-p '(0.5 0.7 0.5)))
(should-not (color-dark-p '(1 1 1 ))))
(ert-deftest color-values-from-color-spec ()
;; #RGB notation
(should-equal '(0 0 0) (color-values-from-color-spec "#000"))
(should-equal '(0 0 0) (color-values-from-color-spec "#000000"))
(should-equal '(0 0 0) (color-values-from-color-spec "#000000000"))
(should-equal '(0 0 0) (color-values-from-color-spec "#000000000000"))
(should-equal '(0 0 65535) (color-values-from-color-spec "#00F"))
(should-equal '(0 0 65535) (color-values-from-color-spec "#0000FF"))
(should-equal '(0 0 65535) (color-values-from-color-spec "#000000FFF"))
(should-equal '(0 0 65535) (color-values-from-color-spec "#00000000FFFF"))
(should-equal '(0 0 65535) (color-values-from-color-spec "#00f"))
(should-equal '(0 0 65535) (color-values-from-color-spec "#0000ff"))
(should-equal '(0 0 65535) (color-values-from-color-spec "#000000fff"))
(should-equal '(0 0 65535) (color-values-from-color-spec "#00000000ffff"))
(should-equal '(0 0 65535) (color-values-from-color-spec "#00000000ffFF"))
(should-equal '(#xffff #x0000 #x5555) (color-values-from-color-spec "#f05"))
(should-equal '(#x1f1f #xb0b0 #xc5c5) (color-values-from-color-spec "#1fb0C5"))
(should-equal '(#x1f83 #xb0ad #xc5e2) (color-values-from-color-spec "#1f83b0ADC5e2"))
(should-not (color-values-from-color-spec ""))
(should-not (color-values-from-color-spec "#"))
(should-not (color-values-from-color-spec "#0"))
(should-not (color-values-from-color-spec "#00"))
(should-not (color-values-from-color-spec "#0000FG"))
(should-not (color-values-from-color-spec "#0000FFF"))
(should-not (color-values-from-color-spec "#0000FFFF"))
(should-equal '(0 4080 65535) (color-values-from-color-spec "#0000FFFFF"))
(should-not (color-values-from-color-spec "#000FF"))
(should-not (color-values-from-color-spec "#0000F"))
(should-not (color-values-from-color-spec " #000000"))
(should-not (color-values-from-color-spec "#000000 "))
(should-not (color-values-from-color-spec " #000000 "))
(should-not (color-values-from-color-spec "#1f83b0ADC5e2g"))
(should-not (color-values-from-color-spec "#1f83b0ADC5e20"))
(should-not (color-values-from-color-spec "#12345"))
;; rgb: notation
(should-equal '(0 0 0) (color-values-from-color-spec "rgb:0/0/0"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgb:0/0/00"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgb:0/00/000"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgb:0/000/0000"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgb:000/0000/0"))
(should-equal '(0 0 65535) (color-values-from-color-spec "rgb:000/0000/F"))
(should-equal '(65535 0 65535) (color-values-from-color-spec "rgb:FFF/0000/F"))
(should-equal '(65535 0 65535) (color-values-from-color-spec "rgb:FFFF/0000/FFFF"))
(should-equal '(0 255 65535) (color-values-from-color-spec "rgb:0/00FF/FFFF"))
(should-equal '(#xffff #x2323 #x28a2) (color-values-from-color-spec "rgb:f/23/28a"))
(should-equal '(#x1234 #x5678 #x09ab) (color-values-from-color-spec "rgb:1234/5678/09ab"))
(should-not (color-values-from-color-spec "rgb:/0000/FFFF"))
(should-not (color-values-from-color-spec "rgb:0000/0000/FFFG"))
(should-not (color-values-from-color-spec "rgb:0000/0000/FFFFF"))
(should-not (color-values-from-color-spec "rgb:0000/0000"))
(should-not (color-values-from-color-spec "rg:0000/0000/0000"))
(should-not (color-values-from-color-spec "rgb: 0000/0000/0000"))
(should-not (color-values-from-color-spec "rgbb:0000/0000/0000"))
(should-not (color-values-from-color-spec "rgb:0000/0000/0000 "))
(should-not (color-values-from-color-spec " rgb:0000/0000/0000 "))
(should-not (color-values-from-color-spec " rgb:0000/0000/0000"))
(should-not (color-values-from-color-spec "rgb:0000/ 0000 /0000"))
(should-not (color-values-from-color-spec "rgb: 0000 /0000 /0000"))
(should-not (color-values-from-color-spec "rgb:0//0"))
;; rgbi: notation
(should-equal '(0 0 0) (color-values-from-color-spec "rgbi:0/0/0"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgbi:0.0/0.0/0.0"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgbi:0.0/0/0"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgbi:0.0/0/0"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgbi:0/0/0."))
(should-equal '(0 0 0) (color-values-from-color-spec "rgbi:0/0/0.0000"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgbi:0/0/.0"))
(should-equal '(0 0 0) (color-values-from-color-spec "rgbi:0/0/.0000"))
(should-equal '(65535 0 0) (color-values-from-color-spec "rgbi:1/0/0.0000"))
(should-equal '(65535 0 0) (color-values-from-color-spec "rgbi:1./0/0.0000"))
(should-equal '(65535 0 0) (color-values-from-color-spec "rgbi:1.0/0/0.0000"))
(should-equal '(65535 32768 0) (color-values-from-color-spec "rgbi:1.0/0.5/0.0000"))
(should-equal '(6554 21843 65469) (color-values-from-color-spec "rgbi:0.1/0.3333/0.999"))
(should-equal '(0 32768 6554) (color-values-from-color-spec "rgbi:0/0.5/0.1"))
(should-equal '(66 655 65535) (color-values-from-color-spec "rgbi:1e-3/1.0e-2/1e0"))
(should-equal '(6554 21843 65469) (color-values-from-color-spec "rgbi:1e-1/+0.3333/0.00999e2"))
(should-not (color-values-from-color-spec "rgbi:1.0001/0/0"))
(should-not (color-values-from-color-spec "rgbi:2/0/0"))
(should-not (color-values-from-color-spec "rgbi:0.a/0/0"))
(should-not (color-values-from-color-spec "rgbi:./0/0"))
(should-not (color-values-from-color-spec "rgbi:./0/0"))
(should-not (color-values-from-color-spec " rgbi:0/0/0"))
(should-not (color-values-from-color-spec "rgbi:0/0/0 "))
(should-not (color-values-from-color-spec " rgbi:0/0/0 "))
(should-not (color-values-from-color-spec "rgbi:0 /0/ 0"))
(should-not (color-values-from-color-spec "rgbi:0/ 0 /0"))
(should-not (color-values-from-color-spec "rgbii:0/0/0"))
(should-not (color-values-from-color-spec "rgbi :0/0/0"))
;; strtod ignores leading whitespace, making these legal colour
;; specifications:
;;
;; (should-not (color-values-from-color-spec "rgbi: 0/0/0"))
;; (should-not (color-values-from-color-spec "rgbi: 0/ 0/ 0"))
(should-not (color-values-from-color-spec "rgbi : 0/0/0"))
(should-not (color-values-from-color-spec "rgbi:0/0.5/10")))
(ert-deftest lookup-key ()
(let ((a-map (make-sparse-keymap))
(b-map (make-sparse-keymap)))
(define-key a-map "x" 'foo)
(define-key b-map "x" 'bar)
(should-equal 'foo (compat-call lookup-key a-map "x"))
(should-equal 'bar (compat-call lookup-key b-map "x"))
(should-equal 'foo (compat-call lookup-key (list a-map b-map) "x"))
(should-equal 'bar (compat-call lookup-key (list b-map a-map) "x"))))
;; We need an indirection since `macroexp-file-name' is a function and not a
;; macro. `macroexp-file-name' is not a function since it is used mostly in a
;; macro context.
(defmacro compat-tests--filename ()
(macroexp-file-name))
(ert-deftest macroexp-file-name ()
(should-equal (file-name-nondirectory (compat-tests--filename)) "compat-tests.el"))
(ert-deftest macroexp-warn-and-return ()
(should-equal (macroexp-warn-and-return "test warning" '(some form)) '(some form)))
(ert-deftest macroexp-parse-body ()
(should-equal '(((declare test)) . (a b c))
(macroexp-parse-body '((declare test) a b c)))
(should-equal '(((interactive)) . (a b c))
(macroexp-parse-body '((interactive) a b c)))
(should-equal '(((interactive) (cl-declare)) . (a b c))
(macroexp-parse-body '((interactive) (cl-declare) a b c))))
(ert-deftest macroexp-quote ()
(should-equal nil (macroexp-quote nil))
(should-equal t (macroexp-quote t))
(should-equal :key (macroexp-quote :key))
(should-equal "str" (macroexp-quote "str"))
(should-equal ''sym (macroexp-quote 'sym))
(should-equal ''(1 2 3) (macroexp-quote '(1 2 3))))
(ert-deftest macroexpand-1 ()
(should-equal '(if a b c) (macroexpand-1 '(if a b c)))
(should-equal '(if a (progn b)) (macroexpand-1 '(when a b)))
(should-equal '(if a (progn (unless b c))) (macroexpand-1 '(when a (unless b c)))))
(ert-deftest time-equal-p ()
(should (time-equal-p nil nil))
;; FIXME: Testing these values can be tricky, because the timestamp
;; might change between evaluating (current-time) and evaluating
;; `time-equal-p', especially in the interpreted compatibility
;; version.
;; (should (time-equal-p (current-time) nil))
;; (should (time-equal-p nil (current-time)))
(should (time-equal-p '(1 2 3 4) '(1 2 3 4)))
(should-not (time-equal-p '(1 2 3 4) '(1 2 3 5)))
(should-not (time-equal-p '(1 2 3 5) '(1 2 3 4)))
(should-not (time-equal-p '(1 2 3 4) '(1 2 4 4)))
(should-not (time-equal-p '(1 2 4 4) '(1 2 3 4)))
(should-not (time-equal-p '(1 2 3 4) '(1 3 3 4)))
(should-not (time-equal-p '(1 3 3 4) '(1 2 3 4)))
(should-not (time-equal-p '(1 2 3 4) '(2 2 3 4)))
(should-not (time-equal-p '(2 2 3 4) '(1 2 3 4)))
;; TODO fix broken tests
;; (should (time-equal-p 0 (time-since nil)))
;; (should (time-equal-p (days-to-time 0) '(0 0)))
;; (should (time-equal-p (days-to-time 1) '(1 20864)))
;; (should (time-equal-p (days-to-time 999) '(1317 2688)))
;; (should (time-equal-p (days-to-time 0.0) '(0 0 0 0)))
;; (should (time-equal-p (days-to-time 0.5) '(0 43200 0 0)))
;; (should (time-equal-p (days-to-time 1.0) '(1 20864 0 0)))
;; (should (time-equal-p (days-to-time 999.0) '(1317 2688 0 0)))
)
(ert-deftest decoded-time ()
(let ((time '(second minute hour day month year weekday dst zone)))
(should-equal (decoded-time-second time) 'second)
(should-equal (decoded-time-minute time) 'minute)
(should-equal (decoded-time-hour time) 'hour)
(should-equal (decoded-time-day time) 'day)
(should-equal (decoded-time-month time) 'month)
(should-equal (decoded-time-year time) 'year)
(should-equal (decoded-time-weekday time) 'weekday)
(should-equal (decoded-time-dst time) 'dst)
(should-equal (decoded-time-zone time) 'zone)
(setf (decoded-time-second time) 'SECOND)
(setf (decoded-time-minute time) 'MINUTE)
(setf (decoded-time-hour time) 'HOUR)
(setf (decoded-time-day time) 'DAY)
(setf (decoded-time-month time) 'MONTH)
(setf (decoded-time-year time) 'YEAR)
(setf (decoded-time-weekday time) 'WEEKDAY)
(setf (decoded-time-dst time) 'DST)
(setf (decoded-time-zone time) 'ZONE)
(should-equal (decoded-time-second time) 'SECOND)
(should-equal (decoded-time-minute time) 'MINUTE)
(should-equal (decoded-time-hour time) 'HOUR)
(should-equal (decoded-time-day time) 'DAY)
(should-equal (decoded-time-month time) 'MONTH)
(should-equal (decoded-time-year time) 'YEAR)
(should-equal (decoded-time-weekday time) 'WEEKDAY)
(should-equal (decoded-time-dst time) 'DST)
(should-equal (decoded-time-zone time) 'ZONE)))
(ert-deftest decoded-time-period ()
(should-equal 0 (decoded-time-period '()))
(should-equal 0 (decoded-time-period '(0)))
(should-equal 1 (decoded-time-period '(1)))
(should-equal 0.125 (decoded-time-period '((1 . 8))))
(should-equal 60 (decoded-time-period '(0 1)))
(should-equal 61 (decoded-time-period '(1 1)))
(should-equal -59 (decoded-time-period '(1 -1)))
(should-equal (* 60 60) (decoded-time-period '(0 0 1)))
(should-equal (+ (* 60 60) 60) (decoded-time-period '(0 1 1)))
(should-equal (+ (* 60 60) 120 1) (decoded-time-period '(1 2 1)))
(should-equal (* 60 60 24) (decoded-time-period '(0 0 0 1)))
(should-equal (+ (* 60 60 24) 1) (decoded-time-period '(1 0 0 1)))
(should-equal (+ (* 60 60 24) (* 60 60) 60 1) (decoded-time-period '(1 1 1 1)))
(should-equal (+ (* 60 60 24) (* 60 60) 120 1) (decoded-time-period '(1 2 1 1)))
(should-equal (* 60 60 24 30) (decoded-time-period '(0 0 0 0 1)))
(should-equal (+ (* 60 60 24 30) 1) (decoded-time-period '(1 0 0 0 1)))
(should-equal (+ (* 60 60 24 30) 60 1) (decoded-time-period '(1 1 0 0 1)))
(should-equal (+ (* 60 60 24 30) (* 60 60) 60 1)
(decoded-time-period '(1 1 1 0 1)))
(should-equal (+ (* 60 60 24 30) (* 60 60 24) (* 60 60) 120 1)
(decoded-time-period '(1 2 1 1 1)))
(should-equal (* 60 60 24 365) (decoded-time-period '(0 0 0 0 0 1)))
(should-equal (+ (* 60 60 24 365) 1)
(decoded-time-period '(1 0 0 0 0 1)))
(should-equal (+ (* 60 60 24 365) 60 1)
(decoded-time-period '(1 1 0 0 0 1)))
(should-equal (+ (* 60 60 24 365) (* 60 60) 60 1)
(decoded-time-period '(1 1 1 0 0 1)))
(should-equal (+ (* 60 60 24 365) (* 60 60 24) (* 60 60) 60 1)
(decoded-time-period '(1 1 1 1 0 1)))
(should-equal (+ (* 60 60 24 365)
(* 60 60 24 30)
(* 60 60 24)
(* 60 60)
120 1)
(decoded-time-period '(1 2 1 1 1 1)))
(should-error (decoded-time-period 'a) :type 'wrong-type-argument)
(should-error (decoded-time-period '(0 a)) :type 'wrong-type-argument)
(should-error (decoded-time-period '(0 0 a)) :type 'wrong-type-argument)
(should-error (decoded-time-period '(0 0 0 a)) :type 'wrong-type-argument)
(should-error (decoded-time-period '(0 0 0 0 a)) :type 'wrong-type-argument)
(should-error (decoded-time-period '(0 0 0 0 0 a)) :type 'wrong-type-argument))
(ert-deftest make-decoded-time ()
(should-equal '(s m h d M Y nil D Z)
(make-decoded-time :second 's :minute 'm :hour 'h
:day 'd :month 'M :year 'Y
:dst 'D :zone 'Z)))
(ert-deftest date-days-in-month ()
(should-equal 31 (date-days-in-month 2020 1))
(should-equal 30 (date-days-in-month 2020 4))
(should-equal 29 (date-days-in-month 2020 2))
(should-equal 28 (date-days-in-month 2021 2)))
(ert-deftest date-ordinal-to-time ()
(should-equal '(nil nil nil 9 4 2020 nil nil nil) (date-ordinal-to-time 2020 100))
(should-equal '(nil nil nil 19 7 2021 nil nil nil) (date-ordinal-to-time 2021 200)))
(ert-deftest regexp-opt ()
;; Ensure `regexp-opt' doesn't change the existing
;; behaviour:
(should-equal "[abc]" (compat-call regexp-opt '("a" "b" "c")))
(should-equal "\\(?:abc\\|def\\|ghe\\)" (compat-call regexp-opt '("abc" "def" "ghe")))
(should-equal "\\<\\([abc]\\)\\>" (compat-call regexp-opt '("a" "b" "c") 'words))
;; Test empty list:
(should-equal "\\(?:\\`a\\`\\)" (compat-call regexp-opt '()))
(should-equal "\\<\\(\\`a\\`\\)\\>" (compat-call regexp-opt '() 'words)))
(ert-deftest regexp-unmatchable ()
(dolist (str '("" ;empty string
"a" ;simple string
"aaa" ;longer string
))
(should-not (string-match-p regexp-unmatchable str))))
(declare-function dired-get-marked-files "dired")
(ert-deftest dired-get-marked-files ()
(require 'dired)
(should-error (compat-call dired-get-marked-files nil nil nil nil t)))
(ert-deftest use-region ()
(with-temp-buffer
(insert "abc\ndef\n")
(set-mark 2)
(goto-char 7)
(transient-mark-mode)
(should (use-region-p))
(should-equal 2 (use-region-beginning))
(should-equal 7 (use-region-end))))
(ert-deftest region-bounds ()
(should-error (region-bounds))
;; FIXME: On Emacs 24 `region-bounds' always returns a continuous region.
(when (> emacs-major-version 24)
(let ((region-extract-function #'ignore))
(should-not (region-bounds)))
(let ((region-extract-function (lambda (_) '((2 . 3) (6 . 7)))))
(should-equal (region-bounds) '((2 . 3) (6 . 7)))))
(with-temp-buffer
(insert "abc\ndef\n")
(set-mark 2)
(goto-char 7)
(should-equal (region-bounds) '((2 . 7)))))
(ert-deftest region-noncontiguous-p ()
(when (> emacs-major-version 24)
(let ((region-extract-function (lambda (_) '((2 . 3) (6 . 7)))))
(should (region-noncontiguous-p))))
(with-temp-buffer
(insert "abc\ndef\n")
(set-mark 2)
(goto-char 7)
(transient-mark-mode)
(should-not (region-noncontiguous-p))
(should-not (use-region-noncontiguous-p))
(should (use-region-p))
;; FIXME: On Emacs 24 `region-bounds' always returns a continuous region.
(when (> emacs-major-version 24)
(let ((region-extract-function (lambda (_) '((2 . 3) (6 . 7)))))
(should (region-noncontiguous-p))
(should (use-region-noncontiguous-p))))))
(ert-deftest get-scratch-buffer-create ()
(should-equal "*scratch*" (buffer-name (get-scratch-buffer-create)))
(should-equal initial-major-mode (buffer-local-value 'major-mode (get-scratch-buffer-create))))
(ert-deftest ring-resize ()
(let ((ring (make-ring 3)))
(ring-insert ring 1)
(ring-insert ring 2)
(ring-insert ring 3)
(ring-resize ring 5)
(should-equal (ring-size ring) 5)
(should-equal (ring-elements ring) '(3 2 1)))
(let ((ring (make-ring 3)))
(ring-resize ring 5)
(should (= (ring-size ring) 5))
(should-equal (ring-elements ring) '()))
(let ((ring (make-ring 3)))
(ring-insert ring 1)
(ring-insert ring 2)
(ring-insert ring 3)
(ring-insert ring 4)
(ring-insert ring 5)
(ring-resize ring 5)
(should-equal (ring-size ring) 5)
(should-equal (ring-elements ring) '(5 4 3)))
(let ((ring (make-ring 5)))
(ring-insert ring 1)
(ring-insert ring 2)
(ring-insert ring 3)
(ring-insert ring 4)
(ring-insert ring 5)
(ring-resize ring 3)
(should-equal (ring-size ring) 3)
(should-equal (ring-elements ring) '(5 4 3))))
(ert-deftest save-mark-and-excursion ()
(with-temp-buffer
(insert "a\nb\nc")
(goto-char 1)
(set-mark 2)
(should-equal (point) 1)
(should-equal (mark) 2)
(save-mark-and-excursion
(goto-char 3)
(set-mark 4)
(should-equal (point) 3)
(should-equal (mark) 4))
(should-equal (point) 1)
(should-equal (mark) 2)))
(ert-deftest text-quoting-style ()
(should (text-quoting-style))
(let ((text-quoting-style t))
(should-equal 'curve (text-quoting-style)))
(let ((text-quoting-style 'foo))
(should-equal 'curve (text-quoting-style)))
(let ((text-quoting-style 'grave))
(should-equal 'grave (text-quoting-style))))
(ert-deftest substitute-quotes ()
(let ((text-quoting-style 'curve))
(should-equal (substitute-quotes "quotes ‘like this’") "quotes ‘like this’")
(should-equal (substitute-quotes "`x'") "‘x’")
(should-equal (substitute-quotes "`") "‘")
(should-equal (substitute-quotes "'") "’")
(should-equal (substitute-quotes "\\`") "\\‘"))
(let ((text-quoting-style 'straight))
(should-equal (substitute-quotes "quotes `like this'") "quotes 'like this'")
(should-equal (substitute-quotes "`x'") "'x'")
(should-equal (substitute-quotes "`") "'")
(should-equal (substitute-quotes "'") "'")
(should-equal (substitute-quotes "\\`") "\\'"))
(let ((text-quoting-style 'grave))
(should-equal (substitute-quotes "quotes `like this'") "quotes `like this'")
(should-equal (substitute-quotes "`x'") "`x'")
(should-equal (substitute-quotes "`") "`")
(should-equal (substitute-quotes "'") "'")
(should-equal (substitute-quotes "\\`") "\\`")))
(ert-deftest readablep ()
(should (readablep "foo"))
(should (readablep '("foo" 1 2.3 (a . b) [x y z] :key)))
(should-not (readablep (list (make-marker))))
(should-not (readablep (make-marker))))
(ert-deftest count-sentences ()
(with-temp-buffer
(insert "First sentence. Second sentence. Third sentence. Fourth sentence.")
(should-equal 4 (count-sentences (point-min) (point-max)))
(should-equal 2 (count-sentences 16 50))))
(ert-deftest major-mode-suspend ()
(with-temp-buffer
(should (local-variable-if-set-p 'major-mode--suspended))
(should (get 'major-mode--suspended 'permanent-local))
(text-mode)
(should sentence-end-double-space)
(setq-local sentence-end-double-space nil)
(major-mode-suspend)
(should-equal major-mode--suspended #'text-mode)
(should sentence-end-double-space)
(prog-mode)
(should-equal major-mode #'prog-mode)
(major-mode-restore)
(should-not major-mode--suspended)
(should sentence-end-double-space)
(should-equal major-mode #'text-mode)))
(provide 'compat-tests)
;;; compat-tests.el ends here