diff options
Diffstat (limited to 'test')
52 files changed, 2176 insertions, 10 deletions
diff --git a/test/README b/test/README index 1f69f7142c1..fe05b5403b1 100644 --- a/test/README +++ b/test/README | |||
| @@ -64,6 +64,11 @@ protect against "make" variable expansion): | |||
| 64 | 64 | ||
| 65 | make <filename> SELECTOR='"foo$$"' | 65 | make <filename> SELECTOR='"foo$$"' |
| 66 | 66 | ||
| 67 | In case you want to use the symbol name of a test as selector, you can | ||
| 68 | use it directly: | ||
| 69 | |||
| 70 | make <filename> SELECTOR='test-foo-remote' | ||
| 71 | |||
| 67 | Note that although the test files are always compiled (unless they set | 72 | Note that although the test files are always compiled (unless they set |
| 68 | no-byte-compile), the source files will be run when expensive or | 73 | no-byte-compile), the source files will be run when expensive or |
| 69 | unstable tests are involved, to give nicer backtraces. To run the | 74 | unstable tests are involved, to give nicer backtraces. To run the |
diff --git a/test/data/mml-sec/.gpg-v21-migrated b/test/data/mml-sec/.gpg-v21-migrated new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/data/mml-sec/.gpg-v21-migrated | |||
diff --git a/test/data/mml-sec/gpg-agent.conf b/test/data/mml-sec/gpg-agent.conf new file mode 100644 index 00000000000..20192990caf --- /dev/null +++ b/test/data/mml-sec/gpg-agent.conf | |||
| @@ -0,0 +1,5 @@ | |||
| 1 | # pinentry-program /usr/bin/pinentry-gtk-2 | ||
| 2 | |||
| 3 | # verbose | ||
| 4 | # log-file /tmp/gpg-agent.log | ||
| 5 | # debug-all | ||
diff --git a/test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key b/test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key new file mode 100644 index 00000000000..58fd0b5edbc --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key b/test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key new file mode 100644 index 00000000000..62f4ab25a69 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key b/test/data/mml-sec/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key new file mode 100644 index 00000000000..2a8ce135fb2 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key b/test/data/mml-sec/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key new file mode 100644 index 00000000000..9f8de71c5e2 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key b/test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key new file mode 100644 index 00000000000..6e4a4e548fd --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key b/test/data/mml-sec/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key new file mode 100644 index 00000000000..cff58edaa89 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key b/test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key new file mode 100644 index 00000000000..14af8662f79 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key b/test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key new file mode 100644 index 00000000000..207a7237d3a --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key b/test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key new file mode 100644 index 00000000000..85ca78da04d --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key b/test/data/mml-sec/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key new file mode 100644 index 00000000000..79f3cd2b841 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key b/test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key new file mode 100644 index 00000000000..776ddf7e9e2 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key b/test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key new file mode 100644 index 00000000000..2b464f0ccbe --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key b/test/data/mml-sec/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key new file mode 100644 index 00000000000..28a07668b21 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key b/test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key new file mode 100644 index 00000000000..137659693bd --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key b/test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key new file mode 100644 index 00000000000..c99824ccd43 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key b/test/data/mml-sec/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key new file mode 100644 index 00000000000..49c2dc58bd8 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key b/test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key new file mode 100644 index 00000000000..ca128408952 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key b/test/data/mml-sec/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key new file mode 100644 index 00000000000..3f14b40927a --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key b/test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key new file mode 100644 index 00000000000..06adc06c427 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key b/test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key new file mode 100644 index 00000000000..cf9a60d233b --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key b/test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key new file mode 100644 index 00000000000..0ed35172fe0 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key b/test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key new file mode 100644 index 00000000000..090059d9e81 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key b/test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key new file mode 100644 index 00000000000..9061f675121 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key b/test/data/mml-sec/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key new file mode 100644 index 00000000000..89f6013100d --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key b/test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key new file mode 100644 index 00000000000..41dac37574e --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key b/test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key new file mode 100644 index 00000000000..5df7b4a5953 --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key b/test/data/mml-sec/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key new file mode 100644 index 00000000000..03daf80975b --- /dev/null +++ b/test/data/mml-sec/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/pubring.gpg b/test/data/mml-sec/pubring.gpg new file mode 100644 index 00000000000..6bd169963df --- /dev/null +++ b/test/data/mml-sec/pubring.gpg | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/pubring.kbx b/test/data/mml-sec/pubring.kbx new file mode 100644 index 00000000000..399a0414fd2 --- /dev/null +++ b/test/data/mml-sec/pubring.kbx | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/secring.gpg b/test/data/mml-sec/secring.gpg new file mode 100644 index 00000000000..b323c072c04 --- /dev/null +++ b/test/data/mml-sec/secring.gpg | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/trustdb.gpg b/test/data/mml-sec/trustdb.gpg new file mode 100644 index 00000000000..09ebd8db114 --- /dev/null +++ b/test/data/mml-sec/trustdb.gpg | |||
| Binary files differ | |||
diff --git a/test/data/mml-sec/trustlist.txt b/test/data/mml-sec/trustlist.txt new file mode 100644 index 00000000000..f886572d283 --- /dev/null +++ b/test/data/mml-sec/trustlist.txt | |||
| @@ -0,0 +1,26 @@ | |||
| 1 | # This is the list of trusted keys. Comment lines, like this one, as | ||
| 2 | # well as empty lines are ignored. Lines have a length limit but this | ||
| 3 | # is not a serious limitation as the format of the entries is fixed and | ||
| 4 | # checked by gpg-agent. A non-comment line starts with optional white | ||
| 5 | # space, followed by the SHA-1 fingerpint in hex, followed by a flag | ||
| 6 | # which may be one of 'P', 'S' or '*' and optionally followed by a list of | ||
| 7 | # other flags. The fingerprint may be prefixed with a '!' to mark the | ||
| 8 | # key as not trusted. You should give the gpg-agent a HUP or run the | ||
| 9 | # command "gpgconf --reload gpg-agent" after changing this file. | ||
| 10 | |||
| 11 | |||
| 12 | # Include the default trust list | ||
| 13 | include-default | ||
| 14 | |||
| 15 | |||
| 16 | # CN=No Expiry | ||
| 17 | D0:6A:A1:18:65:3C:C3:8E:9D:0C:AF:56:ED:7A:21:35:E1:58:21:77 S relax | ||
| 18 | |||
| 19 | # CN=Second Key Pair | ||
| 20 | 0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 S relax | ||
| 21 | |||
| 22 | # CN=No Expiry two UIDs | ||
| 23 | D4:CA:78:E1:47:0B:9F:C2:AE:45:D7:84:64:9B:8C:E6:4E:BB:32:0C S relax | ||
| 24 | |||
| 25 | # CN=Different subkeys | ||
| 26 | 4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC S relax | ||
diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 3eecc67eb53..fe1460cf29e 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el | |||
| @@ -109,4 +109,18 @@ | |||
| 109 | (ert-deftest test-time-since () | 109 | (ert-deftest test-time-since () |
| 110 | (should (time-equal-p 0 (time-since nil)))) | 110 | (should (time-equal-p 0 (time-since nil)))) |
| 111 | 111 | ||
| 112 | (ert-deftest test-time-decoded-period () | ||
| 113 | (should (equal (decoded-time-period '(nil nil 1 nil nil nil nil nil nil)) | ||
| 114 | 3600)) | ||
| 115 | |||
| 116 | (should (equal (decoded-time-period '(1 0 0 0 0 0 nil nil nil)) 1)) | ||
| 117 | (should (equal (decoded-time-period '(0 1 0 0 0 0 nil nil nil)) 60)) | ||
| 118 | (should (equal (decoded-time-period '(0 0 1 0 0 0 nil nil nil)) 3600)) | ||
| 119 | (should (equal (decoded-time-period '(0 0 0 1 0 0 nil nil nil)) 86400)) | ||
| 120 | (should (equal (decoded-time-period '(0 0 0 0 1 0 nil nil nil)) 2592000)) | ||
| 121 | (should (equal (decoded-time-period '(0 0 0 0 0 1 nil nil nil)) 31536000)) | ||
| 122 | |||
| 123 | (should (equal (decoded-time-period '((135 . 10) 0 0 0 0 0 nil nil nil)) | ||
| 124 | 13.5))) | ||
| 125 | |||
| 112 | ;;; time-date-tests.el ends here | 126 | ;;; time-date-tests.el ends here |
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index c235dd43fcc..894914300ae 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el | |||
| @@ -47,6 +47,11 @@ | |||
| 47 | (let ((a 1.0)) (/ 3 a 2)) | 47 | (let ((a 1.0)) (/ 3 a 2)) |
| 48 | (let ((a most-positive-fixnum) (b 2.0)) (* a 2 b)) | 48 | (let ((a most-positive-fixnum) (b 2.0)) (* a 2 b)) |
| 49 | (let ((a 3) (b 2)) (/ a b 1.0)) | 49 | (let ((a 3) (b 2)) (/ a b 1.0)) |
| 50 | (let ((a -0.0)) (+ a)) | ||
| 51 | (let ((a -0.0)) (- a)) | ||
| 52 | (let ((a -0.0)) (* a)) | ||
| 53 | (let ((a -0.0)) (min a)) | ||
| 54 | (let ((a -0.0)) (max a)) | ||
| 50 | (/ 3 -1) | 55 | (/ 3 -1) |
| 51 | (+ 4 3 2 1) | 56 | (+ 4 3 2 1) |
| 52 | (+ 4 3 2.0 1) | 57 | (+ 4 3 2.0 1) |
diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index c8d46541ad4..0ea9742be49 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el | |||
| @@ -20,6 +20,166 @@ | |||
| 20 | ;;; Commentary: | 20 | ;;; Commentary: |
| 21 | 21 | ||
| 22 | (require 'ert) | 22 | (require 'ert) |
| 23 | (require 'cl-lib) | ||
| 24 | |||
| 25 | (ert-deftest cconv-tests-lambda-:documentation () | ||
| 26 | "Docstring for lambda can be specified with :documentation." | ||
| 27 | (let ((fun (lambda () | ||
| 28 | (:documentation (concat "lambda" " documentation")) | ||
| 29 | 'lambda-result))) | ||
| 30 | (should (string= (documentation fun) "lambda documentation")) | ||
| 31 | (should (eq (funcall fun) 'lambda-result)))) | ||
| 32 | |||
| 33 | (ert-deftest cconv-tests-pcase-lambda-:documentation () | ||
| 34 | "Docstring for pcase-lambda can be specified with :documentation." | ||
| 35 | (let ((fun (pcase-lambda (`(,a ,b)) | ||
| 36 | (:documentation (concat "pcase-lambda" " documentation")) | ||
| 37 | (list b a)))) | ||
| 38 | (should (string= (documentation fun) "pcase-lambda documentation")) | ||
| 39 | (should (equal '(2 1) (funcall fun '(1 2)))))) | ||
| 40 | |||
| 41 | (defun cconv-tests-defun () | ||
| 42 | (:documentation (concat "defun" " documentation")) | ||
| 43 | 'defun-result) | ||
| 44 | (ert-deftest cconv-tests-defun-:documentation () | ||
| 45 | "Docstring for defun can be specified with :documentation." | ||
| 46 | (should (string= (documentation 'cconv-tests-defun) | ||
| 47 | "defun documentation")) | ||
| 48 | (should (eq (cconv-tests-defun) 'defun-result))) | ||
| 49 | |||
| 50 | (cl-defun cconv-tests-cl-defun () | ||
| 51 | (:documentation (concat "cl-defun" " documentation")) | ||
| 52 | 'cl-defun-result) | ||
| 53 | (ert-deftest cconv-tests-cl-defun-:documentation () | ||
| 54 | "Docstring for cl-defun can be specified with :documentation." | ||
| 55 | (should (string= (documentation 'cconv-tests-cl-defun) | ||
| 56 | "cl-defun documentation")) | ||
| 57 | (should (eq (cconv-tests-cl-defun) 'cl-defun-result))) | ||
| 58 | |||
| 59 | ;; FIXME: The byte-complier croaks on this. See Bug#28557. | ||
| 60 | ;; (defmacro cconv-tests-defmacro () | ||
| 61 | ;; (:documentation (concat "defmacro" " documentation")) | ||
| 62 | ;; '(quote defmacro-result)) | ||
| 63 | ;; (ert-deftest cconv-tests-defmacro-:documentation () | ||
| 64 | ;; "Docstring for defmacro can be specified with :documentation." | ||
| 65 | ;; (should (string= (documentation 'cconv-tests-defmacro) | ||
| 66 | ;; "defmacro documentation")) | ||
| 67 | ;; (should (eq (cconv-tests-defmacro) 'defmacro-result))) | ||
| 68 | |||
| 69 | ;; FIXME: The byte-complier croaks on this. See Bug#28557. | ||
| 70 | ;; (cl-defmacro cconv-tests-cl-defmacro () | ||
| 71 | ;; (:documentation (concat "cl-defmacro" " documentation")) | ||
| 72 | ;; '(quote cl-defmacro-result)) | ||
| 73 | ;; (ert-deftest cconv-tests-cl-defmacro-:documentation () | ||
| 74 | ;; "Docstring for cl-defmacro can be specified with :documentation." | ||
| 75 | ;; (should (string= (documentation 'cconv-tests-cl-defmacro) | ||
| 76 | ;; "cl-defmacro documentation")) | ||
| 77 | ;; (should (eq (cconv-tests-cl-defmacro) 'cl-defmacro-result))) | ||
| 78 | |||
| 79 | (cl-iter-defun cconv-tests-cl-iter-defun () | ||
| 80 | (:documentation (concat "cl-iter-defun" " documentation")) | ||
| 81 | (iter-yield 'cl-iter-defun-result)) | ||
| 82 | (ert-deftest cconv-tests-cl-iter-defun-:documentation () | ||
| 83 | "Docstring for cl-iter-defun can be specified with :documentation." | ||
| 84 | ;; FIXME: See Bug#28557. | ||
| 85 | :tags '(:unstable) | ||
| 86 | :expected-result :failed | ||
| 87 | (should (string= (documentation 'cconv-tests-cl-iter-defun) | ||
| 88 | "cl-iter-defun documentation")) | ||
| 89 | (should (eq (iter-next (cconv-tests-cl-iter-defun)) | ||
| 90 | 'cl-iter-defun-result))) | ||
| 91 | |||
| 92 | (iter-defun cconv-tests-iter-defun () | ||
| 93 | (:documentation (concat "iter-defun" " documentation")) | ||
| 94 | (iter-yield 'iter-defun-result)) | ||
| 95 | (ert-deftest cconv-tests-iter-defun-:documentation () | ||
| 96 | "Docstring for iter-defun can be specified with :documentation." | ||
| 97 | ;; FIXME: See Bug#28557. | ||
| 98 | :tags '(:unstable) | ||
| 99 | :expected-result :failed | ||
| 100 | (should (string= (documentation 'cconv-tests-iter-defun) | ||
| 101 | "iter-defun documentation")) | ||
| 102 | (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) | ||
| 103 | |||
| 104 | (ert-deftest cconv-tests-iter-lambda-:documentation () | ||
| 105 | "Docstring for iter-lambda can be specified with :documentation." | ||
| 106 | ;; FIXME: See Bug#28557. | ||
| 107 | :expected-result :failed | ||
| 108 | (let ((iter-fun | ||
| 109 | (iter-lambda () | ||
| 110 | (:documentation (concat "iter-lambda" " documentation")) | ||
| 111 | (iter-yield 'iter-lambda-result)))) | ||
| 112 | (should (string= (documentation iter-fun) "iter-lambda documentation")) | ||
| 113 | (should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result)))) | ||
| 114 | |||
| 115 | (ert-deftest cconv-tests-cl-function-:documentation () | ||
| 116 | "Docstring for cl-function can be specified with :documentation." | ||
| 117 | ;; FIXME: See Bug#28557. | ||
| 118 | :expected-result :failed | ||
| 119 | (let ((fun (cl-function (lambda (&key arg) | ||
| 120 | (:documentation (concat "cl-function" | ||
| 121 | " documentation")) | ||
| 122 | (list arg 'cl-function-result))))) | ||
| 123 | (should (string= (documentation fun) "cl-function documentation")) | ||
| 124 | (should (equal (funcall fun :arg t) '(t cl-function-result))))) | ||
| 125 | |||
| 126 | (ert-deftest cconv-tests-function-:documentation () | ||
| 127 | "Docstring for lambda inside function can be specified with :documentation." | ||
| 128 | (let ((fun #'(lambda (arg) | ||
| 129 | (:documentation (concat "function" " documentation")) | ||
| 130 | (list arg 'function-result)))) | ||
| 131 | (should (string= (documentation fun) "function documentation")) | ||
| 132 | (should (equal (funcall fun t) '(t function-result))))) | ||
| 133 | |||
| 134 | (fmakunbound 'cconv-tests-cl-defgeneric) | ||
| 135 | (setplist 'cconv-tests-cl-defgeneric nil) | ||
| 136 | (cl-defgeneric cconv-tests-cl-defgeneric (n) | ||
| 137 | (:documentation (concat "cl-defgeneric" " documentation"))) | ||
| 138 | (cl-defmethod cconv-tests-cl-defgeneric ((n integer)) | ||
| 139 | (:documentation (concat "cl-defmethod" " documentation")) | ||
| 140 | (+ 1 n)) | ||
| 141 | (ert-deftest cconv-tests-cl-defgeneric-:documentation () | ||
| 142 | "Docstring for cl-defgeneric can be specified with :documentation." | ||
| 143 | ;; FIXME: See Bug#28557. | ||
| 144 | :expected-result :failed | ||
| 145 | (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) | ||
| 146 | (set-text-properties 0 (length descr) nil descr) | ||
| 147 | (should (string-match-p "cl-defgeneric documentation" descr)) | ||
| 148 | (should (string-match-p "cl-defmethod documentation" descr))) | ||
| 149 | (should (= 11 (cconv-tests-cl-defgeneric 10)))) | ||
| 150 | |||
| 151 | (fmakunbound 'cconv-tests-cl-defgeneric-literal) | ||
| 152 | (setplist 'cconv-tests-cl-defgeneric-literal nil) | ||
| 153 | (cl-defgeneric cconv-tests-cl-defgeneric-literal (n) | ||
| 154 | (:documentation "cl-defgeneric-literal documentation")) | ||
| 155 | (cl-defmethod cconv-tests-cl-defgeneric-literal ((n integer)) | ||
| 156 | (:documentation "cl-defmethod-literal documentation") | ||
| 157 | (+ 1 n)) | ||
| 158 | (ert-deftest cconv-tests-cl-defgeneric-literal-:documentation () | ||
| 159 | "Docstring for cl-defgeneric can be specified with :documentation." | ||
| 160 | (let ((descr (describe-function 'cconv-tests-cl-defgeneric-literal))) | ||
| 161 | (set-text-properties 0 (length descr) nil descr) | ||
| 162 | (should (string-match-p "cl-defgeneric-literal documentation" descr)) | ||
| 163 | (should (string-match-p "cl-defmethod-literal documentation" descr))) | ||
| 164 | (should (= 11 (cconv-tests-cl-defgeneric-literal 10)))) | ||
| 165 | |||
| 166 | (defsubst cconv-tests-defsubst () | ||
| 167 | (:documentation (concat "defsubst" " documentation")) | ||
| 168 | 'defsubst-result) | ||
| 169 | (ert-deftest cconv-tests-defsubst-:documentation () | ||
| 170 | "Docstring for defsubst can be specified with :documentation." | ||
| 171 | (should (string= (documentation 'cconv-tests-defsubst) | ||
| 172 | "defsubst documentation")) | ||
| 173 | (should (eq (cconv-tests-defsubst) 'defsubst-result))) | ||
| 174 | |||
| 175 | (cl-defsubst cconv-tests-cl-defsubst () | ||
| 176 | (:documentation (concat "cl-defsubst" " documentation")) | ||
| 177 | 'cl-defsubst-result) | ||
| 178 | (ert-deftest cconv-tests-cl-defsubst-:documentation () | ||
| 179 | "Docstring for cl-defsubst can be specified with :documentation." | ||
| 180 | (should (string= (documentation 'cconv-tests-cl-defsubst) | ||
| 181 | "cl-defsubst documentation")) | ||
| 182 | (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result))) | ||
| 23 | 183 | ||
| 24 | (ert-deftest cconv-convert-lambda-lifted () | 184 | (ert-deftest cconv-convert-lambda-lifted () |
| 25 | "Bug#30872." | 185 | "Bug#30872." |
diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 51c9884ddc8..5aa58782f36 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el | |||
| @@ -24,6 +24,7 @@ | |||
| 24 | ;;; Code: | 24 | ;;; Code: |
| 25 | 25 | ||
| 26 | (require 'cl-generic) | 26 | (require 'cl-generic) |
| 27 | (require 'edebug) | ||
| 27 | 28 | ||
| 28 | ;; Don't indirectly require `cl-lib' at run-time. | 29 | ;; Don't indirectly require `cl-lib' at run-time. |
| 29 | (eval-when-compile (require 'ert)) | 30 | (eval-when-compile (require 'ert)) |
| @@ -249,5 +250,42 @@ | |||
| 249 | (should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic)) | 250 | (should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic)) |
| 250 | (should-not (cl--generic-method-files 'cl-generic-tests--generic-without-methods))) | 251 | (should-not (cl--generic-method-files 'cl-generic-tests--generic-without-methods))) |
| 251 | 252 | ||
| 253 | (ert-deftest cl-defgeneric/edebug/method () | ||
| 254 | "Check that `:method' forms in `cl-defgeneric' create unique | ||
| 255 | Edebug symbols (Bug#42672)." | ||
| 256 | (with-temp-buffer | ||
| 257 | (dolist (form '((cl-defgeneric cl-defgeneric/edebug/method/1 (_) | ||
| 258 | (:method ((_ number)) 1) | ||
| 259 | (:method ((_ string)) 2) | ||
| 260 | (:method :around ((_ number)) 3)) | ||
| 261 | (cl-defgeneric cl-defgeneric/edebug/method/2 (_) | ||
| 262 | (:method ((_ number)) 3)))) | ||
| 263 | (print form (current-buffer))) | ||
| 264 | (let* ((edebug-all-defs t) | ||
| 265 | (edebug-initial-mode 'Go-nonstop) | ||
| 266 | (instrumented-names ()) | ||
| 267 | (edebug-new-definition-function | ||
| 268 | (lambda (name) | ||
| 269 | (when (memq name instrumented-names) | ||
| 270 | (error "Duplicate definition of `%s'" name)) | ||
| 271 | (push name instrumented-names) | ||
| 272 | (edebug-new-definition name))) | ||
| 273 | ;; Make generated symbols reproducible. | ||
| 274 | (gensym-counter 10000)) | ||
| 275 | (eval-buffer) | ||
| 276 | (should (equal | ||
| 277 | (reverse instrumented-names) | ||
| 278 | ;; The generic function definitions come after the | ||
| 279 | ;; method definitions because their body ends later. | ||
| 280 | ;; FIXME: We'd rather have names such as | ||
| 281 | ;; `cl-defgeneric/edebug/method/1 ((_ number))', but | ||
| 282 | ;; that requires further changes to Edebug. | ||
| 283 | (list (intern "cl-generic-:method@10000 ((_ number))") | ||
| 284 | (intern "cl-generic-:method@10001 ((_ string))") | ||
| 285 | (intern "cl-generic-:method@10002 :around ((_ number))") | ||
| 286 | 'cl-defgeneric/edebug/method/1 | ||
| 287 | (intern "cl-generic-:method@10003 ((_ number))") | ||
| 288 | 'cl-defgeneric/edebug/method/2)))))) | ||
| 289 | |||
| 252 | (provide 'cl-generic-tests) | 290 | (provide 'cl-generic-tests) |
| 253 | ;;; cl-generic-tests.el ends here | 291 | ;;; cl-generic-tests.el ends here |
diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 41811c9dc07..04a7b2f5a0f 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el | |||
| @@ -938,5 +938,99 @@ test and possibly others should be updated." | |||
| 938 | "g" | 938 | "g" |
| 939 | (should (equal edebug-tests-@-result '(0 1)))))) | 939 | (should (equal edebug-tests-@-result '(0 1)))))) |
| 940 | 940 | ||
| 941 | (ert-deftest edebug-cl-defmethod-qualifier () | ||
| 942 | "Check that secondary `cl-defmethod' forms don't stomp over | ||
| 943 | primary ones (Bug#42671)." | ||
| 944 | (with-temp-buffer | ||
| 945 | (let* ((edebug-all-defs t) | ||
| 946 | (edebug-initial-mode 'Go-nonstop) | ||
| 947 | (defined-symbols ()) | ||
| 948 | (edebug-new-definition-function | ||
| 949 | (lambda (def-name) | ||
| 950 | (push def-name defined-symbols) | ||
| 951 | (edebug-new-definition def-name)))) | ||
| 952 | (dolist (form '((cl-defmethod edebug-cl-defmethod-qualifier ((_ number))) | ||
| 953 | (cl-defmethod edebug-cl-defmethod-qualifier | ||
| 954 | :around ((_ number))))) | ||
| 955 | (print form (current-buffer))) | ||
| 956 | (eval-buffer) | ||
| 957 | (should | ||
| 958 | (equal | ||
| 959 | defined-symbols | ||
| 960 | (list (intern "edebug-cl-defmethod-qualifier :around ((_ number))") | ||
| 961 | (intern "edebug-cl-defmethod-qualifier ((_ number))"))))))) | ||
| 962 | |||
| 963 | (ert-deftest edebug-tests-cl-flet () | ||
| 964 | "Check that Edebug can instrument `cl-flet' forms without name | ||
| 965 | clashes (Bug#41853)." | ||
| 966 | (with-temp-buffer | ||
| 967 | (dolist (form '((defun edebug-tests-cl-flet-1 () | ||
| 968 | (cl-flet ((inner () 0)) (message "Hi")) | ||
| 969 | (cl-flet ((inner () 1)) (inner))) | ||
| 970 | (defun edebug-tests-cl-flet-2 () | ||
| 971 | (cl-flet ((inner () 2)) (inner))))) | ||
| 972 | (print form (current-buffer))) | ||
| 973 | (let* ((edebug-all-defs t) | ||
| 974 | (edebug-initial-mode 'Go-nonstop) | ||
| 975 | (instrumented-names ()) | ||
| 976 | (edebug-new-definition-function | ||
| 977 | (lambda (name) | ||
| 978 | (when (memq name instrumented-names) | ||
| 979 | (error "Duplicate definition of `%s'" name)) | ||
| 980 | (push name instrumented-names) | ||
| 981 | (edebug-new-definition name))) | ||
| 982 | ;; Make generated symbols reproducible. | ||
| 983 | (gensym-counter 10000)) | ||
| 984 | (eval-buffer) | ||
| 985 | (should (equal (reverse instrumented-names) | ||
| 986 | ;; The outer definitions come after the inner | ||
| 987 | ;; ones because their body ends later. | ||
| 988 | ;; FIXME: There are twice as many inner | ||
| 989 | ;; definitions as expected due to Bug#41988. | ||
| 990 | ;; Once that bug is fixed, remove the duplicates. | ||
| 991 | ;; FIXME: We'd rather have names such as | ||
| 992 | ;; `edebug-tests-cl-flet-1@inner@cl-flet@10000', | ||
| 993 | ;; but that requires further changes to Edebug. | ||
| 994 | '(inner@cl-flet@10000 | ||
| 995 | inner@cl-flet@10001 | ||
| 996 | inner@cl-flet@10002 | ||
| 997 | inner@cl-flet@10003 | ||
| 998 | edebug-tests-cl-flet-1 | ||
| 999 | inner@cl-flet@10004 | ||
| 1000 | inner@cl-flet@10005 | ||
| 1001 | edebug-tests-cl-flet-2)))))) | ||
| 1002 | |||
| 1003 | (ert-deftest edebug-tests-duplicate-symbol-backtrack () | ||
| 1004 | "Check that Edebug doesn't create duplicate symbols when | ||
| 1005 | backtracking (Bug#42701)." | ||
| 1006 | (with-temp-buffer | ||
| 1007 | (dolist (form '((require 'subr-x) | ||
| 1008 | (defun edebug-tests-duplicate-symbol-backtrack () | ||
| 1009 | (if-let (x (funcall (lambda (y) 1) 2)) 3 4)))) | ||
| 1010 | (print form (current-buffer))) | ||
| 1011 | (let* ((edebug-all-defs t) | ||
| 1012 | (edebug-initial-mode 'Go-nonstop) | ||
| 1013 | (instrumented-names ()) | ||
| 1014 | (edebug-new-definition-function | ||
| 1015 | (lambda (name) | ||
| 1016 | (when (memq name instrumented-names) | ||
| 1017 | (error "Duplicate definition of `%s'" name)) | ||
| 1018 | (push name instrumented-names) | ||
| 1019 | (edebug-new-definition name))) | ||
| 1020 | ;; Make generated symbols reproducible. | ||
| 1021 | (gensym-counter 10000)) | ||
| 1022 | (eval-buffer) | ||
| 1023 | ;; The anonymous symbols are uninterned. Use their names so we | ||
| 1024 | ;; can perform the assertion. The names should still be unique. | ||
| 1025 | (should (equal (mapcar #'symbol-name (reverse instrumented-names)) | ||
| 1026 | ;; The outer definition comes after the inner | ||
| 1027 | ;; ones because its body ends later. | ||
| 1028 | ;; FIXME: There are twice as many inner | ||
| 1029 | ;; definitions as expected due to Bug#42701. | ||
| 1030 | ;; Once that bug is fixed, remove the duplicates. | ||
| 1031 | '("edebug-anon10000" | ||
| 1032 | "edebug-anon10001" | ||
| 1033 | "edebug-tests-duplicate-symbol-backtrack")))))) | ||
| 1034 | |||
| 941 | (provide 'edebug-tests) | 1035 | (provide 'edebug-tests) |
| 942 | ;;; edebug-tests.el ends here | 1036 | ;;; edebug-tests.el ends here |
diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index 9b1a573ea6a..72eee07be8c 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el | |||
| @@ -22,6 +22,10 @@ | |||
| 22 | 22 | ||
| 23 | ;;; Commentary: | 23 | ;;; Commentary: |
| 24 | 24 | ||
| 25 | ;; Unit tests for generator.el. | ||
| 26 | |||
| 27 | ;;; Code: | ||
| 28 | |||
| 25 | (require 'generator) | 29 | (require 'generator) |
| 26 | (require 'ert) | 30 | (require 'ert) |
| 27 | (require 'cl-lib) | 31 | (require 'cl-lib) |
diff --git a/test/lisp/emacs-lisp/hierarchy-tests.el b/test/lisp/emacs-lisp/hierarchy-tests.el new file mode 100644 index 00000000000..23cfc79d848 --- /dev/null +++ b/test/lisp/emacs-lisp/hierarchy-tests.el | |||
| @@ -0,0 +1,556 @@ | |||
| 1 | ;;; hierarchy-tests.el --- Tests for hierarchy.el | ||
| 2 | |||
| 3 | ;; Copyright (C) 2017-2019 Damien Cassou | ||
| 4 | |||
| 5 | ;; Author: Damien Cassou <damien@cassou.me> | ||
| 6 | ;; Maintainer: emacs-devel@gnu.org | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | |||
| 25 | ;; Tests for hierarchy.el | ||
| 26 | |||
| 27 | ;;; Code: | ||
| 28 | |||
| 29 | (require 'ert) | ||
| 30 | (require 'hierarchy) | ||
| 31 | |||
| 32 | (defun hierarchy-animals () | ||
| 33 | "Create a sorted animal hierarchy." | ||
| 34 | (let ((parentfn (lambda (item) (cl-case item | ||
| 35 | (dove 'bird) | ||
| 36 | (pigeon 'bird) | ||
| 37 | (bird 'animal) | ||
| 38 | (dolphin 'animal) | ||
| 39 | (cow 'animal)))) | ||
| 40 | (hierarchy (hierarchy-new))) | ||
| 41 | (hierarchy-add-tree hierarchy 'dove parentfn) | ||
| 42 | (hierarchy-add-tree hierarchy 'pigeon parentfn) | ||
| 43 | (hierarchy-add-tree hierarchy 'dolphin parentfn) | ||
| 44 | (hierarchy-add-tree hierarchy 'cow parentfn) | ||
| 45 | (hierarchy-sort hierarchy) | ||
| 46 | hierarchy)) | ||
| 47 | |||
| 48 | (ert-deftest hierarchy-add-one-root () | ||
| 49 | (let ((parentfn (lambda (_) nil)) | ||
| 50 | (hierarchy (hierarchy-new))) | ||
| 51 | (hierarchy-add-tree hierarchy 'animal parentfn) | ||
| 52 | (should (equal (hierarchy-roots hierarchy) '(animal))))) | ||
| 53 | |||
| 54 | (ert-deftest hierarchy-add-one-item-with-parent () | ||
| 55 | (let ((parentfn (lambda (item) | ||
| 56 | (cl-case item | ||
| 57 | (bird 'animal)))) | ||
| 58 | (hierarchy (hierarchy-new))) | ||
| 59 | (hierarchy-add-tree hierarchy 'bird parentfn) | ||
| 60 | (should (equal (hierarchy-roots hierarchy) '(animal))) | ||
| 61 | (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) | ||
| 62 | |||
| 63 | (ert-deftest hierarchy-add-one-item-with-parent-and-grand-parent () | ||
| 64 | (let ((parentfn (lambda (item) | ||
| 65 | (cl-case item | ||
| 66 | (dove 'bird) | ||
| 67 | (bird 'animal)))) | ||
| 68 | (hierarchy (hierarchy-new))) | ||
| 69 | (hierarchy-add-tree hierarchy 'dove parentfn) | ||
| 70 | (should (equal (hierarchy-roots hierarchy) '(animal))) | ||
| 71 | (should (equal (hierarchy-children hierarchy 'animal) '(bird))) | ||
| 72 | (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) | ||
| 73 | |||
| 74 | (ert-deftest hierarchy-add-same-root-twice () | ||
| 75 | (let ((parentfn (lambda (_) nil)) | ||
| 76 | (hierarchy (hierarchy-new))) | ||
| 77 | (hierarchy-add-tree hierarchy 'animal parentfn) | ||
| 78 | (hierarchy-add-tree hierarchy 'animal parentfn) | ||
| 79 | (should (equal (hierarchy-roots hierarchy) '(animal))))) | ||
| 80 | |||
| 81 | (ert-deftest hierarchy-add-same-child-twice () | ||
| 82 | (let ((parentfn (lambda (item) | ||
| 83 | (cl-case item | ||
| 84 | (bird 'animal)))) | ||
| 85 | (hierarchy (hierarchy-new))) | ||
| 86 | (hierarchy-add-tree hierarchy 'bird parentfn) | ||
| 87 | (hierarchy-add-tree hierarchy 'bird parentfn) | ||
| 88 | (should (equal (hierarchy-roots hierarchy) '(animal))) | ||
| 89 | (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) | ||
| 90 | |||
| 91 | (ert-deftest hierarchy-add-item-and-its-parent () | ||
| 92 | (let ((parentfn (lambda (item) | ||
| 93 | (cl-case item | ||
| 94 | (bird 'animal)))) | ||
| 95 | (hierarchy (hierarchy-new))) | ||
| 96 | (hierarchy-add-tree hierarchy 'bird parentfn) | ||
| 97 | (hierarchy-add-tree hierarchy 'animal parentfn) | ||
| 98 | (should (equal (hierarchy-roots hierarchy) '(animal))) | ||
| 99 | (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) | ||
| 100 | |||
| 101 | (ert-deftest hierarchy-add-item-and-its-child () | ||
| 102 | (let ((parentfn (lambda (item) | ||
| 103 | (cl-case item | ||
| 104 | (bird 'animal)))) | ||
| 105 | (hierarchy (hierarchy-new))) | ||
| 106 | (hierarchy-add-tree hierarchy 'animal parentfn) | ||
| 107 | (hierarchy-add-tree hierarchy 'bird parentfn) | ||
| 108 | (should (equal (hierarchy-roots hierarchy) '(animal))) | ||
| 109 | (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) | ||
| 110 | |||
| 111 | (ert-deftest hierarchy-add-two-items-sharing-parent () | ||
| 112 | (let ((parentfn (lambda (item) | ||
| 113 | (cl-case item | ||
| 114 | (dove 'bird) | ||
| 115 | (pigeon 'bird)))) | ||
| 116 | (hierarchy (hierarchy-new))) | ||
| 117 | (hierarchy-add-tree hierarchy 'dove parentfn) | ||
| 118 | (hierarchy-add-tree hierarchy 'pigeon parentfn) | ||
| 119 | (should (equal (hierarchy-roots hierarchy) '(bird))) | ||
| 120 | (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) | ||
| 121 | |||
| 122 | (ert-deftest hierarchy-add-two-hierarchies () | ||
| 123 | (let ((parentfn (lambda (item) | ||
| 124 | (cl-case item | ||
| 125 | (dove 'bird) | ||
| 126 | (circle 'shape)))) | ||
| 127 | (hierarchy (hierarchy-new))) | ||
| 128 | (hierarchy-add-tree hierarchy 'dove parentfn) | ||
| 129 | (hierarchy-add-tree hierarchy 'circle parentfn) | ||
| 130 | (should (equal (hierarchy-roots hierarchy) '(bird shape))) | ||
| 131 | (should (equal (hierarchy-children hierarchy 'bird) '(dove))) | ||
| 132 | (should (equal (hierarchy-children hierarchy 'shape) '(circle))))) | ||
| 133 | |||
| 134 | (ert-deftest hierarchy-add-with-childrenfn () | ||
| 135 | (let ((childrenfn (lambda (item) | ||
| 136 | (cl-case item | ||
| 137 | (animal '(bird)) | ||
| 138 | (bird '(dove pigeon))))) | ||
| 139 | (hierarchy (hierarchy-new))) | ||
| 140 | (hierarchy-add-tree hierarchy 'animal nil childrenfn) | ||
| 141 | (should (equal (hierarchy-roots hierarchy) '(animal))) | ||
| 142 | (should (equal (hierarchy-children hierarchy 'animal) '(bird))) | ||
| 143 | (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) | ||
| 144 | |||
| 145 | (ert-deftest hierarchy-add-with-parentfn-and-childrenfn () | ||
| 146 | (let ((parentfn (lambda (item) | ||
| 147 | (cl-case item | ||
| 148 | (bird 'animal) | ||
| 149 | (animal 'life-form)))) | ||
| 150 | (childrenfn (lambda (item) | ||
| 151 | (cl-case item | ||
| 152 | (bird '(dove pigeon)) | ||
| 153 | (pigeon '(ashy-wood-pigeon))))) | ||
| 154 | (hierarchy (hierarchy-new))) | ||
| 155 | (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) | ||
| 156 | (should (equal (hierarchy-roots hierarchy) '(life-form))) | ||
| 157 | (should (equal (hierarchy-children hierarchy 'life-form) '(animal))) | ||
| 158 | (should (equal (hierarchy-children hierarchy 'animal) '(bird))) | ||
| 159 | (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))) | ||
| 160 | (should (equal (hierarchy-children hierarchy 'pigeon) '(ashy-wood-pigeon))))) | ||
| 161 | |||
| 162 | (ert-deftest hierarchy-add-twice-with-parentfn-and-childrenfn () | ||
| 163 | (let* ((parentfn (lambda (item) | ||
| 164 | (cl-case item | ||
| 165 | (dove 'bird) | ||
| 166 | (bird 'animal)))) | ||
| 167 | (childrenfn (lambda (item) | ||
| 168 | (cl-case item | ||
| 169 | (animal '(bird)) | ||
| 170 | (bird '(dove))))) | ||
| 171 | (hierarchy (hierarchy-new))) | ||
| 172 | (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) | ||
| 173 | (should (equal (hierarchy-children hierarchy 'animal) '(bird))) | ||
| 174 | (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) | ||
| 175 | |||
| 176 | (ert-deftest hierarchy-add-trees () | ||
| 177 | (let ((parentfn (lambda (item) | ||
| 178 | (cl-case item | ||
| 179 | (dove 'bird) | ||
| 180 | (pigeon 'bird) | ||
| 181 | (bird 'animal)))) | ||
| 182 | (hierarchy (hierarchy-new))) | ||
| 183 | (hierarchy-add-trees hierarchy '(dove pigeon) parentfn) | ||
| 184 | (should (equal (hierarchy-roots hierarchy) '(animal))) | ||
| 185 | (should (equal (hierarchy-children hierarchy 'animal) '(bird))) | ||
| 186 | (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) | ||
| 187 | |||
| 188 | (ert-deftest hierarchy-from-list () | ||
| 189 | (let ((hierarchy (hierarchy-from-list | ||
| 190 | '(animal (bird (dove) | ||
| 191 | (pigeon)) | ||
| 192 | (cow) | ||
| 193 | (dolphin))))) | ||
| 194 | (hierarchy-sort hierarchy (lambda (item1 item2) | ||
| 195 | (string< (car item1) | ||
| 196 | (car item2)))) | ||
| 197 | (should (equal (hierarchy-to-string hierarchy (lambda (item) (symbol-name (car item)))) | ||
| 198 | "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) | ||
| 199 | |||
| 200 | (ert-deftest hierarchy-from-list-with-duplicates () | ||
| 201 | (let ((hierarchy (hierarchy-from-list | ||
| 202 | '(a (b) (b)) | ||
| 203 | t))) | ||
| 204 | (hierarchy-sort hierarchy (lambda (item1 item2) | ||
| 205 | ;; sort by ID | ||
| 206 | (< (car item1) (car item2)))) | ||
| 207 | (should (equal (hierarchy-length hierarchy) 3)) | ||
| 208 | (should (equal (hierarchy-to-string | ||
| 209 | hierarchy | ||
| 210 | (lambda (item) | ||
| 211 | (format "%s(%s)" | ||
| 212 | (cadr item) | ||
| 213 | (car item)))) | ||
| 214 | "a(1)\n b(2)\n b(3)\n")))) | ||
| 215 | |||
| 216 | (ert-deftest hierarchy-from-list-with-childrenfn () | ||
| 217 | (let ((hierarchy (hierarchy-from-list | ||
| 218 | "abc" | ||
| 219 | nil | ||
| 220 | (lambda (item) | ||
| 221 | (when (string= item "abc") | ||
| 222 | (split-string item "" t)))))) | ||
| 223 | (hierarchy-sort hierarchy (lambda (item1 item2) (string< item1 item2))) | ||
| 224 | (should (equal (hierarchy-length hierarchy) 4)) | ||
| 225 | (should (equal (hierarchy-to-string hierarchy) | ||
| 226 | "abc\n a\n b\n c\n")))) | ||
| 227 | |||
| 228 | (ert-deftest hierarchy-add-relation-check-error-when-different-parent () | ||
| 229 | (let ((parentfn (lambda (item) | ||
| 230 | (cl-case item | ||
| 231 | (bird 'animal)))) | ||
| 232 | (hierarchy (hierarchy-new))) | ||
| 233 | (hierarchy-add-tree hierarchy 'bird parentfn) | ||
| 234 | (should-error | ||
| 235 | (hierarchy--add-relation hierarchy 'bird 'cow #'identity)))) | ||
| 236 | |||
| 237 | (ert-deftest hierarchy-empty-p-return-non-nil-for-empty () | ||
| 238 | (should (hierarchy-empty-p (hierarchy-new)))) | ||
| 239 | |||
| 240 | (ert-deftest hierarchy-empty-p-return-nil-for-non-empty () | ||
| 241 | (should-not (hierarchy-empty-p (hierarchy-animals)))) | ||
| 242 | |||
| 243 | (ert-deftest hierarchy-length-of-empty-is-0 () | ||
| 244 | (should (equal (hierarchy-length (hierarchy-new)) 0))) | ||
| 245 | |||
| 246 | (ert-deftest hierarchy-length-of-non-empty-counts-items () | ||
| 247 | (let ((parentfn (lambda (item) | ||
| 248 | (cl-case item | ||
| 249 | (bird 'animal) | ||
| 250 | (dove 'bird) | ||
| 251 | (pigeon 'bird)))) | ||
| 252 | (hierarchy (hierarchy-new))) | ||
| 253 | (hierarchy-add-tree hierarchy 'dove parentfn) | ||
| 254 | (hierarchy-add-tree hierarchy 'pigeon parentfn) | ||
| 255 | (should (equal (hierarchy-length hierarchy) 4)))) | ||
| 256 | |||
| 257 | (ert-deftest hierarchy-has-root () | ||
| 258 | (let ((parentfn (lambda (item) | ||
| 259 | (cl-case item | ||
| 260 | (bird 'animal) | ||
| 261 | (dove 'bird) | ||
| 262 | (pigeon 'bird)))) | ||
| 263 | (hierarchy (hierarchy-new))) | ||
| 264 | (should-not (hierarchy-has-root hierarchy 'animal)) | ||
| 265 | (should-not (hierarchy-has-root hierarchy 'bird)) | ||
| 266 | (hierarchy-add-tree hierarchy 'dove parentfn) | ||
| 267 | (hierarchy-add-tree hierarchy 'pigeon parentfn) | ||
| 268 | (should (hierarchy-has-root hierarchy 'animal)) | ||
| 269 | (should-not (hierarchy-has-root hierarchy 'bird)))) | ||
| 270 | |||
| 271 | (ert-deftest hierarchy-leafs () | ||
| 272 | (let ((animals (hierarchy-animals))) | ||
| 273 | (should (equal (hierarchy-leafs animals) | ||
| 274 | '(dove pigeon dolphin cow))))) | ||
| 275 | |||
| 276 | (ert-deftest hierarchy-leafs-includes-lonely-roots () | ||
| 277 | (let ((parentfn (lambda (item) nil)) | ||
| 278 | (hierarchy (hierarchy-new))) | ||
| 279 | (hierarchy-add-tree hierarchy 'foo parentfn) | ||
| 280 | (should (equal (hierarchy-leafs hierarchy) | ||
| 281 | '(foo))))) | ||
| 282 | |||
| 283 | (ert-deftest hierarchy-leafs-of-node () | ||
| 284 | (let ((animals (hierarchy-animals))) | ||
| 285 | (should (equal (hierarchy-leafs animals 'cow) '())) | ||
| 286 | (should (equal (hierarchy-leafs animals 'animal) '(dove pigeon dolphin cow))) | ||
| 287 | (should (equal (hierarchy-leafs animals 'bird) '(dove pigeon))) | ||
| 288 | (should (equal (hierarchy-leafs animals 'dove) '())))) | ||
| 289 | |||
| 290 | (ert-deftest hierarchy-child-p () | ||
| 291 | (let ((animals (hierarchy-animals))) | ||
| 292 | (should (hierarchy-child-p animals 'dove 'bird)) | ||
| 293 | (should (hierarchy-child-p animals 'bird 'animal)) | ||
| 294 | (should (hierarchy-child-p animals 'cow 'animal)) | ||
| 295 | (should-not (hierarchy-child-p animals 'cow 'bird)) | ||
| 296 | (should-not (hierarchy-child-p animals 'bird 'cow)) | ||
| 297 | (should-not (hierarchy-child-p animals 'animal 'dove)) | ||
| 298 | (should-not (hierarchy-child-p animals 'animal 'bird)))) | ||
| 299 | |||
| 300 | (ert-deftest hierarchy-descendant () | ||
| 301 | (let ((animals (hierarchy-animals))) | ||
| 302 | (should (hierarchy-descendant-p animals 'dove 'animal)) | ||
| 303 | (should (hierarchy-descendant-p animals 'dove 'bird)) | ||
| 304 | (should (hierarchy-descendant-p animals 'bird 'animal)) | ||
| 305 | (should (hierarchy-descendant-p animals 'cow 'animal)) | ||
| 306 | (should-not (hierarchy-descendant-p animals 'cow 'bird)) | ||
| 307 | (should-not (hierarchy-descendant-p animals 'bird 'cow)) | ||
| 308 | (should-not (hierarchy-descendant-p animals 'animal 'dove)) | ||
| 309 | (should-not (hierarchy-descendant-p animals 'animal 'bird)))) | ||
| 310 | |||
| 311 | (ert-deftest hierarchy-descendant-if-not-same () | ||
| 312 | (let ((animals (hierarchy-animals))) | ||
| 313 | (should-not (hierarchy-descendant-p animals 'cow 'cow)) | ||
| 314 | (should-not (hierarchy-descendant-p animals 'dove 'dove)) | ||
| 315 | (should-not (hierarchy-descendant-p animals 'bird 'bird)) | ||
| 316 | (should-not (hierarchy-descendant-p animals 'animal 'animal)))) | ||
| 317 | |||
| 318 | ;; keywords supported: :test :key | ||
| 319 | (ert-deftest hierarchy--set-equal () | ||
| 320 | (should (hierarchy--set-equal '(1 2 3) '(1 2 3))) | ||
| 321 | (should (hierarchy--set-equal '(1 2 3) '(3 2 1))) | ||
| 322 | (should (hierarchy--set-equal '(3 2 1) '(1 2 3))) | ||
| 323 | (should-not (hierarchy--set-equal '(2 3) '(3 2 1))) | ||
| 324 | (should-not (hierarchy--set-equal '(1 2 3) '(2 3))) | ||
| 325 | (should-not (hierarchy--set-equal '("1" "2") '("2" "1") :test #'eq)) | ||
| 326 | (should (hierarchy--set-equal '("1" "2") '("2" "1") :test #'equal)) | ||
| 327 | (should-not (hierarchy--set-equal '(1 2) '(-1 -2))) | ||
| 328 | (should (hierarchy--set-equal '(1 2) '(-1 -2) :key #'abs)) | ||
| 329 | (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)))) | ||
| 330 | (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car)) | ||
| 331 | (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :test #'equal)) | ||
| 332 | (should (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car :test #'equal))) | ||
| 333 | |||
| 334 | (ert-deftest hierarchy-equal-returns-true-for-same-hierarchy () | ||
| 335 | (let ((animals (hierarchy-animals))) | ||
| 336 | (should (hierarchy-equal animals animals)) | ||
| 337 | (should (hierarchy-equal (hierarchy-animals) animals)))) | ||
| 338 | |||
| 339 | (ert-deftest hierarchy-equal-returns-true-for-hierarchy-copies () | ||
| 340 | (let ((animals (hierarchy-animals))) | ||
| 341 | (should (hierarchy-equal animals (hierarchy-copy animals))))) | ||
| 342 | |||
| 343 | (ert-deftest hierarchy-map-item-on-leaf () | ||
| 344 | (let* ((animals (hierarchy-animals)) | ||
| 345 | (result (hierarchy-map-item (lambda (item indent) (cons item indent)) | ||
| 346 | 'cow | ||
| 347 | animals))) | ||
| 348 | (should (equal result '((cow . 0)))))) | ||
| 349 | |||
| 350 | (ert-deftest hierarchy-map-item-on-leaf-with-indent () | ||
| 351 | (let* ((animals (hierarchy-animals)) | ||
| 352 | (result (hierarchy-map-item (lambda (item indent) (cons item indent)) | ||
| 353 | 'cow | ||
| 354 | animals | ||
| 355 | 2))) | ||
| 356 | (should (equal result '((cow . 2)))))) | ||
| 357 | |||
| 358 | (ert-deftest hierarchy-map-item-on-parent () | ||
| 359 | (let* ((animals (hierarchy-animals)) | ||
| 360 | (result (hierarchy-map-item (lambda (item indent) (cons item indent)) | ||
| 361 | 'bird | ||
| 362 | animals))) | ||
| 363 | (should (equal result '((bird . 0) (dove . 1) (pigeon . 1)))))) | ||
| 364 | |||
| 365 | (ert-deftest hierarchy-map-item-on-grand-parent () | ||
| 366 | (let* ((animals (hierarchy-animals)) | ||
| 367 | (result (hierarchy-map-item (lambda (item indent) (cons item indent)) | ||
| 368 | 'animal | ||
| 369 | animals))) | ||
| 370 | (should (equal result '((animal . 0) (bird . 1) (dove . 2) (pigeon . 2) | ||
| 371 | (cow . 1) (dolphin . 1)))))) | ||
| 372 | |||
| 373 | (ert-deftest hierarchy-map-conses () | ||
| 374 | (let* ((animals (hierarchy-animals)) | ||
| 375 | (result (hierarchy-map (lambda (item indent) | ||
| 376 | (cons item indent)) | ||
| 377 | animals))) | ||
| 378 | (should (equal result '((animal . 0) | ||
| 379 | (bird . 1) | ||
| 380 | (dove . 2) | ||
| 381 | (pigeon . 2) | ||
| 382 | (cow . 1) | ||
| 383 | (dolphin . 1)))))) | ||
| 384 | |||
| 385 | (ert-deftest hierarchy-map-tree () | ||
| 386 | (let ((animals (hierarchy-animals))) | ||
| 387 | (should (equal (hierarchy-map-tree (lambda (item indent children) | ||
| 388 | (list item indent children)) | ||
| 389 | animals) | ||
| 390 | '(animal | ||
| 391 | 0 | ||
| 392 | ((bird 1 ((dove 2 nil) (pigeon 2 nil))) | ||
| 393 | (cow 1 nil) | ||
| 394 | (dolphin 1 nil))))))) | ||
| 395 | |||
| 396 | (ert-deftest hierarchy-map-hierarchy-keeps-hierarchy () | ||
| 397 | (let* ((animals (hierarchy-animals)) | ||
| 398 | (result (hierarchy-map-hierarchy (lambda (item _) (identity item)) | ||
| 399 | animals))) | ||
| 400 | (should (hierarchy-equal animals result)))) | ||
| 401 | |||
| 402 | (ert-deftest hierarchy-map-applies-function () | ||
| 403 | (let* ((animals (hierarchy-animals)) | ||
| 404 | (parentfn (lambda (item) | ||
| 405 | (cond | ||
| 406 | ((equal item "bird") "animal") | ||
| 407 | ((equal item "dove") "bird") | ||
| 408 | ((equal item "pigeon") "bird") | ||
| 409 | ((equal item "cow") "animal") | ||
| 410 | ((equal item "dolphin") "animal")))) | ||
| 411 | (expected (hierarchy-new))) | ||
| 412 | (hierarchy-add-tree expected "dove" parentfn) | ||
| 413 | (hierarchy-add-tree expected "pigeon" parentfn) | ||
| 414 | (hierarchy-add-tree expected "cow" parentfn) | ||
| 415 | (hierarchy-add-tree expected "dolphin" parentfn) | ||
| 416 | (should (hierarchy-equal | ||
| 417 | (hierarchy-map-hierarchy (lambda (item _) (symbol-name item)) animals) | ||
| 418 | expected)))) | ||
| 419 | |||
| 420 | (ert-deftest hierarchy-extract-tree () | ||
| 421 | (let* ((animals (hierarchy-animals)) | ||
| 422 | (birds (hierarchy-extract-tree animals 'bird))) | ||
| 423 | (hierarchy-sort birds) | ||
| 424 | (should (equal (hierarchy-roots birds) '(animal))) | ||
| 425 | (should (equal (hierarchy-children birds 'animal) '(bird))) | ||
| 426 | (should (equal (hierarchy-children birds 'bird) '(dove pigeon))))) | ||
| 427 | |||
| 428 | (ert-deftest hierarchy-extract-tree-nil-if-not-in-hierarchy () | ||
| 429 | (let* ((animals (hierarchy-animals))) | ||
| 430 | (should-not (hierarchy-extract-tree animals 'foobar)))) | ||
| 431 | |||
| 432 | (ert-deftest hierarchy-items-of-empty-hierarchy-is-empty () | ||
| 433 | (should (seq-empty-p (hierarchy-items (hierarchy-new))))) | ||
| 434 | |||
| 435 | (ert-deftest hierarchy-items-returns-sequence-of-same-length () | ||
| 436 | (let* ((animals (hierarchy-animals)) | ||
| 437 | (result (hierarchy-items animals))) | ||
| 438 | (should (= (seq-length result) (hierarchy-length animals))))) | ||
| 439 | |||
| 440 | (ert-deftest hierarchy-items-return-all-elements-of-hierarchy () | ||
| 441 | (let* ((animals (hierarchy-animals)) | ||
| 442 | (result (hierarchy-items animals))) | ||
| 443 | (should (equal (seq-sort #'string< result) '(animal bird cow dolphin dove pigeon))))) | ||
| 444 | |||
| 445 | (ert-deftest hierarchy-labelfn-indent-no-indent-if-0 () | ||
| 446 | (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) | ||
| 447 | (labelfn (hierarchy-labelfn-indent labelfn-base))) | ||
| 448 | (should (equal | ||
| 449 | (with-temp-buffer | ||
| 450 | (funcall labelfn "bar" 0) | ||
| 451 | (buffer-substring (point-min) (point-max))) | ||
| 452 | "foo")))) | ||
| 453 | |||
| 454 | (ert-deftest hierarchy-labelfn-indent-three-times-if-3 () | ||
| 455 | (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) | ||
| 456 | (labelfn (hierarchy-labelfn-indent labelfn-base))) | ||
| 457 | (should (equal | ||
| 458 | (with-temp-buffer | ||
| 459 | (funcall labelfn "bar" 3) | ||
| 460 | (buffer-substring (point-min) (point-max))) | ||
| 461 | " foo")))) | ||
| 462 | |||
| 463 | (ert-deftest hierarchy-labelfn-indent-default-indent-string () | ||
| 464 | (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) | ||
| 465 | (labelfn (hierarchy-labelfn-indent labelfn-base))) | ||
| 466 | (should (equal | ||
| 467 | (with-temp-buffer | ||
| 468 | (funcall labelfn "bar" 1) | ||
| 469 | (buffer-substring (point-min) (point-max))) | ||
| 470 | " foo")))) | ||
| 471 | |||
| 472 | (ert-deftest hierarchy-labelfn-indent-custom-indent-string () | ||
| 473 | (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) | ||
| 474 | (labelfn (hierarchy-labelfn-indent labelfn-base "###")) | ||
| 475 | (content (with-temp-buffer | ||
| 476 | (funcall labelfn "bar" 1) | ||
| 477 | (buffer-substring (point-min) (point-max))))) | ||
| 478 | (should (equal content "###foo")))) | ||
| 479 | |||
| 480 | (ert-deftest hierarchy-labelfn-button-propertize () | ||
| 481 | (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) | ||
| 482 | (actionfn #'identity) | ||
| 483 | (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) | ||
| 484 | (properties (with-temp-buffer | ||
| 485 | (funcall labelfn "bar" 1) | ||
| 486 | (text-properties-at 1)))) | ||
| 487 | (should (equal (car properties) 'action)))) | ||
| 488 | |||
| 489 | (ert-deftest hierarchy-labelfn-button-execute-labelfn () | ||
| 490 | (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) | ||
| 491 | (actionfn #'identity) | ||
| 492 | (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) | ||
| 493 | (content (with-temp-buffer | ||
| 494 | (funcall labelfn "bar" 1) | ||
| 495 | (buffer-substring-no-properties (point-min) (point-max))))) | ||
| 496 | (should (equal content "foo")))) | ||
| 497 | |||
| 498 | (ert-deftest hierarchy-labelfn-button-if-does-not-button-unless-condition () | ||
| 499 | (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) | ||
| 500 | (spy-count 0) | ||
| 501 | (condition (lambda (_item _indent) nil))) | ||
| 502 | (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) | ||
| 503 | (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) | ||
| 504 | (should (equal spy-count 0))))) | ||
| 505 | |||
| 506 | (ert-deftest hierarchy-labelfn-button-if-does-button-when-condition () | ||
| 507 | (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) | ||
| 508 | (spy-count 0) | ||
| 509 | (condition (lambda (_item _indent) t))) | ||
| 510 | (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) | ||
| 511 | (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) | ||
| 512 | (should (equal spy-count 1))))) | ||
| 513 | |||
| 514 | (ert-deftest hierarchy-labelfn-to-string () | ||
| 515 | (let ((labelfn (lambda (item _indent) (insert item)))) | ||
| 516 | (should (equal (hierarchy-labelfn-to-string labelfn "foo" 1) "foo")))) | ||
| 517 | |||
| 518 | (ert-deftest hierarchy-print () | ||
| 519 | (let* ((animals (hierarchy-animals)) | ||
| 520 | (result (with-temp-buffer | ||
| 521 | (hierarchy-print animals) | ||
| 522 | (buffer-substring-no-properties (point-min) (point-max))))) | ||
| 523 | (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) | ||
| 524 | |||
| 525 | (ert-deftest hierarchy-to-string () | ||
| 526 | (let* ((animals (hierarchy-animals)) | ||
| 527 | (result (hierarchy-to-string animals))) | ||
| 528 | (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) | ||
| 529 | |||
| 530 | (ert-deftest hierarchy-tabulated-display () | ||
| 531 | (let* ((animals (hierarchy-animals)) | ||
| 532 | (labelfn (lambda (item _indent) (insert (symbol-name item)))) | ||
| 533 | (contents (with-temp-buffer | ||
| 534 | (hierarchy-tabulated-display animals labelfn (current-buffer)) | ||
| 535 | (buffer-substring-no-properties (point-min) (point-max))))) | ||
| 536 | (should (equal contents "animal\nbird\ndove\npigeon\ncow\ndolphin\n")))) | ||
| 537 | |||
| 538 | (ert-deftest hierarchy-sort-non-root-nodes () | ||
| 539 | (let* ((animals (hierarchy-animals))) | ||
| 540 | (should (equal (hierarchy-roots animals) '(animal))) | ||
| 541 | (should (equal (hierarchy-children animals 'animal) '(bird cow dolphin))) | ||
| 542 | (should (equal (hierarchy-children animals 'bird) '(dove pigeon))))) | ||
| 543 | |||
| 544 | (ert-deftest hierarchy-sort-roots () | ||
| 545 | (let* ((organisms (hierarchy-new)) | ||
| 546 | (parentfn (lambda (item) | ||
| 547 | (cl-case item | ||
| 548 | (oak 'plant) | ||
| 549 | (bird 'animal))))) | ||
| 550 | (hierarchy-add-tree organisms 'oak parentfn) | ||
| 551 | (hierarchy-add-tree organisms 'bird parentfn) | ||
| 552 | (hierarchy-sort organisms) | ||
| 553 | (should (equal (hierarchy-roots organisms) '(animal plant))))) | ||
| 554 | |||
| 555 | (provide 'hierarchy-tests) | ||
| 556 | ;;; hierarchy-tests.el ends here | ||
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el new file mode 100644 index 00000000000..27f48fa8131 --- /dev/null +++ b/test/lisp/erc/erc-tests.el | |||
| @@ -0,0 +1,47 @@ | |||
| 1 | ;;; erc-tests.el --- Tests for erc. -*- lexical-binding:t -*- | ||
| 2 | |||
| 3 | ;; Copyright (C) 2020 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Lars Ingebrigtsen <larsi@gnus.org> | ||
| 6 | |||
| 7 | ;; This file is part of GNU Emacs. | ||
| 8 | |||
| 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 10 | ;; it under the terms of the GNU General Public License as published by | ||
| 11 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 12 | ;; (at your option) any later version. | ||
| 13 | |||
| 14 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 17 | ;; GNU General Public License for more details. | ||
| 18 | |||
| 19 | ;; You should have received a copy of the GNU General Public License | ||
| 20 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
| 21 | |||
| 22 | ;;; Code: | ||
| 23 | |||
| 24 | (require 'ert) | ||
| 25 | (require 'erc) | ||
| 26 | |||
| 27 | (ert-deftest erc--read-time-period () | ||
| 28 | (cl-letf (((symbol-function 'read-string) (lambda (&rest _) ""))) | ||
| 29 | (should (equal (erc--read-time-period "foo: ") nil))) | ||
| 30 | |||
| 31 | (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " "))) | ||
| 32 | (should (equal (erc--read-time-period "foo: ") nil))) | ||
| 33 | |||
| 34 | (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " 432 "))) | ||
| 35 | (should (equal (erc--read-time-period "foo: ") 432))) | ||
| 36 | |||
| 37 | (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "432"))) | ||
| 38 | (should (equal (erc--read-time-period "foo: ") 432))) | ||
| 39 | |||
| 40 | (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h"))) | ||
| 41 | (should (equal (erc--read-time-period "foo: ") 3600))) | ||
| 42 | |||
| 43 | (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h10s"))) | ||
| 44 | (should (equal (erc--read-time-period "foo: ") 3610))) | ||
| 45 | |||
| 46 | (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d"))) | ||
| 47 | (should (equal (erc--read-time-period "foo: ") 86400)))) | ||
diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el new file mode 100644 index 00000000000..b01e2fc2966 --- /dev/null +++ b/test/lisp/gnus/gnus-util-tests.el | |||
| @@ -0,0 +1,76 @@ | |||
| 1 | ;;; gnus-util-tests.el --- Selectived tests only. | ||
| 2 | ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. | ||
| 3 | |||
| 4 | ;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org> | ||
| 5 | |||
| 6 | ;; This file is not part of GNU Emacs. | ||
| 7 | |||
| 8 | ;; GNU Emacs is free software; you can redistribute it and/or modify | ||
| 9 | ;; it under the terms of the GNU General Public License as published by | ||
| 10 | ;; the Free Software Foundation; either version 3, or (at your option) | ||
| 11 | ;; any later version. | ||
| 12 | |||
| 13 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 16 | ;; GNU General Public License for more details. | ||
| 17 | |||
| 18 | ;; You should have received a copy of the GNU General Public License | ||
| 19 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 20 | |||
| 21 | ;;; Commentary: | ||
| 22 | |||
| 23 | ;;; Code: | ||
| 24 | |||
| 25 | (require 'ert) | ||
| 26 | (require 'gnus-util) | ||
| 27 | |||
| 28 | (ert-deftest gnus-subsetp () | ||
| 29 | ;; False for non-lists. | ||
| 30 | (should-not (gnus-subsetp "1" "1")) | ||
| 31 | (should-not (gnus-subsetp "1" '("1"))) | ||
| 32 | (should-not (gnus-subsetp '("1") "1")) | ||
| 33 | |||
| 34 | ;; Real tests. | ||
| 35 | (should (gnus-subsetp '() '())) | ||
| 36 | (should (gnus-subsetp '() '("1"))) | ||
| 37 | (should (gnus-subsetp '("1") '("1"))) | ||
| 38 | (should (gnus-subsetp '(42) '("1" 42))) | ||
| 39 | (should (gnus-subsetp '(42) '(42 "1"))) | ||
| 40 | (should (gnus-subsetp '(42) '("1" 42 2))) | ||
| 41 | (should-not (gnus-subsetp '("1") '())) | ||
| 42 | (should-not (gnus-subsetp '("1") '(2))) | ||
| 43 | (should-not (gnus-subsetp '("1" 2) '(2))) | ||
| 44 | (should-not (gnus-subsetp '(2 "1") '(2))) | ||
| 45 | (should-not (gnus-subsetp '("1" 2) '(2 3))) | ||
| 46 | |||
| 47 | ;; Duplicates don't matter for sets. | ||
| 48 | (should (gnus-subsetp '("1" "1") '("1"))) | ||
| 49 | (should (gnus-subsetp '("1" 2 "1") '(2 "1"))) | ||
| 50 | (should (gnus-subsetp '("1" 2 "1") '(2 "1" "1" 2))) | ||
| 51 | (should-not (gnus-subsetp '("1" 2 "1" 3) '(2 "1" "1" 2)))) | ||
| 52 | |||
| 53 | (ert-deftest gnus-setdiff () | ||
| 54 | ;; False for non-lists. | ||
| 55 | (should-not (gnus-setdiff "1" "1")) | ||
| 56 | (should-not (gnus-setdiff "1" '())) | ||
| 57 | (should-not (gnus-setdiff '() "1")) | ||
| 58 | |||
| 59 | ;; Real tests. | ||
| 60 | (should-not (gnus-setdiff '() '())) | ||
| 61 | (should-not (gnus-setdiff '() '("1"))) | ||
| 62 | (should-not (gnus-setdiff '("1") '("1"))) | ||
| 63 | (should (equal '("1") (gnus-setdiff '("1") '()))) | ||
| 64 | (should (equal '("1") (gnus-setdiff '("1") '(2)))) | ||
| 65 | (should (equal '("1") (gnus-setdiff '("1" 2) '(2)))) | ||
| 66 | (should (equal '("1") (gnus-setdiff '("1" 2 3) '(3 2)))) | ||
| 67 | (should (equal '("1") (gnus-setdiff '(2 "1" 3) '(3 2)))) | ||
| 68 | (should (equal '("1") (gnus-setdiff '(2 3 "1") '(3 2)))) | ||
| 69 | (should (equal '(2 "1") (gnus-setdiff '(2 3 "1") '(3)))) | ||
| 70 | |||
| 71 | ;; Duplicates aren't touched for sets if they are not removed. | ||
| 72 | (should-not (gnus-setdiff '("1" "1") '("1"))) | ||
| 73 | (should (equal '("1") (gnus-setdiff '(2 "1" 2) '(2)))) | ||
| 74 | (should (equal '("1" "1") (gnus-setdiff '(2 "1" 2 "1") '(2))))) | ||
| 75 | |||
| 76 | ;;; gnustest-gnus-util.el ends here | ||
diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el new file mode 100644 index 00000000000..8f78a66f616 --- /dev/null +++ b/test/lisp/gnus/mml-sec-tests.el | |||
| @@ -0,0 +1,895 @@ | |||
| 1 | ;;; gnustest-mml-sec.el --- Tests mml-sec.el, see README-mml-secure.txt. | ||
| 2 | ;; Copyright (C) 2015 Free Software Foundation, Inc. | ||
| 3 | |||
| 4 | ;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org> | ||
| 5 | |||
| 6 | ;; This file is not part of GNU Emacs. | ||
| 7 | |||
| 8 | ;; GNU Emacs is free software; you can redistribute it and/or modify | ||
| 9 | ;; it under the terms of the GNU General Public License as published by | ||
| 10 | ;; the Free Software Foundation; either version 3, or (at your option) | ||
| 11 | ;; any later version. | ||
| 12 | |||
| 13 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 16 | ;; GNU General Public License for more details. | ||
| 17 | |||
| 18 | ;; You should have received a copy of the GNU General Public License | ||
| 19 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 20 | |||
| 21 | ;;; Commentary: | ||
| 22 | |||
| 23 | ;;; Code: | ||
| 24 | |||
| 25 | (require 'ert) | ||
| 26 | |||
| 27 | (require 'message) | ||
| 28 | (require 'epa) | ||
| 29 | (require 'epg) | ||
| 30 | (require 'mml-sec) | ||
| 31 | (require 'gnus-sum) | ||
| 32 | |||
| 33 | (defvar with-smime nil | ||
| 34 | "If nil, exclude S/MIME from tests as passphrases need to entered manually. | ||
| 35 | Mostly, the empty passphrase is used. However, the keys for | ||
| 36 | \"No Expiry two UIDs\" have the passphrase \"Passphrase\" (for OpenPGP as well | ||
| 37 | as S/MIME).") | ||
| 38 | |||
| 39 | (defun test-conf () | ||
| 40 | (ignore-errors (epg-configuration))) | ||
| 41 | |||
| 42 | (defun enc-standards () | ||
| 43 | (if with-smime '(enc-pgp enc-pgp-mime enc-smime) | ||
| 44 | '(enc-pgp enc-pgp-mime))) | ||
| 45 | (defun enc-sign-standards () | ||
| 46 | (if with-smime | ||
| 47 | '(enc-sign-pgp enc-sign-pgp-mime enc-sign-smime) | ||
| 48 | '(enc-sign-pgp enc-sign-pgp-mime))) | ||
| 49 | (defun sign-standards () | ||
| 50 | (if with-smime | ||
| 51 | '(sign-pgp sign-pgp-mime sign-smime) | ||
| 52 | '(sign-pgp sign-pgp-mime))) | ||
| 53 | |||
| 54 | (defun mml-secure-test-fixture (body &optional interactive) | ||
| 55 | "Setup GnuPG home containing test keys and prepare environment for BODY. | ||
| 56 | If optional INTERACTIVE is non-nil, allow questions to the user in case of | ||
| 57 | key problems. | ||
| 58 | This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests, | ||
| 59 | which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess. | ||
| 60 | Actually, I'm not sure why people would want to cache passwords in Emacs | ||
| 61 | instead of gpg-agent." | ||
| 62 | (unwind-protect | ||
| 63 | (let ((agent-info (getenv "GPG_AGENT_INFO")) | ||
| 64 | (gpghome (getenv "GNUPGHOME"))) | ||
| 65 | (condition-case error | ||
| 66 | (let ((epg-gpg-home-directory | ||
| 67 | (expand-file-name "test/data/mml-sec" source-directory)) | ||
| 68 | (mml-secure-allow-signing-with-unknown-recipient t) | ||
| 69 | (mml-smime-use 'epg) | ||
| 70 | ;; Create debug output in empty epg-debug-buffer. | ||
| 71 | (epg-debug t) | ||
| 72 | (epg-debug-buffer (get-buffer-create " *epg-test*")) | ||
| 73 | (mml-secure-fail-when-key-problem (not interactive))) | ||
| 74 | (with-current-buffer epg-debug-buffer | ||
| 75 | (erase-buffer)) | ||
| 76 | ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs. | ||
| 77 | ;; Just for testing. Jens does not recommend this for daily use. | ||
| 78 | (setenv "GPG_AGENT_INFO") | ||
| 79 | ;; Set GNUPGHOME as gpg-agent started by gpgsm does | ||
| 80 | ;; not look in the proper places otherwise, see: | ||
| 81 | ;; https://bugs.gnupg.org/gnupg/issue2126 | ||
| 82 | (setenv "GNUPGHOME" epg-gpg-home-directory) | ||
| 83 | (funcall body)) | ||
| 84 | (error | ||
| 85 | (setenv "GPG_AGENT_INFO" agent-info) | ||
| 86 | (setenv "GNUPGHOME" gpghome) | ||
| 87 | (signal (car error) (cdr error)))) | ||
| 88 | (setenv "GPG_AGENT_INFO" agent-info) | ||
| 89 | (setenv "GNUPGHOME" gpghome)))) | ||
| 90 | |||
| 91 | (defun mml-secure-test-message-setup (method to from &optional text bcc) | ||
| 92 | "Setup a buffer with MML METHOD, TO, and FROM headers. | ||
| 93 | Optionally, a message TEXT and BCC header can be passed." | ||
| 94 | (with-temp-buffer | ||
| 95 | (when bcc (insert (format "Bcc: %s\n" bcc))) | ||
| 96 | (insert (format "To: %s | ||
| 97 | From: %s | ||
| 98 | Subject: Test | ||
| 99 | %s\n" to from mail-header-separator)) | ||
| 100 | (if text | ||
| 101 | (insert (format "%s" text)) | ||
| 102 | (spook)) | ||
| 103 | (cond ((eq method 'enc-pgp-mime) | ||
| 104 | (mml-secure-message-encrypt-pgpmime 'nosig)) | ||
| 105 | ((eq method 'enc-sign-pgp-mime) | ||
| 106 | (mml-secure-message-encrypt-pgpmime)) | ||
| 107 | ((eq method 'enc-pgp) (mml-secure-message-encrypt-pgp 'nosig)) | ||
| 108 | ((eq method 'enc-sign-pgp) (mml-secure-message-encrypt-pgp)) | ||
| 109 | ((eq method 'enc-smime) (mml-secure-message-encrypt-smime 'nosig)) | ||
| 110 | ((eq method 'enc-sign-smime) (mml-secure-message-encrypt-smime)) | ||
| 111 | ((eq method 'sign-pgp-mime) (mml-secure-message-sign-pgpmime)) | ||
| 112 | ((eq method 'sign-pgp) (mml-secure-message-sign-pgp)) | ||
| 113 | ((eq method 'sign-smime) (mml-secure-message-sign-smime)) | ||
| 114 | (t (error "Unknown method"))) | ||
| 115 | (buffer-string))) | ||
| 116 | |||
| 117 | (defun mml-secure-test-mail-fixture (method to from body2 | ||
| 118 | &optional interactive) | ||
| 119 | "Setup buffer encrypted using METHOD for TO from FROM, call BODY2. | ||
| 120 | Pass optional INTERACTIVE to mml-secure-test-fixture." | ||
| 121 | (mml-secure-test-fixture | ||
| 122 | (lambda () | ||
| 123 | (let ((context (if (memq method '(enc-smime enc-sign-smime sign-smime)) | ||
| 124 | (epg-make-context 'CMS) | ||
| 125 | (epg-make-context 'OpenPGP))) | ||
| 126 | ;; Verify and decrypt by default. | ||
| 127 | (mm-verify-option 'known) | ||
| 128 | (mm-decrypt-option 'known) | ||
| 129 | (plaintext "The Magic Words are Squeamish Ossifrage")) | ||
| 130 | (with-temp-buffer | ||
| 131 | (insert (mml-secure-test-message-setup method to from plaintext)) | ||
| 132 | (message-options-set-recipient) | ||
| 133 | (message-encode-message-body) | ||
| 134 | ;; Replace separator line with newline. | ||
| 135 | (goto-char (point-min)) | ||
| 136 | (re-search-forward | ||
| 137 | (concat "^" (regexp-quote mail-header-separator) "\n")) | ||
| 138 | (replace-match "\n") | ||
| 139 | ;; The following treatment of handles, plainbuf, and multipart | ||
| 140 | ;; resulted from trial-and-error. | ||
| 141 | ;; Someone with more knowledge on how to decrypt messages and verify | ||
| 142 | ;; signatures might know more appropriate functions to invoke | ||
| 143 | ;; instead. | ||
| 144 | (let* ((handles (or (mm-dissect-buffer) | ||
| 145 | (mm-uu-dissect))) | ||
| 146 | (isplain (bufferp (car handles))) | ||
| 147 | (ismultipart (equal (car handles) "multipart/mixed")) | ||
| 148 | (plainbuf (if isplain | ||
| 149 | (car handles) | ||
| 150 | (if ismultipart | ||
| 151 | (car (cadadr handles)) | ||
| 152 | (caadr handles)))) | ||
| 153 | (decrypted | ||
| 154 | (with-current-buffer plainbuf (buffer-string))) | ||
| 155 | (gnus-info | ||
| 156 | (if isplain | ||
| 157 | nil | ||
| 158 | (if ismultipart | ||
| 159 | (or (mm-handle-multipart-ctl-parameter | ||
| 160 | (cadr handles) 'gnus-details) | ||
| 161 | (mm-handle-multipart-ctl-parameter | ||
| 162 | (cadr handles) 'gnus-info)) | ||
| 163 | (mm-handle-multipart-ctl-parameter | ||
| 164 | handles 'gnus-info))))) | ||
| 165 | (funcall body2 gnus-info plaintext decrypted))))) | ||
| 166 | interactive)) | ||
| 167 | |||
| 168 | ;; TODO If the variable BODY3 is renamed to BODY, an infinite recursion | ||
| 169 | ;; occurs. Emacs bug? | ||
| 170 | (defun mml-secure-test-key-fixture (body3) | ||
| 171 | "Customize unique keys for sub@example.org and call BODY3. | ||
| 172 | For OpenPGP, we have: | ||
| 173 | - 1E6B FA97 3D9E 3103 B77F D399 C399 9CF1 268D BEA2 | ||
| 174 | uid Different subkeys <sub@example.org> | ||
| 175 | - 1463 2ECA B9E2 2736 9C8D D97B F7E7 9AB7 AE31 D471 | ||
| 176 | uid Second Key Pair <sub@example.org> | ||
| 177 | |||
| 178 | For S/MIME: | ||
| 179 | ID: 0x479DC6E2 | ||
| 180 | Subject: /CN=Second Key Pair | ||
| 181 | aka: sub@example.org | ||
| 182 | fingerprint: 0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 | ||
| 183 | |||
| 184 | ID: 0x5F88E9FC | ||
| 185 | Subject: /CN=Different subkeys | ||
| 186 | aka: sub@example.org | ||
| 187 | fingerprint: 4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC | ||
| 188 | |||
| 189 | In both cases, the first key is customized for signing and encryption." | ||
| 190 | (mml-secure-test-fixture | ||
| 191 | (lambda () | ||
| 192 | (let* ((mml-secure-key-preferences | ||
| 193 | '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) | ||
| 194 | (pcontext (epg-make-context 'OpenPGP)) | ||
| 195 | (pkey (epg-list-keys pcontext "C3999CF1268DBEA2")) | ||
| 196 | (scontext (epg-make-context 'CMS)) | ||
| 197 | (skey (epg-list-keys scontext "0x479DC6E2"))) | ||
| 198 | (mml-secure-cust-record-keys pcontext 'encrypt "sub@example.org" pkey) | ||
| 199 | (mml-secure-cust-record-keys pcontext 'sign "sub@example.org" pkey) | ||
| 200 | (mml-secure-cust-record-keys scontext 'encrypt "sub@example.org" skey) | ||
| 201 | (mml-secure-cust-record-keys scontext 'sign "sub@example.org" skey) | ||
| 202 | (funcall body3))))) | ||
| 203 | |||
| 204 | (ert-deftest mml-secure-key-checks () | ||
| 205 | "Test mml-secure-check-user-id and mml-secure-check-sub-key on sample keys." | ||
| 206 | (skip-unless (test-conf)) | ||
| 207 | (mml-secure-test-fixture | ||
| 208 | (lambda () | ||
| 209 | (let* ((context (epg-make-context 'OpenPGP)) | ||
| 210 | (keys1 (epg-list-keys context "expired@example.org")) | ||
| 211 | (keys2 (epg-list-keys context "no-exp@example.org")) | ||
| 212 | (keys3 (epg-list-keys context "sub@example.org")) | ||
| 213 | (keys4 (epg-list-keys context "revoked-uid@example.org")) | ||
| 214 | (keys5 (epg-list-keys context "disabled@example.org")) | ||
| 215 | (keys6 (epg-list-keys context "sign@example.org")) | ||
| 216 | (keys7 (epg-list-keys context "jens.lechtenboerger@fsfe")) | ||
| 217 | ) | ||
| 218 | (should (and (= 1 (length keys1)) (= 1 (length keys2)) | ||
| 219 | (= 2 (length keys3)) | ||
| 220 | (= 1 (length keys4)) (= 1 (length keys5)) | ||
| 221 | )) | ||
| 222 | ;; key1 is expired | ||
| 223 | (should-not (mml-secure-check-user-id (car keys1) "expired@example.org")) | ||
| 224 | (should-not (mml-secure-check-sub-key context (car keys1) 'encrypt)) | ||
| 225 | (should-not (mml-secure-check-sub-key context (car keys1) 'sign)) | ||
| 226 | |||
| 227 | ;; key2 does not expire, but does not have the UID expired@example.org | ||
| 228 | (should-not (mml-secure-check-user-id (car keys2) "expired@example.org")) | ||
| 229 | (should (mml-secure-check-user-id (car keys2) "no-exp@example.org")) | ||
| 230 | (should (mml-secure-check-sub-key context (car keys2) 'encrypt)) | ||
| 231 | (should (mml-secure-check-sub-key context (car keys2) 'sign)) | ||
| 232 | |||
| 233 | ;; Two keys exist for sub@example.org. | ||
| 234 | (should (mml-secure-check-user-id (car keys3) "sub@example.org")) | ||
| 235 | (should (mml-secure-check-sub-key context (car keys3) 'encrypt)) | ||
| 236 | (should (mml-secure-check-sub-key context (car keys3) 'sign)) | ||
| 237 | (should (mml-secure-check-user-id (cadr keys3) "sub@example.org")) | ||
| 238 | (should (mml-secure-check-sub-key context (cadr keys3) 'encrypt)) | ||
| 239 | (should (mml-secure-check-sub-key context (cadr keys3) 'sign)) | ||
| 240 | |||
| 241 | ;; The UID revoked-uid@example.org is revoked. The key itself is | ||
| 242 | ;; usable, though (with the UID sub@example.org). | ||
| 243 | (should-not | ||
| 244 | (mml-secure-check-user-id (car keys4) "revoked-uid@example.org")) | ||
| 245 | (should (mml-secure-check-sub-key context (car keys4) 'encrypt)) | ||
| 246 | (should (mml-secure-check-sub-key context (car keys4) 'sign)) | ||
| 247 | (should (mml-secure-check-user-id (car keys4) "sub@example.org")) | ||
| 248 | |||
| 249 | ;; The next key is disabled and, thus, unusable. | ||
| 250 | (should (mml-secure-check-user-id (car keys5) "disabled@example.org")) | ||
| 251 | (should-not (mml-secure-check-sub-key context (car keys5) 'encrypt)) | ||
| 252 | (should-not (mml-secure-check-sub-key context (car keys5) 'sign)) | ||
| 253 | |||
| 254 | ;; The next key has multiple subkeys. | ||
| 255 | ;; 42466F0F is valid sign subkey, 501FFD98 is expired | ||
| 256 | (should (mml-secure-check-sub-key context (car keys6) 'sign "42466F0F")) | ||
| 257 | (should-not | ||
| 258 | (mml-secure-check-sub-key context (car keys6) 'sign "501FFD98")) | ||
| 259 | ;; DC7F66E7 is encrypt subkey | ||
| 260 | (should | ||
| 261 | (mml-secure-check-sub-key context (car keys6) 'encrypt "DC7F66E7")) | ||
| 262 | (should-not | ||
| 263 | (mml-secure-check-sub-key context (car keys6) 'sign "DC7F66E7")) | ||
| 264 | (should-not | ||
| 265 | (mml-secure-check-sub-key context (car keys6) 'encrypt "42466F0F")) | ||
| 266 | |||
| 267 | ;; The final key is just a public key. | ||
| 268 | (should (mml-secure-check-sub-key context (car keys7) 'encrypt)) | ||
| 269 | (should-not (mml-secure-check-sub-key context (car keys7) 'sign)) | ||
| 270 | )))) | ||
| 271 | |||
| 272 | (ert-deftest mml-secure-find-usable-keys-1 () | ||
| 273 | "Make sure that expired and disabled keys and revoked UIDs are not used." | ||
| 274 | (skip-unless (test-conf)) | ||
| 275 | (mml-secure-test-fixture | ||
| 276 | (lambda () | ||
| 277 | (let ((context (epg-make-context 'OpenPGP))) | ||
| 278 | (should-not | ||
| 279 | (mml-secure-find-usable-keys context "expired@example.org" 'encrypt)) | ||
| 280 | (should-not | ||
| 281 | (mml-secure-find-usable-keys context "expired@example.org" 'sign)) | ||
| 282 | |||
| 283 | (should-not | ||
| 284 | (mml-secure-find-usable-keys context "disabled@example.org" 'encrypt)) | ||
| 285 | (should-not | ||
| 286 | (mml-secure-find-usable-keys context "disabled@example.org" 'sign)) | ||
| 287 | |||
| 288 | (should-not | ||
| 289 | (mml-secure-find-usable-keys | ||
| 290 | context "<revoked-uid@example.org>" 'encrypt)) | ||
| 291 | (should-not | ||
| 292 | (mml-secure-find-usable-keys | ||
| 293 | context "<revoked-uid@example.org>" 'sign)) | ||
| 294 | ;; Same test without ankles. Will fail for Ma Gnus v0.14 and earlier. | ||
| 295 | (should-not | ||
| 296 | (mml-secure-find-usable-keys | ||
| 297 | context "revoked-uid@example.org" 'encrypt)) | ||
| 298 | |||
| 299 | ;; Expired key should not be usable. | ||
| 300 | ;; Will fail for Ma Gnus v0.14 and earlier. | ||
| 301 | ;; sign@example.org has the expired subkey 0x501FFD98. | ||
| 302 | (should-not | ||
| 303 | (mml-secure-find-usable-keys context "0x501FFD98" 'sign)) | ||
| 304 | |||
| 305 | (should | ||
| 306 | (mml-secure-find-usable-keys context "no-exp@example.org" 'encrypt)) | ||
| 307 | (should | ||
| 308 | (mml-secure-find-usable-keys context "no-exp@example.org" 'sign)) | ||
| 309 | )))) | ||
| 310 | |||
| 311 | (ert-deftest mml-secure-find-usable-keys-2 () | ||
| 312 | "Test different ways to search for keys." | ||
| 313 | (skip-unless (test-conf)) | ||
| 314 | (mml-secure-test-fixture | ||
| 315 | (lambda () | ||
| 316 | (let ((context (epg-make-context 'OpenPGP))) | ||
| 317 | ;; Plain substring search is not supported. | ||
| 318 | (should | ||
| 319 | (= 0 (length | ||
| 320 | (mml-secure-find-usable-keys context "No Expiry" 'encrypt)))) | ||
| 321 | (should | ||
| 322 | (= 0 (length | ||
| 323 | (mml-secure-find-usable-keys context "No Expiry" 'sign)))) | ||
| 324 | |||
| 325 | ;; Search for e-mail addresses works with and without ankle brackets. | ||
| 326 | (should | ||
| 327 | (= 1 (length (mml-secure-find-usable-keys | ||
| 328 | context "<no-exp@example.org>" 'encrypt)))) | ||
| 329 | (should | ||
| 330 | (= 1 (length (mml-secure-find-usable-keys | ||
| 331 | context "<no-exp@example.org>" 'sign)))) | ||
| 332 | (should | ||
| 333 | (= 1 (length (mml-secure-find-usable-keys | ||
| 334 | context "no-exp@example.org" 'encrypt)))) | ||
| 335 | (should | ||
| 336 | (= 1 (length (mml-secure-find-usable-keys | ||
| 337 | context "no-exp@example.org" 'sign)))) | ||
| 338 | |||
| 339 | ;; Use full UID string. | ||
| 340 | (should | ||
| 341 | (= 1 (length (mml-secure-find-usable-keys | ||
| 342 | context "No Expiry <no-exp@example.org>" 'encrypt)))) | ||
| 343 | (should | ||
| 344 | (= 1 (length (mml-secure-find-usable-keys | ||
| 345 | context "No Expiry <no-exp@example.org>" 'sign)))) | ||
| 346 | |||
| 347 | ;; If just the public key is present, only encryption is possible. | ||
| 348 | ;; Search works with key IDs, with and without prefix "0x". | ||
| 349 | (should | ||
| 350 | (= 1 (length (mml-secure-find-usable-keys | ||
| 351 | context "A142FD84" 'encrypt)))) | ||
| 352 | (should | ||
| 353 | (= 1 (length (mml-secure-find-usable-keys | ||
| 354 | context "0xA142FD84" 'encrypt)))) | ||
| 355 | (should | ||
| 356 | (= 0 (length (mml-secure-find-usable-keys | ||
| 357 | context "A142FD84" 'sign)))) | ||
| 358 | (should | ||
| 359 | (= 0 (length (mml-secure-find-usable-keys | ||
| 360 | context "0xA142FD84" 'sign)))) | ||
| 361 | )))) | ||
| 362 | |||
| 363 | (ert-deftest mml-secure-select-preferred-keys-1 () | ||
| 364 | "If only one key exists for an e-mail address, it is the preferred one." | ||
| 365 | (skip-unless (test-conf)) | ||
| 366 | (mml-secure-test-fixture | ||
| 367 | (lambda () | ||
| 368 | (let ((context (epg-make-context 'OpenPGP))) | ||
| 369 | (should (equal "832F3CC6518D37BC658261B802372A42CA6D40FB" | ||
| 370 | (mml-secure-fingerprint | ||
| 371 | (car (mml-secure-select-preferred-keys | ||
| 372 | context '("no-exp@example.org") 'encrypt))))))))) | ||
| 373 | |||
| 374 | (ert-deftest mml-secure-select-preferred-keys-2 () | ||
| 375 | "If multiple keys exists for an e-mail address, customization is necessary." | ||
| 376 | (skip-unless (test-conf)) | ||
| 377 | (mml-secure-test-fixture | ||
| 378 | (lambda () | ||
| 379 | (let* ((context (epg-make-context 'OpenPGP)) | ||
| 380 | (mml-secure-key-preferences | ||
| 381 | '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) | ||
| 382 | (pref (car (mml-secure-find-usable-keys | ||
| 383 | context "sub@example.org" 'encrypt)))) | ||
| 384 | (should-error (mml-secure-select-preferred-keys | ||
| 385 | context '("sub@example.org") 'encrypt)) | ||
| 386 | (mml-secure-cust-record-keys | ||
| 387 | context 'encrypt "sub@example.org" (list pref)) | ||
| 388 | (should (mml-secure-select-preferred-keys | ||
| 389 | context '("sub@example.org") 'encrypt)) | ||
| 390 | (should-error (mml-secure-select-preferred-keys | ||
| 391 | context '("sub@example.org") 'sign)) | ||
| 392 | (should (mml-secure-select-preferred-keys | ||
| 393 | context '("sub@example.org") 'encrypt)) | ||
| 394 | (should | ||
| 395 | (equal (list (mml-secure-fingerprint pref)) | ||
| 396 | (mml-secure-cust-fpr-lookup context 'encrypt "sub@example.org"))) | ||
| 397 | (should (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")) | ||
| 398 | (should-error (mml-secure-select-preferred-keys | ||
| 399 | context '("sub@example.org") 'encrypt)))))) | ||
| 400 | |||
| 401 | (ert-deftest mml-secure-select-preferred-keys-3 () | ||
| 402 | "Expired customized keys are removed if multiple keys are available." | ||
| 403 | (skip-unless (test-conf)) | ||
| 404 | (mml-secure-test-fixture | ||
| 405 | (lambda () | ||
| 406 | (let ((context (epg-make-context 'OpenPGP)) | ||
| 407 | (mml-secure-key-preferences | ||
| 408 | '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))) | ||
| 409 | ;; sub@example.org has two keys (268DBEA2, AE31D471). | ||
| 410 | ;; Normal preference works. | ||
| 411 | (mml-secure-cust-record-keys | ||
| 412 | context 'encrypt "sub@example.org" (epg-list-keys context "268DBEA2")) | ||
| 413 | (should (mml-secure-select-preferred-keys | ||
| 414 | context '("sub@example.org") 'encrypt)) | ||
| 415 | (mml-secure-cust-remove-keys context 'encrypt "sub@example.org") | ||
| 416 | |||
| 417 | ;; Fake preference for expired (unrelated) key CE15FAE7, | ||
| 418 | ;; results in error (and automatic removal of outdated preference). | ||
| 419 | (mml-secure-cust-record-keys | ||
| 420 | context 'encrypt "sub@example.org" (epg-list-keys context "CE15FAE7")) | ||
| 421 | (should-error (mml-secure-select-preferred-keys | ||
| 422 | context '("sub@example.org") 'encrypt)) | ||
| 423 | (should-not | ||
| 424 | (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")))))) | ||
| 425 | |||
| 426 | (ert-deftest mml-secure-select-preferred-keys-4 () | ||
| 427 | "Multiple keys can be recorded per recipient or signature." | ||
| 428 | (skip-unless (test-conf)) | ||
| 429 | (mml-secure-test-fixture | ||
| 430 | (lambda () | ||
| 431 | (let ((pcontext (epg-make-context 'OpenPGP)) | ||
| 432 | (scontext (epg-make-context 'CMS)) | ||
| 433 | (pkeys '("1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" | ||
| 434 | "14632ECAB9E227369C8DD97BF7E79AB7AE31D471")) | ||
| 435 | (skeys '("0x5F88E9FC" "0x479DC6E2")) | ||
| 436 | (mml-secure-key-preferences | ||
| 437 | '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))) | ||
| 438 | |||
| 439 | ;; OpenPGP preferences via pcontext | ||
| 440 | (dolist (key pkeys nil) | ||
| 441 | (mml-secure-cust-record-keys | ||
| 442 | pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key)) | ||
| 443 | (mml-secure-cust-record-keys | ||
| 444 | pcontext 'sign "sub@example.org" (epg-list-keys pcontext key 'secret))) | ||
| 445 | (let ((p-e-fprs (mml-secure-cust-fpr-lookup | ||
| 446 | pcontext 'encrypt "sub@example.org")) | ||
| 447 | (p-s-fprs (mml-secure-cust-fpr-lookup | ||
| 448 | pcontext 'sign "sub@example.org"))) | ||
| 449 | (should (= 2 (length p-e-fprs))) | ||
| 450 | (should (= 2 (length p-s-fprs))) | ||
| 451 | (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-e-fprs)) | ||
| 452 | (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-e-fprs)) | ||
| 453 | (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-s-fprs)) | ||
| 454 | (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-s-fprs))) | ||
| 455 | ;; Duplicate record does not change anything. | ||
| 456 | (mml-secure-cust-record-keys | ||
| 457 | pcontext 'encrypt "sub@example.org" | ||
| 458 | (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2")) | ||
| 459 | (mml-secure-cust-record-keys | ||
| 460 | pcontext 'sign "sub@example.org" | ||
| 461 | (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2")) | ||
| 462 | (let ((p-e-fprs (mml-secure-cust-fpr-lookup | ||
| 463 | pcontext 'encrypt "sub@example.org")) | ||
| 464 | (p-s-fprs (mml-secure-cust-fpr-lookup | ||
| 465 | pcontext 'sign "sub@example.org"))) | ||
| 466 | (should (= 2 (length p-e-fprs))) | ||
| 467 | (should (= 2 (length p-s-fprs)))) | ||
| 468 | |||
| 469 | ;; S/MIME preferences via scontext | ||
| 470 | (dolist (key skeys nil) | ||
| 471 | (mml-secure-cust-record-keys | ||
| 472 | scontext 'encrypt "sub@example.org" | ||
| 473 | (epg-list-keys scontext key)) | ||
| 474 | (mml-secure-cust-record-keys | ||
| 475 | scontext 'sign "sub@example.org" | ||
| 476 | (epg-list-keys scontext key 'secret))) | ||
| 477 | (let ((s-e-fprs (mml-secure-cust-fpr-lookup | ||
| 478 | scontext 'encrypt "sub@example.org")) | ||
| 479 | (s-s-fprs (mml-secure-cust-fpr-lookup | ||
| 480 | scontext 'sign "sub@example.org"))) | ||
| 481 | (should (= 2 (length s-e-fprs))) | ||
| 482 | (should (= 2 (length s-s-fprs)))) | ||
| 483 | )))) | ||
| 484 | |||
| 485 | (defun mml-secure-test-en-decrypt | ||
| 486 | (method to from | ||
| 487 | &optional checksig checkplain enc-keys expectfail interactive) | ||
| 488 | "Encrypt message using METHOD, addressed to TO, from FROM. | ||
| 489 | If optional CHECKSIG is non-nil, it must be a number, and a signature check is | ||
| 490 | performed; the number indicates how many signatures are expected. | ||
| 491 | If optional CHECKPLAIN is non-nil, the expected plaintext should be obtained | ||
| 492 | via decryption. | ||
| 493 | If optional ENC-KEYS is non-nil, it is a list of pairs of encryption keys (for | ||
| 494 | OpenPGP and S/SMIME) expected in `epg-debug-buffer'. | ||
| 495 | If optional EXPECTFAIL is non-nil, a decryption failure is expected. | ||
| 496 | Pass optional INTERACTIVE to mml-secure-test-mail-fixture." | ||
| 497 | (mml-secure-test-mail-fixture method to from | ||
| 498 | (lambda (gnus-info plaintext decrypted) | ||
| 499 | (if expectfail | ||
| 500 | (should-not (equal plaintext decrypted)) | ||
| 501 | (when checkplain | ||
| 502 | (should (equal plaintext decrypted))) | ||
| 503 | (let ((protocol (if (memq method | ||
| 504 | '(enc-smime enc-sign-smime sign-smime)) | ||
| 505 | 'CMS | ||
| 506 | 'OpenPGP))) | ||
| 507 | (when checksig | ||
| 508 | (let* ((context (epg-make-context protocol)) | ||
| 509 | (signer-names (mml-secure-signer-names protocol from)) | ||
| 510 | (signer-keys (mml-secure-signers context signer-names)) | ||
| 511 | (signer-fprs (mapcar 'mml-secure-fingerprint signer-keys))) | ||
| 512 | (should (eq checksig (length signer-fprs))) | ||
| 513 | (if (eq checksig 0) | ||
| 514 | ;; First key in keyring | ||
| 515 | (should (string-match-p | ||
| 516 | (concat "Good signature from " | ||
| 517 | (if (eq protocol 'CMS) | ||
| 518 | "0E58229B80EE33959FF718FEEF25402B479DC6E2" | ||
| 519 | "02372A42CA6D40FB")) | ||
| 520 | gnus-info))) | ||
| 521 | (dolist (fpr signer-fprs nil) | ||
| 522 | ;; OpenPGP: "Good signature from 02372A42CA6D40FB No Expiry <no-exp@example.org> (trust undefined) created ..." | ||
| 523 | ;; S/MIME: "Good signature from D06AA118653CC38E9D0CAF56ED7A2135E1582177 /CN=No Expiry (trust full) ..." | ||
| 524 | (should (string-match-p | ||
| 525 | (concat "Good signature from " | ||
| 526 | (if (eq protocol 'CMS) | ||
| 527 | fpr | ||
| 528 | (substring fpr -16 nil))) | ||
| 529 | gnus-info))))) | ||
| 530 | (when enc-keys | ||
| 531 | (with-current-buffer epg-debug-buffer | ||
| 532 | (goto-char (point-min)) | ||
| 533 | ;; The following regexp does not necessarily match at the | ||
| 534 | ;; start of the line as a path may or may not be present. | ||
| 535 | ;; Also note that gpg.* matches gpg2 and gpgsm as well. | ||
| 536 | (let* ((line (concat "gpg.*--encrypt.*$")) | ||
| 537 | (end (re-search-forward line)) | ||
| 538 | (match (match-string 0))) | ||
| 539 | (should (and end match)) | ||
| 540 | (dolist (pair enc-keys nil) | ||
| 541 | (let ((fpr (if (eq protocol 'OpenPGP) | ||
| 542 | (car pair) | ||
| 543 | (cdr pair)))) | ||
| 544 | (should (string-match-p (concat "-r " fpr) match)))) | ||
| 545 | (goto-char (point-max)) | ||
| 546 | )))))) | ||
| 547 | interactive)) | ||
| 548 | |||
| 549 | (defun mml-secure-test-en-decrypt-with-passphrase | ||
| 550 | (method to from checksig jl-passphrase do-cache | ||
| 551 | &optional enc-keys expectfail) | ||
| 552 | "Call mml-secure-test-en-decrypt with changed passphrase caching. | ||
| 553 | Args METHOD, TO, FROM, CHECKSIG are passed to mml-secure-test-en-decrypt. | ||
| 554 | JL-PASSPHRASE is fixed as return value for `read-passwd', | ||
| 555 | boolean DO-CACHE determines whether to cache the passphrase. | ||
| 556 | If optional ENC-KEYS is non-nil, it is a list of encryption keys expected | ||
| 557 | in `epg-debug-buffer'. | ||
| 558 | If optional EXPECTFAIL is non-nil, a decryption failure is expected." | ||
| 559 | (let ((mml-secure-cache-passphrase do-cache) | ||
| 560 | (mml1991-cache-passphrase do-cache) | ||
| 561 | (mml2015-cache-passphrase do-cache) | ||
| 562 | (mml-smime-cache-passphrase do-cache) | ||
| 563 | ) | ||
| 564 | (cl-letf (((symbol-function 'read-passwd) | ||
| 565 | (lambda (prompt &optional confirm default) jl-passphrase))) | ||
| 566 | (mml-secure-test-en-decrypt method to from checksig t enc-keys expectfail) | ||
| 567 | ))) | ||
| 568 | |||
| 569 | (ert-deftest mml-secure-en-decrypt-1 () | ||
| 570 | "Encrypt message; then decrypt and test for expected result. | ||
| 571 | In this test, the single matching key is chosen automatically." | ||
| 572 | (skip-unless (test-conf)) | ||
| 573 | (dolist (method (enc-standards) nil) | ||
| 574 | ;; no-exp@example.org with single encryption key | ||
| 575 | (mml-secure-test-en-decrypt | ||
| 576 | method "no-exp@example.org" "sub@example.org" nil t | ||
| 577 | (list (cons "02372A42CA6D40FB" "ED7A2135E1582177"))))) | ||
| 578 | |||
| 579 | (ert-deftest mml-secure-en-decrypt-2 () | ||
| 580 | "Encrypt message; then decrypt and test for expected result. | ||
| 581 | In this test, the encryption key needs to fixed among multiple ones." | ||
| 582 | (skip-unless (test-conf)) | ||
| 583 | ;; sub@example.org with multiple candidate keys, | ||
| 584 | ;; fixture customizes preferred ones. | ||
| 585 | (mml-secure-test-key-fixture | ||
| 586 | (lambda () | ||
| 587 | (dolist (method (enc-standards) nil) | ||
| 588 | (mml-secure-test-en-decrypt | ||
| 589 | method "sub@example.org" "no-exp@example.org" nil t | ||
| 590 | (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2"))))))) | ||
| 591 | |||
| 592 | (ert-deftest mml-secure-en-decrypt-3 () | ||
| 593 | "Encrypt message; then decrypt and test for expected result. | ||
| 594 | In this test, encrypt-to-self variables are set to t." | ||
| 595 | (skip-unless (test-conf)) | ||
| 596 | ;; sub@example.org with multiple candidate keys, | ||
| 597 | ;; fixture customizes preferred ones. | ||
| 598 | (mml-secure-test-key-fixture | ||
| 599 | (lambda () | ||
| 600 | (let ((mml-secure-openpgp-encrypt-to-self t) | ||
| 601 | (mml-secure-smime-encrypt-to-self t)) | ||
| 602 | (dolist (method (enc-standards) nil) | ||
| 603 | (mml-secure-test-en-decrypt | ||
| 604 | method "sub@example.org" "no-exp@example.org" nil t | ||
| 605 | (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") | ||
| 606 | (cons "02372A42CA6D40FB" "ED7A2135E1582177")))))))) | ||
| 607 | |||
| 608 | (ert-deftest mml-secure-en-decrypt-4 () | ||
| 609 | "Encrypt message; then decrypt and test for expected result. | ||
| 610 | In this test, encrypt-to-self variables are set to lists." | ||
| 611 | (skip-unless (test-conf)) | ||
| 612 | ;; Send from sub@example.org, which has two keys; encrypt to both. | ||
| 613 | (let ((mml-secure-openpgp-encrypt-to-self | ||
| 614 | '("C3999CF1268DBEA2" "F7E79AB7AE31D471")) | ||
| 615 | (mml-secure-smime-encrypt-to-self | ||
| 616 | '("EF25402B479DC6E2" "4035D59B5F88E9FC"))) | ||
| 617 | (dolist (method (enc-standards) nil) | ||
| 618 | (mml-secure-test-en-decrypt | ||
| 619 | method "no-exp@example.org" "sub@example.org" nil t | ||
| 620 | (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") | ||
| 621 | (cons "F7E79AB7AE31D471" "4035D59B5F88E9FC")))))) | ||
| 622 | |||
| 623 | (ert-deftest mml-secure-en-decrypt-sign-1-1-single () | ||
| 624 | "Sign and encrypt message; then decrypt and test for expected result. | ||
| 625 | In this test, just multiple encryption and signing keys may be available." | ||
| 626 | :tags '(:unstable) | ||
| 627 | (skip-unless (test-conf)) | ||
| 628 | (mml-secure-test-key-fixture | ||
| 629 | (lambda () | ||
| 630 | (let ((mml-secure-openpgp-sign-with-sender t) | ||
| 631 | (mml-secure-smime-sign-with-sender t)) | ||
| 632 | (dolist (method (enc-sign-standards) nil) | ||
| 633 | ;; no-exp with just one key | ||
| 634 | (mml-secure-test-en-decrypt | ||
| 635 | method "no-exp@example.org" "no-exp@example.org" 1 t) | ||
| 636 | ;; customized choice for encryption key | ||
| 637 | (mml-secure-test-en-decrypt | ||
| 638 | method "sub@example.org" "no-exp@example.org" 1 t) | ||
| 639 | ;; customized choice for signing key | ||
| 640 | (mml-secure-test-en-decrypt | ||
| 641 | method "no-exp@example.org" "sub@example.org" 1 t) | ||
| 642 | ;; customized choice for both keys | ||
| 643 | (mml-secure-test-en-decrypt | ||
| 644 | method "sub@example.org" "sub@example.org" 1 t) | ||
| 645 | ))))) | ||
| 646 | |||
| 647 | (ert-deftest mml-secure-en-decrypt-sign-1-2-double () | ||
| 648 | "Sign and encrypt message; then decrypt and test for expected result. | ||
| 649 | In this test, just multiple encryption and signing keys may be available." | ||
| 650 | (skip-unless (test-conf)) | ||
| 651 | (mml-secure-test-key-fixture | ||
| 652 | (lambda () | ||
| 653 | (let ((mml-secure-openpgp-sign-with-sender t) | ||
| 654 | (mml-secure-smime-sign-with-sender t)) | ||
| 655 | ;; Now use both keys to sign. The customized one via sign-with-sender, | ||
| 656 | ;; the other one via the following setting. | ||
| 657 | (let ((mml-secure-openpgp-signers '("F7E79AB7AE31D471")) | ||
| 658 | (mml-secure-smime-signers '("0x5F88E9FC"))) | ||
| 659 | (dolist (method (enc-sign-standards) nil) | ||
| 660 | (mml-secure-test-en-decrypt | ||
| 661 | method "no-exp@example.org" "sub@example.org" 2 t))))))) | ||
| 662 | |||
| 663 | (ert-deftest mml-secure-en-decrypt-sign-1-3-double () | ||
| 664 | "Sign and encrypt message; then decrypt and test for expected result. | ||
| 665 | In this test, just multiple encryption and signing keys may be available." | ||
| 666 | (skip-unless (test-conf)) | ||
| 667 | (mml-secure-test-key-fixture | ||
| 668 | (lambda () | ||
| 669 | ;; Now use both keys for sub@example.org to sign an e-mail from | ||
| 670 | ;; a different address (without associated keys). | ||
| 671 | (let ((mml-secure-openpgp-sign-with-sender nil) | ||
| 672 | (mml-secure-smime-sign-with-sender nil) | ||
| 673 | (mml-secure-openpgp-signers | ||
| 674 | '("F7E79AB7AE31D471" "C3999CF1268DBEA2")) | ||
| 675 | (mml-secure-smime-signers '("0x5F88E9FC" "0x479DC6E2"))) | ||
| 676 | (dolist (method (enc-sign-standards) nil) | ||
| 677 | (mml-secure-test-en-decrypt | ||
| 678 | method "no-exp@example.org" "no-keys@example.org" 2 t)))))) | ||
| 679 | |||
| 680 | (ert-deftest mml-secure-en-decrypt-sign-2 () | ||
| 681 | "Sign and encrypt message; then decrypt and test for expected result. | ||
| 682 | In this test, lists of encryption and signing keys are customized." | ||
| 683 | (skip-unless (test-conf)) | ||
| 684 | (mml-secure-test-key-fixture | ||
| 685 | (lambda () | ||
| 686 | (let ((mml-secure-key-preferences | ||
| 687 | '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) | ||
| 688 | (pcontext (epg-make-context 'OpenPGP)) | ||
| 689 | (scontext (epg-make-context 'CMS)) | ||
| 690 | (mml-secure-openpgp-sign-with-sender t) | ||
| 691 | (mml-secure-smime-sign-with-sender t)) | ||
| 692 | (dolist (key '("F7E79AB7AE31D471" "C3999CF1268DBEA2") nil) | ||
| 693 | (mml-secure-cust-record-keys | ||
| 694 | pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key)) | ||
| 695 | (mml-secure-cust-record-keys | ||
| 696 | pcontext 'sign "sub@example.org" (epg-list-keys pcontext key t))) | ||
| 697 | (dolist (key '("0x5F88E9FC" "0x479DC6E2") nil) | ||
| 698 | (mml-secure-cust-record-keys | ||
| 699 | scontext 'encrypt "sub@example.org" (epg-list-keys scontext key)) | ||
| 700 | (mml-secure-cust-record-keys | ||
| 701 | scontext 'sign "sub@example.org" (epg-list-keys scontext key t))) | ||
| 702 | (dolist (method (enc-sign-standards) nil) | ||
| 703 | ;; customized choice for encryption key | ||
| 704 | (mml-secure-test-en-decrypt | ||
| 705 | method "sub@example.org" "no-exp@example.org" 1 t) | ||
| 706 | ;; customized choice for signing key | ||
| 707 | (mml-secure-test-en-decrypt | ||
| 708 | method "no-exp@example.org" "sub@example.org" 2 t) | ||
| 709 | ;; customized choice for both keys | ||
| 710 | (mml-secure-test-en-decrypt | ||
| 711 | method "sub@example.org" "sub@example.org" 2 t) | ||
| 712 | ))))) | ||
| 713 | |||
| 714 | (ert-deftest mml-secure-en-decrypt-sign-3 () | ||
| 715 | "Sign and encrypt message; then decrypt and test for expected result. | ||
| 716 | Use sign-with-sender and encrypt-to-self." | ||
| 717 | (skip-unless (test-conf)) | ||
| 718 | (mml-secure-test-key-fixture | ||
| 719 | (lambda () | ||
| 720 | (let ((mml-secure-openpgp-sign-with-sender t) | ||
| 721 | (mml-secure-openpgp-encrypt-to-self t) | ||
| 722 | (mml-secure-smime-sign-with-sender t) | ||
| 723 | (mml-secure-smime-encrypt-to-self t)) | ||
| 724 | (dolist (method (enc-sign-standards) nil) | ||
| 725 | (mml-secure-test-en-decrypt | ||
| 726 | method "sub@example.org" "no-exp@example.org" 1 t | ||
| 727 | (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") | ||
| 728 | (cons "02372A42CA6D40FB" "ED7A2135E1582177")))) | ||
| 729 | )))) | ||
| 730 | |||
| 731 | (ert-deftest mml-secure-sign-verify-1 () | ||
| 732 | "Sign message with sender; then verify and test for expected result." | ||
| 733 | (skip-unless (test-conf)) | ||
| 734 | (mml-secure-test-key-fixture | ||
| 735 | (lambda () | ||
| 736 | (dolist (method (sign-standards) nil) | ||
| 737 | (let ((mml-secure-openpgp-sign-with-sender t) | ||
| 738 | (mml-secure-smime-sign-with-sender t)) | ||
| 739 | ;; A single signing key for sender sub@example.org is customized | ||
| 740 | ;; in the fixture. | ||
| 741 | (mml-secure-test-en-decrypt | ||
| 742 | method "uid1@example.org" "sub@example.org" 1 nil) | ||
| 743 | |||
| 744 | ;; From sub@example.org, sign with two keys; | ||
| 745 | ;; sign-with-sender and one from signers-variable: | ||
| 746 | (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) | ||
| 747 | (mml-secure-smime-signers | ||
| 748 | '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) | ||
| 749 | (mml-secure-test-en-decrypt | ||
| 750 | method "no-exp@example.org" "sub@example.org" 2 nil)) | ||
| 751 | ))))) | ||
| 752 | |||
| 753 | (ert-deftest mml-secure-sign-verify-2 () | ||
| 754 | "Sign message without sender; then verify and test for expected result." | ||
| 755 | (skip-unless (test-conf)) | ||
| 756 | (mml-secure-test-key-fixture | ||
| 757 | (lambda () | ||
| 758 | (dolist (method (sign-standards) nil) | ||
| 759 | (let ((mml-secure-openpgp-sign-with-sender nil) | ||
| 760 | (mml-secure-smime-sign-with-sender nil)) | ||
| 761 | ;; A single signing key for sender sub@example.org is customized | ||
| 762 | ;; in the fixture, but not used here. | ||
| 763 | ;; By default, gpg uses the first secret key in the keyring, which | ||
| 764 | ;; is 02372A42CA6D40FB (OpenPGP) or | ||
| 765 | ;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here. | ||
| 766 | (mml-secure-test-en-decrypt | ||
| 767 | method "uid1@example.org" "sub@example.org" 0 nil) | ||
| 768 | |||
| 769 | ;; From sub@example.org, sign with specified key: | ||
| 770 | (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) | ||
| 771 | (mml-secure-smime-signers | ||
| 772 | '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) | ||
| 773 | (mml-secure-test-en-decrypt | ||
| 774 | method "no-exp@example.org" "sub@example.org" 1 nil)) | ||
| 775 | |||
| 776 | ;; From sub@example.org, sign with different specified key: | ||
| 777 | (let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2")) | ||
| 778 | (mml-secure-smime-signers | ||
| 779 | '("0E58229B80EE33959FF718FEEF25402B479DC6E2"))) | ||
| 780 | (mml-secure-test-en-decrypt | ||
| 781 | method "no-exp@example.org" "sub@example.org" 1 nil)) | ||
| 782 | ))))) | ||
| 783 | |||
| 784 | (ert-deftest mml-secure-sign-verify-3 () | ||
| 785 | "Try to sign message with expired OpenPGP subkey, which raises an error. | ||
| 786 | With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." | ||
| 787 | (skip-unless (test-conf)) | ||
| 788 | (should-error | ||
| 789 | (mml-secure-test-key-fixture | ||
| 790 | (lambda () | ||
| 791 | (let ((with-smime nil) | ||
| 792 | (mml-secure-openpgp-sign-with-sender nil) | ||
| 793 | (mml-secure-openpgp-signers '("501FFD98"))) | ||
| 794 | (dolist (method (sign-standards) nil) | ||
| 795 | (mml-secure-test-en-decrypt | ||
| 796 | method "no-exp@example.org" "sign@example.org" 1 nil) | ||
| 797 | )))))) | ||
| 798 | |||
| 799 | ;; TODO Passphrase passing and caching in Emacs does not seem to work | ||
| 800 | ;; with gpgsm at all. | ||
| 801 | ;; Independently of caching settings, a pinentry dialogue is displayed. | ||
| 802 | ;; Thus, the following tests require the user to enter the correct gpgsm | ||
| 803 | ;; passphrases at the correct points in time. (Either empty string or | ||
| 804 | ;; "Passphrase".) | ||
| 805 | (ert-deftest mml-secure-en-decrypt-passphrase-cache () | ||
| 806 | "Encrypt message; then decrypt and test for expected result. | ||
| 807 | In this test, a key is used that requires the passphrase \"Passphrase\". | ||
| 808 | In the first decryption this passphrase is hardcoded, in the second one it | ||
| 809 | is taken from a cache." | ||
| 810 | (skip-unless (test-conf)) | ||
| 811 | (ert-skip "Requires passphrase") | ||
| 812 | (mml-secure-test-key-fixture | ||
| 813 | (lambda () | ||
| 814 | (dolist (method (enc-standards) nil) | ||
| 815 | (mml-secure-test-en-decrypt-with-passphrase | ||
| 816 | method "uid1@example.org" "sub@example.org" nil | ||
| 817 | ;; Beware! For passphrases copy-sequence is necessary, as they may | ||
| 818 | ;; be erased, which actually changes the function's code and causes | ||
| 819 | ;; multiple invokations to fail. I was surprised... | ||
| 820 | (copy-sequence "Passphrase") t) | ||
| 821 | (mml-secure-test-en-decrypt-with-passphrase | ||
| 822 | method "uid1@example.org" "sub@example.org" nil | ||
| 823 | (copy-sequence "Incorrect") t))))) | ||
| 824 | |||
| 825 | (defun mml-secure-en-decrypt-passphrase-no-cache (method) | ||
| 826 | "Encrypt message with METHOD; then decrypt and test for expected result. | ||
| 827 | In this test, a key is used that requires the passphrase \"Passphrase\". | ||
| 828 | In the first decryption this passphrase is hardcoded, but caching disabled. | ||
| 829 | So the second decryption fails." | ||
| 830 | (mml-secure-test-key-fixture | ||
| 831 | (lambda () | ||
| 832 | (mml-secure-test-en-decrypt-with-passphrase | ||
| 833 | method "uid1@example.org" "sub@example.org" nil | ||
| 834 | (copy-sequence "Passphrase") nil) | ||
| 835 | (mml-secure-test-en-decrypt-with-passphrase | ||
| 836 | method "uid1@example.org" "sub@example.org" nil | ||
| 837 | (copy-sequence "Incorrect") nil nil t)))) | ||
| 838 | |||
| 839 | (ert-deftest mml-secure-en-decrypt-passphrase-no-cache-openpgp-todo () | ||
| 840 | "Passphrase caching with OpenPGP only for GnuPG 1.x." | ||
| 841 | (skip-unless (test-conf)) | ||
| 842 | (skip-unless (string< (cdr (assq 'version (epg-configuration))) "2")) | ||
| 843 | (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp) | ||
| 844 | (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp-mime)) | ||
| 845 | |||
| 846 | (ert-deftest mml-secure-en-decrypt-passphrase-no-cache-smime-todo () | ||
| 847 | "Passphrase caching does not work with S/MIME (and gpgsm)." | ||
| 848 | :expected-result :failed | ||
| 849 | (skip-unless (test-conf)) | ||
| 850 | (if with-smime | ||
| 851 | (mml-secure-en-decrypt-passphrase-no-cache 'enc-smime) | ||
| 852 | (should nil))) | ||
| 853 | |||
| 854 | |||
| 855 | ;; Test truncation of question in y-or-n-p. | ||
| 856 | (defun mml-secure-select-preferred-keys-todo () | ||
| 857 | "Manual customization with truncated question." | ||
| 858 | (mml-secure-test-key-fixture | ||
| 859 | (lambda () | ||
| 860 | (mml-secure-test-en-decrypt | ||
| 861 | 'enc-pgp-mime | ||
| 862 | "jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de" | ||
| 863 | "no-exp@example.org" nil t nil nil t)))) | ||
| 864 | |||
| 865 | (defun mml-secure-select-preferred-keys-ok () | ||
| 866 | "Manual customization with entire question." | ||
| 867 | (mml-secure-test-fixture | ||
| 868 | (lambda () | ||
| 869 | (mml-secure-select-preferred-keys | ||
| 870 | (epg-make-context 'OpenPGP) | ||
| 871 | '("jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de") | ||
| 872 | 'encrypt)) | ||
| 873 | t)) | ||
| 874 | |||
| 875 | |||
| 876 | ;; ERT entry points | ||
| 877 | (defun mml-secure-run-tests () | ||
| 878 | "Run all tests with defaults." | ||
| 879 | (ert-run-tests-batch)) | ||
| 880 | |||
| 881 | (defun mml-secure-run-tests-with-gpg2 () | ||
| 882 | "Run all tests with gpg2 instead of gpg." | ||
| 883 | (let* ((epg-gpg-program "gpg2"); ~/local/gnupg-2.1.9/PLAY/inst/bin/gpg2 | ||
| 884 | (gpg-version (cdr (assq 'version (epg-configuration)))) | ||
| 885 | ;; Empty passphrases do not seem to work with gpgsm in 2.1.x: | ||
| 886 | ;; https://lists.gnupg.org/pipermail/gnupg-users/2015-October/054575.html | ||
| 887 | (with-smime (string< gpg-version "2.1"))) | ||
| 888 | (ert-run-tests-batch))) | ||
| 889 | |||
| 890 | (defun mml-secure-run-tests-without-smime () | ||
| 891 | "Skip S/MIME tests (as they require manual passphrase entry)." | ||
| 892 | (let ((with-smime nil)) | ||
| 893 | (ert-run-tests-batch))) | ||
| 894 | |||
| 895 | ;;; gnustest-mml-sec.el ends here | ||
diff --git a/test/lisp/net/browse-url-tests.el b/test/lisp/net/browse-url-tests.el new file mode 100644 index 00000000000..b2b27d2ae7b --- /dev/null +++ b/test/lisp/net/browse-url-tests.el | |||
| @@ -0,0 +1,119 @@ | |||
| 1 | ;;; browse-url-tests.el --- Tests for browse-url.el -*- lexical-binding: t; -*- | ||
| 2 | |||
| 3 | ;; Copyright (C) 2020 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Simen Heggestøyl <simenheg@gmail.com> | ||
| 6 | ;; Keywords: | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | |||
| 25 | ;; | ||
| 26 | |||
| 27 | ;;; Code: | ||
| 28 | |||
| 29 | (require 'browse-url) | ||
| 30 | (require 'ert) | ||
| 31 | |||
| 32 | (ert-deftest browse-url-tests-browser-kind () | ||
| 33 | (should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org") | ||
| 34 | 'internal)) | ||
| 35 | (should | ||
| 36 | (eq (browse-url--browser-kind #'browse-url-firefox "gnu.org") | ||
| 37 | 'external))) | ||
| 38 | |||
| 39 | (ert-deftest browse-url-tests-non-html-file-url-p () | ||
| 40 | (should (browse-url--non-html-file-url-p "file://foo.txt")) | ||
| 41 | (should-not (browse-url--non-html-file-url-p "file://foo.html"))) | ||
| 42 | |||
| 43 | (ert-deftest browse-url-tests-select-handler-mailto () | ||
| 44 | (should (eq (browse-url-select-handler "mailto:foo@bar.org") | ||
| 45 | 'browse-url--mailto)) | ||
| 46 | (should (eq (browse-url-select-handler "mailto:foo@bar.org" | ||
| 47 | 'internal) | ||
| 48 | 'browse-url--mailto)) | ||
| 49 | (should-not (browse-url-select-handler "mailto:foo@bar.org" | ||
| 50 | 'external))) | ||
| 51 | |||
| 52 | (ert-deftest browse-url-tests-select-handler-man () | ||
| 53 | (should (eq (browse-url-select-handler "man:ls") 'browse-url--man)) | ||
| 54 | (should (eq (browse-url-select-handler "man:ls" 'internal) | ||
| 55 | 'browse-url--man)) | ||
| 56 | (should-not (browse-url-select-handler "man:ls" 'external))) | ||
| 57 | |||
| 58 | (ert-deftest browse-url-tests-select-handler-file () | ||
| 59 | (should (eq (browse-url-select-handler "file://foo.txt") | ||
| 60 | 'browse-url-emacs)) | ||
| 61 | (should (eq (browse-url-select-handler "file://foo.txt" 'internal) | ||
| 62 | 'browse-url-emacs)) | ||
| 63 | (should-not (browse-url-select-handler "file://foo.txt" 'external))) | ||
| 64 | |||
| 65 | (ert-deftest browse-url-tests-url-encode-chars () | ||
| 66 | (should (equal (browse-url-url-encode-chars "foobar" "[ob]") | ||
| 67 | "f%6F%6F%62ar"))) | ||
| 68 | |||
| 69 | (ert-deftest browse-url-tests-encode-url () | ||
| 70 | (should (equal (browse-url-encode-url "") "")) | ||
| 71 | (should (equal (browse-url-encode-url "a b c") "a b c")) | ||
| 72 | (should (equal (browse-url-encode-url "\"a\" \"b\"") | ||
| 73 | "\"a%22\"b\"")) | ||
| 74 | (should (equal (browse-url-encode-url "(a) (b)") "(a%29(b)")) | ||
| 75 | (should (equal (browse-url-encode-url "a$ b$") "a%24b$"))) | ||
| 76 | |||
| 77 | (ert-deftest browse-url-tests-url-at-point () | ||
| 78 | (with-temp-buffer | ||
| 79 | (insert "gnu.org") | ||
| 80 | (should (equal (browse-url-url-at-point) "http://gnu.org")))) | ||
| 81 | |||
| 82 | (ert-deftest browse-url-tests-file-url () | ||
| 83 | (should (equal (browse-url-file-url "/foo") "file:///foo")) | ||
| 84 | (should (equal (browse-url-file-url "/foo:") "ftp://foo/")) | ||
| 85 | (should (equal (browse-url-file-url "/ftp@foo:") "ftp://foo/")) | ||
| 86 | (should (equal (browse-url-file-url "/anonymous@foo:") | ||
| 87 | "ftp://foo/"))) | ||
| 88 | |||
| 89 | (ert-deftest browse-url-tests-delete-temp-file () | ||
| 90 | (let ((browse-url-temp-file-name | ||
| 91 | (make-temp-file "browse-url-tests-"))) | ||
| 92 | (browse-url-delete-temp-file) | ||
| 93 | (should-not (file-exists-p browse-url-temp-file-name))) | ||
| 94 | (let ((file (make-temp-file "browse-url-tests-"))) | ||
| 95 | (browse-url-delete-temp-file file) | ||
| 96 | (should-not (file-exists-p file)))) | ||
| 97 | |||
| 98 | (ert-deftest browse-url-tests-add-buttons () | ||
| 99 | (with-temp-buffer | ||
| 100 | (insert "Visit https://gnu.org") | ||
| 101 | (goto-char (point-min)) | ||
| 102 | (browse-url-add-buttons) | ||
| 103 | (goto-char (- (point-max) 1)) | ||
| 104 | (should (eq (get-text-property (point) 'face) | ||
| 105 | 'browse-url-button)) | ||
| 106 | (should (get-text-property (point) 'browse-url-data)))) | ||
| 107 | |||
| 108 | (ert-deftest browse-url-tests-button-copy () | ||
| 109 | (with-temp-buffer | ||
| 110 | (insert "Visit https://gnu.org") | ||
| 111 | (goto-char (point-min)) | ||
| 112 | (browse-url-add-buttons) | ||
| 113 | (should-error (browse-url-button-copy)) | ||
| 114 | (goto-char (- (point-max) 1)) | ||
| 115 | (browse-url-button-copy) | ||
| 116 | (should (equal (car kill-ring) "https://gnu.org")))) | ||
| 117 | |||
| 118 | (provide 'browse-url-tests) | ||
| 119 | ;;; browse-url-tests.el ends here | ||
diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 7a982548ae1..cf416155e50 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el | |||
| @@ -136,7 +136,20 @@ | |||
| 136 | (t | 136 | (t |
| 137 | )))) | 137 | )))) |
| 138 | 138 | ||
| 139 | (defun network-test--resolve-system-name () | ||
| 140 | (cl-loop for address in (network-lookup-address-info (system-name)) | ||
| 141 | when (or (and (= (length address) 5) | ||
| 142 | ;; IPv4 localhost addresses start with 127. | ||
| 143 | (= (elt address 0) 127)) | ||
| 144 | (and (= (length address) 9) | ||
| 145 | ;; IPv6 localhost address. | ||
| 146 | (equal address [0 0 0 0 0 0 0 1 0]))) | ||
| 147 | return t)) | ||
| 148 | |||
| 139 | (ert-deftest echo-server-with-dns () | 149 | (ert-deftest echo-server-with-dns () |
| 150 | (unless (network-test--resolve-system-name) | ||
| 151 | (ert-skip "Can't test resolver for (system-name)")) | ||
| 152 | |||
| 140 | (let* ((server (make-server (system-name))) | 153 | (let* ((server (make-server (system-name))) |
| 141 | (port (aref (process-contact server :local) 4)) | 154 | (port (aref (process-contact server :local) 4)) |
| 142 | (proc (make-network-process :name "foo" | 155 | (proc (make-network-process :name "foo" |
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index ac24fcf280a..05196e7e4a6 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el | |||
| @@ -2001,12 +2001,13 @@ is greater than 10. | |||
| 2001 | (skip-unless (tramp--test-enabled)) | 2001 | (skip-unless (tramp--test-enabled)) |
| 2002 | 2002 | ||
| 2003 | ;; Multi hops are allowed for inline methods only. | 2003 | ;; Multi hops are allowed for inline methods only. |
| 2004 | (should-error | 2004 | (let (non-essential) |
| 2005 | (file-remote-p "/ssh:user1@host1|method:user2@host2:/path/to/file") | 2005 | (should-error |
| 2006 | :type 'user-error) | 2006 | (expand-file-name "/ssh:user1@host1|method:user2@host2:/path/to/file") |
| 2007 | (should-error | 2007 | :type 'user-error) |
| 2008 | (file-remote-p "/method:user1@host1|ssh:user2@host2:/path/to/file") | 2008 | (should-error |
| 2009 | :type 'user-error) | 2009 | (expand-file-name "/method:user1@host1|ssh:user2@host2:/path/to/file") |
| 2010 | :type 'user-error)) | ||
| 2010 | 2011 | ||
| 2011 | ;; Samba does not support file names with periods followed by | 2012 | ;; Samba does not support file names with periods followed by |
| 2012 | ;; spaces, and trailing periods or spaces. | 2013 | ;; spaces, and trailing periods or spaces. |
| @@ -5681,9 +5682,8 @@ This does not support special file names." | |||
| 5681 | 5682 | ||
| 5682 | (defun tramp--test-sh-p () | 5683 | (defun tramp--test-sh-p () |
| 5683 | "Check, whether the remote host runs a based method from tramp-sh.el." | 5684 | "Check, whether the remote host runs a based method from tramp-sh.el." |
| 5684 | (eq | 5685 | (tramp-sh-file-name-handler-p |
| 5685 | (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) | 5686 | (tramp-dissect-file-name tramp-test-temporary-file-directory))) |
| 5686 | 'tramp-sh-file-name-handler)) | ||
| 5687 | 5687 | ||
| 5688 | (defun tramp--test-sudoedit-p () | 5688 | (defun tramp--test-sudoedit-p () |
| 5689 | "Check, whether the sudoedit method is used." | 5689 | "Check, whether the sudoedit method is used." |
diff --git a/test/lisp/saveplace-resources/saveplace b/test/lisp/saveplace-resources/saveplace new file mode 100644 index 00000000000..3f3f6d501d6 --- /dev/null +++ b/test/lisp/saveplace-resources/saveplace | |||
| @@ -0,0 +1,4 @@ | |||
| 1 | ;;; -*- coding: utf-8 -*- | ||
| 2 | (("/home/skangas/.emacs.d/cache/recentf" . 1306) | ||
| 3 | ("/home/skangas/wip/emacs/" | ||
| 4 | (dired-filename . "/home/skangas/wip/emacs/COPYING"))) | ||
diff --git a/test/lisp/saveplace-tests.el b/test/lisp/saveplace-tests.el new file mode 100644 index 00000000000..ae7749fe930 --- /dev/null +++ b/test/lisp/saveplace-tests.el | |||
| @@ -0,0 +1,103 @@ | |||
| 1 | ;;; saveplace-tests.el --- Tests for saveplace.el -*- lexical-binding:t -*- | ||
| 2 | |||
| 3 | ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Stefan Kangas <stefankangas@gmail.com> | ||
| 6 | |||
| 7 | ;; This file is part of GNU Emacs. | ||
| 8 | |||
| 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 10 | ;; it under the terms of the GNU General Public License as published by | ||
| 11 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 12 | ;; (at your option) any later version. | ||
| 13 | |||
| 14 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 17 | ;; GNU General Public License for more details. | ||
| 18 | |||
| 19 | ;; You should have received a copy of the GNU General Public License | ||
| 20 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
| 21 | |||
| 22 | ;;; Commentary: | ||
| 23 | |||
| 24 | (require 'ert) | ||
| 25 | (require 'saveplace) | ||
| 26 | |||
| 27 | (defvar saveplace-tests-dir | ||
| 28 | (file-truename | ||
| 29 | (expand-file-name "saveplace-resources" | ||
| 30 | (file-name-directory (or load-file-name | ||
| 31 | buffer-file-name))))) | ||
| 32 | |||
| 33 | (ert-deftest saveplace-test-save-place-to-alist/dir () | ||
| 34 | (save-place-mode) | ||
| 35 | (let* ((save-place-alist nil) | ||
| 36 | (save-place-loaded t) | ||
| 37 | (loc saveplace-tests-dir)) | ||
| 38 | (save-window-excursion | ||
| 39 | (dired loc) | ||
| 40 | (save-place-to-alist) | ||
| 41 | (should (equal save-place-alist | ||
| 42 | `((,(concat loc "/") | ||
| 43 | (dired-filename . ,(concat loc "/saveplace"))))))))) | ||
| 44 | |||
| 45 | (ert-deftest saveplace-test-save-place-to-alist/file () | ||
| 46 | (save-place-mode) | ||
| 47 | (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) | ||
| 48 | (save-place-alist nil) | ||
| 49 | (save-place-loaded t) | ||
| 50 | (loc tmpfile) | ||
| 51 | (pos 4)) | ||
| 52 | (unwind-protect | ||
| 53 | (save-window-excursion | ||
| 54 | (find-file loc) | ||
| 55 | (insert "abc") ; must insert something | ||
| 56 | (save-place-to-alist) | ||
| 57 | (should (equal save-place-alist (list (cons tmpfile pos))))) | ||
| 58 | (delete-file tmpfile)))) | ||
| 59 | |||
| 60 | (ert-deftest saveplace-test-forget-unreadable-files () | ||
| 61 | (save-place-mode) | ||
| 62 | (let* ((save-place-loaded t) | ||
| 63 | (tmpfile (make-temp-file "emacs-test-saveplace-")) | ||
| 64 | (alist-orig (list (cons "/this/file/does/not/exist" 10) | ||
| 65 | (cons tmpfile 1917))) | ||
| 66 | (save-place-alist alist-orig)) | ||
| 67 | (unwind-protect | ||
| 68 | (progn | ||
| 69 | (save-place-forget-unreadable-files) | ||
| 70 | (should (equal save-place-alist (cdr alist-orig)))) | ||
| 71 | (delete-file tmpfile)))) | ||
| 72 | |||
| 73 | (ert-deftest saveplace-test-place-alist-to-file () | ||
| 74 | (save-place-mode) | ||
| 75 | (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) | ||
| 76 | (tmpfile2 (make-temp-file "emacs-test-saveplace-")) | ||
| 77 | (save-place-file tmpfile) | ||
| 78 | (save-place-alist (list (cons tmpfile2 99)))) | ||
| 79 | (unwind-protect | ||
| 80 | (progn (save-place-alist-to-file) | ||
| 81 | (setq save-place-alist nil) | ||
| 82 | (save-window-excursion | ||
| 83 | (find-file save-place-file) | ||
| 84 | (unwind-protect | ||
| 85 | (should (string-match tmpfile2 (buffer-string))) | ||
| 86 | (kill-buffer)))) | ||
| 87 | (delete-file tmpfile) | ||
| 88 | (delete-file tmpfile2)))) | ||
| 89 | |||
| 90 | (ert-deftest saveplace-test-load-alist-from-file () | ||
| 91 | (save-place-mode) | ||
| 92 | (let ((save-place-loaded nil) | ||
| 93 | (save-place-file | ||
| 94 | (expand-file-name "saveplace" saveplace-tests-dir)) | ||
| 95 | (save-place-alist nil)) | ||
| 96 | (load-save-place-alist-from-file) | ||
| 97 | (should (equal save-place-alist | ||
| 98 | '(("/home/skangas/.emacs.d/cache/recentf" . 1306) | ||
| 99 | ("/home/skangas/wip/emacs/" | ||
| 100 | (dired-filename . "/home/skangas/wip/emacs/COPYING"))))))) | ||
| 101 | |||
| 102 | (provide 'saveplace-tests) | ||
| 103 | ;;; saveplace-tests.el ends here | ||
diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 8e5cc95ec94..01d196565dd 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el | |||
| @@ -554,7 +554,8 @@ This checks also `vc-backend' and `vc-responsible-backend'." | |||
| 554 | 554 | ||
| 555 | (defvar vc-svn-program) | 555 | (defvar vc-svn-program) |
| 556 | (defun vc-test--svn-enabled () | 556 | (defun vc-test--svn-enabled () |
| 557 | (executable-find vc-svn-program)) | 557 | (and (executable-find "svnadmin") |
| 558 | (executable-find vc-svn-program))) | ||
| 558 | 559 | ||
| 559 | (defun vc-test--sccs-enabled () | 560 | (defun vc-test--sccs-enabled () |
| 560 | (executable-find "sccs")) | 561 | (executable-find "sccs")) |
diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index 5b01c54cf24..2cfabd1ee2d 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el | |||
| @@ -143,6 +143,7 @@ wdired-get-filename before and after editing." | |||
| 143 | (let* ((test-dir (make-temp-file "test-dir-" t)) | 143 | (let* ((test-dir (make-temp-file "test-dir-" t)) |
| 144 | (server-socket-dir test-dir) | 144 | (server-socket-dir test-dir) |
| 145 | (dired-listing-switches "-Fl") | 145 | (dired-listing-switches "-Fl") |
| 146 | (dired-ls-F-marks-symlinks (eq system-type 'darwin)) | ||
| 146 | (buf (find-file-noselect test-dir))) | 147 | (buf (find-file-noselect test-dir))) |
| 147 | (unwind-protect | 148 | (unwind-protect |
| 148 | (progn | 149 | (progn |