mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-04 14:40:54 -08:00
Merge remote-tracking branch 'savannah/master' into HEAD
This commit is contained in:
Andrea Corallo
commit
12a982d978
190 changed files with 6031 additions and 1722 deletions
|
|
@ -64,6 +64,11 @@ protect against "make" variable expansion):
|
|||
|
||||
make <filename> SELECTOR='"foo$$"'
|
||||
|
||||
In case you want to use the symbol name of a test as selector, you can
|
||||
use it directly:
|
||||
|
||||
make <filename> SELECTOR='test-foo-remote'
|
||||
|
||||
Note that although the test files are always compiled (unless they set
|
||||
no-byte-compile), the source files will be run when expensive or
|
||||
unstable tests are involved, to give nicer backtraces. To run the
|
||||
|
|
|
|||
0
test/data/mml-sec/.gpg-v21-migrated
Normal file
0
test/data/mml-sec/.gpg-v21-migrated
Normal file
5
test/data/mml-sec/gpg-agent.conf
Normal file
5
test/data/mml-sec/gpg-agent.conf
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
# pinentry-program /usr/bin/pinentry-gtk-2
|
||||
|
||||
# verbose
|
||||
# log-file /tmp/gpg-agent.log
|
||||
# debug-all
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
BIN
test/data/mml-sec/pubring.gpg
Normal file
BIN
test/data/mml-sec/pubring.gpg
Normal file
Binary file not shown.
BIN
test/data/mml-sec/pubring.kbx
Normal file
BIN
test/data/mml-sec/pubring.kbx
Normal file
Binary file not shown.
BIN
test/data/mml-sec/secring.gpg
Normal file
BIN
test/data/mml-sec/secring.gpg
Normal file
Binary file not shown.
BIN
test/data/mml-sec/trustdb.gpg
Normal file
BIN
test/data/mml-sec/trustdb.gpg
Normal file
Binary file not shown.
26
test/data/mml-sec/trustlist.txt
Normal file
26
test/data/mml-sec/trustlist.txt
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
# This is the list of trusted keys. Comment lines, like this one, as
|
||||
# well as empty lines are ignored. Lines have a length limit but this
|
||||
# is not a serious limitation as the format of the entries is fixed and
|
||||
# checked by gpg-agent. A non-comment line starts with optional white
|
||||
# space, followed by the SHA-1 fingerpint in hex, followed by a flag
|
||||
# which may be one of 'P', 'S' or '*' and optionally followed by a list of
|
||||
# other flags. The fingerprint may be prefixed with a '!' to mark the
|
||||
# key as not trusted. You should give the gpg-agent a HUP or run the
|
||||
# command "gpgconf --reload gpg-agent" after changing this file.
|
||||
|
||||
|
||||
# Include the default trust list
|
||||
include-default
|
||||
|
||||
|
||||
# CN=No Expiry
|
||||
D0:6A:A1:18:65:3C:C3:8E:9D:0C:AF:56:ED:7A:21:35:E1:58:21:77 S relax
|
||||
|
||||
# CN=Second Key Pair
|
||||
0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 S relax
|
||||
|
||||
# CN=No Expiry two UIDs
|
||||
D4:CA:78:E1:47:0B:9F:C2:AE:45:D7:84:64:9B:8C:E6:4E:BB:32:0C S relax
|
||||
|
||||
# CN=Different subkeys
|
||||
4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC S relax
|
||||
|
|
@ -109,4 +109,18 @@
|
|||
(ert-deftest test-time-since ()
|
||||
(should (time-equal-p 0 (time-since nil))))
|
||||
|
||||
(ert-deftest test-time-decoded-period ()
|
||||
(should (equal (decoded-time-period '(nil nil 1 nil nil nil nil nil nil))
|
||||
3600))
|
||||
|
||||
(should (equal (decoded-time-period '(1 0 0 0 0 0 nil nil nil)) 1))
|
||||
(should (equal (decoded-time-period '(0 1 0 0 0 0 nil nil nil)) 60))
|
||||
(should (equal (decoded-time-period '(0 0 1 0 0 0 nil nil nil)) 3600))
|
||||
(should (equal (decoded-time-period '(0 0 0 1 0 0 nil nil nil)) 86400))
|
||||
(should (equal (decoded-time-period '(0 0 0 0 1 0 nil nil nil)) 2592000))
|
||||
(should (equal (decoded-time-period '(0 0 0 0 0 1 nil nil nil)) 31536000))
|
||||
|
||||
(should (equal (decoded-time-period '((135 . 10) 0 0 0 0 0 nil nil nil))
|
||||
13.5)))
|
||||
|
||||
;;; time-date-tests.el ends here
|
||||
|
|
|
|||
|
|
@ -47,6 +47,11 @@
|
|||
(let ((a 1.0)) (/ 3 a 2))
|
||||
(let ((a most-positive-fixnum) (b 2.0)) (* a 2 b))
|
||||
(let ((a 3) (b 2)) (/ a b 1.0))
|
||||
(let ((a -0.0)) (+ a))
|
||||
(let ((a -0.0)) (- a))
|
||||
(let ((a -0.0)) (* a))
|
||||
(let ((a -0.0)) (min a))
|
||||
(let ((a -0.0)) (max a))
|
||||
(/ 3 -1)
|
||||
(+ 4 3 2 1)
|
||||
(+ 4 3 2.0 1)
|
||||
|
|
|
|||
|
|
@ -20,6 +20,166 @@
|
|||
;;; Commentary:
|
||||
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
|
||||
(ert-deftest cconv-tests-lambda-:documentation ()
|
||||
"Docstring for lambda can be specified with :documentation."
|
||||
(let ((fun (lambda ()
|
||||
(:documentation (concat "lambda" " documentation"))
|
||||
'lambda-result)))
|
||||
(should (string= (documentation fun) "lambda documentation"))
|
||||
(should (eq (funcall fun) 'lambda-result))))
|
||||
|
||||
(ert-deftest cconv-tests-pcase-lambda-:documentation ()
|
||||
"Docstring for pcase-lambda can be specified with :documentation."
|
||||
(let ((fun (pcase-lambda (`(,a ,b))
|
||||
(:documentation (concat "pcase-lambda" " documentation"))
|
||||
(list b a))))
|
||||
(should (string= (documentation fun) "pcase-lambda documentation"))
|
||||
(should (equal '(2 1) (funcall fun '(1 2))))))
|
||||
|
||||
(defun cconv-tests-defun ()
|
||||
(:documentation (concat "defun" " documentation"))
|
||||
'defun-result)
|
||||
(ert-deftest cconv-tests-defun-:documentation ()
|
||||
"Docstring for defun can be specified with :documentation."
|
||||
(should (string= (documentation 'cconv-tests-defun)
|
||||
"defun documentation"))
|
||||
(should (eq (cconv-tests-defun) 'defun-result)))
|
||||
|
||||
(cl-defun cconv-tests-cl-defun ()
|
||||
(:documentation (concat "cl-defun" " documentation"))
|
||||
'cl-defun-result)
|
||||
(ert-deftest cconv-tests-cl-defun-:documentation ()
|
||||
"Docstring for cl-defun can be specified with :documentation."
|
||||
(should (string= (documentation 'cconv-tests-cl-defun)
|
||||
"cl-defun documentation"))
|
||||
(should (eq (cconv-tests-cl-defun) 'cl-defun-result)))
|
||||
|
||||
;; FIXME: The byte-complier croaks on this. See Bug#28557.
|
||||
;; (defmacro cconv-tests-defmacro ()
|
||||
;; (:documentation (concat "defmacro" " documentation"))
|
||||
;; '(quote defmacro-result))
|
||||
;; (ert-deftest cconv-tests-defmacro-:documentation ()
|
||||
;; "Docstring for defmacro can be specified with :documentation."
|
||||
;; (should (string= (documentation 'cconv-tests-defmacro)
|
||||
;; "defmacro documentation"))
|
||||
;; (should (eq (cconv-tests-defmacro) 'defmacro-result)))
|
||||
|
||||
;; FIXME: The byte-complier croaks on this. See Bug#28557.
|
||||
;; (cl-defmacro cconv-tests-cl-defmacro ()
|
||||
;; (:documentation (concat "cl-defmacro" " documentation"))
|
||||
;; '(quote cl-defmacro-result))
|
||||
;; (ert-deftest cconv-tests-cl-defmacro-:documentation ()
|
||||
;; "Docstring for cl-defmacro can be specified with :documentation."
|
||||
;; (should (string= (documentation 'cconv-tests-cl-defmacro)
|
||||
;; "cl-defmacro documentation"))
|
||||
;; (should (eq (cconv-tests-cl-defmacro) 'cl-defmacro-result)))
|
||||
|
||||
(cl-iter-defun cconv-tests-cl-iter-defun ()
|
||||
(:documentation (concat "cl-iter-defun" " documentation"))
|
||||
(iter-yield 'cl-iter-defun-result))
|
||||
(ert-deftest cconv-tests-cl-iter-defun-:documentation ()
|
||||
"Docstring for cl-iter-defun can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:tags '(:unstable)
|
||||
:expected-result :failed
|
||||
(should (string= (documentation 'cconv-tests-cl-iter-defun)
|
||||
"cl-iter-defun documentation"))
|
||||
(should (eq (iter-next (cconv-tests-cl-iter-defun))
|
||||
'cl-iter-defun-result)))
|
||||
|
||||
(iter-defun cconv-tests-iter-defun ()
|
||||
(:documentation (concat "iter-defun" " documentation"))
|
||||
(iter-yield 'iter-defun-result))
|
||||
(ert-deftest cconv-tests-iter-defun-:documentation ()
|
||||
"Docstring for iter-defun can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:tags '(:unstable)
|
||||
:expected-result :failed
|
||||
(should (string= (documentation 'cconv-tests-iter-defun)
|
||||
"iter-defun documentation"))
|
||||
(should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result)))
|
||||
|
||||
(ert-deftest cconv-tests-iter-lambda-:documentation ()
|
||||
"Docstring for iter-lambda can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:expected-result :failed
|
||||
(let ((iter-fun
|
||||
(iter-lambda ()
|
||||
(:documentation (concat "iter-lambda" " documentation"))
|
||||
(iter-yield 'iter-lambda-result))))
|
||||
(should (string= (documentation iter-fun) "iter-lambda documentation"))
|
||||
(should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result))))
|
||||
|
||||
(ert-deftest cconv-tests-cl-function-:documentation ()
|
||||
"Docstring for cl-function can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:expected-result :failed
|
||||
(let ((fun (cl-function (lambda (&key arg)
|
||||
(:documentation (concat "cl-function"
|
||||
" documentation"))
|
||||
(list arg 'cl-function-result)))))
|
||||
(should (string= (documentation fun) "cl-function documentation"))
|
||||
(should (equal (funcall fun :arg t) '(t cl-function-result)))))
|
||||
|
||||
(ert-deftest cconv-tests-function-:documentation ()
|
||||
"Docstring for lambda inside function can be specified with :documentation."
|
||||
(let ((fun #'(lambda (arg)
|
||||
(:documentation (concat "function" " documentation"))
|
||||
(list arg 'function-result))))
|
||||
(should (string= (documentation fun) "function documentation"))
|
||||
(should (equal (funcall fun t) '(t function-result)))))
|
||||
|
||||
(fmakunbound 'cconv-tests-cl-defgeneric)
|
||||
(setplist 'cconv-tests-cl-defgeneric nil)
|
||||
(cl-defgeneric cconv-tests-cl-defgeneric (n)
|
||||
(:documentation (concat "cl-defgeneric" " documentation")))
|
||||
(cl-defmethod cconv-tests-cl-defgeneric ((n integer))
|
||||
(:documentation (concat "cl-defmethod" " documentation"))
|
||||
(+ 1 n))
|
||||
(ert-deftest cconv-tests-cl-defgeneric-:documentation ()
|
||||
"Docstring for cl-defgeneric can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:expected-result :failed
|
||||
(let ((descr (describe-function 'cconv-tests-cl-defgeneric)))
|
||||
(set-text-properties 0 (length descr) nil descr)
|
||||
(should (string-match-p "cl-defgeneric documentation" descr))
|
||||
(should (string-match-p "cl-defmethod documentation" descr)))
|
||||
(should (= 11 (cconv-tests-cl-defgeneric 10))))
|
||||
|
||||
(fmakunbound 'cconv-tests-cl-defgeneric-literal)
|
||||
(setplist 'cconv-tests-cl-defgeneric-literal nil)
|
||||
(cl-defgeneric cconv-tests-cl-defgeneric-literal (n)
|
||||
(:documentation "cl-defgeneric-literal documentation"))
|
||||
(cl-defmethod cconv-tests-cl-defgeneric-literal ((n integer))
|
||||
(:documentation "cl-defmethod-literal documentation")
|
||||
(+ 1 n))
|
||||
(ert-deftest cconv-tests-cl-defgeneric-literal-:documentation ()
|
||||
"Docstring for cl-defgeneric can be specified with :documentation."
|
||||
(let ((descr (describe-function 'cconv-tests-cl-defgeneric-literal)))
|
||||
(set-text-properties 0 (length descr) nil descr)
|
||||
(should (string-match-p "cl-defgeneric-literal documentation" descr))
|
||||
(should (string-match-p "cl-defmethod-literal documentation" descr)))
|
||||
(should (= 11 (cconv-tests-cl-defgeneric-literal 10))))
|
||||
|
||||
(defsubst cconv-tests-defsubst ()
|
||||
(:documentation (concat "defsubst" " documentation"))
|
||||
'defsubst-result)
|
||||
(ert-deftest cconv-tests-defsubst-:documentation ()
|
||||
"Docstring for defsubst can be specified with :documentation."
|
||||
(should (string= (documentation 'cconv-tests-defsubst)
|
||||
"defsubst documentation"))
|
||||
(should (eq (cconv-tests-defsubst) 'defsubst-result)))
|
||||
|
||||
(cl-defsubst cconv-tests-cl-defsubst ()
|
||||
(:documentation (concat "cl-defsubst" " documentation"))
|
||||
'cl-defsubst-result)
|
||||
(ert-deftest cconv-tests-cl-defsubst-:documentation ()
|
||||
"Docstring for cl-defsubst can be specified with :documentation."
|
||||
(should (string= (documentation 'cconv-tests-cl-defsubst)
|
||||
"cl-defsubst documentation"))
|
||||
(should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result)))
|
||||
|
||||
(ert-deftest cconv-convert-lambda-lifted ()
|
||||
"Bug#30872."
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@
|
|||
;;; Code:
|
||||
|
||||
(require 'cl-generic)
|
||||
(require 'edebug)
|
||||
|
||||
;; Don't indirectly require `cl-lib' at run-time.
|
||||
(eval-when-compile (require 'ert))
|
||||
|
|
@ -249,5 +250,42 @@
|
|||
(should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic))
|
||||
(should-not (cl--generic-method-files 'cl-generic-tests--generic-without-methods)))
|
||||
|
||||
(ert-deftest cl-defgeneric/edebug/method ()
|
||||
"Check that `:method' forms in `cl-defgeneric' create unique
|
||||
Edebug symbols (Bug#42672)."
|
||||
(with-temp-buffer
|
||||
(dolist (form '((cl-defgeneric cl-defgeneric/edebug/method/1 (_)
|
||||
(:method ((_ number)) 1)
|
||||
(:method ((_ string)) 2)
|
||||
(:method :around ((_ number)) 3))
|
||||
(cl-defgeneric cl-defgeneric/edebug/method/2 (_)
|
||||
(:method ((_ number)) 3))))
|
||||
(print form (current-buffer)))
|
||||
(let* ((edebug-all-defs t)
|
||||
(edebug-initial-mode 'Go-nonstop)
|
||||
(instrumented-names ())
|
||||
(edebug-new-definition-function
|
||||
(lambda (name)
|
||||
(when (memq name instrumented-names)
|
||||
(error "Duplicate definition of `%s'" name))
|
||||
(push name instrumented-names)
|
||||
(edebug-new-definition name)))
|
||||
;; Make generated symbols reproducible.
|
||||
(gensym-counter 10000))
|
||||
(eval-buffer)
|
||||
(should (equal
|
||||
(reverse instrumented-names)
|
||||
;; The generic function definitions come after the
|
||||
;; method definitions because their body ends later.
|
||||
;; FIXME: We'd rather have names such as
|
||||
;; `cl-defgeneric/edebug/method/1 ((_ number))', but
|
||||
;; that requires further changes to Edebug.
|
||||
(list (intern "cl-generic-:method@10000 ((_ number))")
|
||||
(intern "cl-generic-:method@10001 ((_ string))")
|
||||
(intern "cl-generic-:method@10002 :around ((_ number))")
|
||||
'cl-defgeneric/edebug/method/1
|
||||
(intern "cl-generic-:method@10003 ((_ number))")
|
||||
'cl-defgeneric/edebug/method/2))))))
|
||||
|
||||
(provide 'cl-generic-tests)
|
||||
;;; cl-generic-tests.el ends here
|
||||
|
|
|
|||
|
|
@ -938,5 +938,99 @@ test and possibly others should be updated."
|
|||
"g"
|
||||
(should (equal edebug-tests-@-result '(0 1))))))
|
||||
|
||||
(ert-deftest edebug-cl-defmethod-qualifier ()
|
||||
"Check that secondary `cl-defmethod' forms don't stomp over
|
||||
primary ones (Bug#42671)."
|
||||
(with-temp-buffer
|
||||
(let* ((edebug-all-defs t)
|
||||
(edebug-initial-mode 'Go-nonstop)
|
||||
(defined-symbols ())
|
||||
(edebug-new-definition-function
|
||||
(lambda (def-name)
|
||||
(push def-name defined-symbols)
|
||||
(edebug-new-definition def-name))))
|
||||
(dolist (form '((cl-defmethod edebug-cl-defmethod-qualifier ((_ number)))
|
||||
(cl-defmethod edebug-cl-defmethod-qualifier
|
||||
:around ((_ number)))))
|
||||
(print form (current-buffer)))
|
||||
(eval-buffer)
|
||||
(should
|
||||
(equal
|
||||
defined-symbols
|
||||
(list (intern "edebug-cl-defmethod-qualifier :around ((_ number))")
|
||||
(intern "edebug-cl-defmethod-qualifier ((_ number))")))))))
|
||||
|
||||
(ert-deftest edebug-tests-cl-flet ()
|
||||
"Check that Edebug can instrument `cl-flet' forms without name
|
||||
clashes (Bug#41853)."
|
||||
(with-temp-buffer
|
||||
(dolist (form '((defun edebug-tests-cl-flet-1 ()
|
||||
(cl-flet ((inner () 0)) (message "Hi"))
|
||||
(cl-flet ((inner () 1)) (inner)))
|
||||
(defun edebug-tests-cl-flet-2 ()
|
||||
(cl-flet ((inner () 2)) (inner)))))
|
||||
(print form (current-buffer)))
|
||||
(let* ((edebug-all-defs t)
|
||||
(edebug-initial-mode 'Go-nonstop)
|
||||
(instrumented-names ())
|
||||
(edebug-new-definition-function
|
||||
(lambda (name)
|
||||
(when (memq name instrumented-names)
|
||||
(error "Duplicate definition of `%s'" name))
|
||||
(push name instrumented-names)
|
||||
(edebug-new-definition name)))
|
||||
;; Make generated symbols reproducible.
|
||||
(gensym-counter 10000))
|
||||
(eval-buffer)
|
||||
(should (equal (reverse instrumented-names)
|
||||
;; The outer definitions come after the inner
|
||||
;; ones because their body ends later.
|
||||
;; FIXME: There are twice as many inner
|
||||
;; definitions as expected due to Bug#41988.
|
||||
;; Once that bug is fixed, remove the duplicates.
|
||||
;; FIXME: We'd rather have names such as
|
||||
;; `edebug-tests-cl-flet-1@inner@cl-flet@10000',
|
||||
;; but that requires further changes to Edebug.
|
||||
'(inner@cl-flet@10000
|
||||
inner@cl-flet@10001
|
||||
inner@cl-flet@10002
|
||||
inner@cl-flet@10003
|
||||
edebug-tests-cl-flet-1
|
||||
inner@cl-flet@10004
|
||||
inner@cl-flet@10005
|
||||
edebug-tests-cl-flet-2))))))
|
||||
|
||||
(ert-deftest edebug-tests-duplicate-symbol-backtrack ()
|
||||
"Check that Edebug doesn't create duplicate symbols when
|
||||
backtracking (Bug#42701)."
|
||||
(with-temp-buffer
|
||||
(dolist (form '((require 'subr-x)
|
||||
(defun edebug-tests-duplicate-symbol-backtrack ()
|
||||
(if-let (x (funcall (lambda (y) 1) 2)) 3 4))))
|
||||
(print form (current-buffer)))
|
||||
(let* ((edebug-all-defs t)
|
||||
(edebug-initial-mode 'Go-nonstop)
|
||||
(instrumented-names ())
|
||||
(edebug-new-definition-function
|
||||
(lambda (name)
|
||||
(when (memq name instrumented-names)
|
||||
(error "Duplicate definition of `%s'" name))
|
||||
(push name instrumented-names)
|
||||
(edebug-new-definition name)))
|
||||
;; Make generated symbols reproducible.
|
||||
(gensym-counter 10000))
|
||||
(eval-buffer)
|
||||
;; The anonymous symbols are uninterned. Use their names so we
|
||||
;; can perform the assertion. The names should still be unique.
|
||||
(should (equal (mapcar #'symbol-name (reverse instrumented-names))
|
||||
;; The outer definition comes after the inner
|
||||
;; ones because its body ends later.
|
||||
;; FIXME: There are twice as many inner
|
||||
;; definitions as expected due to Bug#42701.
|
||||
;; Once that bug is fixed, remove the duplicates.
|
||||
'("edebug-anon10000"
|
||||
"edebug-anon10001"
|
||||
"edebug-tests-duplicate-symbol-backtrack"))))))
|
||||
|
||||
(provide 'edebug-tests)
|
||||
;;; edebug-tests.el ends here
|
||||
|
|
|
|||
|
|
@ -22,6 +22,10 @@
|
|||
|
||||
;;; Commentary:
|
||||
|
||||
;; Unit tests for generator.el.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'generator)
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
|
|
|
|||
556
test/lisp/emacs-lisp/hierarchy-tests.el
Normal file
556
test/lisp/emacs-lisp/hierarchy-tests.el
Normal file
|
|
@ -0,0 +1,556 @@
|
|||
;;; hierarchy-tests.el --- Tests for hierarchy.el
|
||||
|
||||
;; Copyright (C) 2017-2019 Damien Cassou
|
||||
|
||||
;; Author: Damien Cassou <damien@cassou.me>
|
||||
;; Maintainer: emacs-devel@gnu.org
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Tests for hierarchy.el
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'hierarchy)
|
||||
|
||||
(defun hierarchy-animals ()
|
||||
"Create a sorted animal hierarchy."
|
||||
(let ((parentfn (lambda (item) (cl-case item
|
||||
(dove 'bird)
|
||||
(pigeon 'bird)
|
||||
(bird 'animal)
|
||||
(dolphin 'animal)
|
||||
(cow 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'pigeon parentfn)
|
||||
(hierarchy-add-tree hierarchy 'dolphin parentfn)
|
||||
(hierarchy-add-tree hierarchy 'cow parentfn)
|
||||
(hierarchy-sort hierarchy)
|
||||
hierarchy))
|
||||
|
||||
(ert-deftest hierarchy-add-one-root ()
|
||||
(let ((parentfn (lambda (_) nil))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))))
|
||||
|
||||
(ert-deftest hierarchy-add-one-item-with-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
|
||||
|
||||
(ert-deftest hierarchy-add-one-item-with-parent-and-grand-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove)))))
|
||||
|
||||
(ert-deftest hierarchy-add-same-root-twice ()
|
||||
(let ((parentfn (lambda (_) nil))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))))
|
||||
|
||||
(ert-deftest hierarchy-add-same-child-twice ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
|
||||
|
||||
(ert-deftest hierarchy-add-item-and-its-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
|
||||
|
||||
(ert-deftest hierarchy-add-item-and-its-child ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
|
||||
|
||||
(ert-deftest hierarchy-add-two-items-sharing-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(pigeon 'bird))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'pigeon parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-add-two-hierarchies ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(circle 'shape))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'circle parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(bird shape)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove)))
|
||||
(should (equal (hierarchy-children hierarchy 'shape) '(circle)))))
|
||||
|
||||
(ert-deftest hierarchy-add-with-childrenfn ()
|
||||
(let ((childrenfn (lambda (item)
|
||||
(cl-case item
|
||||
(animal '(bird))
|
||||
(bird '(dove pigeon)))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'animal nil childrenfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-add-with-parentfn-and-childrenfn ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal)
|
||||
(animal 'life-form))))
|
||||
(childrenfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird '(dove pigeon))
|
||||
(pigeon '(ashy-wood-pigeon)))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn childrenfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(life-form)))
|
||||
(should (equal (hierarchy-children hierarchy 'life-form) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))
|
||||
(should (equal (hierarchy-children hierarchy 'pigeon) '(ashy-wood-pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-add-twice-with-parentfn-and-childrenfn ()
|
||||
(let* ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(bird 'animal))))
|
||||
(childrenfn (lambda (item)
|
||||
(cl-case item
|
||||
(animal '(bird))
|
||||
(bird '(dove)))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn childrenfn)
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove)))))
|
||||
|
||||
(ert-deftest hierarchy-add-trees ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(pigeon 'bird)
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-trees hierarchy '(dove pigeon) parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-from-list ()
|
||||
(let ((hierarchy (hierarchy-from-list
|
||||
'(animal (bird (dove)
|
||||
(pigeon))
|
||||
(cow)
|
||||
(dolphin)))))
|
||||
(hierarchy-sort hierarchy (lambda (item1 item2)
|
||||
(string< (car item1)
|
||||
(car item2))))
|
||||
(should (equal (hierarchy-to-string hierarchy (lambda (item) (symbol-name (car item))))
|
||||
"animal\n bird\n dove\n pigeon\n cow\n dolphin\n"))))
|
||||
|
||||
(ert-deftest hierarchy-from-list-with-duplicates ()
|
||||
(let ((hierarchy (hierarchy-from-list
|
||||
'(a (b) (b))
|
||||
t)))
|
||||
(hierarchy-sort hierarchy (lambda (item1 item2)
|
||||
;; sort by ID
|
||||
(< (car item1) (car item2))))
|
||||
(should (equal (hierarchy-length hierarchy) 3))
|
||||
(should (equal (hierarchy-to-string
|
||||
hierarchy
|
||||
(lambda (item)
|
||||
(format "%s(%s)"
|
||||
(cadr item)
|
||||
(car item))))
|
||||
"a(1)\n b(2)\n b(3)\n"))))
|
||||
|
||||
(ert-deftest hierarchy-from-list-with-childrenfn ()
|
||||
(let ((hierarchy (hierarchy-from-list
|
||||
"abc"
|
||||
nil
|
||||
(lambda (item)
|
||||
(when (string= item "abc")
|
||||
(split-string item "" t))))))
|
||||
(hierarchy-sort hierarchy (lambda (item1 item2) (string< item1 item2)))
|
||||
(should (equal (hierarchy-length hierarchy) 4))
|
||||
(should (equal (hierarchy-to-string hierarchy)
|
||||
"abc\n a\n b\n c\n"))))
|
||||
|
||||
(ert-deftest hierarchy-add-relation-check-error-when-different-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(should-error
|
||||
(hierarchy--add-relation hierarchy 'bird 'cow #'identity))))
|
||||
|
||||
(ert-deftest hierarchy-empty-p-return-non-nil-for-empty ()
|
||||
(should (hierarchy-empty-p (hierarchy-new))))
|
||||
|
||||
(ert-deftest hierarchy-empty-p-return-nil-for-non-empty ()
|
||||
(should-not (hierarchy-empty-p (hierarchy-animals))))
|
||||
|
||||
(ert-deftest hierarchy-length-of-empty-is-0 ()
|
||||
(should (equal (hierarchy-length (hierarchy-new)) 0)))
|
||||
|
||||
(ert-deftest hierarchy-length-of-non-empty-counts-items ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal)
|
||||
(dove 'bird)
|
||||
(pigeon 'bird))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'pigeon parentfn)
|
||||
(should (equal (hierarchy-length hierarchy) 4))))
|
||||
|
||||
(ert-deftest hierarchy-has-root ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal)
|
||||
(dove 'bird)
|
||||
(pigeon 'bird))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(should-not (hierarchy-has-root hierarchy 'animal))
|
||||
(should-not (hierarchy-has-root hierarchy 'bird))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'pigeon parentfn)
|
||||
(should (hierarchy-has-root hierarchy 'animal))
|
||||
(should-not (hierarchy-has-root hierarchy 'bird))))
|
||||
|
||||
(ert-deftest hierarchy-leafs ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (equal (hierarchy-leafs animals)
|
||||
'(dove pigeon dolphin cow)))))
|
||||
|
||||
(ert-deftest hierarchy-leafs-includes-lonely-roots ()
|
||||
(let ((parentfn (lambda (item) nil))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'foo parentfn)
|
||||
(should (equal (hierarchy-leafs hierarchy)
|
||||
'(foo)))))
|
||||
|
||||
(ert-deftest hierarchy-leafs-of-node ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (equal (hierarchy-leafs animals 'cow) '()))
|
||||
(should (equal (hierarchy-leafs animals 'animal) '(dove pigeon dolphin cow)))
|
||||
(should (equal (hierarchy-leafs animals 'bird) '(dove pigeon)))
|
||||
(should (equal (hierarchy-leafs animals 'dove) '()))))
|
||||
|
||||
(ert-deftest hierarchy-child-p ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (hierarchy-child-p animals 'dove 'bird))
|
||||
(should (hierarchy-child-p animals 'bird 'animal))
|
||||
(should (hierarchy-child-p animals 'cow 'animal))
|
||||
(should-not (hierarchy-child-p animals 'cow 'bird))
|
||||
(should-not (hierarchy-child-p animals 'bird 'cow))
|
||||
(should-not (hierarchy-child-p animals 'animal 'dove))
|
||||
(should-not (hierarchy-child-p animals 'animal 'bird))))
|
||||
|
||||
(ert-deftest hierarchy-descendant ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (hierarchy-descendant-p animals 'dove 'animal))
|
||||
(should (hierarchy-descendant-p animals 'dove 'bird))
|
||||
(should (hierarchy-descendant-p animals 'bird 'animal))
|
||||
(should (hierarchy-descendant-p animals 'cow 'animal))
|
||||
(should-not (hierarchy-descendant-p animals 'cow 'bird))
|
||||
(should-not (hierarchy-descendant-p animals 'bird 'cow))
|
||||
(should-not (hierarchy-descendant-p animals 'animal 'dove))
|
||||
(should-not (hierarchy-descendant-p animals 'animal 'bird))))
|
||||
|
||||
(ert-deftest hierarchy-descendant-if-not-same ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should-not (hierarchy-descendant-p animals 'cow 'cow))
|
||||
(should-not (hierarchy-descendant-p animals 'dove 'dove))
|
||||
(should-not (hierarchy-descendant-p animals 'bird 'bird))
|
||||
(should-not (hierarchy-descendant-p animals 'animal 'animal))))
|
||||
|
||||
;; keywords supported: :test :key
|
||||
(ert-deftest hierarchy--set-equal ()
|
||||
(should (hierarchy--set-equal '(1 2 3) '(1 2 3)))
|
||||
(should (hierarchy--set-equal '(1 2 3) '(3 2 1)))
|
||||
(should (hierarchy--set-equal '(3 2 1) '(1 2 3)))
|
||||
(should-not (hierarchy--set-equal '(2 3) '(3 2 1)))
|
||||
(should-not (hierarchy--set-equal '(1 2 3) '(2 3)))
|
||||
(should-not (hierarchy--set-equal '("1" "2") '("2" "1") :test #'eq))
|
||||
(should (hierarchy--set-equal '("1" "2") '("2" "1") :test #'equal))
|
||||
(should-not (hierarchy--set-equal '(1 2) '(-1 -2)))
|
||||
(should (hierarchy--set-equal '(1 2) '(-1 -2) :key #'abs))
|
||||
(should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2))))
|
||||
(should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car))
|
||||
(should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :test #'equal))
|
||||
(should (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car :test #'equal)))
|
||||
|
||||
(ert-deftest hierarchy-equal-returns-true-for-same-hierarchy ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (hierarchy-equal animals animals))
|
||||
(should (hierarchy-equal (hierarchy-animals) animals))))
|
||||
|
||||
(ert-deftest hierarchy-equal-returns-true-for-hierarchy-copies ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (hierarchy-equal animals (hierarchy-copy animals)))))
|
||||
|
||||
(ert-deftest hierarchy-map-item-on-leaf ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-item (lambda (item indent) (cons item indent))
|
||||
'cow
|
||||
animals)))
|
||||
(should (equal result '((cow . 0))))))
|
||||
|
||||
(ert-deftest hierarchy-map-item-on-leaf-with-indent ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-item (lambda (item indent) (cons item indent))
|
||||
'cow
|
||||
animals
|
||||
2)))
|
||||
(should (equal result '((cow . 2))))))
|
||||
|
||||
(ert-deftest hierarchy-map-item-on-parent ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-item (lambda (item indent) (cons item indent))
|
||||
'bird
|
||||
animals)))
|
||||
(should (equal result '((bird . 0) (dove . 1) (pigeon . 1))))))
|
||||
|
||||
(ert-deftest hierarchy-map-item-on-grand-parent ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-item (lambda (item indent) (cons item indent))
|
||||
'animal
|
||||
animals)))
|
||||
(should (equal result '((animal . 0) (bird . 1) (dove . 2) (pigeon . 2)
|
||||
(cow . 1) (dolphin . 1))))))
|
||||
|
||||
(ert-deftest hierarchy-map-conses ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map (lambda (item indent)
|
||||
(cons item indent))
|
||||
animals)))
|
||||
(should (equal result '((animal . 0)
|
||||
(bird . 1)
|
||||
(dove . 2)
|
||||
(pigeon . 2)
|
||||
(cow . 1)
|
||||
(dolphin . 1))))))
|
||||
|
||||
(ert-deftest hierarchy-map-tree ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (equal (hierarchy-map-tree (lambda (item indent children)
|
||||
(list item indent children))
|
||||
animals)
|
||||
'(animal
|
||||
0
|
||||
((bird 1 ((dove 2 nil) (pigeon 2 nil)))
|
||||
(cow 1 nil)
|
||||
(dolphin 1 nil)))))))
|
||||
|
||||
(ert-deftest hierarchy-map-hierarchy-keeps-hierarchy ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-hierarchy (lambda (item _) (identity item))
|
||||
animals)))
|
||||
(should (hierarchy-equal animals result))))
|
||||
|
||||
(ert-deftest hierarchy-map-applies-function ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(parentfn (lambda (item)
|
||||
(cond
|
||||
((equal item "bird") "animal")
|
||||
((equal item "dove") "bird")
|
||||
((equal item "pigeon") "bird")
|
||||
((equal item "cow") "animal")
|
||||
((equal item "dolphin") "animal"))))
|
||||
(expected (hierarchy-new)))
|
||||
(hierarchy-add-tree expected "dove" parentfn)
|
||||
(hierarchy-add-tree expected "pigeon" parentfn)
|
||||
(hierarchy-add-tree expected "cow" parentfn)
|
||||
(hierarchy-add-tree expected "dolphin" parentfn)
|
||||
(should (hierarchy-equal
|
||||
(hierarchy-map-hierarchy (lambda (item _) (symbol-name item)) animals)
|
||||
expected))))
|
||||
|
||||
(ert-deftest hierarchy-extract-tree ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(birds (hierarchy-extract-tree animals 'bird)))
|
||||
(hierarchy-sort birds)
|
||||
(should (equal (hierarchy-roots birds) '(animal)))
|
||||
(should (equal (hierarchy-children birds 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children birds 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-extract-tree-nil-if-not-in-hierarchy ()
|
||||
(let* ((animals (hierarchy-animals)))
|
||||
(should-not (hierarchy-extract-tree animals 'foobar))))
|
||||
|
||||
(ert-deftest hierarchy-items-of-empty-hierarchy-is-empty ()
|
||||
(should (seq-empty-p (hierarchy-items (hierarchy-new)))))
|
||||
|
||||
(ert-deftest hierarchy-items-returns-sequence-of-same-length ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-items animals)))
|
||||
(should (= (seq-length result) (hierarchy-length animals)))))
|
||||
|
||||
(ert-deftest hierarchy-items-return-all-elements-of-hierarchy ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-items animals)))
|
||||
(should (equal (seq-sort #'string< result) '(animal bird cow dolphin dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-indent-no-indent-if-0 ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(labelfn (hierarchy-labelfn-indent labelfn-base)))
|
||||
(should (equal
|
||||
(with-temp-buffer
|
||||
(funcall labelfn "bar" 0)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
"foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-indent-three-times-if-3 ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(labelfn (hierarchy-labelfn-indent labelfn-base)))
|
||||
(should (equal
|
||||
(with-temp-buffer
|
||||
(funcall labelfn "bar" 3)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
" foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-indent-default-indent-string ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(labelfn (hierarchy-labelfn-indent labelfn-base)))
|
||||
(should (equal
|
||||
(with-temp-buffer
|
||||
(funcall labelfn "bar" 1)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
" foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-indent-custom-indent-string ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(labelfn (hierarchy-labelfn-indent labelfn-base "###"))
|
||||
(content (with-temp-buffer
|
||||
(funcall labelfn "bar" 1)
|
||||
(buffer-substring (point-min) (point-max)))))
|
||||
(should (equal content "###foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-button-propertize ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(actionfn #'identity)
|
||||
(labelfn (hierarchy-labelfn-button labelfn-base actionfn))
|
||||
(properties (with-temp-buffer
|
||||
(funcall labelfn "bar" 1)
|
||||
(text-properties-at 1))))
|
||||
(should (equal (car properties) 'action))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-button-execute-labelfn ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(actionfn #'identity)
|
||||
(labelfn (hierarchy-labelfn-button labelfn-base actionfn))
|
||||
(content (with-temp-buffer
|
||||
(funcall labelfn "bar" 1)
|
||||
(buffer-substring-no-properties (point-min) (point-max)))))
|
||||
(should (equal content "foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-button-if-does-not-button-unless-condition ()
|
||||
(let ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(spy-count 0)
|
||||
(condition (lambda (_item _indent) nil)))
|
||||
(cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count)))))
|
||||
(funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil)
|
||||
(should (equal spy-count 0)))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-button-if-does-button-when-condition ()
|
||||
(let ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(spy-count 0)
|
||||
(condition (lambda (_item _indent) t)))
|
||||
(cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count)))))
|
||||
(funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil)
|
||||
(should (equal spy-count 1)))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-to-string ()
|
||||
(let ((labelfn (lambda (item _indent) (insert item))))
|
||||
(should (equal (hierarchy-labelfn-to-string labelfn "foo" 1) "foo"))))
|
||||
|
||||
(ert-deftest hierarchy-print ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (with-temp-buffer
|
||||
(hierarchy-print animals)
|
||||
(buffer-substring-no-properties (point-min) (point-max)))))
|
||||
(should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n"))))
|
||||
|
||||
(ert-deftest hierarchy-to-string ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-to-string animals)))
|
||||
(should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n"))))
|
||||
|
||||
(ert-deftest hierarchy-tabulated-display ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(labelfn (lambda (item _indent) (insert (symbol-name item))))
|
||||
(contents (with-temp-buffer
|
||||
(hierarchy-tabulated-display animals labelfn (current-buffer))
|
||||
(buffer-substring-no-properties (point-min) (point-max)))))
|
||||
(should (equal contents "animal\nbird\ndove\npigeon\ncow\ndolphin\n"))))
|
||||
|
||||
(ert-deftest hierarchy-sort-non-root-nodes ()
|
||||
(let* ((animals (hierarchy-animals)))
|
||||
(should (equal (hierarchy-roots animals) '(animal)))
|
||||
(should (equal (hierarchy-children animals 'animal) '(bird cow dolphin)))
|
||||
(should (equal (hierarchy-children animals 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-sort-roots ()
|
||||
(let* ((organisms (hierarchy-new))
|
||||
(parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(oak 'plant)
|
||||
(bird 'animal)))))
|
||||
(hierarchy-add-tree organisms 'oak parentfn)
|
||||
(hierarchy-add-tree organisms 'bird parentfn)
|
||||
(hierarchy-sort organisms)
|
||||
(should (equal (hierarchy-roots organisms) '(animal plant)))))
|
||||
|
||||
(provide 'hierarchy-tests)
|
||||
;;; hierarchy-tests.el ends here
|
||||
47
test/lisp/erc/erc-tests.el
Normal file
47
test/lisp/erc/erc-tests.el
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
;;; erc-tests.el --- Tests for erc. -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 2020 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Lars Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'erc)
|
||||
|
||||
(ert-deftest erc--read-time-period ()
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "")))
|
||||
(should (equal (erc--read-time-period "foo: ") nil)))
|
||||
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) " ")))
|
||||
(should (equal (erc--read-time-period "foo: ") nil)))
|
||||
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) " 432 ")))
|
||||
(should (equal (erc--read-time-period "foo: ") 432)))
|
||||
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "432")))
|
||||
(should (equal (erc--read-time-period "foo: ") 432)))
|
||||
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h")))
|
||||
(should (equal (erc--read-time-period "foo: ") 3600)))
|
||||
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h10s")))
|
||||
(should (equal (erc--read-time-period "foo: ") 3610)))
|
||||
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d")))
|
||||
(should (equal (erc--read-time-period "foo: ") 86400))))
|
||||
76
test/lisp/gnus/gnus-util-tests.el
Normal file
76
test/lisp/gnus/gnus-util-tests.el
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
;;; gnus-util-tests.el --- Selectived tests only.
|
||||
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org>
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 3, or (at your option)
|
||||
;; any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'gnus-util)
|
||||
|
||||
(ert-deftest gnus-subsetp ()
|
||||
;; False for non-lists.
|
||||
(should-not (gnus-subsetp "1" "1"))
|
||||
(should-not (gnus-subsetp "1" '("1")))
|
||||
(should-not (gnus-subsetp '("1") "1"))
|
||||
|
||||
;; Real tests.
|
||||
(should (gnus-subsetp '() '()))
|
||||
(should (gnus-subsetp '() '("1")))
|
||||
(should (gnus-subsetp '("1") '("1")))
|
||||
(should (gnus-subsetp '(42) '("1" 42)))
|
||||
(should (gnus-subsetp '(42) '(42 "1")))
|
||||
(should (gnus-subsetp '(42) '("1" 42 2)))
|
||||
(should-not (gnus-subsetp '("1") '()))
|
||||
(should-not (gnus-subsetp '("1") '(2)))
|
||||
(should-not (gnus-subsetp '("1" 2) '(2)))
|
||||
(should-not (gnus-subsetp '(2 "1") '(2)))
|
||||
(should-not (gnus-subsetp '("1" 2) '(2 3)))
|
||||
|
||||
;; Duplicates don't matter for sets.
|
||||
(should (gnus-subsetp '("1" "1") '("1")))
|
||||
(should (gnus-subsetp '("1" 2 "1") '(2 "1")))
|
||||
(should (gnus-subsetp '("1" 2 "1") '(2 "1" "1" 2)))
|
||||
(should-not (gnus-subsetp '("1" 2 "1" 3) '(2 "1" "1" 2))))
|
||||
|
||||
(ert-deftest gnus-setdiff ()
|
||||
;; False for non-lists.
|
||||
(should-not (gnus-setdiff "1" "1"))
|
||||
(should-not (gnus-setdiff "1" '()))
|
||||
(should-not (gnus-setdiff '() "1"))
|
||||
|
||||
;; Real tests.
|
||||
(should-not (gnus-setdiff '() '()))
|
||||
(should-not (gnus-setdiff '() '("1")))
|
||||
(should-not (gnus-setdiff '("1") '("1")))
|
||||
(should (equal '("1") (gnus-setdiff '("1") '())))
|
||||
(should (equal '("1") (gnus-setdiff '("1") '(2))))
|
||||
(should (equal '("1") (gnus-setdiff '("1" 2) '(2))))
|
||||
(should (equal '("1") (gnus-setdiff '("1" 2 3) '(3 2))))
|
||||
(should (equal '("1") (gnus-setdiff '(2 "1" 3) '(3 2))))
|
||||
(should (equal '("1") (gnus-setdiff '(2 3 "1") '(3 2))))
|
||||
(should (equal '(2 "1") (gnus-setdiff '(2 3 "1") '(3))))
|
||||
|
||||
;; Duplicates aren't touched for sets if they are not removed.
|
||||
(should-not (gnus-setdiff '("1" "1") '("1")))
|
||||
(should (equal '("1") (gnus-setdiff '(2 "1" 2) '(2))))
|
||||
(should (equal '("1" "1") (gnus-setdiff '(2 "1" 2 "1") '(2)))))
|
||||
|
||||
;;; gnustest-gnus-util.el ends here
|
||||
895
test/lisp/gnus/mml-sec-tests.el
Normal file
895
test/lisp/gnus/mml-sec-tests.el
Normal file
|
|
@ -0,0 +1,895 @@
|
|||
;;; gnustest-mml-sec.el --- Tests mml-sec.el, see README-mml-secure.txt.
|
||||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org>
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 3, or (at your option)
|
||||
;; any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
|
||||
(require 'message)
|
||||
(require 'epa)
|
||||
(require 'epg)
|
||||
(require 'mml-sec)
|
||||
(require 'gnus-sum)
|
||||
|
||||
(defvar with-smime nil
|
||||
"If nil, exclude S/MIME from tests as passphrases need to entered manually.
|
||||
Mostly, the empty passphrase is used. However, the keys for
|
||||
\"No Expiry two UIDs\" have the passphrase \"Passphrase\" (for OpenPGP as well
|
||||
as S/MIME).")
|
||||
|
||||
(defun test-conf ()
|
||||
(ignore-errors (epg-configuration)))
|
||||
|
||||
(defun enc-standards ()
|
||||
(if with-smime '(enc-pgp enc-pgp-mime enc-smime)
|
||||
'(enc-pgp enc-pgp-mime)))
|
||||
(defun enc-sign-standards ()
|
||||
(if with-smime
|
||||
'(enc-sign-pgp enc-sign-pgp-mime enc-sign-smime)
|
||||
'(enc-sign-pgp enc-sign-pgp-mime)))
|
||||
(defun sign-standards ()
|
||||
(if with-smime
|
||||
'(sign-pgp sign-pgp-mime sign-smime)
|
||||
'(sign-pgp sign-pgp-mime)))
|
||||
|
||||
(defun mml-secure-test-fixture (body &optional interactive)
|
||||
"Setup GnuPG home containing test keys and prepare environment for BODY.
|
||||
If optional INTERACTIVE is non-nil, allow questions to the user in case of
|
||||
key problems.
|
||||
This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests,
|
||||
which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess.
|
||||
Actually, I'm not sure why people would want to cache passwords in Emacs
|
||||
instead of gpg-agent."
|
||||
(unwind-protect
|
||||
(let ((agent-info (getenv "GPG_AGENT_INFO"))
|
||||
(gpghome (getenv "GNUPGHOME")))
|
||||
(condition-case error
|
||||
(let ((epg-gpg-home-directory
|
||||
(expand-file-name "test/data/mml-sec" source-directory))
|
||||
(mml-secure-allow-signing-with-unknown-recipient t)
|
||||
(mml-smime-use 'epg)
|
||||
;; Create debug output in empty epg-debug-buffer.
|
||||
(epg-debug t)
|
||||
(epg-debug-buffer (get-buffer-create " *epg-test*"))
|
||||
(mml-secure-fail-when-key-problem (not interactive)))
|
||||
(with-current-buffer epg-debug-buffer
|
||||
(erase-buffer))
|
||||
;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs.
|
||||
;; Just for testing. Jens does not recommend this for daily use.
|
||||
(setenv "GPG_AGENT_INFO")
|
||||
;; Set GNUPGHOME as gpg-agent started by gpgsm does
|
||||
;; not look in the proper places otherwise, see:
|
||||
;; https://bugs.gnupg.org/gnupg/issue2126
|
||||
(setenv "GNUPGHOME" epg-gpg-home-directory)
|
||||
(funcall body))
|
||||
(error
|
||||
(setenv "GPG_AGENT_INFO" agent-info)
|
||||
(setenv "GNUPGHOME" gpghome)
|
||||
(signal (car error) (cdr error))))
|
||||
(setenv "GPG_AGENT_INFO" agent-info)
|
||||
(setenv "GNUPGHOME" gpghome))))
|
||||
|
||||
(defun mml-secure-test-message-setup (method to from &optional text bcc)
|
||||
"Setup a buffer with MML METHOD, TO, and FROM headers.
|
||||
Optionally, a message TEXT and BCC header can be passed."
|
||||
(with-temp-buffer
|
||||
(when bcc (insert (format "Bcc: %s\n" bcc)))
|
||||
(insert (format "To: %s
|
||||
From: %s
|
||||
Subject: Test
|
||||
%s\n" to from mail-header-separator))
|
||||
(if text
|
||||
(insert (format "%s" text))
|
||||
(spook))
|
||||
(cond ((eq method 'enc-pgp-mime)
|
||||
(mml-secure-message-encrypt-pgpmime 'nosig))
|
||||
((eq method 'enc-sign-pgp-mime)
|
||||
(mml-secure-message-encrypt-pgpmime))
|
||||
((eq method 'enc-pgp) (mml-secure-message-encrypt-pgp 'nosig))
|
||||
((eq method 'enc-sign-pgp) (mml-secure-message-encrypt-pgp))
|
||||
((eq method 'enc-smime) (mml-secure-message-encrypt-smime 'nosig))
|
||||
((eq method 'enc-sign-smime) (mml-secure-message-encrypt-smime))
|
||||
((eq method 'sign-pgp-mime) (mml-secure-message-sign-pgpmime))
|
||||
((eq method 'sign-pgp) (mml-secure-message-sign-pgp))
|
||||
((eq method 'sign-smime) (mml-secure-message-sign-smime))
|
||||
(t (error "Unknown method")))
|
||||
(buffer-string)))
|
||||
|
||||
(defun mml-secure-test-mail-fixture (method to from body2
|
||||
&optional interactive)
|
||||
"Setup buffer encrypted using METHOD for TO from FROM, call BODY2.
|
||||
Pass optional INTERACTIVE to mml-secure-test-fixture."
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(let ((context (if (memq method '(enc-smime enc-sign-smime sign-smime))
|
||||
(epg-make-context 'CMS)
|
||||
(epg-make-context 'OpenPGP)))
|
||||
;; Verify and decrypt by default.
|
||||
(mm-verify-option 'known)
|
||||
(mm-decrypt-option 'known)
|
||||
(plaintext "The Magic Words are Squeamish Ossifrage"))
|
||||
(with-temp-buffer
|
||||
(insert (mml-secure-test-message-setup method to from plaintext))
|
||||
(message-options-set-recipient)
|
||||
(message-encode-message-body)
|
||||
;; Replace separator line with newline.
|
||||
(goto-char (point-min))
|
||||
(re-search-forward
|
||||
(concat "^" (regexp-quote mail-header-separator) "\n"))
|
||||
(replace-match "\n")
|
||||
;; The following treatment of handles, plainbuf, and multipart
|
||||
;; resulted from trial-and-error.
|
||||
;; Someone with more knowledge on how to decrypt messages and verify
|
||||
;; signatures might know more appropriate functions to invoke
|
||||
;; instead.
|
||||
(let* ((handles (or (mm-dissect-buffer)
|
||||
(mm-uu-dissect)))
|
||||
(isplain (bufferp (car handles)))
|
||||
(ismultipart (equal (car handles) "multipart/mixed"))
|
||||
(plainbuf (if isplain
|
||||
(car handles)
|
||||
(if ismultipart
|
||||
(car (cadadr handles))
|
||||
(caadr handles))))
|
||||
(decrypted
|
||||
(with-current-buffer plainbuf (buffer-string)))
|
||||
(gnus-info
|
||||
(if isplain
|
||||
nil
|
||||
(if ismultipart
|
||||
(or (mm-handle-multipart-ctl-parameter
|
||||
(cadr handles) 'gnus-details)
|
||||
(mm-handle-multipart-ctl-parameter
|
||||
(cadr handles) 'gnus-info))
|
||||
(mm-handle-multipart-ctl-parameter
|
||||
handles 'gnus-info)))))
|
||||
(funcall body2 gnus-info plaintext decrypted)))))
|
||||
interactive))
|
||||
|
||||
;; TODO If the variable BODY3 is renamed to BODY, an infinite recursion
|
||||
;; occurs. Emacs bug?
|
||||
(defun mml-secure-test-key-fixture (body3)
|
||||
"Customize unique keys for sub@example.org and call BODY3.
|
||||
For OpenPGP, we have:
|
||||
- 1E6B FA97 3D9E 3103 B77F D399 C399 9CF1 268D BEA2
|
||||
uid Different subkeys <sub@example.org>
|
||||
- 1463 2ECA B9E2 2736 9C8D D97B F7E7 9AB7 AE31 D471
|
||||
uid Second Key Pair <sub@example.org>
|
||||
|
||||
For S/MIME:
|
||||
ID: 0x479DC6E2
|
||||
Subject: /CN=Second Key Pair
|
||||
aka: sub@example.org
|
||||
fingerprint: 0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2
|
||||
|
||||
ID: 0x5F88E9FC
|
||||
Subject: /CN=Different subkeys
|
||||
aka: sub@example.org
|
||||
fingerprint: 4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC
|
||||
|
||||
In both cases, the first key is customized for signing and encryption."
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(let* ((mml-secure-key-preferences
|
||||
'((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))
|
||||
(pcontext (epg-make-context 'OpenPGP))
|
||||
(pkey (epg-list-keys pcontext "C3999CF1268DBEA2"))
|
||||
(scontext (epg-make-context 'CMS))
|
||||
(skey (epg-list-keys scontext "0x479DC6E2")))
|
||||
(mml-secure-cust-record-keys pcontext 'encrypt "sub@example.org" pkey)
|
||||
(mml-secure-cust-record-keys pcontext 'sign "sub@example.org" pkey)
|
||||
(mml-secure-cust-record-keys scontext 'encrypt "sub@example.org" skey)
|
||||
(mml-secure-cust-record-keys scontext 'sign "sub@example.org" skey)
|
||||
(funcall body3)))))
|
||||
|
||||
(ert-deftest mml-secure-key-checks ()
|
||||
"Test mml-secure-check-user-id and mml-secure-check-sub-key on sample keys."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(let* ((context (epg-make-context 'OpenPGP))
|
||||
(keys1 (epg-list-keys context "expired@example.org"))
|
||||
(keys2 (epg-list-keys context "no-exp@example.org"))
|
||||
(keys3 (epg-list-keys context "sub@example.org"))
|
||||
(keys4 (epg-list-keys context "revoked-uid@example.org"))
|
||||
(keys5 (epg-list-keys context "disabled@example.org"))
|
||||
(keys6 (epg-list-keys context "sign@example.org"))
|
||||
(keys7 (epg-list-keys context "jens.lechtenboerger@fsfe"))
|
||||
)
|
||||
(should (and (= 1 (length keys1)) (= 1 (length keys2))
|
||||
(= 2 (length keys3))
|
||||
(= 1 (length keys4)) (= 1 (length keys5))
|
||||
))
|
||||
;; key1 is expired
|
||||
(should-not (mml-secure-check-user-id (car keys1) "expired@example.org"))
|
||||
(should-not (mml-secure-check-sub-key context (car keys1) 'encrypt))
|
||||
(should-not (mml-secure-check-sub-key context (car keys1) 'sign))
|
||||
|
||||
;; key2 does not expire, but does not have the UID expired@example.org
|
||||
(should-not (mml-secure-check-user-id (car keys2) "expired@example.org"))
|
||||
(should (mml-secure-check-user-id (car keys2) "no-exp@example.org"))
|
||||
(should (mml-secure-check-sub-key context (car keys2) 'encrypt))
|
||||
(should (mml-secure-check-sub-key context (car keys2) 'sign))
|
||||
|
||||
;; Two keys exist for sub@example.org.
|
||||
(should (mml-secure-check-user-id (car keys3) "sub@example.org"))
|
||||
(should (mml-secure-check-sub-key context (car keys3) 'encrypt))
|
||||
(should (mml-secure-check-sub-key context (car keys3) 'sign))
|
||||
(should (mml-secure-check-user-id (cadr keys3) "sub@example.org"))
|
||||
(should (mml-secure-check-sub-key context (cadr keys3) 'encrypt))
|
||||
(should (mml-secure-check-sub-key context (cadr keys3) 'sign))
|
||||
|
||||
;; The UID revoked-uid@example.org is revoked. The key itself is
|
||||
;; usable, though (with the UID sub@example.org).
|
||||
(should-not
|
||||
(mml-secure-check-user-id (car keys4) "revoked-uid@example.org"))
|
||||
(should (mml-secure-check-sub-key context (car keys4) 'encrypt))
|
||||
(should (mml-secure-check-sub-key context (car keys4) 'sign))
|
||||
(should (mml-secure-check-user-id (car keys4) "sub@example.org"))
|
||||
|
||||
;; The next key is disabled and, thus, unusable.
|
||||
(should (mml-secure-check-user-id (car keys5) "disabled@example.org"))
|
||||
(should-not (mml-secure-check-sub-key context (car keys5) 'encrypt))
|
||||
(should-not (mml-secure-check-sub-key context (car keys5) 'sign))
|
||||
|
||||
;; The next key has multiple subkeys.
|
||||
;; 42466F0F is valid sign subkey, 501FFD98 is expired
|
||||
(should (mml-secure-check-sub-key context (car keys6) 'sign "42466F0F"))
|
||||
(should-not
|
||||
(mml-secure-check-sub-key context (car keys6) 'sign "501FFD98"))
|
||||
;; DC7F66E7 is encrypt subkey
|
||||
(should
|
||||
(mml-secure-check-sub-key context (car keys6) 'encrypt "DC7F66E7"))
|
||||
(should-not
|
||||
(mml-secure-check-sub-key context (car keys6) 'sign "DC7F66E7"))
|
||||
(should-not
|
||||
(mml-secure-check-sub-key context (car keys6) 'encrypt "42466F0F"))
|
||||
|
||||
;; The final key is just a public key.
|
||||
(should (mml-secure-check-sub-key context (car keys7) 'encrypt))
|
||||
(should-not (mml-secure-check-sub-key context (car keys7) 'sign))
|
||||
))))
|
||||
|
||||
(ert-deftest mml-secure-find-usable-keys-1 ()
|
||||
"Make sure that expired and disabled keys and revoked UIDs are not used."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(let ((context (epg-make-context 'OpenPGP)))
|
||||
(should-not
|
||||
(mml-secure-find-usable-keys context "expired@example.org" 'encrypt))
|
||||
(should-not
|
||||
(mml-secure-find-usable-keys context "expired@example.org" 'sign))
|
||||
|
||||
(should-not
|
||||
(mml-secure-find-usable-keys context "disabled@example.org" 'encrypt))
|
||||
(should-not
|
||||
(mml-secure-find-usable-keys context "disabled@example.org" 'sign))
|
||||
|
||||
(should-not
|
||||
(mml-secure-find-usable-keys
|
||||
context "<revoked-uid@example.org>" 'encrypt))
|
||||
(should-not
|
||||
(mml-secure-find-usable-keys
|
||||
context "<revoked-uid@example.org>" 'sign))
|
||||
;; Same test without ankles. Will fail for Ma Gnus v0.14 and earlier.
|
||||
(should-not
|
||||
(mml-secure-find-usable-keys
|
||||
context "revoked-uid@example.org" 'encrypt))
|
||||
|
||||
;; Expired key should not be usable.
|
||||
;; Will fail for Ma Gnus v0.14 and earlier.
|
||||
;; sign@example.org has the expired subkey 0x501FFD98.
|
||||
(should-not
|
||||
(mml-secure-find-usable-keys context "0x501FFD98" 'sign))
|
||||
|
||||
(should
|
||||
(mml-secure-find-usable-keys context "no-exp@example.org" 'encrypt))
|
||||
(should
|
||||
(mml-secure-find-usable-keys context "no-exp@example.org" 'sign))
|
||||
))))
|
||||
|
||||
(ert-deftest mml-secure-find-usable-keys-2 ()
|
||||
"Test different ways to search for keys."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(let ((context (epg-make-context 'OpenPGP)))
|
||||
;; Plain substring search is not supported.
|
||||
(should
|
||||
(= 0 (length
|
||||
(mml-secure-find-usable-keys context "No Expiry" 'encrypt))))
|
||||
(should
|
||||
(= 0 (length
|
||||
(mml-secure-find-usable-keys context "No Expiry" 'sign))))
|
||||
|
||||
;; Search for e-mail addresses works with and without ankle brackets.
|
||||
(should
|
||||
(= 1 (length (mml-secure-find-usable-keys
|
||||
context "<no-exp@example.org>" 'encrypt))))
|
||||
(should
|
||||
(= 1 (length (mml-secure-find-usable-keys
|
||||
context "<no-exp@example.org>" 'sign))))
|
||||
(should
|
||||
(= 1 (length (mml-secure-find-usable-keys
|
||||
context "no-exp@example.org" 'encrypt))))
|
||||
(should
|
||||
(= 1 (length (mml-secure-find-usable-keys
|
||||
context "no-exp@example.org" 'sign))))
|
||||
|
||||
;; Use full UID string.
|
||||
(should
|
||||
(= 1 (length (mml-secure-find-usable-keys
|
||||
context "No Expiry <no-exp@example.org>" 'encrypt))))
|
||||
(should
|
||||
(= 1 (length (mml-secure-find-usable-keys
|
||||
context "No Expiry <no-exp@example.org>" 'sign))))
|
||||
|
||||
;; If just the public key is present, only encryption is possible.
|
||||
;; Search works with key IDs, with and without prefix "0x".
|
||||
(should
|
||||
(= 1 (length (mml-secure-find-usable-keys
|
||||
context "A142FD84" 'encrypt))))
|
||||
(should
|
||||
(= 1 (length (mml-secure-find-usable-keys
|
||||
context "0xA142FD84" 'encrypt))))
|
||||
(should
|
||||
(= 0 (length (mml-secure-find-usable-keys
|
||||
context "A142FD84" 'sign))))
|
||||
(should
|
||||
(= 0 (length (mml-secure-find-usable-keys
|
||||
context "0xA142FD84" 'sign))))
|
||||
))))
|
||||
|
||||
(ert-deftest mml-secure-select-preferred-keys-1 ()
|
||||
"If only one key exists for an e-mail address, it is the preferred one."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(let ((context (epg-make-context 'OpenPGP)))
|
||||
(should (equal "832F3CC6518D37BC658261B802372A42CA6D40FB"
|
||||
(mml-secure-fingerprint
|
||||
(car (mml-secure-select-preferred-keys
|
||||
context '("no-exp@example.org") 'encrypt)))))))))
|
||||
|
||||
(ert-deftest mml-secure-select-preferred-keys-2 ()
|
||||
"If multiple keys exists for an e-mail address, customization is necessary."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(let* ((context (epg-make-context 'OpenPGP))
|
||||
(mml-secure-key-preferences
|
||||
'((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))
|
||||
(pref (car (mml-secure-find-usable-keys
|
||||
context "sub@example.org" 'encrypt))))
|
||||
(should-error (mml-secure-select-preferred-keys
|
||||
context '("sub@example.org") 'encrypt))
|
||||
(mml-secure-cust-record-keys
|
||||
context 'encrypt "sub@example.org" (list pref))
|
||||
(should (mml-secure-select-preferred-keys
|
||||
context '("sub@example.org") 'encrypt))
|
||||
(should-error (mml-secure-select-preferred-keys
|
||||
context '("sub@example.org") 'sign))
|
||||
(should (mml-secure-select-preferred-keys
|
||||
context '("sub@example.org") 'encrypt))
|
||||
(should
|
||||
(equal (list (mml-secure-fingerprint pref))
|
||||
(mml-secure-cust-fpr-lookup context 'encrypt "sub@example.org")))
|
||||
(should (mml-secure-cust-remove-keys context 'encrypt "sub@example.org"))
|
||||
(should-error (mml-secure-select-preferred-keys
|
||||
context '("sub@example.org") 'encrypt))))))
|
||||
|
||||
(ert-deftest mml-secure-select-preferred-keys-3 ()
|
||||
"Expired customized keys are removed if multiple keys are available."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(let ((context (epg-make-context 'OpenPGP))
|
||||
(mml-secure-key-preferences
|
||||
'((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))))
|
||||
;; sub@example.org has two keys (268DBEA2, AE31D471).
|
||||
;; Normal preference works.
|
||||
(mml-secure-cust-record-keys
|
||||
context 'encrypt "sub@example.org" (epg-list-keys context "268DBEA2"))
|
||||
(should (mml-secure-select-preferred-keys
|
||||
context '("sub@example.org") 'encrypt))
|
||||
(mml-secure-cust-remove-keys context 'encrypt "sub@example.org")
|
||||
|
||||
;; Fake preference for expired (unrelated) key CE15FAE7,
|
||||
;; results in error (and automatic removal of outdated preference).
|
||||
(mml-secure-cust-record-keys
|
||||
context 'encrypt "sub@example.org" (epg-list-keys context "CE15FAE7"))
|
||||
(should-error (mml-secure-select-preferred-keys
|
||||
context '("sub@example.org") 'encrypt))
|
||||
(should-not
|
||||
(mml-secure-cust-remove-keys context 'encrypt "sub@example.org"))))))
|
||||
|
||||
(ert-deftest mml-secure-select-preferred-keys-4 ()
|
||||
"Multiple keys can be recorded per recipient or signature."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(let ((pcontext (epg-make-context 'OpenPGP))
|
||||
(scontext (epg-make-context 'CMS))
|
||||
(pkeys '("1E6BFA973D9E3103B77FD399C3999CF1268DBEA2"
|
||||
"14632ECAB9E227369C8DD97BF7E79AB7AE31D471"))
|
||||
(skeys '("0x5F88E9FC" "0x479DC6E2"))
|
||||
(mml-secure-key-preferences
|
||||
'((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))))
|
||||
|
||||
;; OpenPGP preferences via pcontext
|
||||
(dolist (key pkeys nil)
|
||||
(mml-secure-cust-record-keys
|
||||
pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key))
|
||||
(mml-secure-cust-record-keys
|
||||
pcontext 'sign "sub@example.org" (epg-list-keys pcontext key 'secret)))
|
||||
(let ((p-e-fprs (mml-secure-cust-fpr-lookup
|
||||
pcontext 'encrypt "sub@example.org"))
|
||||
(p-s-fprs (mml-secure-cust-fpr-lookup
|
||||
pcontext 'sign "sub@example.org")))
|
||||
(should (= 2 (length p-e-fprs)))
|
||||
(should (= 2 (length p-s-fprs)))
|
||||
(should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-e-fprs))
|
||||
(should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-e-fprs))
|
||||
(should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-s-fprs))
|
||||
(should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-s-fprs)))
|
||||
;; Duplicate record does not change anything.
|
||||
(mml-secure-cust-record-keys
|
||||
pcontext 'encrypt "sub@example.org"
|
||||
(epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2"))
|
||||
(mml-secure-cust-record-keys
|
||||
pcontext 'sign "sub@example.org"
|
||||
(epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2"))
|
||||
(let ((p-e-fprs (mml-secure-cust-fpr-lookup
|
||||
pcontext 'encrypt "sub@example.org"))
|
||||
(p-s-fprs (mml-secure-cust-fpr-lookup
|
||||
pcontext 'sign "sub@example.org")))
|
||||
(should (= 2 (length p-e-fprs)))
|
||||
(should (= 2 (length p-s-fprs))))
|
||||
|
||||
;; S/MIME preferences via scontext
|
||||
(dolist (key skeys nil)
|
||||
(mml-secure-cust-record-keys
|
||||
scontext 'encrypt "sub@example.org"
|
||||
(epg-list-keys scontext key))
|
||||
(mml-secure-cust-record-keys
|
||||
scontext 'sign "sub@example.org"
|
||||
(epg-list-keys scontext key 'secret)))
|
||||
(let ((s-e-fprs (mml-secure-cust-fpr-lookup
|
||||
scontext 'encrypt "sub@example.org"))
|
||||
(s-s-fprs (mml-secure-cust-fpr-lookup
|
||||
scontext 'sign "sub@example.org")))
|
||||
(should (= 2 (length s-e-fprs)))
|
||||
(should (= 2 (length s-s-fprs))))
|
||||
))))
|
||||
|
||||
(defun mml-secure-test-en-decrypt
|
||||
(method to from
|
||||
&optional checksig checkplain enc-keys expectfail interactive)
|
||||
"Encrypt message using METHOD, addressed to TO, from FROM.
|
||||
If optional CHECKSIG is non-nil, it must be a number, and a signature check is
|
||||
performed; the number indicates how many signatures are expected.
|
||||
If optional CHECKPLAIN is non-nil, the expected plaintext should be obtained
|
||||
via decryption.
|
||||
If optional ENC-KEYS is non-nil, it is a list of pairs of encryption keys (for
|
||||
OpenPGP and S/SMIME) expected in `epg-debug-buffer'.
|
||||
If optional EXPECTFAIL is non-nil, a decryption failure is expected.
|
||||
Pass optional INTERACTIVE to mml-secure-test-mail-fixture."
|
||||
(mml-secure-test-mail-fixture method to from
|
||||
(lambda (gnus-info plaintext decrypted)
|
||||
(if expectfail
|
||||
(should-not (equal plaintext decrypted))
|
||||
(when checkplain
|
||||
(should (equal plaintext decrypted)))
|
||||
(let ((protocol (if (memq method
|
||||
'(enc-smime enc-sign-smime sign-smime))
|
||||
'CMS
|
||||
'OpenPGP)))
|
||||
(when checksig
|
||||
(let* ((context (epg-make-context protocol))
|
||||
(signer-names (mml-secure-signer-names protocol from))
|
||||
(signer-keys (mml-secure-signers context signer-names))
|
||||
(signer-fprs (mapcar 'mml-secure-fingerprint signer-keys)))
|
||||
(should (eq checksig (length signer-fprs)))
|
||||
(if (eq checksig 0)
|
||||
;; First key in keyring
|
||||
(should (string-match-p
|
||||
(concat "Good signature from "
|
||||
(if (eq protocol 'CMS)
|
||||
"0E58229B80EE33959FF718FEEF25402B479DC6E2"
|
||||
"02372A42CA6D40FB"))
|
||||
gnus-info)))
|
||||
(dolist (fpr signer-fprs nil)
|
||||
;; OpenPGP: "Good signature from 02372A42CA6D40FB No Expiry <no-exp@example.org> (trust undefined) created ..."
|
||||
;; S/MIME: "Good signature from D06AA118653CC38E9D0CAF56ED7A2135E1582177 /CN=No Expiry (trust full) ..."
|
||||
(should (string-match-p
|
||||
(concat "Good signature from "
|
||||
(if (eq protocol 'CMS)
|
||||
fpr
|
||||
(substring fpr -16 nil)))
|
||||
gnus-info)))))
|
||||
(when enc-keys
|
||||
(with-current-buffer epg-debug-buffer
|
||||
(goto-char (point-min))
|
||||
;; The following regexp does not necessarily match at the
|
||||
;; start of the line as a path may or may not be present.
|
||||
;; Also note that gpg.* matches gpg2 and gpgsm as well.
|
||||
(let* ((line (concat "gpg.*--encrypt.*$"))
|
||||
(end (re-search-forward line))
|
||||
(match (match-string 0)))
|
||||
(should (and end match))
|
||||
(dolist (pair enc-keys nil)
|
||||
(let ((fpr (if (eq protocol 'OpenPGP)
|
||||
(car pair)
|
||||
(cdr pair))))
|
||||
(should (string-match-p (concat "-r " fpr) match))))
|
||||
(goto-char (point-max))
|
||||
))))))
|
||||
interactive))
|
||||
|
||||
(defun mml-secure-test-en-decrypt-with-passphrase
|
||||
(method to from checksig jl-passphrase do-cache
|
||||
&optional enc-keys expectfail)
|
||||
"Call mml-secure-test-en-decrypt with changed passphrase caching.
|
||||
Args METHOD, TO, FROM, CHECKSIG are passed to mml-secure-test-en-decrypt.
|
||||
JL-PASSPHRASE is fixed as return value for `read-passwd',
|
||||
boolean DO-CACHE determines whether to cache the passphrase.
|
||||
If optional ENC-KEYS is non-nil, it is a list of encryption keys expected
|
||||
in `epg-debug-buffer'.
|
||||
If optional EXPECTFAIL is non-nil, a decryption failure is expected."
|
||||
(let ((mml-secure-cache-passphrase do-cache)
|
||||
(mml1991-cache-passphrase do-cache)
|
||||
(mml2015-cache-passphrase do-cache)
|
||||
(mml-smime-cache-passphrase do-cache)
|
||||
)
|
||||
(cl-letf (((symbol-function 'read-passwd)
|
||||
(lambda (prompt &optional confirm default) jl-passphrase)))
|
||||
(mml-secure-test-en-decrypt method to from checksig t enc-keys expectfail)
|
||||
)))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-1 ()
|
||||
"Encrypt message; then decrypt and test for expected result.
|
||||
In this test, the single matching key is chosen automatically."
|
||||
(skip-unless (test-conf))
|
||||
(dolist (method (enc-standards) nil)
|
||||
;; no-exp@example.org with single encryption key
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "sub@example.org" nil t
|
||||
(list (cons "02372A42CA6D40FB" "ED7A2135E1582177")))))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-2 ()
|
||||
"Encrypt message; then decrypt and test for expected result.
|
||||
In this test, the encryption key needs to fixed among multiple ones."
|
||||
(skip-unless (test-conf))
|
||||
;; sub@example.org with multiple candidate keys,
|
||||
;; fixture customizes preferred ones.
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(dolist (method (enc-standards) nil)
|
||||
(mml-secure-test-en-decrypt
|
||||
method "sub@example.org" "no-exp@example.org" nil t
|
||||
(list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")))))))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-3 ()
|
||||
"Encrypt message; then decrypt and test for expected result.
|
||||
In this test, encrypt-to-self variables are set to t."
|
||||
(skip-unless (test-conf))
|
||||
;; sub@example.org with multiple candidate keys,
|
||||
;; fixture customizes preferred ones.
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(let ((mml-secure-openpgp-encrypt-to-self t)
|
||||
(mml-secure-smime-encrypt-to-self t))
|
||||
(dolist (method (enc-standards) nil)
|
||||
(mml-secure-test-en-decrypt
|
||||
method "sub@example.org" "no-exp@example.org" nil t
|
||||
(list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")
|
||||
(cons "02372A42CA6D40FB" "ED7A2135E1582177"))))))))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-4 ()
|
||||
"Encrypt message; then decrypt and test for expected result.
|
||||
In this test, encrypt-to-self variables are set to lists."
|
||||
(skip-unless (test-conf))
|
||||
;; Send from sub@example.org, which has two keys; encrypt to both.
|
||||
(let ((mml-secure-openpgp-encrypt-to-self
|
||||
'("C3999CF1268DBEA2" "F7E79AB7AE31D471"))
|
||||
(mml-secure-smime-encrypt-to-self
|
||||
'("EF25402B479DC6E2" "4035D59B5F88E9FC")))
|
||||
(dolist (method (enc-standards) nil)
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "sub@example.org" nil t
|
||||
(list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")
|
||||
(cons "F7E79AB7AE31D471" "4035D59B5F88E9FC"))))))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-sign-1-1-single ()
|
||||
"Sign and encrypt message; then decrypt and test for expected result.
|
||||
In this test, just multiple encryption and signing keys may be available."
|
||||
:tags '(:unstable)
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(let ((mml-secure-openpgp-sign-with-sender t)
|
||||
(mml-secure-smime-sign-with-sender t))
|
||||
(dolist (method (enc-sign-standards) nil)
|
||||
;; no-exp with just one key
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "no-exp@example.org" 1 t)
|
||||
;; customized choice for encryption key
|
||||
(mml-secure-test-en-decrypt
|
||||
method "sub@example.org" "no-exp@example.org" 1 t)
|
||||
;; customized choice for signing key
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "sub@example.org" 1 t)
|
||||
;; customized choice for both keys
|
||||
(mml-secure-test-en-decrypt
|
||||
method "sub@example.org" "sub@example.org" 1 t)
|
||||
)))))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-sign-1-2-double ()
|
||||
"Sign and encrypt message; then decrypt and test for expected result.
|
||||
In this test, just multiple encryption and signing keys may be available."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(let ((mml-secure-openpgp-sign-with-sender t)
|
||||
(mml-secure-smime-sign-with-sender t))
|
||||
;; Now use both keys to sign. The customized one via sign-with-sender,
|
||||
;; the other one via the following setting.
|
||||
(let ((mml-secure-openpgp-signers '("F7E79AB7AE31D471"))
|
||||
(mml-secure-smime-signers '("0x5F88E9FC")))
|
||||
(dolist (method (enc-sign-standards) nil)
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "sub@example.org" 2 t)))))))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-sign-1-3-double ()
|
||||
"Sign and encrypt message; then decrypt and test for expected result.
|
||||
In this test, just multiple encryption and signing keys may be available."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
;; Now use both keys for sub@example.org to sign an e-mail from
|
||||
;; a different address (without associated keys).
|
||||
(let ((mml-secure-openpgp-sign-with-sender nil)
|
||||
(mml-secure-smime-sign-with-sender nil)
|
||||
(mml-secure-openpgp-signers
|
||||
'("F7E79AB7AE31D471" "C3999CF1268DBEA2"))
|
||||
(mml-secure-smime-signers '("0x5F88E9FC" "0x479DC6E2")))
|
||||
(dolist (method (enc-sign-standards) nil)
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "no-keys@example.org" 2 t))))))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-sign-2 ()
|
||||
"Sign and encrypt message; then decrypt and test for expected result.
|
||||
In this test, lists of encryption and signing keys are customized."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(let ((mml-secure-key-preferences
|
||||
'((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))
|
||||
(pcontext (epg-make-context 'OpenPGP))
|
||||
(scontext (epg-make-context 'CMS))
|
||||
(mml-secure-openpgp-sign-with-sender t)
|
||||
(mml-secure-smime-sign-with-sender t))
|
||||
(dolist (key '("F7E79AB7AE31D471" "C3999CF1268DBEA2") nil)
|
||||
(mml-secure-cust-record-keys
|
||||
pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key))
|
||||
(mml-secure-cust-record-keys
|
||||
pcontext 'sign "sub@example.org" (epg-list-keys pcontext key t)))
|
||||
(dolist (key '("0x5F88E9FC" "0x479DC6E2") nil)
|
||||
(mml-secure-cust-record-keys
|
||||
scontext 'encrypt "sub@example.org" (epg-list-keys scontext key))
|
||||
(mml-secure-cust-record-keys
|
||||
scontext 'sign "sub@example.org" (epg-list-keys scontext key t)))
|
||||
(dolist (method (enc-sign-standards) nil)
|
||||
;; customized choice for encryption key
|
||||
(mml-secure-test-en-decrypt
|
||||
method "sub@example.org" "no-exp@example.org" 1 t)
|
||||
;; customized choice for signing key
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "sub@example.org" 2 t)
|
||||
;; customized choice for both keys
|
||||
(mml-secure-test-en-decrypt
|
||||
method "sub@example.org" "sub@example.org" 2 t)
|
||||
)))))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-sign-3 ()
|
||||
"Sign and encrypt message; then decrypt and test for expected result.
|
||||
Use sign-with-sender and encrypt-to-self."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(let ((mml-secure-openpgp-sign-with-sender t)
|
||||
(mml-secure-openpgp-encrypt-to-self t)
|
||||
(mml-secure-smime-sign-with-sender t)
|
||||
(mml-secure-smime-encrypt-to-self t))
|
||||
(dolist (method (enc-sign-standards) nil)
|
||||
(mml-secure-test-en-decrypt
|
||||
method "sub@example.org" "no-exp@example.org" 1 t
|
||||
(list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")
|
||||
(cons "02372A42CA6D40FB" "ED7A2135E1582177"))))
|
||||
))))
|
||||
|
||||
(ert-deftest mml-secure-sign-verify-1 ()
|
||||
"Sign message with sender; then verify and test for expected result."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(dolist (method (sign-standards) nil)
|
||||
(let ((mml-secure-openpgp-sign-with-sender t)
|
||||
(mml-secure-smime-sign-with-sender t))
|
||||
;; A single signing key for sender sub@example.org is customized
|
||||
;; in the fixture.
|
||||
(mml-secure-test-en-decrypt
|
||||
method "uid1@example.org" "sub@example.org" 1 nil)
|
||||
|
||||
;; From sub@example.org, sign with two keys;
|
||||
;; sign-with-sender and one from signers-variable:
|
||||
(let ((mml-secure-openpgp-signers '("02372A42CA6D40FB"))
|
||||
(mml-secure-smime-signers
|
||||
'("D06AA118653CC38E9D0CAF56ED7A2135E1582177")))
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "sub@example.org" 2 nil))
|
||||
)))))
|
||||
|
||||
(ert-deftest mml-secure-sign-verify-2 ()
|
||||
"Sign message without sender; then verify and test for expected result."
|
||||
(skip-unless (test-conf))
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(dolist (method (sign-standards) nil)
|
||||
(let ((mml-secure-openpgp-sign-with-sender nil)
|
||||
(mml-secure-smime-sign-with-sender nil))
|
||||
;; A single signing key for sender sub@example.org is customized
|
||||
;; in the fixture, but not used here.
|
||||
;; By default, gpg uses the first secret key in the keyring, which
|
||||
;; is 02372A42CA6D40FB (OpenPGP) or
|
||||
;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here.
|
||||
(mml-secure-test-en-decrypt
|
||||
method "uid1@example.org" "sub@example.org" 0 nil)
|
||||
|
||||
;; From sub@example.org, sign with specified key:
|
||||
(let ((mml-secure-openpgp-signers '("02372A42CA6D40FB"))
|
||||
(mml-secure-smime-signers
|
||||
'("D06AA118653CC38E9D0CAF56ED7A2135E1582177")))
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "sub@example.org" 1 nil))
|
||||
|
||||
;; From sub@example.org, sign with different specified key:
|
||||
(let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2"))
|
||||
(mml-secure-smime-signers
|
||||
'("0E58229B80EE33959FF718FEEF25402B479DC6E2")))
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "sub@example.org" 1 nil))
|
||||
)))))
|
||||
|
||||
(ert-deftest mml-secure-sign-verify-3 ()
|
||||
"Try to sign message with expired OpenPGP subkey, which raises an error.
|
||||
With Ma Gnus v0.14 and earlier a signature would be created with a wrong key."
|
||||
(skip-unless (test-conf))
|
||||
(should-error
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(let ((with-smime nil)
|
||||
(mml-secure-openpgp-sign-with-sender nil)
|
||||
(mml-secure-openpgp-signers '("501FFD98")))
|
||||
(dolist (method (sign-standards) nil)
|
||||
(mml-secure-test-en-decrypt
|
||||
method "no-exp@example.org" "sign@example.org" 1 nil)
|
||||
))))))
|
||||
|
||||
;; TODO Passphrase passing and caching in Emacs does not seem to work
|
||||
;; with gpgsm at all.
|
||||
;; Independently of caching settings, a pinentry dialogue is displayed.
|
||||
;; Thus, the following tests require the user to enter the correct gpgsm
|
||||
;; passphrases at the correct points in time. (Either empty string or
|
||||
;; "Passphrase".)
|
||||
(ert-deftest mml-secure-en-decrypt-passphrase-cache ()
|
||||
"Encrypt message; then decrypt and test for expected result.
|
||||
In this test, a key is used that requires the passphrase \"Passphrase\".
|
||||
In the first decryption this passphrase is hardcoded, in the second one it
|
||||
is taken from a cache."
|
||||
(skip-unless (test-conf))
|
||||
(ert-skip "Requires passphrase")
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(dolist (method (enc-standards) nil)
|
||||
(mml-secure-test-en-decrypt-with-passphrase
|
||||
method "uid1@example.org" "sub@example.org" nil
|
||||
;; Beware! For passphrases copy-sequence is necessary, as they may
|
||||
;; be erased, which actually changes the function's code and causes
|
||||
;; multiple invokations to fail. I was surprised...
|
||||
(copy-sequence "Passphrase") t)
|
||||
(mml-secure-test-en-decrypt-with-passphrase
|
||||
method "uid1@example.org" "sub@example.org" nil
|
||||
(copy-sequence "Incorrect") t)))))
|
||||
|
||||
(defun mml-secure-en-decrypt-passphrase-no-cache (method)
|
||||
"Encrypt message with METHOD; then decrypt and test for expected result.
|
||||
In this test, a key is used that requires the passphrase \"Passphrase\".
|
||||
In the first decryption this passphrase is hardcoded, but caching disabled.
|
||||
So the second decryption fails."
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(mml-secure-test-en-decrypt-with-passphrase
|
||||
method "uid1@example.org" "sub@example.org" nil
|
||||
(copy-sequence "Passphrase") nil)
|
||||
(mml-secure-test-en-decrypt-with-passphrase
|
||||
method "uid1@example.org" "sub@example.org" nil
|
||||
(copy-sequence "Incorrect") nil nil t))))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-openpgp-todo ()
|
||||
"Passphrase caching with OpenPGP only for GnuPG 1.x."
|
||||
(skip-unless (test-conf))
|
||||
(skip-unless (string< (cdr (assq 'version (epg-configuration))) "2"))
|
||||
(mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp)
|
||||
(mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp-mime))
|
||||
|
||||
(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-smime-todo ()
|
||||
"Passphrase caching does not work with S/MIME (and gpgsm)."
|
||||
:expected-result :failed
|
||||
(skip-unless (test-conf))
|
||||
(if with-smime
|
||||
(mml-secure-en-decrypt-passphrase-no-cache 'enc-smime)
|
||||
(should nil)))
|
||||
|
||||
|
||||
;; Test truncation of question in y-or-n-p.
|
||||
(defun mml-secure-select-preferred-keys-todo ()
|
||||
"Manual customization with truncated question."
|
||||
(mml-secure-test-key-fixture
|
||||
(lambda ()
|
||||
(mml-secure-test-en-decrypt
|
||||
'enc-pgp-mime
|
||||
"jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de"
|
||||
"no-exp@example.org" nil t nil nil t))))
|
||||
|
||||
(defun mml-secure-select-preferred-keys-ok ()
|
||||
"Manual customization with entire question."
|
||||
(mml-secure-test-fixture
|
||||
(lambda ()
|
||||
(mml-secure-select-preferred-keys
|
||||
(epg-make-context 'OpenPGP)
|
||||
'("jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de")
|
||||
'encrypt))
|
||||
t))
|
||||
|
||||
|
||||
;; ERT entry points
|
||||
(defun mml-secure-run-tests ()
|
||||
"Run all tests with defaults."
|
||||
(ert-run-tests-batch))
|
||||
|
||||
(defun mml-secure-run-tests-with-gpg2 ()
|
||||
"Run all tests with gpg2 instead of gpg."
|
||||
(let* ((epg-gpg-program "gpg2"); ~/local/gnupg-2.1.9/PLAY/inst/bin/gpg2
|
||||
(gpg-version (cdr (assq 'version (epg-configuration))))
|
||||
;; Empty passphrases do not seem to work with gpgsm in 2.1.x:
|
||||
;; https://lists.gnupg.org/pipermail/gnupg-users/2015-October/054575.html
|
||||
(with-smime (string< gpg-version "2.1")))
|
||||
(ert-run-tests-batch)))
|
||||
|
||||
(defun mml-secure-run-tests-without-smime ()
|
||||
"Skip S/MIME tests (as they require manual passphrase entry)."
|
||||
(let ((with-smime nil))
|
||||
(ert-run-tests-batch)))
|
||||
|
||||
;;; gnustest-mml-sec.el ends here
|
||||
119
test/lisp/net/browse-url-tests.el
Normal file
119
test/lisp/net/browse-url-tests.el
Normal file
|
|
@ -0,0 +1,119 @@
|
|||
;;; browse-url-tests.el --- Tests for browse-url.el -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2020 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Simen Heggestøyl <simenheg@gmail.com>
|
||||
;; Keywords:
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'browse-url)
|
||||
(require 'ert)
|
||||
|
||||
(ert-deftest browse-url-tests-browser-kind ()
|
||||
(should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org")
|
||||
'internal))
|
||||
(should
|
||||
(eq (browse-url--browser-kind #'browse-url-firefox "gnu.org")
|
||||
'external)))
|
||||
|
||||
(ert-deftest browse-url-tests-non-html-file-url-p ()
|
||||
(should (browse-url--non-html-file-url-p "file://foo.txt"))
|
||||
(should-not (browse-url--non-html-file-url-p "file://foo.html")))
|
||||
|
||||
(ert-deftest browse-url-tests-select-handler-mailto ()
|
||||
(should (eq (browse-url-select-handler "mailto:foo@bar.org")
|
||||
'browse-url--mailto))
|
||||
(should (eq (browse-url-select-handler "mailto:foo@bar.org"
|
||||
'internal)
|
||||
'browse-url--mailto))
|
||||
(should-not (browse-url-select-handler "mailto:foo@bar.org"
|
||||
'external)))
|
||||
|
||||
(ert-deftest browse-url-tests-select-handler-man ()
|
||||
(should (eq (browse-url-select-handler "man:ls") 'browse-url--man))
|
||||
(should (eq (browse-url-select-handler "man:ls" 'internal)
|
||||
'browse-url--man))
|
||||
(should-not (browse-url-select-handler "man:ls" 'external)))
|
||||
|
||||
(ert-deftest browse-url-tests-select-handler-file ()
|
||||
(should (eq (browse-url-select-handler "file://foo.txt")
|
||||
'browse-url-emacs))
|
||||
(should (eq (browse-url-select-handler "file://foo.txt" 'internal)
|
||||
'browse-url-emacs))
|
||||
(should-not (browse-url-select-handler "file://foo.txt" 'external)))
|
||||
|
||||
(ert-deftest browse-url-tests-url-encode-chars ()
|
||||
(should (equal (browse-url-url-encode-chars "foobar" "[ob]")
|
||||
"f%6F%6F%62ar")))
|
||||
|
||||
(ert-deftest browse-url-tests-encode-url ()
|
||||
(should (equal (browse-url-encode-url "") ""))
|
||||
(should (equal (browse-url-encode-url "a b c") "a b c"))
|
||||
(should (equal (browse-url-encode-url "\"a\" \"b\"")
|
||||
"\"a%22\"b\""))
|
||||
(should (equal (browse-url-encode-url "(a) (b)") "(a%29(b)"))
|
||||
(should (equal (browse-url-encode-url "a$ b$") "a%24b$")))
|
||||
|
||||
(ert-deftest browse-url-tests-url-at-point ()
|
||||
(with-temp-buffer
|
||||
(insert "gnu.org")
|
||||
(should (equal (browse-url-url-at-point) "http://gnu.org"))))
|
||||
|
||||
(ert-deftest browse-url-tests-file-url ()
|
||||
(should (equal (browse-url-file-url "/foo") "file:///foo"))
|
||||
(should (equal (browse-url-file-url "/foo:") "ftp://foo/"))
|
||||
(should (equal (browse-url-file-url "/ftp@foo:") "ftp://foo/"))
|
||||
(should (equal (browse-url-file-url "/anonymous@foo:")
|
||||
"ftp://foo/")))
|
||||
|
||||
(ert-deftest browse-url-tests-delete-temp-file ()
|
||||
(let ((browse-url-temp-file-name
|
||||
(make-temp-file "browse-url-tests-")))
|
||||
(browse-url-delete-temp-file)
|
||||
(should-not (file-exists-p browse-url-temp-file-name)))
|
||||
(let ((file (make-temp-file "browse-url-tests-")))
|
||||
(browse-url-delete-temp-file file)
|
||||
(should-not (file-exists-p file))))
|
||||
|
||||
(ert-deftest browse-url-tests-add-buttons ()
|
||||
(with-temp-buffer
|
||||
(insert "Visit https://gnu.org")
|
||||
(goto-char (point-min))
|
||||
(browse-url-add-buttons)
|
||||
(goto-char (- (point-max) 1))
|
||||
(should (eq (get-text-property (point) 'face)
|
||||
'browse-url-button))
|
||||
(should (get-text-property (point) 'browse-url-data))))
|
||||
|
||||
(ert-deftest browse-url-tests-button-copy ()
|
||||
(with-temp-buffer
|
||||
(insert "Visit https://gnu.org")
|
||||
(goto-char (point-min))
|
||||
(browse-url-add-buttons)
|
||||
(should-error (browse-url-button-copy))
|
||||
(goto-char (- (point-max) 1))
|
||||
(browse-url-button-copy)
|
||||
(should (equal (car kill-ring) "https://gnu.org"))))
|
||||
|
||||
(provide 'browse-url-tests)
|
||||
;;; browse-url-tests.el ends here
|
||||
|
|
@ -136,7 +136,20 @@
|
|||
(t
|
||||
))))
|
||||
|
||||
(defun network-test--resolve-system-name ()
|
||||
(cl-loop for address in (network-lookup-address-info (system-name))
|
||||
when (or (and (= (length address) 5)
|
||||
;; IPv4 localhost addresses start with 127.
|
||||
(= (elt address 0) 127))
|
||||
(and (= (length address) 9)
|
||||
;; IPv6 localhost address.
|
||||
(equal address [0 0 0 0 0 0 0 1 0])))
|
||||
return t))
|
||||
|
||||
(ert-deftest echo-server-with-dns ()
|
||||
(unless (network-test--resolve-system-name)
|
||||
(ert-skip "Can't test resolver for (system-name)"))
|
||||
|
||||
(let* ((server (make-server (system-name)))
|
||||
(port (aref (process-contact server :local) 4))
|
||||
(proc (make-network-process :name "foo"
|
||||
|
|
|
|||
|
|
@ -2001,12 +2001,13 @@ is greater than 10.
|
|||
(skip-unless (tramp--test-enabled))
|
||||
|
||||
;; Multi hops are allowed for inline methods only.
|
||||
(should-error
|
||||
(file-remote-p "/ssh:user1@host1|method:user2@host2:/path/to/file")
|
||||
:type 'user-error)
|
||||
(should-error
|
||||
(file-remote-p "/method:user1@host1|ssh:user2@host2:/path/to/file")
|
||||
:type 'user-error)
|
||||
(let (non-essential)
|
||||
(should-error
|
||||
(expand-file-name "/ssh:user1@host1|method:user2@host2:/path/to/file")
|
||||
:type 'user-error)
|
||||
(should-error
|
||||
(expand-file-name "/method:user1@host1|ssh:user2@host2:/path/to/file")
|
||||
:type 'user-error))
|
||||
|
||||
;; Samba does not support file names with periods followed by
|
||||
;; spaces, and trailing periods or spaces.
|
||||
|
|
@ -5681,9 +5682,8 @@ This does not support special file names."
|
|||
|
||||
(defun tramp--test-sh-p ()
|
||||
"Check, whether the remote host runs a based method from tramp-sh.el."
|
||||
(eq
|
||||
(tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory)
|
||||
'tramp-sh-file-name-handler))
|
||||
(tramp-sh-file-name-handler-p
|
||||
(tramp-dissect-file-name tramp-test-temporary-file-directory)))
|
||||
|
||||
(defun tramp--test-sudoedit-p ()
|
||||
"Check, whether the sudoedit method is used."
|
||||
|
|
|
|||
4
test/lisp/saveplace-resources/saveplace
Normal file
4
test/lisp/saveplace-resources/saveplace
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
;;; -*- coding: utf-8 -*-
|
||||
(("/home/skangas/.emacs.d/cache/recentf" . 1306)
|
||||
("/home/skangas/wip/emacs/"
|
||||
(dired-filename . "/home/skangas/wip/emacs/COPYING")))
|
||||
103
test/lisp/saveplace-tests.el
Normal file
103
test/lisp/saveplace-tests.el
Normal file
|
|
@ -0,0 +1,103 @@
|
|||
;;; saveplace-tests.el --- Tests for saveplace.el -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Stefan Kangas <stefankangas@gmail.com>
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
(require 'ert)
|
||||
(require 'saveplace)
|
||||
|
||||
(defvar saveplace-tests-dir
|
||||
(file-truename
|
||||
(expand-file-name "saveplace-resources"
|
||||
(file-name-directory (or load-file-name
|
||||
buffer-file-name)))))
|
||||
|
||||
(ert-deftest saveplace-test-save-place-to-alist/dir ()
|
||||
(save-place-mode)
|
||||
(let* ((save-place-alist nil)
|
||||
(save-place-loaded t)
|
||||
(loc saveplace-tests-dir))
|
||||
(save-window-excursion
|
||||
(dired loc)
|
||||
(save-place-to-alist)
|
||||
(should (equal save-place-alist
|
||||
`((,(concat loc "/")
|
||||
(dired-filename . ,(concat loc "/saveplace")))))))))
|
||||
|
||||
(ert-deftest saveplace-test-save-place-to-alist/file ()
|
||||
(save-place-mode)
|
||||
(let* ((tmpfile (make-temp-file "emacs-test-saveplace-"))
|
||||
(save-place-alist nil)
|
||||
(save-place-loaded t)
|
||||
(loc tmpfile)
|
||||
(pos 4))
|
||||
(unwind-protect
|
||||
(save-window-excursion
|
||||
(find-file loc)
|
||||
(insert "abc") ; must insert something
|
||||
(save-place-to-alist)
|
||||
(should (equal save-place-alist (list (cons tmpfile pos)))))
|
||||
(delete-file tmpfile))))
|
||||
|
||||
(ert-deftest saveplace-test-forget-unreadable-files ()
|
||||
(save-place-mode)
|
||||
(let* ((save-place-loaded t)
|
||||
(tmpfile (make-temp-file "emacs-test-saveplace-"))
|
||||
(alist-orig (list (cons "/this/file/does/not/exist" 10)
|
||||
(cons tmpfile 1917)))
|
||||
(save-place-alist alist-orig))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(save-place-forget-unreadable-files)
|
||||
(should (equal save-place-alist (cdr alist-orig))))
|
||||
(delete-file tmpfile))))
|
||||
|
||||
(ert-deftest saveplace-test-place-alist-to-file ()
|
||||
(save-place-mode)
|
||||
(let* ((tmpfile (make-temp-file "emacs-test-saveplace-"))
|
||||
(tmpfile2 (make-temp-file "emacs-test-saveplace-"))
|
||||
(save-place-file tmpfile)
|
||||
(save-place-alist (list (cons tmpfile2 99))))
|
||||
(unwind-protect
|
||||
(progn (save-place-alist-to-file)
|
||||
(setq save-place-alist nil)
|
||||
(save-window-excursion
|
||||
(find-file save-place-file)
|
||||
(unwind-protect
|
||||
(should (string-match tmpfile2 (buffer-string)))
|
||||
(kill-buffer))))
|
||||
(delete-file tmpfile)
|
||||
(delete-file tmpfile2))))
|
||||
|
||||
(ert-deftest saveplace-test-load-alist-from-file ()
|
||||
(save-place-mode)
|
||||
(let ((save-place-loaded nil)
|
||||
(save-place-file
|
||||
(expand-file-name "saveplace" saveplace-tests-dir))
|
||||
(save-place-alist nil))
|
||||
(load-save-place-alist-from-file)
|
||||
(should (equal save-place-alist
|
||||
'(("/home/skangas/.emacs.d/cache/recentf" . 1306)
|
||||
("/home/skangas/wip/emacs/"
|
||||
(dired-filename . "/home/skangas/wip/emacs/COPYING")))))))
|
||||
|
||||
(provide 'saveplace-tests)
|
||||
;;; saveplace-tests.el ends here
|
||||
|
|
@ -554,7 +554,8 @@ This checks also `vc-backend' and `vc-responsible-backend'."
|
|||
|
||||
(defvar vc-svn-program)
|
||||
(defun vc-test--svn-enabled ()
|
||||
(executable-find vc-svn-program))
|
||||
(and (executable-find "svnadmin")
|
||||
(executable-find vc-svn-program)))
|
||||
|
||||
(defun vc-test--sccs-enabled ()
|
||||
(executable-find "sccs"))
|
||||
|
|
|
|||
|
|
@ -143,6 +143,7 @@ wdired-get-filename before and after editing."
|
|||
(let* ((test-dir (make-temp-file "test-dir-" t))
|
||||
(server-socket-dir test-dir)
|
||||
(dired-listing-switches "-Fl")
|
||||
(dired-ls-F-marks-symlinks (eq system-type 'darwin))
|
||||
(buf (find-file-noselect test-dir)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue