commit a59296d9984023960453322ff7d664ec79250f7a (HEAD, refs/remotes/origin/master) Author: Lars Ingebrigtsen Date: Wed Aug 5 10:27:40 2020 +0200 Make the erc /ignore command prompt for a timeout * lisp/erc/erc.el (erc--unignore-user): Separate into own function (bug#40137). (erc-cmd-IGNORE): Ask if the user wants a timeout. (erc--read-time-period): New function. diff --git a/etc/NEWS b/etc/NEWS index c1879169dd..670e97f52c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -590,6 +590,12 @@ Previously 'xml-print' would produce invalid XML when given a string with characters that are not valid in XML (see https://www.w3.org/TR/xml/#charsets). Now it rejects such strings. +** erc + +--- +*** The /ignore command will now ask for a timeout to stop ignoring the user. +Allowed inputs are seconds or ISO8601-like periods like "1h" or "4h30m". + ** Battery --- diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 8830dd4c45..927546abc3 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -63,6 +63,8 @@ (require 'thingatpt) (require 'auth-source) (require 'erc-compat) +(require 'time-date) +(require 'iso8601) (eval-when-compile (require 'subr-x)) (defvar erc-official-location @@ -2905,6 +2907,44 @@ therefore has to contain the command itself as well." (erc-server-send (substring line 1)) t) +(defvar erc--read-time-period-history nil) + +(defun erc--read-time-period (prompt) + "Read a time period on the \"2h\" format. +If there's no letter spec, the input is interpreted as a number of seconds. + +If input is blank, this function returns nil. Otherwise it +returns the time spec converted to a number of seconds." + (let ((period (string-trim + (read-string prompt nil 'erc--read-time-period-history)))) + (cond + ;; Blank input. + ((zerop (length period)) + nil) + ;; All-number -- interpret as seconds. + ((string-match-p "\\`[0-9]+\\'" period) + (string-to-number period)) + ;; Parse as a time spec. + (t + (let ((time (condition-case nil + (iso8601-parse-duration + (concat (cond + ((string-match-p "\\`P" (upcase period)) + ;; Somebody typed in a full ISO8601 period. + (upcase period)) + ((string-match-p "[YD]" (upcase period)) + ;; If we have a year/day element, + ;; we have a full spec. + "P") + (t + ;; Otherwise it's just a sub-day spec. + "PT")) + (upcase period))) + (wrong-type-argument nil)))) + (unless time + (user-error "%s is not a valid time period" period)) + (decoded-time-period time)))))) + (defun erc-cmd-IGNORE (&optional user) "Ignore USER. This should be a regexp matching nick!user@host. If no USER argument is specified, list the contents of `erc-ignore-list'." @@ -2914,10 +2954,18 @@ If no USER argument is specified, list the contents of `erc-ignore-list'." (y-or-n-p (format "Use regexp-quoted form (%s) instead? " quoted))) (setq user quoted)) - (erc-display-line - (erc-make-notice (format "Now ignoring %s" user)) - 'active) - (erc-with-server-buffer (add-to-list 'erc-ignore-list user))) + (let ((timeout + (erc--read-time-period + "Add a timeout? (Blank for no, or a time spec like 2h): ")) + (buffer (current-buffer))) + (when timeout + (run-at-time timeout nil + (lambda () + (erc--unignore-user user buffer)))) + (erc-display-line + (erc-make-notice (format "Now ignoring %s" user)) + 'active) + (erc-with-server-buffer (add-to-list 'erc-ignore-list user)))) (if (null (erc-with-server-buffer erc-ignore-list)) (erc-display-line (erc-make-notice "Ignore list is empty") 'active) (erc-display-line (erc-make-notice "Ignore list:") 'active) @@ -2941,12 +2989,17 @@ If no USER argument is specified, list the contents of `erc-ignore-list'." (erc-make-notice (format "%s is not currently ignored!" user)) 'active))) (when ignored-nick + (erc--unignore-user user (current-buffer)))) + t) + +(defun erc--unignore-user (user buffer) + (when (buffer-live-p buffer) + (with-current-buffer buffer (erc-display-line (erc-make-notice (format "No longer ignoring %s" user)) 'active) (erc-with-server-buffer - (setq erc-ignore-list (delete ignored-nick erc-ignore-list))))) - t) + (setq erc-ignore-list (delete user erc-ignore-list)))))) (defun erc-cmd-CLEAR () "Clear the window content." diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el new file mode 100644 index 0000000000..27f48fa813 --- /dev/null +++ b/test/lisp/erc/erc-tests.el @@ -0,0 +1,47 @@ +;;; erc-tests.el --- Tests for erc. -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'erc) + +(ert-deftest erc--read-time-period () + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) ""))) + (should (equal (erc--read-time-period "foo: ") nil))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " "))) + (should (equal (erc--read-time-period "foo: ") nil))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " 432 "))) + (should (equal (erc--read-time-period "foo: ") 432))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "432"))) + (should (equal (erc--read-time-period "foo: ") 432))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h"))) + (should (equal (erc--read-time-period "foo: ") 3600))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h10s"))) + (should (equal (erc--read-time-period "foo: ") 3610))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d"))) + (should (equal (erc--read-time-period "foo: ") 86400)))) commit 1f3e2ac4b62e38af2d9424f2a4fcc1515a4c0b30 Author: Lars Ingebrigtsen Date: Wed Aug 5 10:07:13 2020 +0200 Add new function decoded-time-period * lisp/calendar/time-date.el (decoded-time-period): New function. diff --git a/etc/NEWS b/etc/NEWS index f135b3f6b3..c1879169dd 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -731,6 +731,11 @@ optional argument specifying whether to follow symbolic links. ** 'parse-time-string' can now parse ISO 8601 format strings, such as "2020-01-15T16:12:21-08:00". +--- +** The new function 'decoded-time-period' has been added. +It interprets a decoded time structure as a period and returns the +equivalent period in seconds. + +++ ** The new function 'dom-remove-attribute' has been added. diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index eeb09926a6..125f9acc70 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -527,6 +527,21 @@ TIME is modified and returned." time) +(defun decoded-time-period (time) + "Interpret DECODED as a period and return its length in seconds. +For computational purposes, years are 365 days long and months +are 30 days long." + (+ (if (consp (decoded-time-second time)) + ;; Fractional second. + (/ (float (car (decoded-time-second time))) + (cdr (decoded-time-second time))) + (or (decoded-time-second time) 0)) + (* (or (decoded-time-minute time) 0) 60) + (* (or (decoded-time-hour time) 0) 60 60) + (* (or (decoded-time-day time) 0) 60 60 24) + (* (or (decoded-time-month time) 0) 60 60 24 30) + (* (or (decoded-time-year time) 0) 60 60 24 365))) + (provide 'time-date) ;;; time-date.el ends here diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 3eecc67eb5..fe1460cf29 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -109,4 +109,18 @@ (ert-deftest test-time-since () (should (time-equal-p 0 (time-since nil)))) +(ert-deftest test-time-decoded-period () + (should (equal (decoded-time-period '(nil nil 1 nil nil nil nil nil nil)) + 3600)) + + (should (equal (decoded-time-period '(1 0 0 0 0 0 nil nil nil)) 1)) + (should (equal (decoded-time-period '(0 1 0 0 0 0 nil nil nil)) 60)) + (should (equal (decoded-time-period '(0 0 1 0 0 0 nil nil nil)) 3600)) + (should (equal (decoded-time-period '(0 0 0 1 0 0 nil nil nil)) 86400)) + (should (equal (decoded-time-period '(0 0 0 0 1 0 nil nil nil)) 2592000)) + (should (equal (decoded-time-period '(0 0 0 0 0 1 nil nil nil)) 31536000)) + + (should (equal (decoded-time-period '((135 . 10) 0 0 0 0 0 nil nil nil)) + 13.5))) + ;;; time-date-tests.el ends here commit 398242bb3f08db3be4d8f1a7a95ba44f7aea995c Author: Stefan Monnier Date: Tue Aug 4 20:15:41 2020 -0400 * lisp/x-dnd.el: Use lexical-scoping diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index b22af5cc77..1d49f46253 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -1,4 +1,4 @@ -;;; x-dnd.el --- drag and drop support for X +;;; x-dnd.el --- drag and drop support for X -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2020 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ (require 'dnd) ;;; Customizable variables -(defcustom x-dnd-test-function 'x-dnd-default-test-function +(defcustom x-dnd-test-function #'x-dnd-default-test-function "The function drag and drop uses to determine if to accept or reject a drop. The function takes three arguments, WINDOW, ACTION and TYPES. WINDOW is where the mouse is when the function is called. WINDOW may be a commit cbb5a67effce7ce2923e498be252c7c8ad96ab53 Author: Juri Linkov Date: Wed Aug 5 02:51:00 2020 +0300 * lisp/generic-x.el (ansible-inventory-generic-mode): Fix filename (bug#42703) diff --git a/lisp/generic-x.el b/lisp/generic-x.el index cd24f497c9..48ac123205 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -643,7 +643,7 @@ like an INI file. You can add this hook to `find-file-hook'." ("\\([^ =\n\r]+\\)=\\([^ \n\r]*\\)" (1 font-lock-variable-name-face) (2 font-lock-keyword-face))) - '("inventory") + '("inventory\\'") (list (function (lambda () commit 519a93e067f459ceddb57573261a52118086b73d Author: Alan Third Date: Sun Aug 2 20:43:56 2020 +0100 Don't smooth images when scaling up (bug#38394) * src/image.c (image_set_transform [HAVE_XRENDER]): Use different filter when scaling up vs scaling down. * src/nsimage.m (ns_image_set_smoothing): ([EmacsImage setSmoothing:]): New functions. * src/nsterm.h: Add definitions. * src/nsterm.m (ns_dumpglyphs_image): Disable smoothing if requested. diff --git a/src/image.c b/src/image.c index e7e0a93313..e236b38921 100644 --- a/src/image.c +++ b/src/image.c @@ -259,6 +259,8 @@ cr_put_image_to_cr_data (struct image *img) cairo_matrix_t matrix; cairo_pattern_get_matrix (img->cr_data, &matrix); cairo_pattern_set_matrix (pattern, &matrix); + cairo_pattern_set_filter + (pattern, cairo_pattern_get_filter (img->cr_data)); cairo_pattern_destroy (img->cr_data); } cairo_surface_destroy (surface); @@ -2114,6 +2116,15 @@ image_set_transform (struct frame *f, struct image *img) double rotation = 0.0; compute_image_rotation (img, &rotation); +# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS + /* We want scale up operations to use a nearest neighbour filter to + show real pixels instead of munging them, but scale down + operations to use a blended filter, to avoid aliasing and the like. + + TODO: implement for Windows. */ + bool scale_down = (width < img->width) || (height < img->height); +# endif + /* Perform scale transformation. */ matrix3x3 matrix @@ -2225,11 +2236,14 @@ image_set_transform (struct frame *f, struct image *img) /* Under NS the transform is applied to the drawing surface at drawing time, so store it for later. */ ns_image_set_transform (img->pixmap, matrix); + ns_image_set_smoothing (img->pixmap, scale_down); # elif defined USE_CAIRO cairo_matrix_t cr_matrix = {matrix[0][0], matrix[0][1], matrix[1][0], matrix[1][1], matrix[2][0], matrix[2][1]}; cairo_pattern_t *pattern = cairo_pattern_create_rgb (0, 0, 0); cairo_pattern_set_matrix (pattern, &cr_matrix); + cairo_pattern_set_filter (pattern, scale_down + ? CAIRO_FILTER_BEST : CAIRO_FILTER_NEAREST); /* Dummy solid color pattern just to record pattern matrix. */ img->cr_data = pattern; # elif defined (HAVE_XRENDER) @@ -2246,14 +2260,14 @@ image_set_transform (struct frame *f, struct image *img) XDoubleToFixed (matrix[1][2]), XDoubleToFixed (matrix[2][2])}}}; - XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->picture, FilterBest, - 0, 0); + XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->picture, + scale_down ? FilterBest : FilterNearest, 0, 0); XRenderSetPictureTransform (FRAME_X_DISPLAY (f), img->picture, &tmat); if (img->mask_picture) { XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->mask_picture, - FilterBest, 0, 0); + scale_down ? FilterBest : FilterNearest, 0, 0); XRenderSetPictureTransform (FRAME_X_DISPLAY (f), img->mask_picture, &tmat); } diff --git a/src/nsimage.m b/src/nsimage.m index 07750de95f..966e7044f1 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -199,6 +199,12 @@ Updated by Christian Limpach (chris@nice.ch) [(EmacsImage *)img setTransform:m]; } +void +ns_image_set_smoothing (void *img, bool smooth) +{ + [(EmacsImage *)img setSmoothing:smooth]; +} + unsigned long ns_get_pixel (void *img, int x, int y) { @@ -591,4 +597,10 @@ - (void)setTransform: (double[3][3]) m [transform setTransformStruct:tm]; } +- (void)setSmoothing: (BOOL) s +{ + smoothing = s; +} + + @end diff --git a/src/nsterm.h b/src/nsterm.h index 8d5371c8f2..a511fef5b9 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -640,6 +640,7 @@ typedef id instancetype; unsigned long xbm_fg; @public NSAffineTransform *transform; + BOOL smoothing; } + (instancetype)allocInitFromFile: (Lisp_Object)file; - (void)dealloc; @@ -658,6 +659,7 @@ typedef id instancetype; - (Lisp_Object)getMetadata; - (BOOL)setFrame: (unsigned int) index; - (void)setTransform: (double[3][3]) m; +- (void)setSmoothing: (BOOL)s; @end @@ -1200,6 +1202,7 @@ extern int ns_image_width (void *img); extern int ns_image_height (void *img); extern void ns_image_set_size (void *img, int width, int height); extern void ns_image_set_transform (void *img, double m[3][3]); +extern void ns_image_set_smoothing (void *img, bool smooth); extern unsigned long ns_get_pixel (void *img, int x, int y); extern void ns_put_pixel (void *img, int x, int y, unsigned long argb); extern void ns_set_alpha (void *img, int x, int y, unsigned char a); diff --git a/src/nsterm.m b/src/nsterm.m index df7f716f51..572b859a98 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -4043,10 +4043,22 @@ Function modeled after x_draw_glyph_string_box (). [doTransform concat]; + /* Smoothing is the default, so if we don't want smoothing we + have to turn it off. */ + if (! img->smoothing) + [[NSGraphicsContext currentContext] + setImageInterpolation:NSImageInterpolationNone]; + [img drawInRect:ir fromRect:ir operation:NSCompositingOperationSourceOver fraction:1.0 respectFlipped:YES hints:nil]; + /* Apparently image interpolation is not reset with + restoreGraphicsState, so we have to manually reset it. */ + if (! img->smoothing) + [[NSGraphicsContext currentContext] + setImageInterpolation:NSImageInterpolationDefault]; + [[NSGraphicsContext currentContext] restoreGraphicsState]; } commit 6e70b3793b9cb7730ab8a7132aa6e99f1ca13f98 Author: Lars Ingebrigtsen Date: Tue Aug 4 21:42:44 2020 +0200 When decrypting non-decrypted files, make epa show the raw files * lisp/epa-file.el (epa-file-insert-file-contents): When trying to decrypt a non-decrypted file, just show the bytes from the file instead (bug#3829). diff --git a/lisp/epa-file.el b/lisp/epa-file.el index 20043a9eae..bbd9279a9a 100644 --- a/lisp/epa-file.el +++ b/lisp/epa-file.el @@ -151,17 +151,25 @@ encryption is used." (nth 3 error))) (let ((exists (file-exists-p local-file))) (when exists - ;; Hack to prevent find-file from opening empty buffer - ;; when decryption failed (bug#6568). See the place - ;; where `find-file-not-found-functions' are called in - ;; `find-file-noselect-1'. - (setq-local epa-file-error error) - (add-hook 'find-file-not-found-functions - 'epa-file--find-file-not-found-function - nil t) - (epa-display-error context)) - (signal (if exists 'file-error 'file-missing) - (cons "Opening input file" (cdr error)))))) + (epa-display-error context) + ;; When the .gpg file isn't an encrypted file (e.g., + ;; it's a keyring.gpg file instead), then gpg will + ;; say "Unexpected exit" as the error message. In + ;; that case, just display the bytes. + (if (equal (caddr error) "Unexpected; Exit") + (setq string (with-temp-buffer + (insert-file-contents-literally local-file) + (buffer-string))) + ;; Hack to prevent find-file from opening empty buffer + ;; when decryption failed (bug#6568). See the place + ;; where `find-file-not-found-functions' are called in + ;; `find-file-noselect-1'. + (setq-local epa-file-error error) + (add-hook 'find-file-not-found-functions + 'epa-file--find-file-not-found-function + nil t) + (signal (if exists 'file-error 'file-missing) + (cons "Opening input file" (cdr error)))))))) (set-buffer buf) ;In case timer/filter changed/killed it (bug#16029)! (setq-local epa-file-encrypt-to (mapcar #'car (epg-context-result-for commit 9c967e7298cc4f0e6acbaf9b13755d674d9d460c Author: Arik Mitschang Date: Tue Aug 4 20:32:13 2020 +0200 Add options for mode modern ciphers in smime-encrypt-cipher * lisp/gnus/smime.el (smime-encrypt-cipher): Add support for more modern ciphers (bug#8474). Copyright-paperwork-exempt: yes diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index fe6daf6b03..5500148e51 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -185,6 +185,9 @@ and the files themselves should be in PEM format." :version "22.1" :type '(choice (const :tag "Triple DES" "-des3") (const :tag "DES" "-des") + (const :tag "AES 256 bits" "-aes256") + (const :tag "AES 192 bits" "-aes192") + (const :tag "AES 128 bits" "-aes128") (const :tag "RC2 40 bits" "-rc2-40") (const :tag "RC2 64 bits" "-rc2-64") (const :tag "RC2 128 bits" "-rc2-128")) commit fe2649528b0b7637e6b6851c41e696a1016d8d53 Author: Paul Eggert Date: Tue Aug 4 11:09:55 2020 -0700 Drop support for -fcheck-pointer-bounds GCC has removed the -fcheck-pointer bounds option, and the Linux kernel has also removed support for Intel MPX, so there’s no point to keeping this debugging option within Emacs. * src/bytecode.c (BYTE_CODE_THREADED): * src/lisp.h (DEFINE_LISP_SYMBOL, XSYMBOL, make_lisp_symbol): Assume __CHKP__ is not defined. * src/ptr-bounds.h: Remove. All uses of ptr_bounds_clip, ptr_bounds_copy, ptr_bounds_init, ptr_bounds_set removed. diff --git a/etc/NEWS b/etc/NEWS index cd5cc2c339..f135b3f6b3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -58,6 +58,11 @@ shaping, so 'configure' now recommends that combination. ** The ftx font backend driver has been removed. It was declared obsolete in Emacs 27.1. +--- +** Support for building with '-fcheck-pointer-bounds' has been removed. +GCC has withdrawn the '-fcheck-pointer-bounds' option and support for +its implementation has been removed from the Linux kernel. + --- ** Emacs no longer supports old OpenBSD systems. OpenBSD 5.3 and older releases are no longer supported, as they lack diff --git a/src/alloc.c b/src/alloc.c index 3a02ef3f8c..b16b2f8b93 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -34,7 +34,6 @@ along with GNU Emacs. If not, see . */ #include "bignum.h" #include "dispextern.h" #include "intervals.h" -#include "ptr-bounds.h" #include "puresize.h" #include "sheap.h" #include "sysstdio.h" @@ -1624,8 +1623,7 @@ static struct Lisp_String *string_free_list; a pointer to the `u.data' member of its sdata structure; the structure starts at a constant offset in front of that. */ -#define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \ - - SDATA_DATA_OFFSET)) +#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET)) #ifdef GC_CHECK_STRING_OVERRUN @@ -1799,7 +1797,7 @@ allocate_string (void) /* Every string on a free list should have NULL data pointer. */ s->u.s.data = NULL; NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = ptr_bounds_clip (s, sizeof *s); + string_free_list = s; } } @@ -1908,7 +1906,7 @@ allocate_string_data (struct Lisp_String *s, MALLOC_UNBLOCK_INPUT; - s->u.s.data = ptr_bounds_clip (SDATA_DATA (data), nbytes + 1); + s->u.s.data = SDATA_DATA (data); #ifdef GC_CHECK_STRING_BYTES SDATA_NBYTES (data) = nbytes; #endif @@ -2036,7 +2034,7 @@ sweep_strings (void) /* Put the string on the free-list. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = ptr_bounds_clip (s, sizeof *s); + string_free_list = s; ++nfree; } } @@ -2044,7 +2042,7 @@ sweep_strings (void) { /* S was on the free-list before. Put it there again. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = ptr_bounds_clip (s, sizeof *s); + string_free_list = s; ++nfree; } } @@ -2171,8 +2169,7 @@ compact_small_strings (void) { eassert (tb != b || to < from); memmove (to, from, size + GC_STRING_EXTRA); - to->string->u.s.data - = ptr_bounds_clip (SDATA_DATA (to), nbytes + 1); + to->string->u.s.data = SDATA_DATA (to); } /* Advance past the sdata we copied to. */ @@ -2959,7 +2956,6 @@ Lisp_Object zero_vector; static void setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes) { - v = ptr_bounds_clip (v, nbytes); eassume (header_size <= nbytes); ptrdiff_t nwords = (nbytes - header_size) / word_size; XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords); @@ -3307,7 +3303,7 @@ allocate_vectorlike (ptrdiff_t len, bool clearit) MALLOC_UNBLOCK_INPUT; - return ptr_bounds_clip (p, nbytes); + return p; } @@ -4461,7 +4457,6 @@ live_string_holding (struct mem_node *m, void *p) must not be on the free-list. */ if (0 <= offset && offset < sizeof b->strings) { - cp = ptr_bounds_copy (cp, b); struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; if (s->u.s.data) return s; @@ -4494,7 +4489,6 @@ live_cons_holding (struct mem_node *m, void *p) && (b != cons_block || offset / sizeof b->conses[0] < cons_block_index)) { - cp = ptr_bounds_copy (cp, b); struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; if (!deadp (s->u.s.car)) return s; @@ -4528,7 +4522,6 @@ live_symbol_holding (struct mem_node *m, void *p) && (b != symbol_block || offset / sizeof b->symbols[0] < symbol_block_index)) { - cp = ptr_bounds_copy (cp, b); struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; if (!deadp (s->u.s.function)) return s; @@ -5234,7 +5227,7 @@ pure_alloc (size_t size, int type) pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; if (pure_bytes_used <= pure_size) - return ptr_bounds_clip (result, size); + return result; /* Don't allocate a large amount here, because it might get mmap'd and then its address @@ -5325,7 +5318,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes) /* Check the remaining characters. */ if (memcmp (data, non_lisp_beg + start, nbytes) == 0) /* Found. */ - return ptr_bounds_clip (non_lisp_beg + start, nbytes + 1); + return non_lisp_beg + start; start += last_char_skip; } @@ -6049,7 +6042,6 @@ garbage_collect (void) stack_copy = xrealloc (stack_copy, stack_size); stack_copy_size = stack_size; } - stack = ptr_bounds_set (stack, stack_size); no_sanitize_memcpy (stack_copy, stack, stack_size); } } @@ -6885,8 +6877,7 @@ sweep_conses (void) for (pos = start; pos < stop; pos++) { - struct Lisp_Cons *acons - = ptr_bounds_copy (&cblk->conses[pos], cblk); + struct Lisp_Cons *acons = &cblk->conses[pos]; if (!XCONS_MARKED_P (acons)) { this_free++; @@ -6939,7 +6930,7 @@ sweep_floats (void) int this_free = 0; for (int i = 0; i < lim; i++) { - struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk); + struct Lisp_Float *afloat = &fblk->floats[i]; if (!XFLOAT_MARKED_P (afloat)) { this_free++; diff --git a/src/bytecode.c b/src/bytecode.c index 5ac30aa101..1913a4812a 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -24,7 +24,6 @@ along with GNU Emacs. If not, see . */ #include "character.h" #include "buffer.h" #include "keyboard.h" -#include "ptr-bounds.h" #include "syntax.h" #include "window.h" @@ -47,7 +46,7 @@ along with GNU Emacs. If not, see . */ indirect threaded, using GCC's computed goto extension. This code, as currently implemented, is incompatible with BYTE_CODE_SAFE and BYTE_CODE_METER. */ -#if (defined __GNUC__ && !defined __STRICT_ANSI__ && !defined __CHKP__ \ +#if (defined __GNUC__ && !defined __STRICT_ANSI__ \ && !BYTE_CODE_SAFE && !defined BYTE_CODE_METER) #define BYTE_CODE_THREADED #endif @@ -368,14 +367,12 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, USE_SAFE_ALLOCA; void *alloc; SAFE_ALLOCA_LISP_EXTRA (alloc, stack_items, bytestr_length); - ptrdiff_t item_bytes = stack_items * word_size; - Lisp_Object *stack_base = ptr_bounds_clip (alloc, item_bytes); + Lisp_Object *stack_base = alloc; Lisp_Object *top = stack_base; *top = vector; /* Ensure VECTOR survives GC (Bug#33014). */ Lisp_Object *stack_lim = stack_base + stack_items; - unsigned char *bytestr_data = alloc; - bytestr_data = ptr_bounds_clip (bytestr_data + item_bytes, bytestr_length); - memcpy (bytestr_data, SDATA (bytestr), bytestr_length); + unsigned char const *bytestr_data = memcpy (stack_lim, + SDATA (bytestr), bytestr_length); unsigned char const *pc = bytestr_data; ptrdiff_t count = SPECPDL_INDEX (); diff --git a/src/callint.c b/src/callint.c index eb916353a0..f609c96a6f 100644 --- a/src/callint.c +++ b/src/callint.c @@ -21,7 +21,6 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" -#include "ptr-bounds.h" #include "character.h" #include "buffer.h" #include "keyboard.h" @@ -440,9 +439,6 @@ invoke it (via an `interactive' spec that contains, for instance, an signed char *varies = (signed char *) (visargs + nargs); memclear (args, nargs * (2 * word_size + 1)); - args = ptr_bounds_clip (args, nargs * sizeof *args); - visargs = ptr_bounds_clip (visargs, nargs * sizeof *visargs); - varies = ptr_bounds_clip (varies, nargs * sizeof *varies); if (!NILP (enable)) specbind (Qenable_recursive_minibuffers, Qt); diff --git a/src/dispnew.c b/src/dispnew.c index 1ae59e3ff2..d318e26308 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -25,7 +25,6 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" -#include "ptr-bounds.h" #include "termchar.h" /* cm.h must come after dispextern.h on Windows. */ #include "dispextern.h" @@ -4891,12 +4890,6 @@ scrolling (struct frame *frame) unsigned *new_hash = old_hash + height; int *draw_cost = (int *) (new_hash + height); int *old_draw_cost = draw_cost + height; - old_hash = ptr_bounds_clip (old_hash, height * sizeof *old_hash); - new_hash = ptr_bounds_clip (new_hash, height * sizeof *new_hash); - draw_cost = ptr_bounds_clip (draw_cost, height * sizeof *draw_cost); - old_draw_cost = ptr_bounds_clip (old_draw_cost, - height * sizeof *old_draw_cost); - eassert (current_matrix); /* Compute hash codes of all the lines. Also calculate number of diff --git a/src/editfns.c b/src/editfns.c index 763d95bb8f..cb09ea8a31 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -46,7 +46,6 @@ along with GNU Emacs. If not, see . */ #include "composite.h" #include "intervals.h" -#include "ptr-bounds.h" #include "systime.h" #include "character.h" #include "buffer.h" @@ -3131,8 +3130,6 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) string was not copied into the output. It is 2 if byte I was not the first byte of its character. */ char *discarded = (char *) &info[nspec_bound]; - info = ptr_bounds_clip (info, info_size); - discarded = ptr_bounds_clip (discarded, formatlen); memset (discarded, 0, formatlen); /* Try to determine whether the result should be multibyte. diff --git a/src/emacs.c b/src/emacs.c index 8a6bb3ad22..8e5eaf5e43 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -83,7 +83,6 @@ along with GNU Emacs. If not, see . */ #include "charset.h" #include "composite.h" #include "dispextern.h" -#include "ptr-bounds.h" #include "regex-emacs.h" #include "sheap.h" #include "syntax.h" diff --git a/src/frame.c b/src/frame.c index c871e4fd99..c21d4708f7 100644 --- a/src/frame.c +++ b/src/frame.c @@ -35,7 +35,6 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" /* These help us bind and responding to switch-frame events. */ #include "keyboard.h" -#include "ptr-bounds.h" #include "frame.h" #include "blockinput.h" #include "termchar.h" @@ -5019,8 +5018,6 @@ gui_display_get_resource (Display_Info *dpyinfo, Lisp_Object attribute, USE_SAFE_ALLOCA; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; - name_key = ptr_bounds_clip (name_key, name_keysize); - class_key = ptr_bounds_clip (class_key, class_keysize); /* Start with emacs.FRAMENAME for the name (the specific one) and with `Emacs' for the class key (the general one). */ @@ -5091,9 +5088,6 @@ x_get_resource_string (const char *attribute, const char *class) ptrdiff_t class_keysize = sizeof (EMACS_CLASS) - 1 + strlen (class) + 2; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; - name_key = ptr_bounds_clip (name_key, name_keysize); - class_key = ptr_bounds_clip (class_key, class_keysize); - esprintf (name_key, "%s.%s", SSDATA (Vinvocation_name), attribute); sprintf (class_key, "%s.%s", EMACS_CLASS, class); diff --git a/src/fringe.c b/src/fringe.c index fc4c738dc2..c3d64fefc8 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -23,7 +23,6 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "frame.h" -#include "ptr-bounds.h" #include "window.h" #include "dispextern.h" #include "buffer.h" @@ -1607,9 +1606,7 @@ If BITMAP already exists, the existing definition is replaced. */) fb.dynamic = true; xfb = xmalloc (sizeof fb + fb.height * BYTES_PER_BITMAP_ROW); - fb.bits = b = ((unsigned short *) - ptr_bounds_clip (xfb + 1, fb.height * BYTES_PER_BITMAP_ROW)); - xfb = ptr_bounds_clip (xfb, sizeof *xfb); + fb.bits = b = (unsigned short *) (xfb + 1); j = 0; while (j < fb.height) diff --git a/src/gmalloc.c b/src/gmalloc.c index 8450a639e7..3560c74453 100644 --- a/src/gmalloc.c +++ b/src/gmalloc.c @@ -38,8 +38,6 @@ License along with this library. If not, see . #include "lisp.h" -#include "ptr-bounds.h" - #ifdef HAVE_MALLOC_H # if GNUC_PREREQ (4, 2, 0) # pragma GCC diagnostic ignored "-Wdeprecated-declarations" @@ -200,8 +198,7 @@ extern size_t _bytes_free; /* Internal versions of `malloc', `realloc', and `free' used when these functions need to call each other. - They are the same but don't call the hooks - and don't bound the resulting pointers. */ + They are the same but don't call the hooks. */ extern void *_malloc_internal (size_t); extern void *_realloc_internal (void *, size_t); extern void _free_internal (void *); @@ -551,7 +548,7 @@ malloc_initialize_1 (void) _heapinfo[0].free.size = 0; _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; _heapindex = 0; - _heapbase = (char *) ptr_bounds_init (_heapinfo); + _heapbase = (char *) _heapinfo; _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info)); register_heapinfo (); @@ -912,8 +909,7 @@ malloc (size_t size) among multiple threads. We just leave it for compatibility with glibc malloc (i.e., assignments to gmalloc_hook) for now. */ hook = gmalloc_hook; - void *result = (hook ? hook : _malloc_internal) (size); - return ptr_bounds_clip (result, size); + return (hook ? hook : _malloc_internal) (size); } #if !(defined (_LIBC) || defined (HYBRID_MALLOC)) @@ -991,7 +987,6 @@ _free_internal_nolock (void *ptr) if (ptr == NULL) return; - ptr = ptr_bounds_init (ptr); PROTECT_MALLOC_STATE (0); @@ -1303,7 +1298,6 @@ _realloc_internal_nolock (void *ptr, size_t size) else if (ptr == NULL) return _malloc_internal_nolock (size); - ptr = ptr_bounds_init (ptr); block = BLOCK (ptr); PROTECT_MALLOC_STATE (0); @@ -1426,8 +1420,7 @@ realloc (void *ptr, size_t size) return NULL; hook = grealloc_hook; - void *result = (hook ? hook : _realloc_internal) (ptr, size); - return ptr_bounds_clip (result, size); + return (hook ? hook : _realloc_internal) (ptr, size); } /* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. @@ -1601,7 +1594,6 @@ aligned_alloc (size_t alignment, size_t size) { l->exact = result; result = l->aligned = (char *) result + adj; - result = ptr_bounds_clip (result, size); } UNLOCK_ALIGNED_BLOCKS (); if (l == NULL) diff --git a/src/lisp.h b/src/lisp.h index 22ddf3e5fa..17b92a0414 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -893,8 +893,8 @@ verify (GCALIGNED (struct Lisp_Symbol)); convert it to a Lisp_Word. */ #if LISP_WORDS_ARE_POINTERS /* untagged_ptr is a pointer so that the compiler knows that TAG_PTR - yields a pointer; this can help with gcc -fcheck-pointer-bounds. - It is char * so that adding a tag uses simple machine addition. */ + yields a pointer. It is char * so that adding a tag uses simple + machine addition. */ typedef char *untagged_ptr; typedef uintptr_t Lisp_Word_tag; #else @@ -922,13 +922,9 @@ typedef EMACS_UINT Lisp_Word_tag; when using a debugger like GDB, on older platforms where the debug format does not represent C macros. However, they are unbounded and would just be asking for trouble if checking pointer bounds. */ -#ifdef __CHKP__ -# define DEFINE_LISP_SYMBOL(name) -#else -# define DEFINE_LISP_SYMBOL(name) \ - DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ - DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) -#endif +#define DEFINE_LISP_SYMBOL(name) \ + DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ + DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) /* The index of the C-defined Lisp symbol SYM. This can be used in a static initializer. */ @@ -1002,30 +998,15 @@ XSYMBOL (Lisp_Object a) eassert (SYMBOLP (a)); intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); void *p = (char *) lispsym + i; -#ifdef __CHKP__ - /* Bypass pointer checking. Although this could be improved it is - probably not worth the trouble. */ - p = __builtin___bnd_set_ptr_bounds (p, sizeof (struct Lisp_Symbol)); -#endif return p; } INLINE Lisp_Object make_lisp_symbol (struct Lisp_Symbol *sym) { -#ifdef __CHKP__ - /* Although '__builtin___bnd_narrow_ptr_bounds (sym, sym, sizeof *sym)' - should be more efficient, it runs afoul of GCC bug 83251 - . - Also, attempting to call __builtin___bnd_chk_ptr_bounds (sym, sizeof *sym) - here seems to trigger a GCC bug, as yet undiagnosed. */ - char *addr = __builtin___bnd_set_ptr_bounds (sym, sizeof *sym); - char *symoffset = addr - (intptr_t) lispsym; -#else - /* If !__CHKP__, GCC 7 x86-64 generates faster code if lispsym is + /* GCC 7 x86-64 generates faster code if lispsym is cast to char * rather than to intptr_t. */ char *symoffset = (char *) ((char *) sym - (char *) lispsym); -#endif Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); eassert (XSYMBOL (a) == sym); return a; diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h deleted file mode 100644 index 22d49f25b6..0000000000 --- a/src/ptr-bounds.h +++ /dev/null @@ -1,79 +0,0 @@ -/* Pointer bounds checking for GNU Emacs - -Copyright 2017-2020 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 . */ - -/* Pointer bounds checking is a no-op unless running on hardware - supporting Intel MPX (Intel Skylake or better). Also, it requires - GCC 5 and Linux kernel 3.19, or later. Configure with - CFLAGS='-fcheck-pointer-bounds -mmpx', perhaps with - -fchkp-first-field-has-own-bounds thrown in. - - Although pointer bounds checking can help during debugging, it is - disabled by default because it hurts performance significantly. - The checking does not detect all pointer errors. For example, a - dumped Emacs might not detect a bounds violation of a pointer that - was created before Emacs was dumped. */ - -#ifndef PTR_BOUNDS_H -#define PTR_BOUNDS_H - -#include - -/* When not checking pointer bounds, the following macros simply - return their first argument. These macros return either void *, or - the same type as their first argument. */ - -INLINE_HEADER_BEGIN - -/* Return a copy of P, with bounds narrowed to [P, P + N). */ -#ifdef __CHKP__ -INLINE void * -ptr_bounds_clip (void const *p, size_t n) -{ - return __builtin___bnd_narrow_ptr_bounds (p, p, n); -} -#else -# define ptr_bounds_clip(p, n) ((void) (size_t) {n}, p) -#endif - -/* Return a copy of P, but with the bounds of Q. */ -#ifdef __CHKP__ -# define ptr_bounds_copy(p, q) __builtin___bnd_copy_ptr_bounds (p, q) -#else -# define ptr_bounds_copy(p, q) ((void) (void const *) {q}, p) -#endif - -/* Return a copy of P, but with infinite bounds. - This is a loophole in pointer bounds checking. */ -#ifdef __CHKP__ -# define ptr_bounds_init(p) __builtin___bnd_init_ptr_bounds (p) -#else -# define ptr_bounds_init(p) (p) -#endif - -/* Return a copy of P, but with bounds [P, P + N). - This is a loophole in pointer bounds checking. */ -#ifdef __CHKP__ -# define ptr_bounds_set(p, n) __builtin___bnd_set_ptr_bounds (p, n) -#else -# define ptr_bounds_set(p, n) ((void) (size_t) {n}, p) -#endif - -INLINE_HEADER_END - -#endif /* PTR_BOUNDS_H */ commit 1308587c25cc28248c3d38748f76bb9e6324b929 Author: Lars Ingebrigtsen Date: Tue Aug 4 19:50:37 2020 +0200 Ignore test/data/mml-sec/random_seed The file is generated when mml-sec-tests is run. diff --git a/.gitignore b/.gitignore index 890e63a431..d69a40af8c 100644 --- a/.gitignore +++ b/.gitignore @@ -152,6 +152,7 @@ test/manual/etags/regexfile test/manual/etags/ETAGS test/manual/etags/CTAGS test/manual/indent/*.new +test/data/mml-sec/random_seed # ctags, etags. TAGS commit cc41b36af9372e6396d10198bbf286b49d8a5255 Author: Lars Ingebrigtsen Date: Tue Aug 4 19:48:12 2020 +0200 Remove mistakenly checked-in random_seed file diff --git a/test/data/mml-sec/random_seed b/test/data/mml-sec/random_seed deleted file mode 100644 index 530fd76c1e..0000000000 Binary files a/test/data/mml-sec/random_seed and /dev/null differ commit 34229d3915f3205324eeab1ade37bb5eccc468b1 Author: Lars Ingebrigtsen Date: Tue Aug 4 19:47:06 2020 +0200 Tweak mml-sec test that sometimes fails * test/lisp/gnus/mml-sec-tests.el (mml-first-secure-en-decrypt-sign-1): mml-secure-en-decrypt-sign-1 fail sometimes, on some machines, unless it's the first test. I'm guessing there's a race condition somewhere in the test, but put it first now to avoid build reports. diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el index 28be3b9bd4..50bb6e6b27 100644 --- a/test/lisp/gnus/mml-sec-tests.el +++ b/test/lisp/gnus/mml-sec-tests.el @@ -606,7 +606,7 @@ In this test, encrypt-to-self variables are set to lists." (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") (cons "F7E79AB7AE31D471" "4035D59B5F88E9FC")))))) -(ert-deftest mml-secure-en-decrypt-sign-1 () +(ert-deftest mml-first-secure-en-decrypt-sign-1 () "Sign and encrypt message; then decrypt and test for expected result. In this test, just multiple encryption and signing keys may be available." (mml-secure-test-key-fixture commit 0c6d2f0ff51eb24938f4af4116855b5facee9d24 Author: Jens Lechtenbörger Date: Tue Aug 4 19:28:41 2020 +0200 Add tests for mml-sec.el diff --git a/test/data/mml-sec/.gpg-v21-migrated b/test/data/mml-sec/.gpg-v21-migrated new file mode 100644 index 0000000000..e69de29bb2 diff --git a/test/data/mml-sec/gpg-agent.conf b/test/data/mml-sec/gpg-agent.conf new file mode 100644 index 0000000000..20192990ca --- /dev/null +++ b/test/data/mml-sec/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/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 0000000000..58fd0b5edb Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key 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 0000000000..62f4ab25a6 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key 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 0000000000..2a8ce135fb Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key 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 0000000000..9f8de71c5e Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key 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 0000000000..6e4a4e548f Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key 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 0000000000..cff58edaa8 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key 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 0000000000..14af8662f7 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key 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 0000000000..207a7237d3 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key 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 0000000000..85ca78da04 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key 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 0000000000..79f3cd2b84 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key 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 0000000000..776ddf7e9e Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key 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 0000000000..2b464f0ccb Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key 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 0000000000..28a07668b2 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key 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 0000000000..137659693b Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key 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 0000000000..c99824ccd4 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key 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 0000000000..49c2dc58bd Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key 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 0000000000..ca12840895 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key 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 0000000000..3f14b40927 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key 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 0000000000..06adc06c42 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key 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 0000000000..cf9a60d233 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key 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 0000000000..0ed35172fe Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key 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 0000000000..090059d9e8 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key 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 0000000000..9061f67512 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key 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 0000000000..89f6013100 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key 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 0000000000..41dac37574 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key 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 0000000000..5df7b4a595 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key 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 0000000000..03daf80975 Binary files /dev/null and b/test/data/mml-sec/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key differ diff --git a/test/data/mml-sec/pubring.gpg b/test/data/mml-sec/pubring.gpg new file mode 100644 index 0000000000..6bd169963d Binary files /dev/null and b/test/data/mml-sec/pubring.gpg differ diff --git a/test/data/mml-sec/pubring.kbx b/test/data/mml-sec/pubring.kbx new file mode 100644 index 0000000000..399a0414fd Binary files /dev/null and b/test/data/mml-sec/pubring.kbx differ diff --git a/test/data/mml-sec/random_seed b/test/data/mml-sec/random_seed new file mode 100644 index 0000000000..530fd76c1e Binary files /dev/null and b/test/data/mml-sec/random_seed differ diff --git a/test/data/mml-sec/secring.gpg b/test/data/mml-sec/secring.gpg new file mode 100644 index 0000000000..b323c072c0 Binary files /dev/null and b/test/data/mml-sec/secring.gpg differ diff --git a/test/data/mml-sec/trustdb.gpg b/test/data/mml-sec/trustdb.gpg new file mode 100644 index 0000000000..09ebd8db11 Binary files /dev/null and b/test/data/mml-sec/trustdb.gpg differ diff --git a/test/data/mml-sec/trustlist.txt b/test/data/mml-sec/trustlist.txt new file mode 100644 index 0000000000..f886572d28 --- /dev/null +++ b/test/data/mml-sec/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 0000000000..28be3b9bd4 --- /dev/null +++ b/test/lisp/gnus/mml-sec-tests.el @@ -0,0 +1,859 @@ +;;; gnustest-mml-sec.el --- Tests mml-sec.el, see README-mml-secure.txt. +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Jens Lechtenbörger + +;; This file is not part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(require 'message) +(require 'epa) +(require 'epg) +(require 'mml-sec) +(require 'gnus-sum) + +(defvar with-smime nil + "If nil, exclude S/MIME from tests as passphrases need to entered manually. +Mostly, the empty passphrase is used. However, the keys for + \"No Expiry two UIDs\" have the passphrase \"Passphrase\" (for OpenPGP as well + as S/MIME).") + +(defun enc-standards () + (if with-smime '(enc-pgp enc-pgp-mime enc-smime) + '(enc-pgp enc-pgp-mime))) +(defun enc-sign-standards () + (if with-smime + '(enc-sign-pgp enc-sign-pgp-mime enc-sign-smime) + '(enc-sign-pgp enc-sign-pgp-mime))) +(defun sign-standards () + (if with-smime + '(sign-pgp sign-pgp-mime sign-smime) + '(sign-pgp sign-pgp-mime))) + +(defun mml-secure-test-fixture (body &optional interactive) + "Setup GnuPG home containing test keys and prepare environment for BODY. +If optional INTERACTIVE is non-nil, allow questions to the user in case of +key problems. +This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests, +which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess. +Actually, I'm not sure why people would want to cache passwords in Emacs +instead of gpg-agent." + (unwind-protect + (let ((agent-info (getenv "GPG_AGENT_INFO")) + (gpghome (getenv "GNUPGHOME"))) + (condition-case error + (let ((epg-gpg-home-directory + (expand-file-name "test/data/mml-sec" source-directory)) + (mml-secure-allow-signing-with-unknown-recipient t) + (mml-smime-use 'epg) + ;; Create debug output in empty epg-debug-buffer. + (epg-debug t) + (epg-debug-buffer (get-buffer-create " *epg-test*")) + (mml-secure-fail-when-key-problem (not interactive))) + (with-current-buffer epg-debug-buffer + (erase-buffer)) + ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs. + ;; Just for testing. Jens does not recommend this for daily use. + (setenv "GPG_AGENT_INFO") + ;; Set GNUPGHOME as gpg-agent started by gpgsm does + ;; not look in the proper places otherwise, see: + ;; https://bugs.gnupg.org/gnupg/issue2126 + (setenv "GNUPGHOME" epg-gpg-home-directory) + (funcall body)) + (error + (setenv "GPG_AGENT_INFO" agent-info) + (setenv "GNUPGHOME" gpghome) + (signal (car error) (cdr error)))) + (setenv "GPG_AGENT_INFO" agent-info) + (setenv "GNUPGHOME" gpghome)))) + +(defun mml-secure-test-message-setup (method to from &optional text bcc) + "Setup a buffer with MML METHOD, TO, and FROM headers. +Optionally, a message TEXT and BCC header can be passed." + (with-temp-buffer + (when bcc (insert (format "Bcc: %s\n" bcc))) + (insert (format "To: %s +From: %s +Subject: Test +%s\n" to from mail-header-separator)) + (if text + (insert (format "%s" text)) + (spook)) + (cond ((eq method 'enc-pgp-mime) + (mml-secure-message-encrypt-pgpmime 'nosig)) + ((eq method 'enc-sign-pgp-mime) + (mml-secure-message-encrypt-pgpmime)) + ((eq method 'enc-pgp) (mml-secure-message-encrypt-pgp 'nosig)) + ((eq method 'enc-sign-pgp) (mml-secure-message-encrypt-pgp)) + ((eq method 'enc-smime) (mml-secure-message-encrypt-smime 'nosig)) + ((eq method 'enc-sign-smime) (mml-secure-message-encrypt-smime)) + ((eq method 'sign-pgp-mime) (mml-secure-message-sign-pgpmime)) + ((eq method 'sign-pgp) (mml-secure-message-sign-pgp)) + ((eq method 'sign-smime) (mml-secure-message-sign-smime)) + (t (error "Unknown method"))) + (buffer-string))) + +(defun mml-secure-test-mail-fixture (method to from body2 + &optional interactive) + "Setup buffer encrypted using METHOD for TO from FROM, call BODY2. +Pass optional INTERACTIVE to mml-secure-test-fixture." + (mml-secure-test-fixture + (lambda () + (let ((context (if (memq method '(enc-smime enc-sign-smime sign-smime)) + (epg-make-context 'CMS) + (epg-make-context 'OpenPGP))) + ;; Verify and decrypt by default. + (mm-verify-option 'known) + (mm-decrypt-option 'known) + (plaintext "The Magic Words are Squeamish Ossifrage")) + (with-temp-buffer + (insert (mml-secure-test-message-setup method to from plaintext)) + (message-options-set-recipient) + (message-encode-message-body) + ;; Replace separator line with newline. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + ;; The following treatment of handles, plainbuf, and multipart + ;; resulted from trial-and-error. + ;; Someone with more knowledge on how to decrypt messages and verify + ;; signatures might know more appropriate functions to invoke + ;; instead. + (let* ((handles (or (mm-dissect-buffer) + (mm-uu-dissect))) + (isplain (bufferp (car handles))) + (ismultipart (equal (car handles) "multipart/mixed")) + (plainbuf (if isplain + (car handles) + (if ismultipart + (car (cadadr handles)) + (caadr handles)))) + (decrypted + (with-current-buffer plainbuf (buffer-string))) + (gnus-info + (if isplain + nil + (if ismultipart + (or (mm-handle-multipart-ctl-parameter + (cadr handles) 'gnus-details) + (mm-handle-multipart-ctl-parameter + (cadr handles) 'gnus-info)) + (mm-handle-multipart-ctl-parameter + handles 'gnus-info))))) + (funcall body2 gnus-info plaintext decrypted))))) + interactive)) + +;; TODO If the variable BODY3 is renamed to BODY, an infinite recursion +;; occurs. Emacs bug? +(defun mml-secure-test-key-fixture (body3) + "Customize unique keys for sub@example.org and call BODY3. +For OpenPGP, we have: +- 1E6B FA97 3D9E 3103 B77F D399 C399 9CF1 268D BEA2 + uid Different subkeys +- 1463 2ECA B9E2 2736 9C8D D97B F7E7 9AB7 AE31 D471 + uid Second Key Pair + +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." + (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." + (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 "" 'encrypt)) + (should-not + (mml-secure-find-usable-keys + context "" '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." + (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 "" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "" '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 " 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "No Expiry " '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." + (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." + (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." + (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." + (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 (trust undefined) created ..." + ;; S/MIME: "Good signature from D06AA118653CC38E9D0CAF56ED7A2135E1582177 /CN=No Expiry (trust full) ..." + (should (string-match-p + (concat "Good signature from " + (if (eq protocol 'CMS) + fpr + (substring fpr -16 nil))) + gnus-info))))) + (when enc-keys + (with-current-buffer epg-debug-buffer + (goto-char (point-min)) + ;; The following regexp does not necessarily match at the + ;; start of the line as a path may or may not be present. + ;; Also note that gpg.* matches gpg2 and gpgsm as well. + (let* ((line (concat "gpg.*--encrypt.*$")) + (end (re-search-forward line)) + (match (match-string 0))) + (should (and end match)) + (dolist (pair enc-keys nil) + (let ((fpr (if (eq protocol 'OpenPGP) + (car pair) + (cdr pair)))) + (should (string-match-p (concat "-r " fpr) match)))) + (goto-char (point-max)) + )))))) + interactive)) + +(defun mml-secure-test-en-decrypt-with-passphrase + (method to from checksig jl-passphrase do-cache + &optional enc-keys expectfail) + "Call mml-secure-test-en-decrypt with changed passphrase caching. +Args METHOD, TO, FROM, CHECKSIG are passed to mml-secure-test-en-decrypt. +JL-PASSPHRASE is fixed as return value for `read-passwd', +boolean DO-CACHE determines whether to cache the passphrase. +If optional ENC-KEYS is non-nil, it is a list of encryption keys expected +in `epg-debug-buffer'. +If optional EXPECTFAIL is non-nil, a decryption failure is expected." + (let ((mml-secure-cache-passphrase do-cache) + (mml1991-cache-passphrase do-cache) + (mml2015-cache-passphrase do-cache) + (mml-smime-cache-passphrase do-cache) + ) + (cl-letf (((symbol-function 'read-passwd) + (lambda (prompt &optional confirm default) jl-passphrase))) + (mml-secure-test-en-decrypt method to from checksig t enc-keys expectfail) + ))) + +(ert-deftest mml-secure-en-decrypt-1 () + "Encrypt message; then decrypt and test for expected result. +In this test, the single matching key is chosen automatically." + (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." + ;; 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." + ;; 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." + ;; 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 () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + (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) + ) + + ;; 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) + ))) + + ;; 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." + (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." + (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." + (mml-secure-test-key-fixture + (lambda () + (dolist (method (sign-standards) nil) + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + ;; A single signing key for sender sub@example.org is customized + ;; in the fixture. + (mml-secure-test-en-decrypt + method "uid1@example.org" "sub@example.org" 1 nil) + + ;; From sub@example.org, sign with two keys; + ;; sign-with-sender and one from signers-variable: + (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) + (mml-secure-smime-signers + '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 nil)) + ))))) + +(ert-deftest mml-secure-sign-verify-2 () + "Sign message without sender; then verify and test for expected result." + (mml-secure-test-key-fixture + (lambda () + (dolist (method (sign-standards) nil) + (let ((mml-secure-openpgp-sign-with-sender nil) + (mml-secure-smime-sign-with-sender nil)) + ;; A single signing key for sender sub@example.org is customized + ;; in the fixture, but not used here. + ;; By default, gpg uses the first secret key in the keyring, which + ;; is 02372A42CA6D40FB (OpenPGP) or + ;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here. + (mml-secure-test-en-decrypt + method "uid1@example.org" "sub@example.org" 0 nil) + + ;; From sub@example.org, sign with specified key: + (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) + (mml-secure-smime-signers + '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 1 nil)) + + ;; From sub@example.org, sign with different specified key: + (let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2")) + (mml-secure-smime-signers + '("0E58229B80EE33959FF718FEEF25402B479DC6E2"))) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 1 nil)) + ))))) + +(ert-deftest mml-secure-sign-verify-3 () + "Try to sign message with expired OpenPGP subkey, which raises an error. +With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." + (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." + (ert-skip "Requires passphrase") + (mml-secure-test-key-fixture + (lambda () + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + ;; Beware! For passphrases copy-sequence is necessary, as they may + ;; be erased, which actually changes the function's code and causes + ;; multiple invokations to fail. I was surprised... + (copy-sequence "Passphrase") t) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Incorrect") t))))) + +(defun mml-secure-en-decrypt-passphrase-no-cache (method) + "Encrypt message with METHOD; then decrypt and test for expected result. +In this test, a key is used that requires the passphrase \"Passphrase\". +In the first decryption this passphrase is hardcoded, but caching disabled. +So the second decryption fails." + (mml-secure-test-key-fixture + (lambda () + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Passphrase") nil) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Incorrect") nil nil t)))) + +(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-openpgp-todo () + "Passphrase caching with OpenPGP only for GnuPG 1.x." + (skip-unless (string< (cdr (assq 'version (epg-configuration))) "2")) + (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp) + (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp-mime)) + +(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-smime-todo () + "Passphrase caching does not work with S/MIME (and gpgsm)." + :expected-result :failed + (if with-smime + (mml-secure-en-decrypt-passphrase-no-cache 'enc-smime) + (should nil))) + + +;; Test truncation of question in y-or-n-p. +(defun mml-secure-select-preferred-keys-todo () + "Manual customization with truncated question." + (mml-secure-test-key-fixture + (lambda () + (mml-secure-test-en-decrypt + 'enc-pgp-mime + "jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de" + "no-exp@example.org" nil t nil nil t)))) + +(defun mml-secure-select-preferred-keys-ok () + "Manual customization with entire question." + (mml-secure-test-fixture + (lambda () + (mml-secure-select-preferred-keys + (epg-make-context 'OpenPGP) + '("jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de") + 'encrypt)) + t)) + + +;; ERT entry points +(defun mml-secure-run-tests () + "Run all tests with defaults." + (ert-run-tests-batch)) + +(defun mml-secure-run-tests-with-gpg2 () + "Run all tests with gpg2 instead of gpg." + (let* ((epg-gpg-program "gpg2"); ~/local/gnupg-2.1.9/PLAY/inst/bin/gpg2 + (gpg-version (cdr (assq 'version (epg-configuration)))) + ;; Empty passphrases do not seem to work with gpgsm in 2.1.x: + ;; https://lists.gnupg.org/pipermail/gnupg-users/2015-October/054575.html + (with-smime (string< gpg-version "2.1"))) + (ert-run-tests-batch))) + +(defun mml-secure-run-tests-without-smime () + "Skip S/MIME tests (as they require manual passphrase entry)." + (let ((with-smime nil)) + (ert-run-tests-batch))) + +;;; gnustest-mml-sec.el ends here commit 59243e9f18a247bddd91ed704c8e3234383ed414 Author: Lars Ingebrigtsen Date: Tue Aug 4 19:26:04 2020 +0200 Fix two mml-sec minor bugs revealed by new test harness * lisp/gnus/mml-sec.el (mml-secure-allow-signing-with-unknown-recipient): New variable (bug#18393) (but this should probably be fixed in a different way). (mml-secure-epg-sign): Use it. (mml-secure-check-user-id): Protect against recipients that aren't email addresses, like "No recipient". diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 740e1d2b72..69852c381d 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -665,8 +665,9 @@ The passphrase is read and cached." (epg-user-id-string uid)))) (equal (downcase (car (mail-header-parse-address (epg-user-id-string uid)))) - (downcase (car (mail-header-parse-address - recipient)))) + (downcase (or (car (mail-header-parse-address + recipient)) + recipient))) (not (memq (epg-user-id-validity uid) '(revoked expired)))) (throw 'break t)))))) @@ -937,6 +938,10 @@ If no one is selected, symmetric encryption will be performed. " (signal (car error) (cdr error)))) cipher)) +;; Should probably be removed and the interface should be different. +(defvar mml-secure-allow-signing-with-unknown-recipient nil + "Variable to bind to allow automatic recipient selection.") + (defun mml-secure-epg-sign (protocol mode) ;; Based on code appearing inside mml2015-epg-sign. (let* ((context (epg-make-context protocol)) @@ -953,7 +958,8 @@ If no one is selected, symmetric encryption will be performed. " ;; then there's no point advising the user to examine it. If ;; there are any other variables worth examining, please ;; improve this error message by having it mention them. - (error "Couldn't find any signer names%s" maybe-msg))) + (unless mml-secure-allow-signing-with-unknown-recipient + (error "Couldn't find any signer names%s" maybe-msg)))) (when (eq 'OpenPGP protocol) (setf (epg-context-armor context) t) (setf (epg-context-textmode context) t) commit fbfa70f486522e1b752ebf3d8590375508ea2a55 Author: Lars Ingebrigtsen Date: Tue Aug 4 18:53:47 2020 +0200 Add test file lost when merged from Gnus in 2016 diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el new file mode 100644 index 0000000000..b01e2fc296 --- /dev/null +++ b/test/lisp/gnus/gnus-util-tests.el @@ -0,0 +1,76 @@ +;;; gnus-util-tests.el --- Selectived tests only. +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Jens Lechtenbörger + +;; This file is not part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'gnus-util) + +(ert-deftest gnus-subsetp () + ;; False for non-lists. + (should-not (gnus-subsetp "1" "1")) + (should-not (gnus-subsetp "1" '("1"))) + (should-not (gnus-subsetp '("1") "1")) + + ;; Real tests. + (should (gnus-subsetp '() '())) + (should (gnus-subsetp '() '("1"))) + (should (gnus-subsetp '("1") '("1"))) + (should (gnus-subsetp '(42) '("1" 42))) + (should (gnus-subsetp '(42) '(42 "1"))) + (should (gnus-subsetp '(42) '("1" 42 2))) + (should-not (gnus-subsetp '("1") '())) + (should-not (gnus-subsetp '("1") '(2))) + (should-not (gnus-subsetp '("1" 2) '(2))) + (should-not (gnus-subsetp '(2 "1") '(2))) + (should-not (gnus-subsetp '("1" 2) '(2 3))) + + ;; Duplicates don't matter for sets. + (should (gnus-subsetp '("1" "1") '("1"))) + (should (gnus-subsetp '("1" 2 "1") '(2 "1"))) + (should (gnus-subsetp '("1" 2 "1") '(2 "1" "1" 2))) + (should-not (gnus-subsetp '("1" 2 "1" 3) '(2 "1" "1" 2)))) + +(ert-deftest gnus-setdiff () + ;; False for non-lists. + (should-not (gnus-setdiff "1" "1")) + (should-not (gnus-setdiff "1" '())) + (should-not (gnus-setdiff '() "1")) + + ;; Real tests. + (should-not (gnus-setdiff '() '())) + (should-not (gnus-setdiff '() '("1"))) + (should-not (gnus-setdiff '("1") '("1"))) + (should (equal '("1") (gnus-setdiff '("1") '()))) + (should (equal '("1") (gnus-setdiff '("1") '(2)))) + (should (equal '("1") (gnus-setdiff '("1" 2) '(2)))) + (should (equal '("1") (gnus-setdiff '("1" 2 3) '(3 2)))) + (should (equal '("1") (gnus-setdiff '(2 "1" 3) '(3 2)))) + (should (equal '("1") (gnus-setdiff '(2 3 "1") '(3 2)))) + (should (equal '(2 "1") (gnus-setdiff '(2 3 "1") '(3)))) + + ;; Duplicates aren't touched for sets if they are not removed. + (should-not (gnus-setdiff '("1" "1") '("1"))) + (should (equal '("1") (gnus-setdiff '(2 "1" 2) '(2)))) + (should (equal '("1" "1") (gnus-setdiff '(2 "1" 2 "1") '(2))))) + +;;; gnustest-gnus-util.el ends here commit 9eb04d87409db48ce63ef5d40201c92bc9e7028c Author: Lars Ingebrigtsen Date: Tue Aug 4 18:52:31 2020 +0200 Mark unused Gnus util function as obsolete * lisp/gnus/gnus-util.el (gnus-test-list): Mark utility function as obsolete -- there are no in-tree usage. diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 8d8956f1fb..abe546b8cb 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1654,6 +1654,7 @@ The first found will be returned if a file has hard or symbolic links." "To each element of LIST apply PREDICATE. Return nil if LIST is no list or is empty or some test returns nil; otherwise, return t." + (declare (obsolete nil "28.1")) (when (and list (listp list)) (let ((result (mapcar predicate list))) (not (memq nil result))))) commit b0e828da4f55d0dddcd8f8fc2e21e4b02a12852e Author: Stefan Kangas Date: Fri Jul 31 06:09:09 2020 +0200 Add new cconv-tests (Bug#28557) These tests are all written by Gemini Lasswell . * test/lisp/emacs-lisp/cconv-tests.el (top-level): Add two commented out tests which the byte-compiler can't handle. (cconv-tests-lambda-:documentation) (cconv-tests-pcase-lambda-:documentation) (cconv-tests-defun-:documentation) (cconv-tests-cl-defun-:documentation) (cconv-tests-function-:documentation) (cconv-tests-cl-defgeneric-literal-:documentation) (cconv-tests-defsubst-:documentation) (cconv-tests-cl-defsubst-:documentation): New tests. (cconv-tests-cl-iter-defun-:documentation) (cconv-tests-iter-defun-:documentation) (cconv-tests-iter-lambda-:documentation) (cconv-tests-cl-function-:documentation) (cconv-tests-cl-defgeneric-:documentation): New failing tests. diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index c8d46541ad..148bcd69be 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -20,6 +20,164 @@ ;;; Commentary: (require 'ert) +(require 'cl-lib) + +(ert-deftest cconv-tests-lambda-:documentation () + "Docstring for lambda can be specified with :documentation." + (let ((fun (lambda () + (:documentation (concat "lambda" " documentation")) + 'lambda-result))) + (should (string= (documentation fun) "lambda documentation")) + (should (eq (funcall fun) 'lambda-result)))) + +(ert-deftest cconv-tests-pcase-lambda-:documentation () + "Docstring for pcase-lambda can be specified with :documentation." + (let ((fun (pcase-lambda (`(,a ,b)) + (:documentation (concat "pcase-lambda" " documentation")) + (list b a)))) + (should (string= (documentation fun) "pcase-lambda documentation")) + (should (equal '(2 1) (funcall fun '(1 2)))))) + +(defun cconv-tests-defun () + (:documentation (concat "defun" " documentation")) + 'defun-result) +(ert-deftest cconv-tests-defun-:documentation () + "Docstring for defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defun) + "defun documentation")) + (should (eq (cconv-tests-defun) 'defun-result))) + +(cl-defun cconv-tests-cl-defun () + (:documentation (concat "cl-defun" " documentation")) + 'cl-defun-result) +(ert-deftest cconv-tests-cl-defun-:documentation () + "Docstring for cl-defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defun) + "cl-defun documentation")) + (should (eq (cconv-tests-cl-defun) 'cl-defun-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (defmacro cconv-tests-defmacro () +;; (:documentation (concat "defmacro" " documentation")) +;; '(quote defmacro-result)) +;; (ert-deftest cconv-tests-defmacro-:documentation () +;; "Docstring for defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-defmacro) +;; "defmacro documentation")) +;; (should (eq (cconv-tests-defmacro) 'defmacro-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (cl-defmacro cconv-tests-cl-defmacro () +;; (:documentation (concat "cl-defmacro" " documentation")) +;; '(quote cl-defmacro-result)) +;; (ert-deftest cconv-tests-cl-defmacro-:documentation () +;; "Docstring for cl-defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-cl-defmacro) +;; "cl-defmacro documentation")) +;; (should (eq (cconv-tests-cl-defmacro) 'cl-defmacro-result))) + +(cl-iter-defun cconv-tests-cl-iter-defun () + (:documentation (concat "cl-iter-defun" " documentation")) + (iter-yield 'cl-iter-defun-result)) +(ert-deftest cconv-tests-cl-iter-defun-:documentation () + "Docstring for cl-iter-defun can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (should (string= (documentation 'cconv-tests-cl-iter-defun) + "cl-iter-defun documentation")) + (should (eq (iter-next (cconv-tests-cl-iter-defun)) + 'cl-iter-defun-result))) + +(iter-defun cconv-tests-iter-defun () + (:documentation (concat "iter-defun" " documentation")) + (iter-yield 'iter-defun-result)) +(ert-deftest cconv-tests-iter-defun-:documentation () + "Docstring for iter-defun can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (should (string= (documentation 'cconv-tests-iter-defun) + "iter-defun documentation")) + (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) + +(ert-deftest cconv-tests-iter-lambda-:documentation () + "Docstring for iter-lambda can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((iter-fun + (iter-lambda () + (:documentation (concat "iter-lambda" " documentation")) + (iter-yield 'iter-lambda-result)))) + (should (string= (documentation iter-fun) "iter-lambda documentation")) + (should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result)))) + +(ert-deftest cconv-tests-cl-function-:documentation () + "Docstring for cl-function can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((fun (cl-function (lambda (&key arg) + (:documentation (concat "cl-function" + " documentation")) + (list arg 'cl-function-result))))) + (should (string= (documentation fun) "cl-function documentation")) + (should (equal (funcall fun :arg t) '(t cl-function-result))))) + +(ert-deftest cconv-tests-function-:documentation () + "Docstring for lambda inside function can be specified with :documentation." + (let ((fun #'(lambda (arg) + (:documentation (concat "function" " documentation")) + (list arg 'function-result)))) + (should (string= (documentation fun) "function documentation")) + (should (equal (funcall fun t) '(t function-result))))) + +(fmakunbound 'cconv-tests-cl-defgeneric) +(setplist 'cconv-tests-cl-defgeneric nil) +(cl-defgeneric cconv-tests-cl-defgeneric (n) + (:documentation (concat "cl-defgeneric" " documentation"))) +(cl-defmethod cconv-tests-cl-defgeneric ((n integer)) + (:documentation (concat "cl-defmethod" " documentation")) + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric documentation" descr)) + (should (string-match-p "cl-defmethod documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric 10)))) + +(fmakunbound 'cconv-tests-cl-defgeneric-literal) +(setplist 'cconv-tests-cl-defgeneric-literal nil) +(cl-defgeneric cconv-tests-cl-defgeneric-literal (n) + (:documentation "cl-defgeneric-literal documentation")) +(cl-defmethod cconv-tests-cl-defgeneric-literal ((n integer)) + (:documentation "cl-defmethod-literal documentation") + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-literal-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + (let ((descr (describe-function 'cconv-tests-cl-defgeneric-literal))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric-literal documentation" descr)) + (should (string-match-p "cl-defmethod-literal documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric-literal 10)))) + +(defsubst cconv-tests-defsubst () + (:documentation (concat "defsubst" " documentation")) + 'defsubst-result) +(ert-deftest cconv-tests-defsubst-:documentation () + "Docstring for defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defsubst) + "defsubst documentation")) + (should (eq (cconv-tests-defsubst) 'defsubst-result))) + +(cl-defsubst cconv-tests-cl-defsubst () + (:documentation (concat "cl-defsubst" " documentation")) + 'cl-defsubst-result) +(ert-deftest cconv-tests-cl-defsubst-:documentation () + "Docstring for cl-defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defsubst) + "cl-defsubst documentation")) + (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result))) (ert-deftest cconv-convert-lambda-lifted () "Bug#30872." commit 0a12d43e84eb5592c39350432c7a3e8fdaa71a06 Author: Lars Ingebrigtsen Date: Tue Aug 4 18:08:47 2020 +0200 Fix viewing encrypted+signed messages from Outlook * lisp/gnus/mm-decode.el (mm-possibly-verify-or-decrypt): Fix problem with CRLF-encoded encrypted+signed parts (bug#42637). diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 587c4e01b9..7f8ab5f9ef 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1680,6 +1680,12 @@ If RECURSIVE, search recursively." (t (y-or-n-p (format "Decrypt (S/MIME) part? ")))) (mm-view-pkcs7 parts from)) + (goto-char (point-min)) + ;; The encrypted document is a MIME part, and may use either + ;; CRLF (Outlook and the like) or newlines for end-of-line + ;; markers. Translate from CRLF. + (while (search-forward "\r\n" nil t) + (replace-match "\n")) ;; Normally there will be a Content-type header here, but ;; some mailers don't add that to the encrypted part, which ;; makes the subsequent re-dissection fail here. commit 89dbd0838b980f6ef58fa0f614bd743f86ec1c74 Author: Lars Ingebrigtsen Date: Tue Aug 4 17:34:21 2020 +0200 Fix previous network stream test * test/lisp/net/network-stream-tests.el (network-test--resolve-system-name): There's only one ipv6 localhost address. diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index f44682e1ed..cf416155e5 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -142,8 +142,8 @@ ;; IPv4 localhost addresses start with 127. (= (elt address 0) 127)) (and (= (length address) 9) - ;; IPv6 localhost addresses start with 0. - (= (elt address 0) 0))) + ;; IPv6 localhost address. + (equal address [0 0 0 0 0 0 0 1 0]))) return t)) (ert-deftest echo-server-with-dns () commit 99e9bdcd4105ac70f8f7ee06f2450cdbb15dbf3b Author: Lars Ingebrigtsen Date: Tue Aug 4 17:25:36 2020 +0200 Make a network-stream test more robust * test/lisp/net/network-stream-tests.el (network-test--resolve-system-name): New function. (echo-server-with-dns): Skip test if (system-name) doesn't look like it's going to resolve (bug#42535). diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 7a982548ae..f44682e1ed 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -136,7 +136,20 @@ (t )))) +(defun network-test--resolve-system-name () + (cl-loop for address in (network-lookup-address-info (system-name)) + when (or (and (= (length address) 5) + ;; IPv4 localhost addresses start with 127. + (= (elt address 0) 127)) + (and (= (length address) 9) + ;; IPv6 localhost addresses start with 0. + (= (elt address 0) 0))) + return t)) + (ert-deftest echo-server-with-dns () + (unless (network-test--resolve-system-name) + (ert-skip "Can't test resolver for (system-name)")) + (let* ((server (make-server (system-name))) (port (aref (process-contact server :local) 4)) (proc (make-network-process :name "foo" commit ea9520a7a23dfd66de30b04d0c5ff878fecfd3d2 Author: Lars Ingebrigtsen Date: Tue Aug 4 15:56:12 2020 +0200 Mark the end of file names correctly on Macos in wdired * lisp/wdired.el (wdired--restore-dired-filename-prop): Fix problem with finding the end of the name on Macos. diff --git a/lisp/wdired.el b/lisp/wdired.el index 768b8f597b..b98becfafe 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -609,7 +609,10 @@ Optional arguments are ignored." (defun wdired--restore-dired-filename-prop (beg end _len) (save-match-data (save-excursion - (let ((lep (line-end-position))) + (let ((lep (line-end-position)) + (used-F (dired-check-switches + dired-actual-switches + "F" "classify"))) (beginning-of-line) (when (re-search-forward directory-listing-before-filename-regexp lep t) @@ -623,13 +626,17 @@ Optional arguments are ignored." (and (re-search-backward dired-permission-flags-regexp nil t) (looking-at "l") - (search-forward " -> " lep t)) + ;; macOS and Ultrix adds "@" to the end + ;; of symlinks when using -F. + (if (and used-F + dired-ls-F-marks-symlinks) + (re-search-forward "@? -> " lep t) + (search-forward " -> " lep t))) ;; When dired-listing-switches includes "F" ;; or "classify", don't treat appended ;; indicator characters as part of the file ;; name (bug#34915). - (and (dired-check-switches dired-actual-switches - "F" "classify") + (and used-F (re-search-forward "[*/@|=>]$" lep t))) (goto-char (match-beginning 0)) lep)) commit 1432cfd485d33bb518ab6ac5667ae4e4faf7f6b5 Author: Lars Ingebrigtsen Date: Tue Aug 4 15:15:36 2020 +0200 Fix debugging code checked in from wdired-tests diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index fcd8b62640..2cfabd1ee2 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -132,7 +132,7 @@ wdired-mode." (declare-function dired-smart-shell-command "dired-x" (command &optional output-buffer error-buffer)) -(defun wdired-test-bug34915 () +(ert-deftest wdired-test-bug34915 () "Test editing when dired-listing-switches includes -F. Appended file indicators should not count as part of the file name, either before or after editing. Since commit a3c870d7e2426bd401c2de60fa851176cf631f7c Author: Lars Ingebrigtsen Date: Tue Aug 4 14:48:33 2020 +0200 Fix svn tests on Macos * test/lisp/vc/vc-tests.el (vc-test--svn-enabled): Macos machines may have a dummy svn program that helpfully just outputs "There's no svn program here", so also test for the svnadmin program (bug#42536). diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 8e5cc95ec9..01d196565d 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'." (defvar vc-svn-program) (defun vc-test--svn-enabled () - (executable-find vc-svn-program)) + (and (executable-find "svnadmin") + (executable-find vc-svn-program))) (defun vc-test--sccs-enabled () (executable-find "sccs")) commit 934585a6498428f60d709e2ec0379f4667554c6b Author: Lars Ingebrigtsen Date: Tue Aug 4 14:31:36 2020 +0200 dired-ls-F-marks-symlinks should be set under Macos * lisp/dired.el (dired-ls-F-marks-symlinks): Not that this should be set under Macos (bug#42537). diff --git a/lisp/dired.el b/lisp/dired.el index 1792250ac9..d19d6d1581 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -125,7 +125,7 @@ For more details, see Info node `(emacs)ls in Lisp'." "Informs Dired about how `ls -lF' marks symbolic links. Set this to t if `ls' (or whatever program is specified by `insert-directory-program') with `-lF' marks the symbolic link -itself with a trailing @ (usually the case under Ultrix). +itself with a trailing @ (usually the case under Ultrix and macOS). Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to nil (the default), if it gives `bar@ -> foo', set it to t. commit e208d67e8401b8e08d697273e6e162b1e4620005 Author: Lars Ingebrigtsen Date: Tue Aug 4 14:30:13 2020 +0200 Fix wdired test for Macos * test/lisp/wdired-tests.el (wdired-test-bug34915): Macos adds "@" to the end of symlinks (bug#42537). diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index 5b01c54cf2..fcd8b62640 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -132,7 +132,7 @@ wdired-mode." (declare-function dired-smart-shell-command "dired-x" (command &optional output-buffer error-buffer)) -(ert-deftest wdired-test-bug34915 () +(defun wdired-test-bug34915 () "Test editing when dired-listing-switches includes -F. Appended file indicators should not count as part of the file name, either before or after editing. Since @@ -143,6 +143,7 @@ wdired-get-filename before and after editing." (let* ((test-dir (make-temp-file "test-dir-" t)) (server-socket-dir test-dir) (dired-listing-switches "-Fl") + (dired-ls-F-marks-symlinks (eq system-type 'darwin)) (buf (find-file-noselect test-dir))) (unwind-protect (progn commit 3da0d3852923f0a20157f72aba6d8896019559f8 Author: Michael Albinus Date: Tue Aug 4 14:20:16 2020 +0200 * etc/NEWS: Add Tramp support of direct asynchronous process invocation. diff --git a/etc/NEWS b/etc/NEWS index 7221c9cf9e..cd5cc2c339 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -324,6 +324,16 @@ This command marks a remote directory to contain only encrypted files. See the "(tramp) Keeping files encrypted" node of the Tramp manual for details. This feature is experimental. ++++ +*** Support of direct asynchronous process invocation. +When Tramp connection property "direct-async-process" is set to +non-nil for a given connection, 'make-process' and 'start-file-process' +calls are performed directly as in "ssh ... ". This avoids +initialization performance penalties. See the "(tramp) Improving +performance of asynchronous remote processes" node of the Tramp manual +for details, and also for a discussion or restrictions. This feature +is experimental. + ** Tempo --- commit 83b1db043b44a8efb091ced873eab686e671c5ac Author: Michael Albinus Date: Tue Aug 4 14:19:51 2020 +0200 Add Tramp support of direct asynchronous process invocation * doc/misc/tramp.texi (Predefined connection information): Add "direct-async-process". (Remote processes): New subsection "Improving performance of asynchronous remote processes". * lisp/net/tramp-adb.el (tramp-methods) : Add `tramp-login-program' and `tramp-login-args'. (tramp-adb-handle-make-process): Use `tramp-handle-make-process'. (tramp-adb-maybe-open-connection): Add "set +o vi +o emacs" command. * lisp/net/tramp-sh.el (tramp-sh-handle-make-process): Use `tramp-handle-make-process'. (tramp-sh-file-name-handler-p, tramp-multi-hop-p): New defuns. (tramp-compute-multi-hops): Use `tramp-multi-hop-p'. * lisp/net/tramp.el (tramp-dissect-file-name, tramp-dissect-hop-name): Use `tramp-multi-hop-p'. (tramp-handle-insert-file-contents, tramp-local-host-p): Use `tramp-sh-file-name-handler-p'. (tramp-handle-make-process): New defun. * test/README: Add another example how to use SELECTOR. * test/lisp/net/tramp-tests.el (tramp-test03-file-name-method-rules): Adapt test. (tramp--test-sh-p): Use `tramp-sh-file-name-handler-p'. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index b4195111d4..91b1e996f4 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2053,6 +2053,13 @@ The temporary directory on the remote host. If not specified, the default value is @t{"/data/local/tmp"} for the @option{adb} method, @t{"/C$/Temp"} for the @option{smb} method, and @t{"/tmp"} otherwise. +@item @t{"direct-async-process"} + +When this property is non-@code{nil}, an alternative, more performant +implementation of @code{make-process} and +@code{start-file-process} is applied. @ref{Improving performance of +asynchronous remote processes} for a discussion of constraints. + @item @t{"posix"} Connections using the @option{smb} method check, whether the remote @@ -2458,10 +2465,9 @@ overwrite as follows: @lisp @group -(add-to-list - 'tramp-connection-properties - `(,(regexp-quote "192.168.0.1") - "remote-copy-args" (("-l") ("%r")))) +(add-to-list 'tramp-connection-properties + `(,(regexp-quote "192.168.0.1") + "remote-copy-args" (("-l") ("%r")))) @end group @end lisp @@ -3527,6 +3533,70 @@ To open @command{powershell} as a remote shell, use this: @end lisp +@anchor{Improving performance of asynchronous remote processes} +@subsection Improving performance of asynchronous remote processes +@cindex Asynchronous remote processes +@findex make-process +@findex start-file-process + +@value{tramp}'s implementation of @code{make-process} and +@code{start-file-process} requires a serious overhead for +initialization, every process invocation. This is needed for handling +interactive dialogues when connecting the remote host (like providing +a password), and initial environment setup. + +Sometimes, this is not needed. Instead of starting a remote shell and +running the command afterwards, it is sufficient to run the command +directly. @value{tramp} supports this by an alternative +implementation of @code{make-process} and @code{start-file-process}. +This is triggered by the connection property +@t{"direct-async-process"}, @xref{Predefined connection information}, +which must be set to a non-@code{nil} value. Example: + +@lisp +@group +(add-to-list 'tramp-connection-properties + (list (regexp-quote "@trampfn{ssh,user@@host,}") + "direct-async-process" t)) +@end group +@end lisp + +However, this approach has different limitations: + +@itemize +@item +It works only for connection methods defined in @file{tramp-sh.el} and +@file{tramp-adb.el}. + +@item +It does not support multi-hop methods. + +@item +It does not support interactive user authentication, like password +handling. + +@item +It does not support a separated error stream. + +@item +It cannot be killed via @code{interrupt-process}. + +@item +It does not report the remote terminal name via @code{process-tty-name}. + +@item +It does not use @code{tramp-remote-path} and +@code{tramp-remote-process-environment}. + +@item +It does not set environment variable @env{INSIDE_EMACS}. +@end itemize + +In order to gain even more performance, it is recommended to bind +@code{tramp-verbose} to 0 when running @code{make-process} or +@code{start-file-process}. + + @node Cleanup remote connections @section Cleanup remote connections @cindex cleanup @@ -4555,9 +4625,8 @@ Abbreviation list expansion can be used to reduce typing long file names: @lisp @group -(add-to-list - 'directory-abbrev-alist - '("^/xy" . "@trampfn{ssh,news@@news.my.domain,/opt/news/etc/}")) +(add-to-list 'directory-abbrev-alist + '("^/xy" . "@trampfn{ssh,news@@news.my.domain,/opt/news/etc/}")) @end group @end lisp diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 7e5af6910b..88f5c2928e 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -96,8 +96,10 @@ It is used for TCP/IP devices." (tramp--with-startup (add-to-list 'tramp-methods `(,tramp-adb-method - (tramp-tmpdir "/data/local/tmp") - (tramp-default-port 5555))) + (tramp-login-program ,tramp-adb-program) + (tramp-login-args (("shell"))) + (tramp-tmpdir "/data/local/tmp") + (tramp-default-port 5555))) (add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil "")) @@ -885,158 +887,163 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; The complete STDERR buffer is available only when the process has ;; terminated. (defun tramp-adb-handle-make-process (&rest args) - "Like `make-process' for Tramp files." - (when args - (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let ((name (plist-get args :name)) - (buffer (plist-get args :buffer)) - (command (plist-get args :command)) - (coding (plist-get args :coding)) - (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) - (filter (plist-get args :filter)) - (sentinel (plist-get args :sentinel)) - (stderr (plist-get args :stderr))) - (unless (stringp name) - (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) - (unless (consp command) - (signal 'wrong-type-argument (list #'consp command))) - (unless (or (null coding) - (and (symbolp coding) (memq coding coding-system-list)) - (and (consp coding) - (memq (car coding) coding-system-list) - (memq (cdr coding) coding-system-list))) - (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) - (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) - (signal 'wrong-type-argument (list #'functionp filter))) - (unless (or (null sentinel) (functionp sentinel)) - (signal 'wrong-type-argument (list #'functionp sentinel))) - (unless (or (null stderr) (bufferp stderr) (stringp stderr)) - (signal 'wrong-type-argument (list #'stringp stderr))) - (when (and (stringp stderr) (tramp-tramp-file-p stderr) - (not (tramp-equal-remote default-directory stderr))) - (signal 'file-error (list "Wrong stderr" stderr))) - - (let* ((buffer - (if buffer - (get-buffer-create buffer) - ;; BUFFER can be nil. We use a temporary buffer. - (generate-new-buffer tramp-temp-buffer-name))) - ;; STDERR can also be a file name. - (tmpstderr - (and stderr - (if (and (stringp stderr) (tramp-tramp-file-p stderr)) - (tramp-unquote-file-local-name stderr) - (tramp-make-tramp-temp-file v)))) - (remote-tmpstderr - (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) - (program (car command)) - (args (cdr command)) - (command - (format "cd %s && exec %s %s" - (tramp-shell-quote-argument localname) - (if tmpstderr (format "2>'%s'" tmpstderr) "") - (mapconcat #'tramp-shell-quote-argument - (cons program args) " "))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0)) - - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' - ;; could be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t)) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-adb-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (tramp-adb-maybe-open-connection v) - (delete-region (point-min) (point-max)) - ;; Send the command. - (let* ((p (tramp-get-connection-process v))) - (tramp-adb-send-command v command nil t) ; nooutput - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the - ;; process could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point))) - ;; We must flush them here already; otherwise - ;; `rename-file', `delete-file' or - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Copy tmpstderr file. - (when (and (stringp stderr) - (not (tramp-tramp-file-p stderr))) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (rename-file remote-tmpstderr stderr)))) - ;; Read initial output. Remove the first line, - ;; which is the command echo. - (while - (progn - (goto-char (point-min)) - (not (re-search-forward "[\n]" nil t))) - (tramp-accept-process-output p 0)) - (delete-region (point-min) (point)) - ;; Provide error buffer. This shows only - ;; initial error messages; messages arriving - ;; later on will be inserted when the process - ;; is deleted. The temporary file will exist - ;; until the process is deleted. - (when (bufferp stderr) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit)) - ;; Delete tmpstderr file. - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit nil nil 'replace)) - (delete-file remote-tmpstderr)))) - ;; Return process. - p)))) - - ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer (tramp-get-connection-process v) nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")))))))) + "Like `make-process' for Tramp files. +If connection property \"direct-async-process\" is non-nil, an +alternative implementation will be used." + (if (tramp-get-connection-property + (tramp-dissect-file-name default-directory) "direct-async-process" nil) + (apply #'tramp-handle-make-process args) + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (program (car command)) + (args (cdr command)) + (command + (format "cd %s && exec %s %s" + (tramp-shell-quote-argument localname) + (if tmpstderr (format "2>'%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0)) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + ;; We call `tramp-adb-maybe-open-connection', + ;; in order to cleanup the prompt afterwards. + (tramp-adb-maybe-open-connection v) + (delete-region (point-min) (point-max)) + ;; Send the command. + (let* ((p (tramp-get-connection-process v))) + (tramp-adb-send-command v command nil t) ; nooutput + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for + ;; this process. We ignore errors, because + ;; the process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; + ;; otherwise `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) + ;; Read initial output. Remove the first + ;; line, which is the command echo. + (while + (progn + (goto-char (point-min)) + (not (re-search-forward "[\n]" nil t))) + (tramp-accept-process-output p 0)) + (delete-region (point-min) (point)) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the + ;; process is deleted. The temporary file + ;; will exist until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) + ;; Return process. + p)))) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer (tramp-get-connection-process v) nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))))) (defun tramp-adb-handle-exec-path () "Like `exec-path' for Tramp files." @@ -1253,6 +1260,14 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt)) + ;; Disable line editing. + (tramp-adb-send-command + vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs") + + ;; Dump option settings in the traces. + (when (>= tramp-verbose 9) + (tramp-adb-send-command vec "set -o")) + ;; Check whether the properties have been changed. If ;; yes, this is a strong indication that we must expire all ;; connection properties. We start again. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index f9f0cbcc02..3e2eb023a3 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2787,228 +2787,233 @@ the result will be a local, non-Tramp, file name." ;; terminated. (defun tramp-sh-handle-make-process (&rest args) "Like `make-process' for Tramp files. -STDERR can also be a file name." - (when args - (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let ((name (plist-get args :name)) - (buffer (plist-get args :buffer)) - (command (plist-get args :command)) - (coding (plist-get args :coding)) - (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) - (filter (plist-get args :filter)) - (sentinel (plist-get args :sentinel)) - (stderr (plist-get args :stderr))) - (unless (stringp name) - (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) - (unless (consp command) - (signal 'wrong-type-argument (list #'consp command))) - (unless (or (null coding) - (and (symbolp coding) (memq coding coding-system-list)) - (and (consp coding) - (memq (car coding) coding-system-list) - (memq (cdr coding) coding-system-list))) - (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) - (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) - (signal 'wrong-type-argument (list #'functionp filter))) - (unless (or (null sentinel) (functionp sentinel)) - (signal 'wrong-type-argument (list #'functionp sentinel))) - (unless (or (null stderr) (bufferp stderr) (stringp stderr)) - (signal 'wrong-type-argument (list #'stringp stderr))) - (when (and (stringp stderr) (tramp-tramp-file-p stderr) - (not (tramp-equal-remote default-directory stderr))) - (signal 'file-error (list "Wrong stderr" stderr))) - - (let* ((buffer - (if buffer - (get-buffer-create buffer) - ;; BUFFER can be nil. We use a temporary buffer. - (generate-new-buffer tramp-temp-buffer-name))) - ;; STDERR can also be a file name. - (tmpstderr - (and stderr - (if (and (stringp stderr) (tramp-tramp-file-p stderr)) - (tramp-unquote-file-local-name stderr) - (tramp-make-tramp-temp-file v)))) - (remote-tmpstderr - (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) - (program (car command)) - (args (cdr command)) - ;; When PROGRAM matches "*sh", and the first arg is - ;; "-c", it might be that the arguments exceed the - ;; command line length. Therefore, we modify the - ;; command. - (heredoc (and (stringp program) - (string-match-p "sh$" program) - (string-equal "-c" (car args)) - (= (length args) 2))) - ;; When PROGRAM is nil, we just provide a tty. - (args (if (not heredoc) args - (let ((i 250)) - (while (and (< i (length (cadr args))) - (string-match " " (cadr args) i)) - (setcdr - args - (list - (replace-match " \\\\\n" nil nil (cadr args)))) - (setq i (+ i 250)))) - (cdr args))) - ;; Use a human-friendly prompt, for example for - ;; `shell'. We discard hops, if existing, that's why - ;; we cannot use `file-remote-p'. - (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name v nil 'nohop) - tramp-initial-end-of-output)) - ;; We use as environment the difference to toplevel - ;; `process-environment'. - env uenv - (env (dolist (elt (cons prompt process-environment) env) - (or (member - elt (default-toplevel-value 'process-environment)) - (if (string-match-p "=" elt) - (setq env (append env `(,elt))) - (if (tramp-get-env-with-u-option v) - (setq env (append `("-u" ,elt) env)) - (setq uenv (cons elt uenv))))))) - (command - (when (stringp program) - (setenv-internal - env "INSIDE_EMACS" - (concat (or (getenv "INSIDE_EMACS") emacs-version) - ",tramp:" tramp-version) - 'keep) - (format "cd %s && %s exec %s %s env %s %s" - (tramp-shell-quote-argument localname) - (if uenv - (format - "unset %s &&" - (mapconcat - #'tramp-shell-quote-argument uenv " ")) - "") - (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") - (if tmpstderr (format "2>'%s'" tmpstderr) "") - (mapconcat #'tramp-shell-quote-argument env " ") - (if heredoc - (format "%s\n(\n%s\n) " name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' could - ;; be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t) - (mark (point-max))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (catch 'suppress - (tramp-maybe-open-connection v) - (setq p (tramp-get-connection-process v)) - ;; Set the pid of the remote shell. This is - ;; needed when sending signals remotely. - (let ((pid (tramp-send-command-and-read v "echo $$"))) - (process-put p 'remote-pid pid) - (tramp-set-connection-property p "remote-pid" pid)) - ;; `tramp-maybe-open-connection' and - ;; `tramp-send-command-and-read' could have - ;; trashed the connection buffer. Remove this. - (widen) - (delete-region mark (point-max)) +STDERR can also be a file name. If connection property +\"direct-async-process\" is non-nil, an alternative +implementation will be used." + (if (tramp-get-connection-property + (tramp-dissect-file-name default-directory) "direct-async-process" nil) + (apply #'tramp-handle-make-process args) + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (program (car command)) + (args (cdr command)) + ;; When PROGRAM matches "*sh", and the first arg is + ;; "-c", it might be that the arguments exceed the + ;; command line length. Therefore, we modify the + ;; command. + (heredoc (and (stringp program) + (string-match-p "sh$" program) + (string-equal "-c" (car args)) + (= (length args) 2))) + ;; When PROGRAM is nil, we just provide a tty. + (args (if (not heredoc) args + (let ((i 250)) + (while (and (< i (length (cadr args))) + (string-match " " (cadr args) i)) + (setcdr + args + (list + (replace-match " \\\\\n" nil nil (cadr args)))) + (setq i (+ i 250)))) + (cdr args))) + ;; Use a human-friendly prompt, for example for + ;; `shell'. We discard hops, if existing, that's why + ;; we cannot use `file-remote-p'. + (prompt (format "PS1=%s %s" + (tramp-make-tramp-file-name v nil 'nohop) + tramp-initial-end-of-output)) + ;; We use as environment the difference to toplevel + ;; `process-environment'. + env uenv + (env (dolist (elt (cons prompt process-environment) env) + (or (member + elt (default-toplevel-value 'process-environment)) + (if (string-match-p "=" elt) + (setq env (append env `(,elt))) + (if (tramp-get-env-with-u-option v) + (setq env (append `("-u" ,elt) env)) + (setq uenv (cons elt uenv))))))) + (command + (when (stringp program) + (setenv-internal + env "INSIDE_EMACS" + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version) + 'keep) + (format "cd %s && %s exec %s %s env %s %s" + (tramp-shell-quote-argument localname) + (if uenv + (format + "unset %s &&" + (mapconcat + #'tramp-shell-quote-argument uenv " ")) + "") + (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") + (if tmpstderr (format "2>'%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument env " ") + (if heredoc + (format "%s\n(\n%s\n) " name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (mark (point-max))) + (clear-visited-file-modtime) (narrow-to-region (point-max) (point-max)) - ;; Now do it. - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (unless (process-get p 'remote-tty) - (tramp-error - v 'file-error - "pty association is not supported for `%s'" - name)))) - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the - ;; process could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point))) - ;; We must flush them here already; otherwise - ;; `rename-file', `delete-file' or - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Copy tmpstderr file. - (when (and (stringp stderr) - (not (tramp-tramp-file-p stderr))) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (rename-file remote-tmpstderr stderr)))) - ;; Provide error buffer. This shows only - ;; initial error messages; messages arriving - ;; later on will be inserted when the process is - ;; deleted. The temporary file will exist until - ;; the process is deleted. - (when (bufferp stderr) - (with-current-buffer stderr - (insert-file-contents-literally remote-tmpstderr)) - ;; Delete tmpstderr file. - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (when (file-exists-p remote-tmpstderr) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr nil nil nil 'replace)) - (delete-file remote-tmpstderr))))) - ;; Return process. - p))) + ;; We call `tramp-maybe-open-connection', in + ;; order to cleanup the prompt afterwards. + (catch 'suppress + (tramp-maybe-open-connection v) + (setq p (tramp-get-connection-process v)) + ;; Set the pid of the remote shell. This is + ;; needed when sending signals remotely. + (let ((pid (tramp-send-command-and-read v "echo $$"))) + (process-put p 'remote-pid pid) + (tramp-set-connection-property p "remote-pid" pid)) + ;; `tramp-maybe-open-connection' and + ;; `tramp-send-command-and-read' could have + ;; trashed the connection buffer. Remove this. + (widen) + (delete-region mark (point-max)) + (narrow-to-region (point-max) (point-max)) + ;; Now do it. + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (unless (process-get p 'remote-tty) + (tramp-error + v 'file-error + "pty association is not supported for `%s'" + name)))) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the process + ;; is deleted. The temporary file will exist + ;; until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally remote-tmpstderr)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (when (file-exists-p remote-tmpstderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr nil nil nil 'replace)) + (delete-file remote-tmpstderr))))) + ;; Return process. + p))) - ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer p nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")))))))) + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))))) (defun tramp-sh-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." @@ -3646,6 +3651,14 @@ Fall back to normal file name handler if no Tramp handler exists." (save-match-data (apply (cdr fn) args)) (tramp-run-real-handler operation args))) +;;;###tramp-autoload +(defun tramp-sh-file-name-handler-p (vec) + "Whether VEC uses a method from `tramp-sh-file-name-handler'." + (and (assoc (tramp-file-name-method vec) tramp-methods) + (eq (tramp-find-foreign-file-name-handler + (tramp-make-tramp-file-name vec nil 'nohop)) + 'tramp-sh-file-name-handler))) + ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload (tramp--with-startup @@ -4769,6 +4782,12 @@ Goes through the list `tramp-inline-compress-commands'." (tramp-message vec 2 "Couldn't find an inline transfer compress command"))))) +;;;###tramp-autoload +(defun tramp-multi-hop-p (vec) + "Whether the method of VEC is capable of multi-hops." + (and (tramp-sh-file-name-handler-p vec) + (not (tramp-get-method-parameter vec 'tramp-copy-program)))) + (defun tramp-compute-multi-hops (vec) "Expands VEC according to `tramp-default-proxies-alist'." (let ((saved-tdpa tramp-default-proxies-alist) @@ -4832,8 +4851,7 @@ Goes through the list `tramp-inline-compress-commands'." (when (cdr target-alist) (setq choices target-alist) (while (setq item (pop choices)) - (when (or (not (tramp-get-method-parameter item 'tramp-login-program)) - (tramp-get-method-parameter item 'tramp-copy-program)) + (unless (tramp-multi-hop-p item) (setq tramp-default-proxies-alist saved-tdpa) (tramp-user-error vec "Method `%s' is not supported for multi-hops." diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index c169a86f91..d1b2935a3c 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1482,10 +1482,7 @@ default values are used." (tramp-user-error v "Method `%s' is not known." method)) ;; Only some methods from tramp-sh.el do support multi-hops. - (when (and - hop - (or (not (tramp-get-method-parameter v 'tramp-login-program)) - (tramp-get-method-parameter v 'tramp-copy-program))) + (unless (or (null hop) nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error v "Method `%s' is not supported for multi-hops." method))))))) @@ -1499,8 +1496,7 @@ See `tramp-dissect-file-name' for details." tramp-postfix-host-format name)) nodefault))) ;; Only some methods from tramp-sh.el do support multi-hops. - (when (or (not (tramp-get-method-parameter v 'tramp-login-program)) - (tramp-get-method-parameter v 'tramp-copy-program)) + (unless (or nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error v "Method `%s' is not supported for multi-hops." (tramp-file-name-method v))) @@ -3519,13 +3515,10 @@ User is always nil." ;; When we shall insert only a part of the file, we ;; copy this part. This works only for the shell file - ;; name handlers. + ;; name handlers. It doesn't work for crypted files. (when (and (or beg end) - ;; Direct actions aren't possible for - ;; crypted directories. - (null tramp-crypt-enabled) - (tramp-get-method-parameter - v 'tramp-login-program)) + (tramp-sh-file-name-handler-p v) + (null tramp-crypt-enabled)) (setq remote-copy (tramp-make-tramp-temp-file v)) ;; This is defined in tramp-sh.el. Let's assume ;; this is loaded already. @@ -3640,6 +3633,152 @@ User is always nil." (load local-copy noerror t nosuffix must-suffix) (delete-file local-copy))))) t))) +;; We use BUFFER also as connection buffer during setup. Because of +;; this, its original contents must be saved, and restored once +;; connection has been setup. +(defun tramp-handle-make-process (&rest args) + "An alternative `make-process' implementation for Tramp files." + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + (command (append `("cd" ,localname "&&") + (mapcar #'tramp-shell-quote-argument command))) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0) + ;; We do not want to raise an error when `make-process' + ;; has been started several times in `eshell' and + ;; friends. + tramp-current-connection + p) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + (let* ((login-program + (tramp-get-method-parameter v 'tramp-login-program)) + (login-args + (tramp-get-method-parameter v 'tramp-login-args)) + (async-args + (tramp-get-method-parameter v 'tramp-async-args)) + ;; We don't create the temporary file. In + ;; fact, it is just a prefix for the + ;; ControlPath option of ssh; the real + ;; temporary file has another name, and it is + ;; created and protected by ssh. It is also + ;; removed by ssh when the connection is + ;; closed. The temporary file name is cached + ;; in the main connection process, therefore + ;; we cannot use `tramp-get-connection-process'. + (tmpfile + (when (tramp-sh-file-name-handler-p v) + (with-tramp-connection-property + (tramp-get-process v) "temp-file" + (tramp-compat-make-temp-name)))) + (options + (when (tramp-sh-file-name-handler-p v) + (tramp-compat-funcall + 'tramp-ssh-controlmaster-options v))) + spec) + + ;; Replace `login-args' place holders. + (setq + spec (format-spec-make ?t tmpfile) + options (format-spec (or options "") spec) + spec (format-spec-make + ?h (or host "") ?u (or user "") ?p (or port "") + ?c options ?l "") + ;; Add arguments for asynchronous processes. + login-args (append async-args login-args) + ;; Expand format spec. + login-args + (tramp-compat-flatten-tree + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) x)) + login-args)) + ;; Split ControlMaster options. + login-args + (tramp-compat-flatten-tree + (mapcar (lambda (x) (split-string x " ")) login-args)) + p (apply + #'start-process + name buffer login-program (append login-args command))) + + (tramp-message v 6 "%s" (string-join (process-command p) " ")) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Return process. + p) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) (defun tramp-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) @@ -4706,7 +4845,7 @@ This handles also chrooted environments, which are not regarded as local." ;; The method shall be applied to one of the shell file name ;; handlers. `tramp-local-host-p' is also called for "smb" and ;; alike, where it must fail. - (tramp-get-method-parameter vec 'tramp-login-program) + (tramp-sh-file-name-handler-p vec) ;; Direct actions aren't possible for crypted directories. (null tramp-crypt-enabled) ;; The local temp directory must be writable for the other user. diff --git a/test/README b/test/README index 1f69f7142c..fe05b5403b 100644 --- a/test/README +++ b/test/README @@ -64,6 +64,11 @@ protect against "make" variable expansion): make SELECTOR='"foo$$"' +In case you want to use the symbol name of a test as selector, you can +use it directly: + + make SELECTOR='test-foo-remote' + Note that although the test files are always compiled (unless they set no-byte-compile), the source files will be run when expensive or unstable tests are involved, to give nicer backtraces. To run the diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index ac24fcf280..05196e7e4a 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2001,12 +2001,13 @@ is greater than 10. (skip-unless (tramp--test-enabled)) ;; Multi hops are allowed for inline methods only. - (should-error - (file-remote-p "/ssh:user1@host1|method:user2@host2:/path/to/file") - :type 'user-error) - (should-error - (file-remote-p "/method:user1@host1|ssh:user2@host2:/path/to/file") - :type 'user-error) + (let (non-essential) + (should-error + (expand-file-name "/ssh:user1@host1|method:user2@host2:/path/to/file") + :type 'user-error) + (should-error + (expand-file-name "/method:user1@host1|ssh:user2@host2:/path/to/file") + :type 'user-error)) ;; Samba does not support file names with periods followed by ;; spaces, and trailing periods or spaces. @@ -5681,9 +5682,8 @@ This does not support special file names." (defun tramp--test-sh-p () "Check, whether the remote host runs a based method from tramp-sh.el." - (eq - (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) - 'tramp-sh-file-name-handler)) + (tramp-sh-file-name-handler-p + (tramp-dissect-file-name tramp-test-temporary-file-directory))) (defun tramp--test-sudoedit-p () "Check, whether the sudoedit method is used." commit b8b25400d544b2178ddc51de05a681ed11d581d6 Author: Theodor Thornhill Date: Tue Aug 4 12:12:46 2020 +0200 Add sass @use rule to css-mode * lisp/textmodes/css-mode.el (scss-at-ids): Add 'use' to scss-at-ids for autocompletion (bug#42700). diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 2cd99787e8..cc5879880c 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -67,7 +67,7 @@ (defconst scss-at-ids '("at-root" "content" "debug" "each" "else" "else if" "error" "extend" - "for" "function" "if" "import" "include" "mixin" "return" "warn" + "for" "function" "if" "import" "include" "mixin" "return" "use" "warn" "while") "Additional identifiers that appear in the form @foo in SCSS.")