aboutsummaryrefslogtreecommitdiffstats
path: root/test
diff options
context:
space:
mode:
authorAndrea Corallo2020-08-09 15:03:23 +0200
committerAndrea Corallo2020-08-09 15:03:23 +0200
commit12a982d9789052d8e85efcacb4b311f4876c882a (patch)
treea452a8e888c6ee9c85d6a487359b7a1c0c9fa15b /test
parent80d7f710f2fab902e46aa3fddb8e1c1795420af3 (diff)
parent8e82baf5a730ff542118ddba5b76afdc1db643f6 (diff)
downloademacs-12a982d9789052d8e85efcacb4b311f4876c882a.tar.gz
emacs-12a982d9789052d8e85efcacb4b311f4876c882a.zip
Merge remote-tracking branch 'savannah/master' into HEAD
Diffstat (limited to 'test')
-rw-r--r--test/README5
-rw-r--r--test/data/mml-sec/.gpg-v21-migrated0
-rw-r--r--test/data/mml-sec/gpg-agent.conf5
-rw-r--r--test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.keybin0 -> 797 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.keybin0 -> 526 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.keybin0 -> 841 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.keybin0 -> 797 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.keybin0 -> 526 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.keybin0 -> 797 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.keybin0 -> 797 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.keybin0 -> 798 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.keybin0 -> 798 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.keybin0 -> 526 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.keybin0 -> 710 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.keybin0 -> 798 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.keybin0 -> 527 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.keybin0 -> 798 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.keybin0 -> 526 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.keybin0 -> 709 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.keybin0 -> 797 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.keybin0 -> 710 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.keybin0 -> 841 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.keybin0 -> 841 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.keybin0 -> 527 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.keybin0 -> 710 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.keybin0 -> 797 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.keybin0 -> 710 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.keybin0 -> 797 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.keybin0 -> 797 bytes
-rw-r--r--test/data/mml-sec/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.keybin0 -> 841 bytes
-rw-r--r--test/data/mml-sec/pubring.gpgbin0 -> 13883 bytes
-rw-r--r--test/data/mml-sec/pubring.kbxbin0 -> 3076 bytes
-rw-r--r--test/data/mml-sec/secring.gpgbin0 -> 17362 bytes
-rw-r--r--test/data/mml-sec/trustdb.gpgbin0 -> 1880 bytes
-rw-r--r--test/data/mml-sec/trustlist.txt26
-rw-r--r--test/lisp/calendar/time-date-tests.el14
-rw-r--r--test/lisp/emacs-lisp/bytecomp-tests.el5
-rw-r--r--test/lisp/emacs-lisp/cconv-tests.el160
-rw-r--r--test/lisp/emacs-lisp/cl-generic-tests.el38
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el94
-rw-r--r--test/lisp/emacs-lisp/generator-tests.el4
-rw-r--r--test/lisp/emacs-lisp/hierarchy-tests.el556
-rw-r--r--test/lisp/erc/erc-tests.el47
-rw-r--r--test/lisp/gnus/gnus-util-tests.el76
-rw-r--r--test/lisp/gnus/mml-sec-tests.el895
-rw-r--r--test/lisp/net/browse-url-tests.el119
-rw-r--r--test/lisp/net/network-stream-tests.el13
-rw-r--r--test/lisp/net/tramp-tests.el18
-rw-r--r--test/lisp/saveplace-resources/saveplace4
-rw-r--r--test/lisp/saveplace-tests.el103
-rw-r--r--test/lisp/vc/vc-tests.el3
-rw-r--r--test/lisp/wdired-tests.el1
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
67In case you want to use the symbol name of a test as selector, you can
68use it directly:
69
70 make <filename> SELECTOR='test-foo-remote'
71
67Note that although the test files are always compiled (unless they set 72Note that although the test files are always compiled (unless they set
68no-byte-compile), the source files will be run when expensive or 73no-byte-compile), the source files will be run when expensive or
69unstable tests are involved, to give nicer backtraces. To run the 74unstable 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
13include-default
14
15
16# CN=No Expiry
17D0: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
200E: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
23D4: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
264F: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
255Edebug 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
943primary 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
965clashes (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
1005backtracking (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.
35Mostly, 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.
56If optional INTERACTIVE is non-nil, allow questions to the user in case of
57key problems.
58This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests,
59which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess.
60Actually, I'm not sure why people would want to cache passwords in Emacs
61instead 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.
93Optionally, 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
97From: %s
98Subject: 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.
120Pass 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.
172For 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
178For 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
189In 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.
489If optional CHECKSIG is non-nil, it must be a number, and a signature check is
490performed; the number indicates how many signatures are expected.
491If optional CHECKPLAIN is non-nil, the expected plaintext should be obtained
492via decryption.
493If optional ENC-KEYS is non-nil, it is a list of pairs of encryption keys (for
494OpenPGP and S/SMIME) expected in `epg-debug-buffer'.
495If optional EXPECTFAIL is non-nil, a decryption failure is expected.
496Pass 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.
553Args METHOD, TO, FROM, CHECKSIG are passed to mml-secure-test-en-decrypt.
554JL-PASSPHRASE is fixed as return value for `read-passwd',
555boolean DO-CACHE determines whether to cache the passphrase.
556If optional ENC-KEYS is non-nil, it is a list of encryption keys expected
557in `epg-debug-buffer'.
558If 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.
571In 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.
581In 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.
594In 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.
610In 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.
625In 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.
649In 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.
665In 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.
682In 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.
716Use 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.
786With 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.
807In this test, a key is used that requires the passphrase \"Passphrase\".
808In 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.
827In this test, a key is used that requires the passphrase \"Passphrase\".
828In the first decryption this passphrase is hardcoded, but caching disabled.
829So 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