diff options
author | Stefan Monnier <monnier@iro.umontreal.ca> | 2022-09-25 16:15:16 -0400 |
---|---|---|
committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2022-09-25 16:15:16 -0400 |
commit | 650c20f1ca4e07591a727e1cfcc74b3363d15985 (patch) | |
tree | 85d11f6437cde22f410c25e0e5f71a3131ebd07d /test/lisp/gnus | |
parent | 8869332684c2302b5ba1ead4568bbc7ba1c0183e (diff) | |
parent | 4b85ae6a24380fb67a3315eaec9233f17a872473 (diff) | |
download | emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.tar.gz emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.tar.bz2 emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.zip |
Merge 'master' into noverlay
Diffstat (limited to 'test/lisp/gnus')
46 files changed, 1958 insertions, 13 deletions
diff --git a/test/lisp/gnus/gnus-group-tests.el b/test/lisp/gnus/gnus-group-tests.el new file mode 100644 index 00000000000..4ae5fea3eb7 --- /dev/null +++ b/test/lisp/gnus/gnus-group-tests.el @@ -0,0 +1,52 @@ +;;; gnus-group-tests.el --- Tests for gnus-group.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'gnus-group) +(require 'ert) + +(ert-deftest gnus-short-group-name () + (map-apply + (lambda (input expected) + (should (string-equal (gnus-short-group-name input) expected))) + '(("nnimap+email@example.com:archives/2020/03" . "email@example:a/2/03") + ("nndiary+diary:birthdays" . "diary:birthdays") + ("nnimap+email@example.com:test" . "email@example:test") + ("nnimap+email@example.com:234" . "email@example:234") + + ;; This is a very aggressive shortening of the left hand side. + ("nnimap+email@banana.salesman.example.com:234" . "email@banana:234") + ("nntp+some.where.edu:soc.motss" . "some:s.motss") + ("nntp+news.gmane.org:gmane.emacs.gnus.general" . "news:g.e.g.general") + ("nntp+news.gnus.org:gmane.text.docbook.apps" . "news:g.t.d.apps") + + ;; nnimap groups. + ("nnimap+email@example.com:[Invoices]/Bananas" . "email@example:I/Bananas") + ("nnimap+email@banana.salesman.example.com:[Invoices]/Bananas" + . "email@banana:I/Bananas") + + ;; The "n" from "nnspool" is perhaps not optimal. + ("nnspool+alt.binaries.pictures.furniture" . "n.b.p.furniture")))) + +;;; gnus-group-tests.el ends here diff --git a/test/lisp/gnus/gnus-icalendar-tests.el b/test/lisp/gnus/gnus-icalendar-tests.el new file mode 100644 index 00000000000..348ddf9f056 --- /dev/null +++ b/test/lisp/gnus/gnus-icalendar-tests.el @@ -0,0 +1,259 @@ +;;; gnus-icalendar-tests.el --- tests -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; Author: Jan Tatarik <jan.tatarik@gmail.com> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'gnus-icalendar) + + +(defun gnus-icalendar-tests--get-ical-event (ical-string &optional participant) + "Return gnus-icalendar event for ICAL-STRING." + (let (event) + (with-temp-buffer + (insert ical-string) + (setq event (gnus-icalendar-event-from-buffer (buffer-name) participant))) + event)) + +(ert-deftest gnus-icalendar-parse () + "test" + (let ((tz (getenv "TZ")) + (event (gnus-icalendar-tests--get-ical-event "\ +BEGIN:VCALENDAR +PRODID:-//Google Inc//Google Calendar 70.9054//EN +VERSION:2.0 +CALSCALE:GREGORIAN +METHOD:REQUEST +BEGIN:VTIMEZONE +TZID:America/New_York +X-LIC-LOCATION:America/New_York +BEGIN:DAYLIGHT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +DTSTART:19700308T020000 +RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=2SU +END:DAYLIGHT +BEGIN:STANDARD +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +DTSTART:19701101T020000 +RRULE:FREQ=YEARLY;BYMONTH=11;BYDAY=1SU +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTART;TZID=America/New_York:20201208T090000 +DTEND;TZID=America/New_York:20201208T100000 +DTSTAMP:20200728T182853Z +ORGANIZER;CN=Company Events:mailto:anoncompany.com_3bm6fh805bme9uoeliqcle1sa + g@group.calendar.google.com +UID:iipdt88slddpeu7hheuu09sfmd@google.com +X-MICROSOFT-CDO-OWNERAPPTID:-362490173 +RECURRENCE-ID;TZID=America/New_York:20201208T091500 +CREATED:20200309T134939Z +DESCRIPTION:In this meeting\\, we will cover topics from product and enginee + ring presentations and demos to new hire announcements to watching the late +LAST-MODIFIED:20200728T182852Z +LOCATION:New York-22-Town Hall Space (250) [Chrome Box] +SEQUENCE:4 +STATUS:CONFIRMED +SUMMARY:Townhall | All Company Meeting +TRANSP:OPAQUE +END:VEVENT +END:VCALENDAR +"))) + + (unwind-protect + (progn + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") + (should (eq (eieio-object-class event) 'gnus-icalendar-event-request)) + (should (not (gnus-icalendar-event:recurring-p event))) + (should (string= (gnus-icalendar-event:start event) "2020-12-08 15:00")) + (with-slots (organizer summary description location end-time uid rsvp participation-type) event + (should (string= organizer "anoncompany.com_3bm6fh805bme9uoeliqcle1sag@group.calendar.google.com")) + (should (string= summary "Townhall | All Company Meeting")) + (should (string= description "In this meeting, we will cover topics from product and engineering presentations and demos to new hire announcements to watching the late")) + (should (string= location "New York-22-Town Hall Space (250) [Chrome Box]")) + (should (string= (format-time-string "%Y-%m-%d %H:%M" end-time) "2020-12-08 16:00")) + (should (string= uid "iipdt88slddpeu7hheuu09sfmd@google.com")) + (should (not rsvp)) + (should (eq participation-type 'non-participant)))) + (setenv "TZ" tz)))) + +(ert-deftest gnus-icalendary-byday () + "" + (let ((tz (getenv "TZ")) + (event (gnus-icalendar-tests--get-ical-event "\ +BEGIN:VCALENDAR +PRODID:Zimbra-Calendar-Provider +VERSION:2.0 +METHOD:REQUEST +BEGIN:VTIMEZONE +TZID:America/New_York +BEGIN:STANDARD +DTSTART:16010101T020000 +TZOFFSETTO:-0500 +TZOFFSETFROM:-0400 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=11;BYDAY=1SU +TZNAME:EST +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETTO:-0400 +TZOFFSETFROM:-0500 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=3;BYDAY=2SU +TZNAME:EDT +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +UID:903a5415-9067-4f63-b499-1b6205f49c88 +RRULE:FREQ=DAILY;UNTIL=20200825T035959Z;INTERVAL=1;BYDAY=MO,TU,WE,TH,FR +SUMMARY:appointment every weekday\\, start jul 24\\, 2020\\, end aug 24\\, 2020 +ATTENDEE;CN=Mark Hershberger;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP + =TRUE:mailto:hexmode <at> gmail.com +ORGANIZER;CN=Mark A. Hershberger:mailto:mah <at> nichework.com +DTSTART;TZID=\"America/New_York\":20200724T090000 +DTEND;TZID=\"America/New_York\":20200724T093000 +STATUS:CONFIRMED +CLASS:PUBLIC +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +TRANSP:OPAQUE +LAST-MODIFIED:20200719T150815Z +DTSTAMP:20200719T150815Z +SEQUENCE:0 +DESCRIPTION:The following is a new meeting request: +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER;RELATED=START:-PT5M +DESCRIPTION:Reminder +END:VALARM +END:VEVENT +END:VCALENDAR" (list "Mark Hershberger")))) + + (unwind-protect + (progn + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") + (should (eq (eieio-object-class event) 'gnus-icalendar-event-request)) + (should (gnus-icalendar-event:recurring-p event)) + (should (string= (gnus-icalendar-event:recurring-interval event) "1")) + (should (string= (gnus-icalendar-event:start event) "2020-07-24 15:00")) + (with-slots (organizer summary description location end-time uid rsvp participation-type) event + (should (string= organizer "mah <at> nichework.com")) + (should (string= summary "appointment every weekday, start jul 24, 2020, end aug 24, 2020")) + (should (string= description "The following is a new meeting request:")) + (should (null location)) + (should (string= (format-time-string "%Y-%m-%d %H:%M" end-time) "2020-07-24 15:30")) + (should (string= uid "903a5415-9067-4f63-b499-1b6205f49c88")) + (should rsvp) + (should (eq participation-type 'required))) + (should (equal (gnus-icalendar-event:recurring-days event) '(1 2 3 4 5))) + (should (string= (gnus-icalendar-event:org-timestamp event) "<2020-07-24 15:00-15:30 +1w> +<2020-07-27 15:00-15:30 +1w> +<2020-07-28 15:00-15:30 +1w> +<2020-07-29 15:00-15:30 +1w> +<2020-07-30 15:00-15:30 +1w>"))) + (setenv "TZ" tz)))) + +(ert-deftest gnus-icalendary-weekly-byday () + "" + (let ((tz (getenv "TZ")) + (event (gnus-icalendar-tests--get-ical-event "\ +BEGIN:VCALENDAR +PRODID:-//Google Inc//Google Calendar 70.9054//EN +VERSION:2.0 +CALSCALE:GREGORIAN +METHOD:REQUEST +BEGIN:VTIMEZONE +TZID:Europe/Berlin +X-LIC-LOCATION:Europe/Berlin +BEGIN:DAYLIGHT +TZOFFSETFROM:+0100 +TZOFFSETTO:+0200 +TZNAME:CEST +DTSTART:19700329T020000 +RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=-1SU +END:DAYLIGHT +BEGIN:STANDARD +TZOFFSETFROM:+0200 +TZOFFSETTO:+0100 +TZNAME:CET +DTSTART:19701025T030000 +RRULE:FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTART;TZID=Europe/Berlin:20200915T140000 +DTEND;TZID=Europe/Berlin:20200915T143000 +RRULE:FREQ=WEEKLY;BYDAY=FR,MO,TH,TU,WE +DTSTAMP:20200915T120627Z +ORGANIZER;CN=anon@anoncompany.com:mailto:anon@anoncompany.com +UID:7b6g3m7iftuo90ei4ul00feqn_R20200915T120000@google.com +ATTENDEE;CUTYPE=INDIVIDUAL;PARTSTAT=ACCEPTED;RSVP=TRUE + ;CN=participant@anoncompany.com;X-NUM-GUESTS=0:mailto:participant@anoncompany.com +CREATED:20200325T095723Z +DESCRIPTION:Coffee talk +LAST-MODIFIED:20200915T120623Z +LOCATION: +SEQUENCE:0 +STATUS:CONFIRMED +SUMMARY:Casual coffee talk +TRANSP:OPAQUE +END:VEVENT +END:VCALENDAR" (list "participant@anoncompany.com")))) + + (unwind-protect + (progn + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") + (should (eq (eieio-object-class event) 'gnus-icalendar-event-request)) + (should (gnus-icalendar-event:recurring-p event)) + (should (string= (gnus-icalendar-event:recurring-interval event) "1")) + (should (string= (gnus-icalendar-event:start event) "2020-09-15 14:00")) + (with-slots (organizer summary description location end-time uid rsvp participation-type) event + (should (string= organizer "anon@anoncompany.com")) + (should (string= summary "Casual coffee talk")) + (should (string= description "Coffee talk")) + (should (string= location "")) + (should (string= (format-time-string "%Y-%m-%d %H:%M" end-time) "2020-09-15 14:30")) + (should (string= uid "7b6g3m7iftuo90ei4ul00feqn_R20200915T120000@google.com")) + (should rsvp) + (should (eq participation-type 'required))) + (should (equal (sort (gnus-icalendar-event:recurring-days event) #'<) '(1 2 3 4 5))) + (should (string= (gnus-icalendar-event:org-timestamp event) "<2020-09-15 14:00-14:30 +1w> +<2020-09-16 14:00-14:30 +1w> +<2020-09-17 14:00-14:30 +1w> +<2020-09-18 14:00-14:30 +1w> +<2020-09-21 14:00-14:30 +1w>"))) + (setenv "TZ" tz)))) + +(provide 'gnus-icalendar-tests) +;;; gnus-icalendar-tests.el ends here diff --git a/test/lisp/gnus/gnus-search-tests.el b/test/lisp/gnus/gnus-search-tests.el new file mode 100644 index 00000000000..4a5def97d3c --- /dev/null +++ b/test/lisp/gnus/gnus-search-tests.el @@ -0,0 +1,100 @@ +;;; gnus-search-tests.el --- Tests for Gnus' search routines -*- lexical-binding: t; -*- + +;; Copyright (C) 2017, 2021-2022 Free Software Foundation, Inc. + +;; Author: Eric Abrahamsen <eric@ericabrahamsen.net> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the search parsing, search engines, and their +;; transformations. + +;;; Code: + +(require 'ert) +(require 'gnus-search) + +(ert-deftest gnus-s-parse () + "Test basic structural parsing." + (let ((pairs + '(("string" . ("string")) + ("from:john" . ((from . "john"))) + ("here and there" . ("here" and "there")) + ("here or there" . ((or "here" "there"))) + ("here (there or elsewhere)" . ("here" ((or "there" "elsewhere")))) + ("here not there" . ("here" (not "there"))) + ("from:boss or not vacation" . ((or (from . "boss") (not "vacation"))))))) + (dolist (p pairs) + (should (equal (gnus-search-parse-query (car p)) (cdr p)))))) + +(ert-deftest gnus-s-expand-keyword () + "Test expansion of keywords" + (let ((gnus-search-expandable-keys + (default-value 'gnus-search-expandable-keys)) + (pairs + '(("su" . "subject") + ("sin" . "since") + ("body" . "body") + ("list-id" . "list-id")))) + (dolist (p pairs) + (should (equal (gnus-search-query-expand-key (car p)) + (cdr p)))) + (should-error (gnus-search-query-expand-key "s") + :type 'gnus-search-parse-error))) + +(ert-deftest gnus-s-parse-date () + "Test parsing of date expressions." + (let ((rel-date (encode-time 0 0 0 15 4 2017)) + (pairs + '(("January" . (nil 1 nil)) + ("2017" . (nil nil 2017)) + ("15" . (15 nil nil)) + ("January 15" . (15 1 nil)) + ("tuesday" . (11 4 2017)) + ("1d" . (14 4 2017)) + ("1w" . (8 4 2017))))) + (dolist (p pairs) + (should (equal (gnus-search-query-parse-date (car p) rel-date) + (cdr p)))))) + +(ert-deftest gnus-s-delimited-string () + "Test proper functioning of `gnus-search-query-return-string'." + (with-temp-buffer + (insert "one\ntwo words\nthree \"words with quotes\"\n\"quotes at start\"\n/alternate \"quotes\"/\n(more bits)") + (goto-char (point-min)) + (should (string= (gnus-search-query-return-string) + "one")) + (forward-line) + (should (string= (gnus-search-query-return-string) + "two")) + (forward-line) + (should (string= (gnus-search-query-return-string) + "three")) + (forward-line) + (should (string= (gnus-search-query-return-string "\"") + "\"quotes at start\"")) + (forward-line) + (should (string= (gnus-search-query-return-string "/") + "/alternate \"quotes\"/")) + (forward-line) + (should (string= (gnus-search-query-return-string ")" t) + "more bits")))) + +(provide 'gnus-search-tests) +;;; gnus-search-tests.el ends here diff --git a/test/lisp/gnus/gnus-test-headers.el b/test/lisp/gnus/gnus-test-headers.el new file mode 100644 index 00000000000..730c10f9818 --- /dev/null +++ b/test/lisp/gnus/gnus-test-headers.el @@ -0,0 +1,178 @@ +;;; gnus-test-headers.el --- Tests for Gnus header-related functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2022 Free Software Foundation, Inc. + +;; Author: Eric Abrahamsen <eric@ericabrahamsen.net> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; The tests her are for + +;;; Code: + +(require 'ert) +(require 'gnus-sum) + +(defconst gnus-headers-test-data + '([2 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>" + "Thu, 14 Sep 2000 11:10:46 +0100" + "<200009141010.LAA26351@djlvig.dl.ac.uk>" + "<20000913175943.A26093@sparky.nisa.net>" + 1882 16 "nnmaildir mails:2" + ((To . "Jeff Bailey <jbailey@nisa.net>") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [3 "Re: [Emacs-devel] Emacs move" "Sam Steingold <sds@gnu.org>" + "14 Sep 2000 10:21:56 -0400" "<upum7xddn.fsf@xchange.com>" + "<20000913175943.A26093@sparky.nisa.net>" + 2991 50 "nnmaildir mails:3" + ((To . "Jeff Bailey <jbailey@nisa.net>") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [4 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>" + "Thu, 14 Sep 2000 09:14:47 -0700" + "<20000914091447.G4827@sparky.nisa.net>" + "<20000913175943.A26093@sparky.nisa.net> <upum7xddn.fsf@xchange.com>" + 1780 15 "nnmaildir mails:4" + ((To . "sds@gnu.org, Jeff Bailey <jbailey@nisa.net>") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [5 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>" + "Thu, 14 Sep 2000 18:24:36 +0100" + "<200009141724.SAA26807@djlvig.dl.ac.uk>" + "<20000913175943.A26093@sparky.nisa.net>" + 1343 9 "nnmaildir mails:5" + ((To . "Jeff Bailey <jbailey@nisa.net>") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [6 "Re: [Emacs-devel] Emacs move" "Karl Fogel <kfogel@galois.collab.net>" + "14 Sep 2000 10:37:35 -0500" "<87em2nyog0.fsf@galois.collab.net>" + "<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk>" + 3740 124 "nnmaildir mails:6" + ((To . "Dave Love <d.love@dl.ac.uk>") + (Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [7 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>" + "Thu, 14 Sep 2000 10:55:12 -0700" + "<20000914105512.A29291@sparky.nisa.net>" + "<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk> <87em2nyog0.fsf@galois.collab.net>" + 1687 16 "nnmaildir mails:7" + ((To . "kfogel@red-bean.com, Dave Love <d.love@dl.ac.uk>") + (Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [8 "Re: [Emacs-devel] Emacs move" "John Wiegley <johnw@gnu.org>" + "Thu, 14 Sep 2000 12:19:01 -0700" + "<200009141919.MAA05085@localhost.localdomain>" + "<20000913175943.A26093@sparky.nisa.net>" + 1978 27 "nnmaildir mails:8" + ((To . "emacs-devel@gnu.org"))] + [9 "Re: [Emacs-devel] Emacs move" + "\"Robert J. Chassell\" <bob@rattlesnake.com>" + "Thu, 14 Sep 2000 07:33:15 -0400 (EDT)" + "<m13ZXGV-000BCgC@megalith.rattlesnake.com>" + "<20000913175943.A26093@sparky.nisa.net>" + 3046 72 "nnmaildir mails:9" + ((To . "jbailey@nisa.net") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [10 "Re: [Emacs-devel] Emacs move" + "wmperry@aventail.com (William M. Perry)" + "14 Sep 2000 09:10:25 -0500" + "<86g0n3f4j2.fsf@megalith.bp.aventail.com>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>" + 3104 44 "nnmaildir mails:10" + ((To . "bob@rattlesnake.com") + (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [11 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>" + "Thu, 14 Sep 2000 21:51:05 +0200 (CEST)" + "<200009141951.VAA06005@gerd.segv.de>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <86g0n3f4j2.fsf@megalith.bp.aventail.com>" + 1884 6 "nnmaildir mails:11" + ((To . "wmvperry@aventail.com") + (Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [12 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>" + "Thu, 14 Sep 2000 21:49:03 +0200 (CEST)" + "<200009141949.VAA05998@gerd.segv.de>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>" + 2408 24 "nnmaildir mails:12" + ((To . "bob@rattlesnake.com") + (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [13 "Re: [Emacs-devel] Emacs move" + "\"Robert J. Chassell\" <bob@rattlesnake.com>" + "Thu, 14 Sep 2000 17:50:01 -0400 (EDT)" + "<m13ZgtN-000BD3C@megalith.rattlesnake.com>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de>" + 1968 23 "nnmaildir mails:13" + ((To . "gerd@gnu.org") + (Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [14 "Re: [Emacs-devel] Emacs move" "Richard Stallman <rms@gnu.org>" + "Fri, 15 Sep 2000 16:28:12 -0600 (MDT)" + "<200009152228.QAA20526@wijiji.santafe.edu>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>" + 1288 2 "nnmaildir mails:14" + ((To . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [15 "[Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>" + "Wed, 13 Sep 2000 17:59:43 -0700" + "<20000913175943.A26093@sparky.nisa.net>" "" + 1661 26 "nnmaildir mails:15" + ((To . "emacs-devel@gnu.org") + (Cc . "cvs-hackers@gnu.org"))] + [16 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>" + "Fri, 15 Sep 2000 22:00:12 -0700" + "<20000915220012.A3923@sparky.nisa.net>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de> <m13ZgtN-000BD3C@megalith.rattlesnake.com>" + 2857 51 "nnmaildir mails:16" + ((To . "bob@rattlesnake.com, gerd@gnu.org") + (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]) + "A pile of headers with potential interdependencies.") + +(ert-deftest gnus-headers-make-dependency-table () + (let ((table (gnus-make-hashtable 20)) + (data (copy-sequence gnus-headers-test-data)) + ret) + (dolist (h data) + ;; `gnus-dependencies-add-header' returns nil if it fails to add + ;; the header. + (should (gnus-dependencies-add-header h table nil))) + ;; Pick a value to test. + (setq ret (gethash "<m13ZXGV-000BCgC@megalith.rattlesnake.com>" + table)) + ;; The message has three children. + (should (= 3 (length (cdr ret)))) + ;; The first of those children has one child. + (should (= 1 (length (cdr (nth 1 ret))))))) + +(ert-deftest gnus-headers-loop-dependencies () + "Intentionally create a reference loop." + (let ((table (gnus-make-hashtable 20)) + (data (copy-sequence gnus-headers-test-data)) + (parent-id "<200009141724.SAA26807@djlvig.dl.ac.uk>") + (child-id "<87em2nyog0.fsf@galois.collab.net>") + parent) + (dolist (h data) + (gnus-dependencies-add-header h table nil)) + + (setq parent (gethash parent-id table)) + + ;; Put the parent header in the child references of one of its own + ;; children. `gnus-thread-loop-p' only checks if there's a loop + ;; between parent and immediate child, not parent and random + ;; descendant. At least, near as I can tell that's the case. + + (push (list (car parent)) (cdr (gethash child-id table))) + + (let ((gnus-newsgroup-dependencies table)) + (should + (= 1 ; 1 indicates an infloop. + (gnus-thread-loop-p (car parent) (cadr parent))))))) + +(provide 'gnus-test-headers) +;;; gnus-test-headers.el ends here diff --git a/test/lisp/gnus/gnus-tests.el b/test/lisp/gnus/gnus-tests.el index c2a41d717cf..4c5a6a8191c 100644 --- a/test/lisp/gnus/gnus-tests.el +++ b/test/lisp/gnus/gnus-tests.el @@ -1,6 +1,6 @@ -;;; gnus-tests.el --- Wrapper for the Gnus tests +;;; gnus-tests.el --- Wrapper for the Gnus tests -*- lexical-binding:t -*- -;; Copyright (C) 2011-2017 Free Software Foundation, Inc. +;; Copyright (C) 2011-2022 Free Software Foundation, Inc. ;; Author: Teodor Zlatanov <tzz@lifelogs.com> @@ -26,8 +26,6 @@ ;;; Code: ;; registry.el is required by gnus-registry.el but this way we're explicit. -(eval-when-compile (require 'cl)) - (require 'registry) (require 'gnus-registry) diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el new file mode 100644 index 00000000000..464567061f6 --- /dev/null +++ b/test/lisp/gnus/gnus-util-tests.el @@ -0,0 +1,135 @@ +;;; gnus-util-tests.el --- Selectived tests only. -*- lexical-binding:t -*- +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. + +;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'gnus-util) + +(ert-deftest gnus-string> () + ;; Failure paths + (should-error (gnus-string> "" 1) + :type 'wrong-type-argument) + (should-error (gnus-string> "") + :type 'wrong-number-of-arguments) + + ;; String tests + (should (gnus-string> "def" "abc")) + (should (gnus-string> 'def 'abc)) + (should (gnus-string> "abc" "DEF")) + (should (gnus-string> "abc" 'DEF)) + (should (gnus-string> "αβγ" "abc")) + (should (gnus-string> "×בג" "αβγ")) + (should (gnus-string> nil "")) + (should (gnus-string> "abc" "")) + (should (gnus-string> "abc" "ab")) + (should-not (gnus-string> "abc" "abc")) + (should-not (gnus-string> "abc" "def")) + (should-not (gnus-string> "DEF" "abc")) + (should-not (gnus-string> 'DEF "abc")) + (should-not (gnus-string> "123" "abc")) + (should-not (gnus-string> "" ""))) + +(ert-deftest gnus-string< () + ;; Failure paths + (should-error (gnus-string< "" 1) + :type 'wrong-type-argument) + (should-error (gnus-string< "") + :type 'wrong-number-of-arguments) + + ;; String tests + (setq case-fold-search nil) + (should (gnus-string< "abc" "def")) + (should (gnus-string< 'abc 'def)) + (should (gnus-string< "DEF" "abc")) + (should (gnus-string< "DEF" 'abc)) + (should (gnus-string< "abc" "αβγ")) + (should (gnus-string< "αβγ" "×בג")) + (should (gnus-string< "" nil)) + (should (gnus-string< "" "abc")) + (should (gnus-string< "ab" "abc")) + (should-not (gnus-string< "abc" "abc")) + (should-not (gnus-string< "def" "abc")) + (should-not (gnus-string< "abc" "DEF")) + (should-not (gnus-string< "abc" 'DEF)) + (should-not (gnus-string< "abc" "123")) + (should-not (gnus-string< "" "")) + + ;; gnus-string< checks case-fold-search + (setq case-fold-search t) + (should (gnus-string< "abc" "DEF")) + (should (gnus-string< "abc" 'GHI)) + (should (gnus-string< 'abc "DEF")) + (should (gnus-string< 'GHI 'JKL)) + (should (gnus-string< "abc" "ΑΒΓ")) + (should-not (gnus-string< "ABC" "abc")) + (should-not (gnus-string< "def" "ABC"))) + +(ert-deftest gnus-subsetp () + ;; False for non-lists. + (should-not (gnus-subsetp "1" "1")) + (should-not (gnus-subsetp "1" '("1"))) + (should-not (gnus-subsetp '("1") "1")) + + ;; Real tests. + (should (gnus-subsetp '() '())) + (should (gnus-subsetp '() '("1"))) + (should (gnus-subsetp '("1") '("1"))) + (should (gnus-subsetp '(42) '("1" 42))) + (should (gnus-subsetp '(42) '(42 "1"))) + (should (gnus-subsetp '(42) '("1" 42 2))) + (should-not (gnus-subsetp '("1") '())) + (should-not (gnus-subsetp '("1") '(2))) + (should-not (gnus-subsetp '("1" 2) '(2))) + (should-not (gnus-subsetp '(2 "1") '(2))) + (should-not (gnus-subsetp '("1" 2) '(2 3))) + + ;; Duplicates don't matter for sets. + (should (gnus-subsetp '("1" "1") '("1"))) + (should (gnus-subsetp '("1" 2 "1") '(2 "1"))) + (should (gnus-subsetp '("1" 2 "1") '(2 "1" "1" 2))) + (should-not (gnus-subsetp '("1" 2 "1" 3) '(2 "1" "1" 2)))) + +(ert-deftest gnus-setdiff () + ;; False for non-lists. + (should-not (gnus-setdiff "1" "1")) + (should-not (gnus-setdiff "1" '())) + (should-not (gnus-setdiff '() "1")) + + ;; Real tests. + (should-not (gnus-setdiff '() '())) + (should-not (gnus-setdiff '() '("1"))) + (should-not (gnus-setdiff '("1") '("1"))) + (should (equal '("1") (gnus-setdiff '("1") '()))) + (should (equal '("1") (gnus-setdiff '("1") '(2)))) + (should (equal '("1") (gnus-setdiff '("1" 2) '(2)))) + (should (equal '("1") (gnus-setdiff '("1" 2 3) '(3 2)))) + (should (equal '("1") (gnus-setdiff '(2 "1" 3) '(3 2)))) + (should (equal '("1") (gnus-setdiff '(2 3 "1") '(3 2)))) + (should (equal '(2 "1") (gnus-setdiff '(2 3 "1") '(3)))) + + ;; Duplicates aren't touched for sets if they are not removed. + (should-not (gnus-setdiff '("1" "1") '("1"))) + (should (equal '("1") (gnus-setdiff '(2 "1" 2) '(2)))) + (should (equal '("1" "1") (gnus-setdiff '(2 "1" 2 "1") '(2))))) + +;;; gnus-util-tests.el ends here diff --git a/test/lisp/gnus/message-tests.el b/test/lisp/gnus/message-tests.el index f905ba3e263..a724428ecb4 100644 --- a/test/lisp/gnus/message-tests.el +++ b/test/lisp/gnus/message-tests.el @@ -1,6 +1,6 @@ -;;; message-mode-tests.el --- Tests for message-mode -*- lexical-binding: t; -*- +;;; message-tests.el --- Tests for message-mode -*- lexical-binding: t; -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Author: JoĂŁo Távora <joaotavora@gmail.com> @@ -29,6 +29,8 @@ (require 'ert) (require 'ert-x) +(require 'cl-lib) + (ert-deftest message-mode-propertize () (with-temp-buffer (unwind-protect @@ -45,14 +47,10 @@ (setq-local parse-sexp-lookup-properties t) (backward-sexp) (should (string= "here's an opener " - (buffer-substring-no-properties - (line-beginning-position) - (point)))) + (buffer-substring-no-properties (pos-bol) (point)))) (forward-sexp) (should (string= "and here's a closer )" - (buffer-substring-no-properties - (line-beginning-position) - (point))))) + (buffer-substring-no-properties (pos-bol) (point))))) (set-buffer-modified-p nil)))) @@ -97,7 +95,90 @@ (should (string= stripped-was (message-strip-subject-trailing-was with-was))))))) +(ert-deftest message-all-recipients () + (ert-with-test-buffer (:name "message") + (insert "To: Person 1 <p1@p1.org>, Person 2 <p2@p2.org>\n") + (insert "Cc: Person 3 <p3@p3.org>, Person 4 <p4@p4.org>\n") + (insert "Bcc: Person 5 <p5@p5.org>, Person 6 <p6@p6.org>\n") + (should (equal (message-all-recipients) + '(("Person 1" "p1@p1.org") + ("Person 2" "p2@p2.org") + ("Person 3" "p3@p3.org") + ("Person 4" "p4@p4.org") + ("Person 5" "p5@p5.org") + ("Person 6" "p6@p6.org")))))) + +(ert-deftest message-all-epg-keys-available-p () + (skip-unless (epg-check-configuration (epg-find-configuration 'OpenPGP))) + (let ((person1 '("Person 1" "p1@p1.org")) + (person2 '("Person 2" "p2@p2.org")) + (person3 '("Person 3" "p3@p3.org")) + (recipients nil) + (keyring '("p1@p1.org" "p2@p2.org"))) + (cl-letf (((symbol-function 'epg-list-keys) + (lambda (_ email) (cl-find email keyring :test #'string=))) + ((symbol-function 'message-all-recipients) + (lambda () recipients))) + + (setq recipients (list)) + (should (message-all-epg-keys-available-p)) + + (setq recipients (list person1)) + (should (message-all-epg-keys-available-p)) + + (setq recipients (list person1 person2)) + (should (message-all-epg-keys-available-p)) + + (setq recipients (list person3)) + (should-not (message-all-epg-keys-available-p)) + + (setq recipients (list person1 person3)) + (should-not (message-all-epg-keys-available-p)) + + (setq recipients (list person3 person1)) + (should-not (message-all-epg-keys-available-p)) + + (setq recipients (list person1 person2 person3)) + (should-not (message-all-epg-keys-available-p))))) + +(ert-deftest message-alter-repeat-address () + (should (equal (message--alter-repeat-address + "Lars Ingebrigtsen <larsi@gnus.org>") + "Lars Ingebrigtsen <larsi@gnus.org>")) + + (should (equal (message--alter-repeat-address + "\"larsi@gnus.org\" <larsi@gnus.org>") + "larsi@gnus.org"))) + +(ert-deftest message-replace-header () + (with-temp-buffer + (save-excursion + (insert "From: dang@gnus.org +To: user1, + user2 +Cc: user3, + user4 +--text follows this line-- +Hello. +")) + (save-excursion + (message-replace-header "From" "ding@gnus.org") + (should (cl-search "ding" (message-field-value "From")))) + (save-excursion + (message-replace-header "From" "dong@gnus.org" "To") + (should (cl-search "dong" (message-field-value "From"))) + (should (re-search-forward "From:")) + (should-error (re-search-forward "To:")) + (should (re-search-forward "Cc:"))) + (save-excursion + (message-replace-header "From" "dang@gnus.org" (split-string "To Cc")) + (should (cl-search "dang" (message-field-value "From"))) + (should (re-search-forward "From:")) + (should-error (re-search-forward "To:")) + ;; That this isn't so is probably a bug from 1997. + ;; (should-error (re-search-forward "Cc:")) + ))) (provide 'message-mode-tests) -;;; message-mode-tests.el ends here +;;; message-tests.el ends here diff --git a/test/lisp/gnus/mm-decode-resources/8bit-multipart.bin b/test/lisp/gnus/mm-decode-resources/8bit-multipart.bin new file mode 100644 index 00000000000..0b193a27234 --- /dev/null +++ b/test/lisp/gnus/mm-decode-resources/8bit-multipart.bin @@ -0,0 +1,20 @@ +From: example <example@example.org>
+To: example <example@example.org>
+Content-Type: multipart/alternative; boundary="===============2877195075946974246=="
+Date: Thu, 29 Oct 2020 14:47:55 +0100
+MIME-Version: 1.0
+Subject: test
+
+--===============2877195075946974246==
+Content-Type: text/plain; charset="utf-8"
+Content-Transfer-Encoding: 8bit
+
+ääää
+
+--===============2877195075946974246==
+Content-Type: text/html; charset="utf-8"
+Content-Transfer-Encoding: 8bit
+
+<!doctype html><html><head><meta http-equiv="content-type" content="text/html; charset=UTF-8"></head><body>ääää</body></html>
+
+--===============2877195075946974246==--
diff --git a/test/lisp/gnus/mm-decode-resources/win1252-multipart.bin b/test/lisp/gnus/mm-decode-resources/win1252-multipart.bin new file mode 100644 index 00000000000..d3c5026dcce --- /dev/null +++ b/test/lisp/gnus/mm-decode-resources/win1252-multipart.bin @@ -0,0 +1,44 @@ +To: example <example@example.org> +From: example <example@example.org> +Date: Tue, 5 Jan 2021 10:30:34 +0100 +MIME-Version: 1.0 +Content-Type: multipart/mixed; boundary="------------FB569A4368539497CC91D1DC" +Content-Language: fr +Subject: test + +--------------FB569A4368539497CC91D1DC +Content-Type: multipart/alternative; + boundary="------------61C81A7DC7592E4C6F856A85" + + +--------------61C81A7DC7592E4C6F856A85 +Content-Type: text/plain; charset=windows-1252; format=flowed +Content-Transfer-Encoding: 8bit + +déjŕ raté + +--------------61C81A7DC7592E4C6F856A85 +Content-Type: text/html; charset=windows-1252 +Content-Transfer-Encoding: 8bit + +<html> + <head> + <meta http-equiv="content-type" content="text/html; charset=windows-1252"> + </head> + <body> + déjŕ raté + </body> +</html> + +--------------61C81A7DC7592E4C6F856A85-- + +--------------FB569A4368539497CC91D1DC +Content-Type: text/plain; charset="us-ascii" +MIME-Version: 1.0 +Content-Transfer-Encoding: 7bit +Content-Disposition: inline + +mailing list signature + +--------------FB569A4368539497CC91D1DC-- + diff --git a/test/lisp/gnus/mm-decode-tests.el b/test/lisp/gnus/mm-decode-tests.el new file mode 100644 index 00000000000..5f39a32b0de --- /dev/null +++ b/test/lisp/gnus/mm-decode-tests.el @@ -0,0 +1,102 @@ +;;; mm-decode-tests.el --- -*- lexical-binding:t -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'mm-decode) + +(ert-deftest test-mm-dissect-buffer () + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally (ert-resource-file "8bit-multipart.bin")) + (while (search-forward "\r\n" nil t) + (replace-match "\n")) + (let ((handle (mm-dissect-buffer))) + (should (equal (mm-handle-media-type handle) "multipart/alternative")) + ;; Skip multipart type. + (pop handle) + (let ((part (pop handle))) + (should (equal (mm-handle-media-type part) "text/plain")) + (should (eq (mm-handle-encoding part) '8bit)) + (with-current-buffer (mm-handle-buffer part) + (should (equal (decode-coding-string + (buffer-string) + (intern (mail-content-type-get (mm-handle-type part) + 'charset))) + "ääää\n")))) + (let ((part (pop handle))) + (should (equal (mm-handle-media-type part) "text/html")) + (should (eq (mm-handle-encoding part) '8bit)) + (with-current-buffer (mm-handle-buffer part) + (should (equal (decode-coding-string + (buffer-string) + (intern (mail-content-type-get (mm-handle-type part) + 'charset))) + "<!doctype html><html><head><meta http-equiv=\"content-type\" content=\"text/html; charset=UTF-8\"></head><body>ääää</body></html>\n"))))))) + +(ert-deftest test-mm-with-part-unibyte () + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally (ert-resource-file "8bit-multipart.bin")) + (while (search-forward "\r\n" nil t) + (replace-match "\n")) + (let ((handle (mm-dissect-buffer))) + (pop handle) + (let ((part (pop handle))) + (should (equal (decode-coding-string + (mm-with-part part + (buffer-string)) + (intern (mail-content-type-get (mm-handle-type part) + 'charset))) + "ääää\n")))))) + +(ert-deftest test-mm-dissect-buffer-win1252 () + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally (ert-resource-file "win1252-multipart.bin")) + (let ((handle (mm-dissect-buffer))) + (should (equal (mm-handle-media-type handle) "multipart/mixed")) + ;; Skip multipart type. + (pop handle) + (setq handle (car handle)) + (pop handle) + (let ((part (pop handle))) + (should (equal (mm-handle-media-type part) "text/plain")) + (should (eq (mm-handle-encoding part) '8bit)) + (with-current-buffer (mm-handle-buffer part) + (should (equal (decode-coding-string + (buffer-string) + (intern (mail-content-type-get (mm-handle-type part) + 'charset))) + "dĂ©jĂ ratĂ©\n")))) + (let ((part (pop handle))) + (should (equal (mm-handle-media-type part) "text/html")) + (should (eq (mm-handle-encoding part) '8bit)) + (with-current-buffer (mm-handle-buffer part) + (should (equal (decode-coding-string + (buffer-string) + (intern (mail-content-type-get (mm-handle-type part) + 'charset))) + "<html>\n <head>\n <meta http-equiv=\"content-type\" content=\"text/html; charset=windows-1252\">\n </head>\n <body>\n dĂ©jĂ ratĂ©\n </body>\n</html>\n"))))))) + +;;; mm-decode-tests.el ends here diff --git a/test/lisp/gnus/mml-sec-resources/.gpg-v21-migrated b/test/lisp/gnus/mml-sec-resources/.gpg-v21-migrated new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/.gpg-v21-migrated diff --git a/test/lisp/gnus/mml-sec-resources/gpg-agent.conf b/test/lisp/gnus/mml-sec-resources/gpg-agent.conf new file mode 100644 index 00000000000..20192990caf --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/gpg-agent.conf @@ -0,0 +1,5 @@ +# pinentry-program /usr/bin/pinentry-gtk-2 + +# verbose +# log-file /tmp/gpg-agent.log +# debug-all diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key Binary files differnew file mode 100644 index 00000000000..58fd0b5edbc --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key Binary files differnew file mode 100644 index 00000000000..62f4ab25a69 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key Binary files differnew file mode 100644 index 00000000000..2a8ce135fb2 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key Binary files differnew file mode 100644 index 00000000000..9f8de71c5e2 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key Binary files differnew file mode 100644 index 00000000000..6e4a4e548fd --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key Binary files differnew file mode 100644 index 00000000000..cff58edaa89 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key Binary files differnew file mode 100644 index 00000000000..14af8662f79 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key Binary files differnew file mode 100644 index 00000000000..207a7237d3a --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key Binary files differnew file mode 100644 index 00000000000..85ca78da04d --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key Binary files differnew file mode 100644 index 00000000000..79f3cd2b841 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key Binary files differnew file mode 100644 index 00000000000..776ddf7e9e2 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key Binary files differnew file mode 100644 index 00000000000..2b464f0ccbe --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key Binary files differnew file mode 100644 index 00000000000..28a07668b21 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key Binary files differnew file mode 100644 index 00000000000..137659693bd --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key Binary files differnew file mode 100644 index 00000000000..c99824ccd43 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key Binary files differnew file mode 100644 index 00000000000..49c2dc58bd8 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key Binary files differnew file mode 100644 index 00000000000..ca128408952 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key Binary files differnew file mode 100644 index 00000000000..3f14b40927a --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key Binary files differnew file mode 100644 index 00000000000..06adc06c427 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key Binary files differnew file mode 100644 index 00000000000..cf9a60d233b --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key Binary files differnew file mode 100644 index 00000000000..0ed35172fe0 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key Binary files differnew file mode 100644 index 00000000000..090059d9e81 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key Binary files differnew file mode 100644 index 00000000000..9061f675121 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key Binary files differnew file mode 100644 index 00000000000..89f6013100d --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key Binary files differnew file mode 100644 index 00000000000..41dac37574e --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key Binary files differnew file mode 100644 index 00000000000..5df7b4a5953 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key Binary files differnew file mode 100644 index 00000000000..03daf80975b --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key diff --git a/test/lisp/gnus/mml-sec-resources/pubring.gpg b/test/lisp/gnus/mml-sec-resources/pubring.gpg Binary files differnew file mode 100644 index 00000000000..6bd169963df --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/pubring.gpg diff --git a/test/lisp/gnus/mml-sec-resources/pubring.kbx b/test/lisp/gnus/mml-sec-resources/pubring.kbx Binary files differnew file mode 100644 index 00000000000..399a0414fd2 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/pubring.kbx diff --git a/test/lisp/gnus/mml-sec-resources/secring.gpg b/test/lisp/gnus/mml-sec-resources/secring.gpg Binary files differnew file mode 100644 index 00000000000..b323c072c04 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/secring.gpg diff --git a/test/lisp/gnus/mml-sec-resources/trustdb.gpg b/test/lisp/gnus/mml-sec-resources/trustdb.gpg Binary files differnew file mode 100644 index 00000000000..09ebd8db114 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/trustdb.gpg diff --git a/test/lisp/gnus/mml-sec-resources/trustlist.txt b/test/lisp/gnus/mml-sec-resources/trustlist.txt new file mode 100644 index 00000000000..f886572d283 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/trustlist.txt @@ -0,0 +1,26 @@ +# This is the list of trusted keys. Comment lines, like this one, as +# well as empty lines are ignored. Lines have a length limit but this +# is not a serious limitation as the format of the entries is fixed and +# checked by gpg-agent. A non-comment line starts with optional white +# space, followed by the SHA-1 fingerpint in hex, followed by a flag +# which may be one of 'P', 'S' or '*' and optionally followed by a list of +# other flags. The fingerprint may be prefixed with a '!' to mark the +# key as not trusted. You should give the gpg-agent a HUP or run the +# command "gpgconf --reload gpg-agent" after changing this file. + + +# Include the default trust list +include-default + + +# CN=No Expiry +D0:6A:A1:18:65:3C:C3:8E:9D:0C:AF:56:ED:7A:21:35:E1:58:21:77 S relax + +# CN=Second Key Pair +0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 S relax + +# CN=No Expiry two UIDs +D4:CA:78:E1:47:0B:9F:C2:AE:45:D7:84:64:9B:8C:E6:4E:BB:32:0C S relax + +# CN=Different subkeys +4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC S relax diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el new file mode 100644 index 00000000000..f308a617645 --- /dev/null +++ b/test/lisp/gnus/mml-sec-tests.el @@ -0,0 +1,900 @@ +;;; mml-sec-tests.el --- Tests mml-sec.el, see README-mml-secure.txt. -*- lexical-binding:t -*- + +;; Copyright (C) 2015, 2020-2022 Free Software Foundation, Inc. + +;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'ert-x) + +(require 'message) +(require 'epa) +(require 'epg) +(require 'mml-sec) +(require 'gnus-sum) + +(defvar with-smime nil + "If nil, exclude S/MIME from tests as passphrases need to entered manually. +Mostly, the empty passphrase is used. However, the keys for + \"No Expiry two UIDs\" have the passphrase \"Passphrase\" (for OpenPGP as well + as S/MIME).") + +(defun test-conf () + ;; Emacs doesn't have support for finding the name of the PGP agent + ;; on MacOS, so disable the checks. + (and (not (eq system-type 'darwin)) + (ignore-errors (epg-find-configuration 'OpenPGP)))) + +(defun enc-standards () + (if with-smime '(enc-pgp enc-pgp-mime enc-smime) + '(enc-pgp enc-pgp-mime))) +(defun enc-sign-standards () + (if with-smime + '(enc-sign-pgp enc-sign-pgp-mime enc-sign-smime) + '(enc-sign-pgp enc-sign-pgp-mime))) +(defun sign-standards () + (if with-smime + '(sign-pgp sign-pgp-mime sign-smime) + '(sign-pgp sign-pgp-mime))) + +(defvar mml-smime-use) + +(defun mml-secure-test-fixture (body &optional interactive) + "Setup GnuPG home containing test keys and prepare environment for BODY. +If optional INTERACTIVE is non-nil, allow questions to the user in case of +key problems. +This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests, +which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess. +Actually, I'm not sure why people would want to cache passwords in Emacs +instead of gpg-agent." + (unwind-protect + (let ((agent-info (getenv "GPG_AGENT_INFO")) + (gpghome (getenv "GNUPGHOME"))) + (condition-case error + (let ((epg-gpg-home-directory (ert-resource-directory)) + (mml-smime-use 'epg) + ;; Create debug output in empty epg-debug-buffer. + (epg-debug t) + (epg-debug-buffer (get-buffer-create " *epg-test*")) + (mml-secure-fail-when-key-problem (not interactive))) + (with-current-buffer epg-debug-buffer + (erase-buffer)) + ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs. + ;; Just for testing. Jens does not recommend this for daily use. + (setenv "GPG_AGENT_INFO") + ;; Set GNUPGHOME as gpg-agent started by gpgsm does + ;; not look in the proper places otherwise, see: + ;; https://bugs.gnupg.org/gnupg/issue2126 + (setenv "GNUPGHOME" epg-gpg-home-directory) + (unwind-protect + (funcall body) + (mml-sec-test--kill-gpg-agent))) + (error + (setenv "GPG_AGENT_INFO" agent-info) + (setenv "GNUPGHOME" gpghome) + (signal (car error) (cdr error)))) + (setenv "GPG_AGENT_INFO" agent-info) + (setenv "GNUPGHOME" gpghome)))) + +(defun mml-secure-test-message-setup (method to from &optional text bcc) + "Setup a buffer with MML METHOD, TO, and FROM headers. +Optionally, a message TEXT and BCC header can be passed." + (with-temp-buffer + (when bcc (insert (format "Bcc: %s\n" bcc))) + (insert (format "To: %s +From: %s +Subject: Test +%s\n" to from mail-header-separator)) + (if text + (insert (format "%s" text)) + (spook)) + (cond ((eq method 'enc-pgp-mime) + (mml-secure-message-encrypt-pgpmime 'nosig)) + ((eq method 'enc-sign-pgp-mime) + (mml-secure-message-encrypt-pgpmime)) + ((eq method 'enc-pgp) (mml-secure-message-encrypt-pgp 'nosig)) + ((eq method 'enc-sign-pgp) (mml-secure-message-encrypt-pgp)) + ((eq method 'enc-smime) (mml-secure-message-encrypt-smime 'nosig)) + ((eq method 'enc-sign-smime) (mml-secure-message-encrypt-smime)) + ((eq method 'sign-pgp-mime) (mml-secure-message-sign-pgpmime)) + ((eq method 'sign-pgp) (mml-secure-message-sign-pgp)) + ((eq method 'sign-smime) (mml-secure-message-sign-smime)) + (t (error "Unknown method"))) + (buffer-string))) + +(defun mml-secure-test-mail-fixture (method to from body2 + &optional interactive) + "Setup buffer encrypted using METHOD for TO from FROM, call BODY2. +Pass optional INTERACTIVE to mml-secure-test-fixture." + (mml-secure-test-fixture + (lambda () + (let ((_context (if (memq method '(enc-smime enc-sign-smime sign-smime)) + (epg-make-context 'CMS) + (epg-make-context 'OpenPGP))) + ;; Verify and decrypt by default. + (mm-verify-option 'known) + (mm-decrypt-option 'known) + (plaintext "The Magic Words are Squeamish Ossifrage")) + (with-temp-buffer + (insert (mml-secure-test-message-setup method to from plaintext)) + (message-options-set-recipient) + (message-encode-message-body) + ;; Replace separator line with newline. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + ;; The following treatment of handles, plainbuf, and multipart + ;; resulted from trial-and-error. + ;; Someone with more knowledge on how to decrypt messages and verify + ;; signatures might know more appropriate functions to invoke + ;; instead. + (let* ((handles (or (mm-dissect-buffer) + (mm-uu-dissect))) + (isplain (bufferp (car handles))) + (ismultipart (equal (car handles) "multipart/mixed")) + (plainbuf (if isplain + (car handles) + (if ismultipart + (car (cadadr handles)) + (caadr handles)))) + (decrypted + (with-current-buffer plainbuf (buffer-string))) + (gnus-info + (if isplain + nil + (if ismultipart + (or (mm-handle-multipart-ctl-parameter + (cadr handles) 'gnus-details) + (mm-handle-multipart-ctl-parameter + (cadr handles) 'gnus-info)) + (mm-handle-multipart-ctl-parameter + handles 'gnus-info))))) + (funcall body2 gnus-info plaintext decrypted))))) + interactive)) + +;; TODO If the variable BODY3 is renamed to BODY, an infinite recursion +;; occurs. Emacs bug? +(defun mml-secure-test-key-fixture (body3) + "Customize unique keys for sub@example.org and call BODY3. +For OpenPGP, we have: +- 1E6B FA97 3D9E 3103 B77F D399 C399 9CF1 268D BEA2 + uid Different subkeys <sub@example.org> +- 1463 2ECA B9E2 2736 9C8D D97B F7E7 9AB7 AE31 D471 + uid Second Key Pair <sub@example.org> + +For S/MIME: + ID: 0x479DC6E2 + Subject: /CN=Second Key Pair + aka: sub@example.org + fingerprint: 0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 + + ID: 0x5F88E9FC + Subject: /CN=Different subkeys + aka: sub@example.org + fingerprint: 4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC + +In both cases, the first key is customized for signing and encryption." + (mml-secure-test-fixture + (lambda () + (let* ((mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) + (pcontext (epg-make-context 'OpenPGP)) + (pkey (epg-list-keys pcontext "C3999CF1268DBEA2")) + (scontext (epg-make-context 'CMS)) + (skey (epg-list-keys scontext "0x479DC6E2"))) + (mml-secure-cust-record-keys pcontext 'encrypt "sub@example.org" pkey) + (mml-secure-cust-record-keys pcontext 'sign "sub@example.org" pkey) + (mml-secure-cust-record-keys scontext 'encrypt "sub@example.org" skey) + (mml-secure-cust-record-keys scontext 'sign "sub@example.org" skey) + (funcall body3))))) + +(ert-deftest mml-secure-key-checks () + "Test mml-secure-check-user-id and mml-secure-check-sub-key on sample keys." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let* ((context (epg-make-context 'OpenPGP)) + (keys1 (epg-list-keys context "expired@example.org")) + (keys2 (epg-list-keys context "no-exp@example.org")) + (keys3 (epg-list-keys context "sub@example.org")) + (keys4 (epg-list-keys context "revoked-uid@example.org")) + (keys5 (epg-list-keys context "disabled@example.org")) + (keys6 (epg-list-keys context "sign@example.org")) + (keys7 (epg-list-keys context "jens.lechtenboerger@fsfe")) + ) + (should (and (= 1 (length keys1)) (= 1 (length keys2)) + (= 2 (length keys3)) + (= 1 (length keys4)) (= 1 (length keys5)) + )) + ;; key1 is expired + (should-not (mml-secure-check-user-id (car keys1) "expired@example.org")) + (should-not (mml-secure-check-sub-key context (car keys1) 'encrypt)) + (should-not (mml-secure-check-sub-key context (car keys1) 'sign)) + + ;; key2 does not expire, but does not have the UID expired@example.org + (should-not (mml-secure-check-user-id (car keys2) "expired@example.org")) + (should (mml-secure-check-user-id (car keys2) "no-exp@example.org")) + (should (mml-secure-check-sub-key context (car keys2) 'encrypt)) + (should (mml-secure-check-sub-key context (car keys2) 'sign)) + + ;; Two keys exist for sub@example.org. + (should (mml-secure-check-user-id (car keys3) "sub@example.org")) + (should (mml-secure-check-sub-key context (car keys3) 'encrypt)) + (should (mml-secure-check-sub-key context (car keys3) 'sign)) + (should (mml-secure-check-user-id (cadr keys3) "sub@example.org")) + (should (mml-secure-check-sub-key context (cadr keys3) 'encrypt)) + (should (mml-secure-check-sub-key context (cadr keys3) 'sign)) + + ;; The UID revoked-uid@example.org is revoked. The key itself is + ;; usable, though (with the UID sub@example.org). + (should-not + (mml-secure-check-user-id (car keys4) "revoked-uid@example.org")) + (should (mml-secure-check-sub-key context (car keys4) 'encrypt)) + (should (mml-secure-check-sub-key context (car keys4) 'sign)) + (should (mml-secure-check-user-id (car keys4) "sub@example.org")) + + ;; The next key is disabled and, thus, unusable. + (should (mml-secure-check-user-id (car keys5) "disabled@example.org")) + (should-not (mml-secure-check-sub-key context (car keys5) 'encrypt)) + (should-not (mml-secure-check-sub-key context (car keys5) 'sign)) + + ;; The next key has multiple subkeys. + ;; 42466F0F is valid sign subkey, 501FFD98 is expired + (should (mml-secure-check-sub-key context (car keys6) 'sign "42466F0F")) + (should-not + (mml-secure-check-sub-key context (car keys6) 'sign "501FFD98")) + ;; DC7F66E7 is encrypt subkey + (should + (mml-secure-check-sub-key context (car keys6) 'encrypt "DC7F66E7")) + (should-not + (mml-secure-check-sub-key context (car keys6) 'sign "DC7F66E7")) + (should-not + (mml-secure-check-sub-key context (car keys6) 'encrypt "42466F0F")) + + ;; The final key is just a public key. + (should (mml-secure-check-sub-key context (car keys7) 'encrypt)) + (should-not (mml-secure-check-sub-key context (car keys7) 'sign)) + )))) + +(ert-deftest mml-secure-find-usable-keys-1 () + "Make sure that expired and disabled keys and revoked UIDs are not used." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP))) + (should-not + (mml-secure-find-usable-keys context "expired@example.org" 'encrypt)) + (should-not + (mml-secure-find-usable-keys context "expired@example.org" 'sign)) + + (should-not + (mml-secure-find-usable-keys context "disabled@example.org" 'encrypt)) + (should-not + (mml-secure-find-usable-keys context "disabled@example.org" 'sign)) + + (should-not + (mml-secure-find-usable-keys + context "<revoked-uid@example.org>" 'encrypt)) + (should-not + (mml-secure-find-usable-keys + context "<revoked-uid@example.org>" 'sign)) + ;; Same test without ankles. Will fail for Ma Gnus v0.14 and earlier. + (should-not + (mml-secure-find-usable-keys + context "revoked-uid@example.org" 'encrypt)) + + ;; Expired key should not be usable. + ;; Will fail for Ma Gnus v0.14 and earlier. + ;; sign@example.org has the expired subkey 0x501FFD98. + (should-not + (mml-secure-find-usable-keys context "0x501FFD98" 'sign)) + + (should + (mml-secure-find-usable-keys context "no-exp@example.org" 'encrypt)) + (should + (mml-secure-find-usable-keys context "no-exp@example.org" 'sign)) + )))) + +(ert-deftest mml-secure-find-usable-keys-2 () + "Test different ways to search for keys." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP))) + ;; Plain substring search is not supported. + (should + (= 0 (length + (mml-secure-find-usable-keys context "No Expiry" 'encrypt)))) + (should + (= 0 (length + (mml-secure-find-usable-keys context "No Expiry" 'sign)))) + + ;; Search for e-mail addresses works with and without ankle brackets. + (should + (= 1 (length (mml-secure-find-usable-keys + context "<no-exp@example.org>" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "<no-exp@example.org>" 'sign)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "no-exp@example.org" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "no-exp@example.org" 'sign)))) + + ;; Use full UID string. + (should + (= 1 (length (mml-secure-find-usable-keys + context "No Expiry <no-exp@example.org>" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "No Expiry <no-exp@example.org>" 'sign)))) + + ;; If just the public key is present, only encryption is possible. + ;; Search works with key IDs, with and without prefix "0x". + (should + (= 1 (length (mml-secure-find-usable-keys + context "A142FD84" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "0xA142FD84" 'encrypt)))) + (should + (= 0 (length (mml-secure-find-usable-keys + context "A142FD84" 'sign)))) + (should + (= 0 (length (mml-secure-find-usable-keys + context "0xA142FD84" 'sign)))) + )))) + +(ert-deftest mml-secure-select-preferred-keys-1 () + "If only one key exists for an e-mail address, it is the preferred one." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP))) + (should (equal "832F3CC6518D37BC658261B802372A42CA6D40FB" + (mml-secure-fingerprint + (car (mml-secure-select-preferred-keys + context '("no-exp@example.org") 'encrypt))))))))) + +(ert-deftest mml-secure-select-preferred-keys-2 () + "If multiple keys exists for an e-mail address, customization is necessary." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let* ((context (epg-make-context 'OpenPGP)) + (mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) + (pref (car (mml-secure-find-usable-keys + context "sub@example.org" 'encrypt)))) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (mml-secure-cust-record-keys + context 'encrypt "sub@example.org" (list pref)) + (should (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'sign)) + (should (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (should + (equal (list (mml-secure-fingerprint pref)) + (mml-secure-cust-fpr-lookup context 'encrypt "sub@example.org"))) + (should (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)))))) + +(ert-deftest mml-secure-select-preferred-keys-3 () + "Expired customized keys are removed if multiple keys are available." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP)) + (mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))) + ;; sub@example.org has two keys (268DBEA2, AE31D471). + ;; Normal preference works. + (mml-secure-cust-record-keys + context 'encrypt "sub@example.org" (epg-list-keys context "268DBEA2")) + (should (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (mml-secure-cust-remove-keys context 'encrypt "sub@example.org") + + ;; Fake preference for expired (unrelated) key CE15FAE7, + ;; results in error (and automatic removal of outdated preference). + (mml-secure-cust-record-keys + context 'encrypt "sub@example.org" (epg-list-keys context "CE15FAE7")) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (should-not + (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")))))) + +(ert-deftest mml-secure-select-preferred-keys-4 () + "Multiple keys can be recorded per recipient or signature." + (skip-unless (test-conf)) + (skip-unless (ignore-errors (epg-find-configuration 'CMS))) + (mml-secure-test-fixture + (lambda () + (let ((pcontext (epg-make-context 'OpenPGP)) + (scontext (epg-make-context 'CMS)) + (pkeys '("1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" + "14632ECAB9E227369C8DD97BF7E79AB7AE31D471")) + (skeys '("0x5F88E9FC" "0x479DC6E2")) + (mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))) + + ;; OpenPGP preferences via pcontext + (dolist (key pkeys nil) + (mml-secure-cust-record-keys + pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key)) + (mml-secure-cust-record-keys + pcontext 'sign "sub@example.org" (epg-list-keys pcontext key 'secret))) + (let ((p-e-fprs (mml-secure-cust-fpr-lookup + pcontext 'encrypt "sub@example.org")) + (p-s-fprs (mml-secure-cust-fpr-lookup + pcontext 'sign "sub@example.org"))) + (should (= 2 (length p-e-fprs))) + (should (= 2 (length p-s-fprs))) + (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-e-fprs)) + (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-e-fprs)) + (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-s-fprs)) + (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-s-fprs))) + ;; Duplicate record does not change anything. + (mml-secure-cust-record-keys + pcontext 'encrypt "sub@example.org" + (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2")) + (mml-secure-cust-record-keys + pcontext 'sign "sub@example.org" + (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2")) + (let ((p-e-fprs (mml-secure-cust-fpr-lookup + pcontext 'encrypt "sub@example.org")) + (p-s-fprs (mml-secure-cust-fpr-lookup + pcontext 'sign "sub@example.org"))) + (should (= 2 (length p-e-fprs))) + (should (= 2 (length p-s-fprs)))) + + ;; S/MIME preferences via scontext + (dolist (key skeys nil) + (mml-secure-cust-record-keys + scontext 'encrypt "sub@example.org" + (epg-list-keys scontext key)) + (mml-secure-cust-record-keys + scontext 'sign "sub@example.org" + (epg-list-keys scontext key 'secret))) + (let ((s-e-fprs (mml-secure-cust-fpr-lookup + scontext 'encrypt "sub@example.org")) + (s-s-fprs (mml-secure-cust-fpr-lookup + scontext 'sign "sub@example.org"))) + (should (= 2 (length s-e-fprs))) + (should (= 2 (length s-s-fprs)))) + )))) + +(defun mml-secure-test-en-decrypt + (method to from + &optional checksig checkplain enc-keys expectfail interactive) + "Encrypt message using METHOD, addressed to TO, from FROM. +If optional CHECKSIG is non-nil, it must be a number, and a signature check is +performed; the number indicates how many signatures are expected. +If optional CHECKPLAIN is non-nil, the expected plaintext should be obtained +via decryption. +If optional ENC-KEYS is non-nil, it is a list of pairs of encryption keys (for +OpenPGP and S/SMIME) expected in `epg-debug-buffer'. +If optional EXPECTFAIL is non-nil, a decryption failure is expected. +Pass optional INTERACTIVE to mml-secure-test-mail-fixture." + (mml-secure-test-mail-fixture method to from + (lambda (gnus-info plaintext decrypted) + (if expectfail + (should-not (equal plaintext decrypted)) + (when checkplain + (should (equal plaintext decrypted))) + (let ((protocol (if (memq method + '(enc-smime enc-sign-smime sign-smime)) + 'CMS + 'OpenPGP))) + (when checksig + (let* ((context (epg-make-context protocol)) + (signer-names (mml-secure-signer-names protocol from)) + (signer-keys (mml-secure-signers context signer-names)) + (signer-fprs (mapcar 'mml-secure-fingerprint signer-keys))) + (should (eq checksig (length signer-fprs))) + (if (eq checksig 0) + ;; First key in keyring + (should (string-match-p + (concat "Good signature from " + (if (eq protocol 'CMS) + "0E58229B80EE33959FF718FEEF25402B479DC6E2" + "02372A42CA6D40FB")) + gnus-info))) + (dolist (fpr signer-fprs nil) + ;; OpenPGP: "Good signature from 02372A42CA6D40FB No Expiry <no-exp@example.org> (trust undefined) created ..." + ;; S/MIME: "Good signature from D06AA118653CC38E9D0CAF56ED7A2135E1582177 /CN=No Expiry (trust full) ..." + (should (string-match-p + (concat "Good signature from " + (if (eq protocol 'CMS) + fpr + (substring fpr -16 nil))) + gnus-info))))) + (when enc-keys + (with-current-buffer epg-debug-buffer + (goto-char (point-min)) + ;; The following regexp does not necessarily match at the + ;; start of the line as a path may or may not be present. + ;; Also note that gpg.* matches gpg2 and gpgsm as well. + (let* ((line (concat "gpg.*--encrypt.*$")) + (end (re-search-forward line)) + (match (match-string 0))) + (should (and end match)) + (dolist (pair enc-keys nil) + (let ((fpr (if (eq protocol 'OpenPGP) + (car pair) + (cdr pair)))) + (should (string-match-p (concat "-r " fpr) match)))) + (goto-char (point-max)) + )))))) + interactive)) + +(defvar mml-smime-cache-passphrase) +(defvar mml2015-cache-passphrase) +(defvar mml1991-cache-passphrase) + +(defun mml-secure-test-en-decrypt-with-passphrase + (method to from checksig jl-passphrase do-cache + &optional enc-keys expectfail) + "Call mml-secure-test-en-decrypt with changed passphrase caching. +Args METHOD, TO, FROM, CHECKSIG are passed to mml-secure-test-en-decrypt. +JL-PASSPHRASE is fixed as return value for `read-passwd', +boolean DO-CACHE determines whether to cache the passphrase. +If optional ENC-KEYS is non-nil, it is a list of encryption keys expected +in `epg-debug-buffer'. +If optional EXPECTFAIL is non-nil, a decryption failure is expected." + (let ((mml-secure-cache-passphrase do-cache) + (mml1991-cache-passphrase do-cache) + (mml2015-cache-passphrase do-cache) + (mml-smime-cache-passphrase do-cache) + ) + (cl-letf (((symbol-function 'read-passwd) + (lambda (_prompt &optional _confirm _default) jl-passphrase))) + (mml-secure-test-en-decrypt method to from checksig t enc-keys expectfail) + ))) + +(ert-deftest mml-secure-en-decrypt-1 () + "Encrypt message; then decrypt and test for expected result. +In this test, the single matching key is chosen automatically." + (skip-unless (test-conf)) + (dolist (method (enc-standards) nil) + ;; no-exp@example.org with single encryption key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" nil t + (list (cons "02372A42CA6D40FB" "ED7A2135E1582177"))))) + +(ert-deftest mml-secure-en-decrypt-2 () + "Encrypt message; then decrypt and test for expected result. +In this test, the encryption key needs to fixed among multiple ones." + (skip-unless (test-conf)) + (skip-unless (ignore-errors (epg-find-configuration 'CMS))) + ;; sub@example.org with multiple candidate keys, + ;; fixture customizes preferred ones. + (mml-secure-test-key-fixture + (lambda () + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" nil t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2"))))))) + +(ert-deftest mml-secure-en-decrypt-3 () + "Encrypt message; then decrypt and test for expected result. +In this test, encrypt-to-self variables are set to t." + ;; Random failures with "wrong-type-argument stringp nil". + ;; Seems unlikely to be specific to hydra.nixos.org... + :tags (if (getenv "EMACS_HYDRA_CI") '(:unstable)) + (skip-unless (test-conf)) + (skip-unless (ignore-errors (epg-find-configuration 'CMS))) + ;; sub@example.org with multiple candidate keys, + ;; fixture customizes preferred ones. + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-encrypt-to-self t) + (mml-secure-smime-encrypt-to-self t)) + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" nil t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") + (cons "02372A42CA6D40FB" "ED7A2135E1582177")))))))) + +(ert-deftest mml-secure-en-decrypt-4 () + "Encrypt message; then decrypt and test for expected result. +In this test, encrypt-to-self variables are set to lists." + (skip-unless (test-conf)) + ;; Send from sub@example.org, which has two keys; encrypt to both. + (let ((mml-secure-openpgp-encrypt-to-self + '("C3999CF1268DBEA2" "F7E79AB7AE31D471")) + (mml-secure-smime-encrypt-to-self + '("EF25402B479DC6E2" "4035D59B5F88E9FC"))) + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" nil t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") + (cons "F7E79AB7AE31D471" "4035D59B5F88E9FC")))))) + +(ert-deftest mml-secure-en-decrypt-sign-1-1-single () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + (dolist (method (enc-sign-standards) nil) + ;; no-exp with just one key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "no-exp@example.org" 1 t) + ;; customized choice for encryption key + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" 1 t) + ;; customized choice for signing key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 1 t) + ;; customized choice for both keys + (mml-secure-test-en-decrypt + method "sub@example.org" "sub@example.org" 1 t) + ))))) + +(ert-deftest mml-secure-en-decrypt-sign-1-2-double () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + ;; Now use both keys to sign. The customized one via sign-with-sender, + ;; the other one via the following setting. + (let ((mml-secure-openpgp-signers '("F7E79AB7AE31D471")) + (mml-secure-smime-signers '("0x5F88E9FC"))) + (dolist (method (enc-sign-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 t))))))) + +(ert-deftest mml-secure-en-decrypt-sign-1-3-double () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + ;; Now use both keys for sub@example.org to sign an e-mail from + ;; a different address (without associated keys). + (let ((mml-secure-openpgp-sign-with-sender nil) + (mml-secure-smime-sign-with-sender nil) + (mml-secure-openpgp-signers + '("F7E79AB7AE31D471" "C3999CF1268DBEA2")) + (mml-secure-smime-signers '("0x5F88E9FC" "0x479DC6E2"))) + (dolist (method (enc-sign-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "no-keys@example.org" 2 t)))))) + +(ert-deftest mml-secure-en-decrypt-sign-2 () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, lists of encryption and signing keys are customized." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) + (pcontext (epg-make-context 'OpenPGP)) + (scontext (epg-make-context 'CMS)) + (mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + (dolist (key '("F7E79AB7AE31D471" "C3999CF1268DBEA2") nil) + (mml-secure-cust-record-keys + pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key)) + (mml-secure-cust-record-keys + pcontext 'sign "sub@example.org" (epg-list-keys pcontext key t))) + (dolist (key '("0x5F88E9FC" "0x479DC6E2") nil) + (mml-secure-cust-record-keys + scontext 'encrypt "sub@example.org" (epg-list-keys scontext key)) + (mml-secure-cust-record-keys + scontext 'sign "sub@example.org" (epg-list-keys scontext key t))) + (dolist (method (enc-sign-standards) nil) + ;; customized choice for encryption key + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" 1 t) + ;; customized choice for signing key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 t) + ;; customized choice for both keys + (mml-secure-test-en-decrypt + method "sub@example.org" "sub@example.org" 2 t) + ))))) + +(ert-deftest mml-secure-en-decrypt-sign-3 () + "Sign and encrypt message; then decrypt and test for expected result. +Use sign-with-sender and encrypt-to-self." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-openpgp-encrypt-to-self t) + (mml-secure-smime-sign-with-sender t) + (mml-secure-smime-encrypt-to-self t)) + (dolist (method (enc-sign-standards) nil) + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" 1 t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") + (cons "02372A42CA6D40FB" "ED7A2135E1582177")))) + )))) + +(ert-deftest mml-secure-sign-verify-1 () + "Sign message with sender; then verify and test for expected result." + (skip-unless (test-conf)) + (skip-unless (ignore-errors (epg-find-configuration 'CMS))) + (mml-secure-test-key-fixture + (lambda () + (dolist (method (sign-standards) nil) + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + ;; A single signing key for sender sub@example.org is customized + ;; in the fixture. + (mml-secure-test-en-decrypt + method "uid1@example.org" "sub@example.org" 1 nil) + + ;; From sub@example.org, sign with two keys; + ;; sign-with-sender and one from signers-variable: + (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) + (mml-secure-smime-signers + '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 nil)) + ))))) + +(ert-deftest mml-secure-sign-verify-3 () + "Try to sign message with expired OpenPGP subkey, which raises an error. +With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." + (skip-unless (test-conf)) + (should-error + (mml-secure-test-key-fixture + (lambda () + (let ((with-smime nil) + (mml-secure-openpgp-sign-with-sender nil) + (mml-secure-openpgp-signers '("501FFD98"))) + (dolist (method (sign-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sign@example.org" 1 nil) + )))))) + +;; TODO Passphrase passing and caching in Emacs does not seem to work +;; with gpgsm at all. +;; Independently of caching settings, a pinentry dialogue is displayed. +;; Thus, the following tests require the user to enter the correct gpgsm +;; passphrases at the correct points in time. (Either empty string or +;; "Passphrase".) +(ert-deftest mml-secure-en-decrypt-passphrase-cache () + "Encrypt message; then decrypt and test for expected result. +In this test, a key is used that requires the passphrase \"Passphrase\". +In the first decryption this passphrase is hardcoded, in the second one it + is taken from a cache." + (skip-unless (test-conf)) + (ert-skip "Requires passphrase") + (mml-secure-test-key-fixture + (lambda () + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + ;; Beware! For passphrases copy-sequence is necessary, as they may + ;; be erased, which actually changes the function's code and causes + ;; multiple invocations to fail. I was surprised... + (copy-sequence "Passphrase") t) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Incorrect") t))))) + +(defun mml-secure-en-decrypt-passphrase-no-cache (method) + "Encrypt message with METHOD; then decrypt and test for expected result. +In this test, a key is used that requires the passphrase \"Passphrase\". +In the first decryption this passphrase is hardcoded, but caching disabled. +So the second decryption fails." + (mml-secure-test-key-fixture + (lambda () + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Passphrase") nil) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Incorrect") nil nil t)))) + +(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-openpgp-todo () + "Passphrase caching with OpenPGP only for GnuPG 1.x." + (skip-unless (test-conf)) + (skip-unless (string< (cdr (assq 'version (epg-find-configuration 'OpenPGP))) + "2")) + (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp) + (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp-mime)) + +(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-smime-todo () + "Passphrase caching does not work with S/MIME (and gpgsm)." + :expected-result :failed + (skip-unless (test-conf)) + (if with-smime + (mml-secure-en-decrypt-passphrase-no-cache 'enc-smime) + (should nil))) + + +;; Test truncation of question in y-or-n-p. +(defun mml-secure-select-preferred-keys-todo () + "Manual customization with truncated question." + (mml-secure-test-key-fixture + (lambda () + (mml-secure-test-en-decrypt + 'enc-pgp-mime + "jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de" + "no-exp@example.org" nil t nil nil t)))) + +(defun mml-secure-select-preferred-keys-ok () + "Manual customization with entire question." + (mml-secure-test-fixture + (lambda () + (mml-secure-select-preferred-keys + (epg-make-context 'OpenPGP) + '("jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de") + 'encrypt)) + t)) + + +;; ERT entry points +(defun mml-secure-run-tests () + "Run all tests with defaults." + (ert-run-tests-batch)) + +(defun mml-secure-run-tests-with-gpg2 () + "Run all tests with gpg2 instead of gpg." + (let* ((epg-gpg-program "gpg2"); ~/local/gnupg-2.1.9/PLAY/inst/bin/gpg2 + (gpg-version (cdr (assq 'version (epg-find-configuration 'OpenPGP)))) + ;; Empty passphrases do not seem to work with gpgsm in 2.1.x: + ;; https://lists.gnupg.org/pipermail/gnupg-users/2015-October/054575.html + (with-smime (string< gpg-version "2.1"))) + (ert-run-tests-batch))) + +(defun mml-secure-run-tests-without-smime () + "Skip S/MIME tests (as they require manual passphrase entry)." + (let ((with-smime nil)) + (ert-run-tests-batch))) + +(defun mml-sec-test--kill-gpg-agent () + (dolist (pid (list-system-processes)) + (let ((atts (process-attributes pid))) + (when (and (equal (cdr (assq 'user atts)) (user-login-name)) + (or (equal (cdr (assq 'comm atts)) "gpg-agent") + (equal (cdr (assq 'comm atts)) "scdaemon")) + (string-match + (concat "homedir.*" + (regexp-quote (directory-file-name + (ert-resource-directory)))) + (cdr (assq 'args atts)))) + (call-process "kill" nil nil nil (format "%d" pid)))))) + +;;; mml-sec-tests.el ends here diff --git a/test/lisp/gnus/nnrss-tests.el b/test/lisp/gnus/nnrss-tests.el new file mode 100644 index 00000000000..47d208cb160 --- /dev/null +++ b/test/lisp/gnus/nnrss-tests.el @@ -0,0 +1,45 @@ +;;; nnrss-tests.el --- tests for gnus/nnrss.el -*- lexical-binding:t -*- + +;; Copyright (C) 2019-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'nnrss) + +(ert-deftest test-nnrss-normalize () + (should (equal (nnrss-normalize-date "2004-09-17T05:09:49.001+00:00") + "Fri, 17 Sep 2004 05:09:49 +0000"))) + +(defconst test-nnrss-xml + '((rss + ((version . "2.0") + (xmlns:dc . "http://purl.org/dc/elements/1.1/")) + (channel + ((xmlns:content . "http://purl.org/rss/1.0/modules/content/")))))) + +(ert-deftest test-nnrss-namespace-top () + (should (equal (nnrss-get-namespace-prefix + test-nnrss-xml "http://purl.org/dc/elements/1.1/") + "dc:"))) +(ert-deftest test-nnrss-namespace-inner () + (should (equal (nnrss-get-namespace-prefix + test-nnrss-xml "http://purl.org/rss/1.0/modules/content/") + "content:"))) + +;;; nnrss-tests.el ends here |