commit a1b72008a7228a65af819118d6de620b89d0e0d4 (HEAD, refs/remotes/origin/master) Merge: 1faa1726f0 c09ad0cabd Author: Stefan Kangas Date: Sat Dec 25 06:32:13 2021 +0100 Merge from origin/emacs-28 c09ad0cabd Fix the bug with duplicate entries in xref output commit 1faa1726f093886446879180997d8bd7426b30eb Author: Stefan Kangas Date: Sat Dec 25 05:02:59 2021 +0100 Move mouse key bindings to gametree-mode-map * lisp/play/gametree.el (gametree-mode-map): Move mouse key bindings here. diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el index cc9a6b7a4f..ff4b97d884 100644 --- a/lisp/play/gametree.el +++ b/lisp/play/gametree.el @@ -554,7 +554,32 @@ buffer, it is replaced by the new value. See the documentation for (gametree-hack-file-layout)) nil) + +;;;; Mouse commands + +(defun gametree-mouse-break-line-here (event) + (interactive "e") + (mouse-set-point event) + (gametree-break-line-here)) + +(defun gametree-mouse-show-children-and-entry (event) + (interactive "e") + (mouse-set-point event) + (gametree-show-children-and-entry)) + +(defun gametree-mouse-show-subtree (event) + (interactive "e") + (mouse-set-point event) + (outline-show-subtree)) + +(defun gametree-mouse-hide-subtree (event) + (interactive "e") + (mouse-set-point event) + (outline-hide-subtree)) + + ;;;; Key bindings + (defvar gametree-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-j" 'gametree-break-line-here) @@ -566,6 +591,14 @@ buffer, it is replaced by the new value. See the documentation for (define-key map "\C-c\C-y" 'gametree-save-and-hack-layout) (define-key map "\C-c;" 'gametree-insert-score) (define-key map "\C-c^" 'gametree-compute-and-insert-score) + (define-key map [M-down-mouse-2 M-mouse-2] + #'gametree-mouse-break-line-here) + (define-key map [S-down-mouse-1 S-mouse-1] + #'gametree-mouse-show-children-and-entry) + (define-key map [S-down-mouse-2 S-mouse-2] + #'gametree-mouse-show-subtree) + (define-key map [S-down-mouse-3 S-mouse-3] + #'gametree-mouse-hide-subtree) map)) (define-derived-mode gametree-mode outline-mode "GameTree" @@ -577,32 +610,6 @@ shogi, etc.) players, it is a slightly modified version of Outline mode. (auto-fill-mode 0) (add-hook 'write-contents-functions 'gametree-save-and-hack-layout nil t)) -;;;; Goodies for mousing users -(defun gametree-mouse-break-line-here (event) - (interactive "e") - (mouse-set-point event) - (gametree-break-line-here)) -(defun gametree-mouse-show-children-and-entry (event) - (interactive "e") - (mouse-set-point event) - (gametree-show-children-and-entry)) -(defun gametree-mouse-show-subtree (event) - (interactive "e") - (mouse-set-point event) - (outline-show-subtree)) -(defun gametree-mouse-hide-subtree (event) - (interactive "e") - (mouse-set-point event) - (outline-hide-subtree)) -(define-key gametree-mode-map [M-down-mouse-2 M-mouse-2] - 'gametree-mouse-break-line-here) -(define-key gametree-mode-map [S-down-mouse-1 S-mouse-1] - 'gametree-mouse-show-children-and-entry) -(define-key gametree-mode-map [S-down-mouse-2 S-mouse-2] - 'gametree-mouse-show-subtree) -(define-key gametree-mode-map [S-down-mouse-3 S-mouse-3] - 'gametree-mouse-hide-subtree) - (provide 'gametree) ;;; gametree.el ends here commit 71eb1aac54e2143d40c16a9f67e76200f63e6561 Author: Po Lu Date: Sat Dec 25 10:38:23 2021 +0800 Add support for XI 2.4 We will be able to use touchpad (not touchscreen) gestures, such as pinch and swipe gestures after this change, but they are not yet exposed to Lisp. * src/xterm.c (x_term_init): Declare support for XI 2.4 if present. diff --git a/src/xterm.c b/src/xterm.c index 42001023b3..6be7e2e9f9 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -14764,7 +14764,9 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) dpyinfo->supports_xi2 = false; int rc; int major = 2; -#ifdef XI_BarrierHit /* XInput 2.3 */ +#ifdef XI_GesturePinchBegin /* XInput 2.4 */ + int minor = 4; +#elif XI_BarrierHit /* XInput 2.3 */ int minor = 3; #elif defined XI_TouchBegin /* XInput 2.2 */ int minor = 2; commit 8b0e9f44b757ead61537fe213fe8546af911cb54 Author: Po Lu Date: Sat Dec 25 08:29:00 2021 +0800 Fix Emacs tooltips on PGTK * src/pgtkfns.c (x_create_tip_frame): Don't set cursor and show window. (Fx_show_tip): Set cursor and show window. diff --git a/src/pgtkfns.c b/src/pgtkfns.c index a756bd4284..c782efe395 100644 --- a/src/pgtkfns.c +++ b/src/pgtkfns.c @@ -2913,9 +2913,6 @@ x_create_tip_frame (struct pgtk_display_info *dpyinfo, Lisp_Object parms, struct gtk_window_set_decorated (GTK_WINDOW (tip_window), FALSE); gtk_window_set_type_hint (GTK_WINDOW (tip_window), GDK_WINDOW_TYPE_HINT_TOOLTIP); f->output_data.pgtk->current_cursor = f->output_data.pgtk->text_cursor; - gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (f)); - gdk_window_set_cursor (gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)), - f->output_data.pgtk->current_cursor); #if 0 x_make_gc (f); @@ -3451,6 +3448,11 @@ Text larger than the specified size is clipped. */) block_input (); gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (tip_f)), width, height); gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (tip_f)), root_x, root_y); + gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (tip_f)); + SET_FRAME_VISIBLE (tip_f, 1); + gdk_window_set_cursor (gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (tip_f)), + f->output_data.pgtk->current_cursor); + unblock_input (); pgtk_cr_update_surface_desired_size (tip_f, width, height, false); commit 992bb3a9aef973447bc369e389c8f7228672f82c Author: Stefan Kangas Date: Fri Dec 24 17:29:05 2021 +0100 Simplify command remapping in play/blackbox.el * lisp/play/blackbox.el (blackbox-redefine-key): Make obsolete. (blackbox-mode-map): Simplify. diff --git a/lisp/play/blackbox.el b/lisp/play/blackbox.el index 13bcdcc859..1b82d1a425 100644 --- a/lisp/play/blackbox.el +++ b/lisp/play/blackbox.el @@ -85,31 +85,22 @@ (defvar bb-balls-placed nil "List of already placed balls.") -;; This is used below to remap existing bindings for cursor motion to -;; blackbox-specific bindings in blackbox-mode-map. This is so that -;; users who prefer non-default key bindings for cursor motion don't -;; lose that when they play Blackbox. -(defun blackbox-redefine-key (map oldfun newfun) - "Redefine keys that run the function OLDFUN to run NEWFUN instead." - (define-key map (vector 'remap oldfun) newfun)) - - (defvar blackbox-mode-map - (let ((map (make-keymap))) + (let ((map (make-sparse-keymap))) (suppress-keymap map t) - (blackbox-redefine-key map 'backward-char 'bb-left) - (blackbox-redefine-key map 'left-char 'bb-left) - (blackbox-redefine-key map 'forward-char 'bb-right) - (blackbox-redefine-key map 'right-char 'bb-right) - (blackbox-redefine-key map 'previous-line 'bb-up) - (blackbox-redefine-key map 'next-line 'bb-down) - (blackbox-redefine-key map 'move-end-of-line 'bb-eol) - (blackbox-redefine-key map 'move-beginning-of-line 'bb-bol) (define-key map " " 'bb-romp) (define-key map "q" 'bury-buffer) (define-key map [insert] 'bb-romp) (define-key map [return] 'bb-done) - (blackbox-redefine-key map 'newline 'bb-done) + (define-key map [remap backward-char] #'bb-left) + (define-key map [remap left-char] #'bb-left) + (define-key map [remap forward-char] #'bb-right) + (define-key map [remap right-char] #'bb-right) + (define-key map [remap previous-line] #'bb-up) + (define-key map [remap next-line] #'bb-down) + (define-key map [remap move-end-of-line] #'bb-eol) + (define-key map [remap move-beginning-of-line] #'bb-bol) + (define-key map [remap newline] #'bb-done) map)) ;; Blackbox mode is suitable only for specially formatted data. @@ -426,6 +417,11 @@ a reflection." (insert c) (backward-char 1))) +(defun blackbox-redefine-key (map oldfun newfun) + "Redefine keys that run the function OLDFUN to run NEWFUN instead." + (declare (obsolete define-key "29.1")) + (define-key map (vector 'remap oldfun) newfun)) + (provide 'blackbox) ;;; blackbox.el ends here commit b6ea93c62cb0b54bf90a954227f6d8603bdbaf80 Author: Stefan Kangas Date: Fri Dec 24 15:37:08 2021 +0100 ; * lisp/gnus/mm-url.el: Delete spurious defvars. diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index 3d58738d63..fd23a4e2cf 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -34,8 +34,6 @@ (require 'gnus) (defvar url-current-object) -(defvar url-package-name) -(defvar url-package-version) (defgroup mm-url nil "A wrapper of url package and external url command for Gnus." commit 5b6c3a20a32273d094c72bb1b84fb3ada196eef4 Author: Stefan Kangas Date: Fri Dec 24 03:24:44 2021 +0100 Prefer the defcustom :risky property in eshell * lisp/eshell/em-banner.el (eshell-banner-message): * lisp/eshell/em-hist.el (eshell-input-filter): * lisp/eshell/em-pred.el (eshell-predicate-alist) (eshell-modifier-alist): * lisp/eshell/esh-cmd.el (eshell-subcommand-bindings): * lisp/eshell/esh-io.el (eshell-virtual-targets): * lisp/eshell/esh-var.el (eshell-variable-aliases-list): Prefer defcustom :risky property to setting 'risky-local-variable manually. diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el index 034fa059b1..cebb030ded 100644 --- a/lisp/eshell/em-banner.el +++ b/lisp/eshell/em-banner.el @@ -61,10 +61,9 @@ modules may have a simple template to begin with." "The banner message to be displayed when Eshell is loaded. This can be any sexp, and should end with at least two newlines." :type 'sexp + :risky t :group 'eshell-banner) -(put 'eshell-banner-message 'risky-local-variable t) - (defcustom eshell-banner-load-hook nil "A list of functions to run when `eshell-banner' is loaded." :version "24.1" ; removed eshell-banner-initialize diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index d01e763b3e..ea9b820bcd 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -125,9 +125,8 @@ the input history list. Default is to save anything that isn't all whitespace." :type '(radio (function-item eshell-input-filter-default) (function-item eshell-input-filter-initial-space) - (function :tag "Other function"))) - -(put 'eshell-input-filter 'risky-local-variable t) + (function :tag "Other function")) + :risky t) (defun eshell-hist--update-keymap (symbol value) "Update `eshell-hist-mode-map' for `eshell-hist-match-partial'." diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index fc41bb8298..41afcc3dce 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -107,9 +107,8 @@ ordinary strings." The format of each entry is (CHAR . PREDICATE-FUNC-SEXP)" - :type '(repeat (cons character sexp))) - -(put 'eshell-predicate-alist 'risky-local-variable t) + :type '(repeat (cons character sexp)) + :risky t) (defcustom eshell-modifier-alist '((?E . (lambda (lst) @@ -144,9 +143,8 @@ The format of each entry is The format of each entry is (CHAR ENTRYWISE-P MODIFIER-FUNC-SEXP)" - :type '(repeat (cons character sexp))) - -(put 'eshell-modifier-alist 'risky-local-variable t) + :type '(repeat (cons character sexp)) + :risky t) (defvar eshell-predicate-help-string "Eshell predicate quick reference: diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 213b7ab289..1ddcc50f6f 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -258,9 +258,8 @@ the command." (default-directory default-directory) (process-environment (eshell-copy-environment))) "A list of `let' bindings for subcommand environments." - :type 'sexp) - -(put 'risky-local-variable 'eshell-subcommand-bindings t) + :type 'sexp + :risky t) (defvar eshell-ensure-newline-p nil "If non-nil, ensure that a newline is emitted after a Lisp form. diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el index c2471912ab..205275154b 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -147,10 +147,9 @@ not be added to this variable." function (choice (const :tag "Func returns output-func" t) (const :tag "Func is output-func" nil)))) + :risky t :group 'eshell-io) -(put 'eshell-virtual-targets 'risky-local-variable t) - ;;; Internal Variables: (defvar eshell-current-handles nil) diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 9aa50f2bd0..1c5a2f28cb 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -205,9 +205,8 @@ Additionally, each member may specify if it should be copied to the environment of created subprocesses." :type '(repeat (list string sexp (choice (const :tag "Copy to environment" t) - (const :tag "Use only in Eshell" nil))))) - -(put 'eshell-variable-aliases-list 'risky-local-variable t) + (const :tag "Use only in Eshell" nil)))) + :risky t) (defvar-keymap eshell-var-mode-map "C-c M-v" #'eshell-insert-envvar) commit 32fc42322487bc43b62fb964529c2321c2e0215c Author: Stefan Kangas Date: Thu Dec 23 20:10:26 2021 +0100 * lisp/eshell/em-hist.el (eshell-hist-match-partial): Minor doc fix. diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index df342df461..d01e763b3e 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -149,9 +149,9 @@ whitespace." (defcustom eshell-hist-match-partial t "If non-nil, movement through history is constrained by current input. -Otherwise, typing and will always go to the next history +Otherwise, typing \\`M-p' and \\`M-n' will always go to the next history element, regardless of any text on the command line. In that case, - and still offer that functionality." +\\`C-c M-r' and \\`C-c M-s' still offer that functionality." :type 'boolean :set 'eshell-hist--update-keymap) commit 31d34e43e54c6c45869562c40711cce6c5e48dab Author: Stefan Kangas Date: Thu Dec 23 19:03:53 2021 +0100 Use defvar-keymap in eshell * lisp/eshell/em-cmpl.el (eshell-cmpl-mode-map): * lisp/eshell/em-hist.el (eshell-isearch-map, eshell-hist-mode-map): * lisp/eshell/em-pred.el (eshell-pred-mode-map): * lisp/eshell/em-prompt.el (eshell-prompt-mode-map): * lisp/eshell/em-rebind.el (eshell-rebind-mode-map): * lisp/eshell/esh-arg.el (eshell-arg-mode-map): * lisp/eshell/esh-mode.el (eshell-mode-map, eshell-command-map): * lisp/eshell/esh-proc.el (eshell-proc-mode-map): * lisp/eshell/esh-var.el (eshell-var-mode-map): Use defvar-keymap. diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 4fd0afbeb8..8afc57bd75 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -226,19 +226,17 @@ to writing a completion function." (let ((completion-at-point-functions '(elisp-completion-at-point))) (completion-at-point))) -(defvar eshell-cmpl-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?i)] #'completion-at-point) - ;; jww (1999-10-19): Will this work on anything but X? - (define-key map [backtab] #'pcomplete-reverse) - (define-key map [(meta ??)] #'completion-help-at-point) - (define-key map [(meta control ?i)] #'eshell-complete-lisp-symbol) - ;; C-c prefix: - (define-key map (kbd "C-c M-h") #'eshell-completion-help) - (define-key map (kbd "C-c TAB") #'pcomplete-expand-and-complete) - (define-key map (kbd "C-c C-i") #'pcomplete-expand-and-complete) - (define-key map (kbd "C-c SPC") #'pcomplete-expand) - map)) +(defvar-keymap eshell-cmpl-mode-map + "C-i" #'completion-at-point + ;; jww (1999-10-19): Will this work on anything but X? + "" #'pcomplete-reverse + "M-?" #'completion-help-at-point + "C-M-i" #'eshell-complete-lisp-symbol + ;; C-c prefix: + "C-c M-h" #'eshell-completion-help + "C-c TAB" #'pcomplete-expand-and-complete + "C-c C-i" #'pcomplete-expand-and-complete + "C-c SPC" #'pcomplete-expand) (define-minor-mode eshell-cmpl-mode "Minor mode that provides a keymap when `eshell-cmpl' active. diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 4e7cccc0b5..df342df461 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -199,31 +199,28 @@ element, regardless of any text on the command line. In that case, (defvar eshell-matching-input-from-input-string "") (defvar eshell-save-history-index nil) -(defvar eshell-isearch-map - (let ((map (copy-keymap isearch-mode-map))) - (define-key map [(control ?m)] 'eshell-isearch-return) - (define-key map [(control ?r)] 'eshell-isearch-repeat-backward) - (define-key map [(control ?s)] 'eshell-isearch-repeat-forward) - (define-key map [(control ?g)] 'eshell-isearch-abort) - (define-key map [backspace] 'eshell-isearch-delete-char) - (define-key map [delete] 'eshell-isearch-delete-char) - (define-key map "\C-c\C-c" 'eshell-isearch-cancel) - map) - "Keymap used in isearch in Eshell.") - -(defvar eshell-hist-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [up] #'eshell-previous-matching-input-from-input) - (define-key map [down] #'eshell-next-matching-input-from-input) - (define-key map [(control up)] #'eshell-previous-input) - (define-key map [(control down)] #'eshell-next-input) - (define-key map [(meta ?r)] #'eshell-previous-matching-input) - (define-key map [(meta ?s)] #'eshell-next-matching-input) - (define-key map (kbd "C-c M-r") #'eshell-previous-matching-input-from-input) - (define-key map (kbd "C-c M-s") #'eshell-next-matching-input-from-input) - (define-key map (kbd "C-c C-l") #'eshell-list-history) - (define-key map (kbd "C-c C-x") #'eshell-get-next-from-history) - map)) +(defvar-keymap eshell-isearch-map + :doc "Keymap used in isearch in Eshell." + :parent isearch-mode-map + "C-m" #'eshell-isearch-return + "C-r" #'eshell-isearch-repeat-backward + "C-s" #'eshell-isearch-repeat-forward + "C-g" #'eshell-isearch-abort + "" #'eshell-isearch-delete-char + "" #'eshell-isearch-delete-char + "C-c C-c" #'eshell-isearch-cancel) + +(defvar-keymap eshell-hist-mode-map + "" #'eshell-previous-matching-input-from-input + "" #'eshell-next-matching-input-from-input + "C-" #'eshell-previous-input + "C-" #'eshell-next-input + "M-r" #'eshell-previous-matching-input + "M-s" #'eshell-next-matching-input + "C-c M-r" #'eshell-previous-matching-input-from-input + "C-c M-s" #'eshell-next-matching-input-from-input + "C-c C-l" #'eshell-list-history + "C-c C-x" #'eshell-get-next-from-history) ;; Update `eshell-hist-mode-map' for `eshell-hist-match-partial'. (eshell-hist--update-keymap 'eshell-hist-match-partial eshell-hist-match-partial) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 75a803d3ad..fc41bb8298 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -225,11 +225,9 @@ FOR LISTS OF ARGUMENTS: EXAMPLES: *.c(:o) sorted list of .c files") -(defvar eshell-pred-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-q") #'eshell-display-predicate-help) - (define-key map (kbd "C-c M-m") #'eshell-display-modifier-help) - map)) +(defvar-keymap eshell-pred-mode-map + "C-c M-q" #'eshell-display-predicate-help + "C-c M-m" #'eshell-display-modifier-help) ;;; Functions: diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index aa96166087..6a4c05d34f 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -96,11 +96,9 @@ arriving, or after." :options '(eshell-show-maximum-output) :group 'eshell-prompt) -(defvar eshell-prompt-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-n") #'eshell-next-prompt) - (define-key map (kbd "C-c C-p") #'eshell-previous-prompt) - map)) +(defvar-keymap eshell-prompt-mode-map + "C-c C-n" #'eshell-next-prompt + "C-c C-p" #'eshell-previous-prompt) ;;; Functions: diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el index d70444ea10..d24cfb3f42 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -136,10 +136,8 @@ This is default behavior of shells like bash." :type '(repeat function) :group 'eshell-rebind) -(defvar eshell-rebind-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-l") #'eshell-lock-local-map) - map)) +(defvar-keymap eshell-rebind-mode-map + "C-c M-l" #'eshell-lock-local-map) ;; Internal Variables: diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 1990c0cfa5..907625a554 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -152,10 +152,8 @@ treated as a literal character." :type 'hook :group 'eshell-arg) -(defvar eshell-arg-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-b") #'eshell-insert-buffer-name) - map)) +(defvar-keymap eshell-arg-mode-map + "C-c M-b" #'eshell-insert-buffer-name) ;;; Functions: diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index cae5236d89..7d176f4ea0 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -260,31 +260,28 @@ This is used by `eshell-watch-for-password-prompt'." (standard-syntax-table)) st)) -(defvar eshell-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c)] 'eshell-command-map) - (define-key map "\r" #'eshell-send-input) - (define-key map "\M-\r" #'eshell-queue-input) - (define-key map [(meta control ?l)] #'eshell-show-output) - (define-key map [(control ?a)] #'eshell-bol) - map)) - -(defvar eshell-command-map - (let ((map (define-prefix-command 'eshell-command-map))) - (define-key map [(meta ?o)] #'eshell-mark-output) - (define-key map [(meta ?d)] #'eshell-toggle-direct-send) - (define-key map [(control ?a)] #'eshell-bol) - (define-key map [(control ?b)] #'eshell-backward-argument) - (define-key map [(control ?e)] #'eshell-show-maximum-output) - (define-key map [(control ?f)] #'eshell-forward-argument) - (define-key map [(control ?m)] #'eshell-copy-old-input) - (define-key map [(control ?o)] #'eshell-kill-output) - (define-key map [(control ?r)] #'eshell-show-output) - (define-key map [(control ?t)] #'eshell-truncate-buffer) - (define-key map [(control ?u)] #'eshell-kill-input) - (define-key map [(control ?w)] #'backward-kill-word) - (define-key map [(control ?y)] #'eshell-repeat-argument) - map)) +(defvar-keymap eshell-mode-map + "C-c" 'eshell-command-map + "RET" #'eshell-send-input + "M-RET" #'eshell-queue-input + "C-M-l" #'eshell-show-output + "C-a" #'eshell-bol) + +(defvar-keymap eshell-command-map + :prefix 'eshell-command-map + "M-o" #'eshell-mark-output + "M-d" #'eshell-toggle-direct-send + "C-a" #'eshell-bol + "C-b" #'eshell-backward-argument + "C-e" #'eshell-show-maximum-output + "C-f" #'eshell-forward-argument + "C-m" #'eshell-copy-old-input + "C-o" #'eshell-kill-output + "C-r" #'eshell-show-output + "C-t" #'eshell-truncate-buffer + "C-u" #'eshell-kill-input + "C-w" #'backward-kill-word + "C-y" #'eshell-repeat-argument) ;;; User Functions: diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 7a0b26a065..75f3872d75 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -101,15 +101,13 @@ information, for example." (defvar eshell-process-list nil "A list of the current status of subprocesses.") -(defvar eshell-proc-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-i") #'eshell-insert-process) - (define-key map (kbd "C-c C-c") #'eshell-interrupt-process) - (define-key map (kbd "C-c C-k") #'eshell-kill-process) - (define-key map (kbd "C-c C-d") #'eshell-send-eof-to-process) - (define-key map (kbd "C-c C-s") #'list-processes) - (define-key map (kbd "C-c C-\\") #'eshell-quit-process) - map)) +(defvar-keymap eshell-proc-mode-map + "C-c M-i" #'eshell-insert-process + "C-c C-c" #'eshell-interrupt-process + "C-c C-k" #'eshell-kill-process + "C-c C-d" #'eshell-send-eof-to-process + "C-c C-s" #'list-processes + "C-c C-\\" #'eshell-quit-process) ;;; Functions: diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index fa9853ae00..9aa50f2bd0 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -209,10 +209,8 @@ environment of created subprocesses." (put 'eshell-variable-aliases-list 'risky-local-variable t) -(defvar eshell-var-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-v") #'eshell-insert-envvar) - map)) +(defvar-keymap eshell-var-mode-map + "C-c M-v" #'eshell-insert-envvar) ;;; Functions: commit 1668a9b91ec436f8d458dad65395c101e42ad1a8 Author: Stefan Kangas Date: Thu Dec 23 20:10:16 2021 +0100 Respect changes in eshell-hist-match-partial * lisp/eshell/em-hist.el (eshell-hist--update-keymap): New function. (eshell-hist-match-partial): Add :set property with above new function. (eshell-hist-mode-map): Update for eshell-hist-match-partial using eshell-hist--update-keymap. diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index aa158fa24c..4e7cccc0b5 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -129,12 +129,31 @@ whitespace." (put 'eshell-input-filter 'risky-local-variable t) +(defun eshell-hist--update-keymap (symbol value) + "Update `eshell-hist-mode-map' for `eshell-hist-match-partial'." + ;; Don't try to set this before it is bound. See below. + (when (and (boundp 'eshell-hist-mode-map) + (eq symbol 'eshell-hist-match-partial)) + (dolist (keyb + (if value + `(("M-p" . ,#'eshell-previous-matching-input-from-input) + ("M-n" . ,#'eshell-next-matching-input-from-input) + ("C-c M-p" . ,#'eshell-previous-input) + ("C-c M-n" . ,#'eshell-next-input)) + `(("M-p" . ,#'eshell-previous-input) + ("M-n" . ,#'eshell-next-input) + ("C-c M-p" . ,#'eshell-previous-matching-input-from-input) + ("C-c M-n" . ,#'eshell-next-matching-input-from-input)))) + (keymap-set eshell-hist-mode-map (car keyb) (cdr keyb)))) + (set-default symbol value)) + (defcustom eshell-hist-match-partial t "If non-nil, movement through history is constrained by current input. Otherwise, typing and will always go to the next history element, regardless of any text on the command line. In that case, and still offer that functionality." - :type 'boolean) + :type 'boolean + :set 'eshell-hist--update-keymap) (defcustom eshell-hist-move-to-end t "If non-nil, move to the end of the buffer before cycling history." @@ -202,21 +221,12 @@ element, regardless of any text on the command line. In that case, (define-key map [(meta ?s)] #'eshell-next-matching-input) (define-key map (kbd "C-c M-r") #'eshell-previous-matching-input-from-input) (define-key map (kbd "C-c M-s") #'eshell-next-matching-input-from-input) - ;; FIXME: Relies on `eshell-hist-match-partial' being set _before_ - ;; em-hist is loaded and won't respect changes. - (if eshell-hist-match-partial - (progn - (define-key map [(meta ?p)] 'eshell-previous-matching-input-from-input) - (define-key map [(meta ?n)] 'eshell-next-matching-input-from-input) - (define-key map (kbd "C-c M-p") #'eshell-previous-input) - (define-key map (kbd "C-c M-n") #'eshell-next-input)) - (define-key map [(meta ?p)] #'eshell-previous-input) - (define-key map [(meta ?n)] #'eshell-next-input) - (define-key map (kbd "C-c M-p") #'eshell-previous-matching-input-from-input) - (define-key map (kbd "C-c M-n") #'eshell-next-matching-input-from-input)) (define-key map (kbd "C-c C-l") #'eshell-list-history) (define-key map (kbd "C-c C-x") #'eshell-get-next-from-history) map)) +;; Update `eshell-hist-mode-map' for `eshell-hist-match-partial'. +(eshell-hist--update-keymap 'eshell-hist-match-partial + eshell-hist-match-partial) (defvar eshell-rebind-keys-alist) commit ab6452c47d524f46f9cd078c2255a2e18351ad5c Author: Yuuki Harano Date: Fri Dec 24 23:21:50 2021 +0900 * etc/PROBLEMS: Add a problem when PGTK started in systemd unit file diff --git a/etc/PROBLEMS b/etc/PROBLEMS index e70f61b719..230313d224 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -2798,6 +2798,17 @@ file; for example: "/usr/local/opt/libgccjit/lib/gcc/11" "/usr/local/opt/gcc/lib/gcc/11/gcc/x86_64-apple-darwin20/11.2.0") ":")) +* Runtime problems specific to PGTK + +** Some modifier keys doesn't work if Emacs is started in a systemd unit file. + +Environment variables may be different if there is a difference in the +behavior of keys between when started in the systemd unit file and +when started from the command line. + +Especially, PGTK Emacs needs environment variables LANG and +GTK_IM_MODULE. + * Build-time problems ** Configuration commit c09ad0cabde922374c1a34350595a3141ab7f806 Author: Dmitry Gutov Date: Fri Dec 24 15:27:00 2021 +0200 Fix the bug with duplicate entries in xref output * lisp/progmodes/etags.el (xref-backend-definitions): Make sure to save the changed intermediate value of the list (bug#52734). diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index f53b09d9e8..a63c3f3397 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -2084,14 +2084,15 @@ file name, add `tag-partial-file-name-match-p' to the list value.") (definitions (etags--xref-find-definitions symbol)) same-file-definitions) (when (and etags-xref-prefer-current-file file) - (cl-delete-if - (lambda (definition) - (when (equal file - (xref-location-group - (xref-item-location definition))) - (push definition same-file-definitions) - t)) - definitions) + (setq definitions + (cl-delete-if + (lambda (definition) + (when (equal file + (xref-location-group + (xref-item-location definition))) + (push definition same-file-definitions) + t)) + definitions)) (setq definitions (nconc (nreverse same-file-definitions) definitions))) definitions)) commit 54c96badf971860059ab88ab026a6b91d6e20bae Author: Michael Albinus Date: Fri Dec 24 11:32:34 2021 +0100 Add tag :tramp-asynchronous-processes to tramp-tests.el * test/lisp/net/tramp-tests.el (tramp-test29-start-file-process) (tramp--test--deftest-direct-async-process) (tramp-test30-make-process, tramp-test31-interrupt-process) (tramp-test34-explicit-shell-file-name) (tramp-test44-asynchronous-requests): Add :tramp-asynchronous-processes tag. (tramp--test-asynchronous-processes-p): New defun. (tramp-test32-shell-command, tramp-test33-environment-variables): Use it. (tramp--test-expensive-test-p): Rename from `tramp--test-expensive-test'. Make it a defun. Adapt all callees. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index eeb29314cc..f14d63af4c 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -157,13 +157,6 @@ being the result.") ;; Return result. (cdr tramp--test-enabled-checked)) -(defsubst tramp--test-expensive-test () - "Whether expensive tests are run." - (ert-select-tests - (ert--stats-selector ert--current-run-stats) - (list (make-ert-test :name (ert-test-name (ert-running-test)) - :body nil :tags '(:expensive-test))))) - (defun tramp--test-make-temp-name (&optional local quoted) "Return a temporary file name for test. If LOCAL is non-nil, a local file name is returned. @@ -2330,7 +2323,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `file-exist-p', `write-region' and `delete-file'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (should-not (file-exists-p tmp-name)) (write-region "foo" nil tmp-name) @@ -2365,7 +2358,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `file-local-copy'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) tmp-name2) (unwind-protect @@ -2397,7 +2390,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `insert-file-contents'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (with-temp-buffer @@ -2434,7 +2427,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `write-region'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) (inhibit-message t)) (unwind-protect @@ -2570,8 +2563,9 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless (tramp--test-enabled)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2598,7 +2592,7 @@ This checks also `file-name-as-directory', `file-name-directory', (with-temp-buffer (insert-file-contents target) (should (string-equal (buffer-string) "foo"))) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (copy-file source target) :type 'file-already-exists)) @@ -2616,7 +2610,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (copy-file source target) :type 'file-already-exists) @@ -2681,8 +2675,9 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless (tramp--test-enabled)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2712,7 +2707,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (buffer-string) "foo"))) (write-region "foo" nil source) (should (file-exists-p source)) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (rename-file source target) :type 'file-already-exists)) @@ -2730,7 +2725,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (rename-file source target) :type 'file-already-exists) @@ -2798,7 +2793,7 @@ This checks also `file-name-as-directory', `file-name-directory', This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo/bar" tmp-name1)) (unusual-file-mode-1 #o740) @@ -2836,7 +2831,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `delete-directory'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1))) ;; Delete empty directory. @@ -2913,7 +2908,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rclone-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (expand-file-name @@ -3022,7 +3017,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `directory-files'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "bla" tmp-name1)) (tmp-name3 (expand-file-name "foo" tmp-name1))) @@ -3066,7 +3061,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `file-expand-wildcards'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1)) (tmp-name3 (expand-file-name "bar" tmp-name1)) @@ -3136,7 +3131,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Emacs 27.1. (skip-unless (or (not (tramp--test-crypt-p)) (tramp--test-emacs27-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -3217,7 +3212,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Wildcards are not supported in tramp-crypt.el. (skip-unless (not (tramp--test-crypt-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 @@ -3321,7 +3316,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Relative file names in dired are not supported in tramp-crypt.el. (skip-unless (not (tramp--test-crypt-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -3375,7 +3370,7 @@ This tests also `access-file', `file-readable-p', `file-regular-p' and `file-ownership-preserved-p'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -3580,7 +3575,7 @@ They might differ only in time attributes or directory size." "Check `directory-files-and-attributes'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; `directory-files-and-attributes' contains also values for ;; "../". Ensure that this doesn't change during tests, for ;; example due to handling temporary files. @@ -3638,7 +3633,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-set-file-modes-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted))) @@ -3729,7 +3724,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -3754,11 +3749,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if quoted #'tramp-compat-file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (make-symbolic-link tmp-name1 tmp-name2) :type 'file-already-exists)) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) ;; A number means interactive case. (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error @@ -3798,7 +3793,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal tmp-name1 (file-symlink-p tmp-name3)))) ;; Check directory as newname. (make-directory tmp-name4) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (make-symbolic-link tmp-name1 tmp-name4) :type 'file-already-exists)) @@ -3826,7 +3821,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Check `add-name-to-file'. (unwind-protect - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (tramp--test-ignore-add-name-to-file-error (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) @@ -3941,11 +3936,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal (file-truename tmp-name2) (file-truename tmp-name3))) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (with-temp-buffer (insert-file-contents tmp-name2)) :type 'file-missing)) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (with-temp-buffer (insert-file-contents tmp-name3)) :type 'file-missing)) @@ -3963,7 +3958,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Detect cyclic symbolic links. (unwind-protect - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (tramp--test-ignore-make-symbolic-link-error (make-symbolic-link tmp-name2 tmp-name1) (should (file-symlink-p tmp-name1)) @@ -4001,7 +3996,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (or (tramp--test-adb-p) (tramp--test-gvfs-p) (tramp--test-sh-p) (tramp--test-sudoedit-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name nil quoted))) @@ -4050,7 +4045,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `set-visited-file-modtime' and `verify-visited-file-modtime'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -4083,8 +4078,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (tramp--test-crypt-p))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -4162,8 +4158,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (tramp--test-crypt-p))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -4310,7 +4307,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (unwind-protect (dolist (syntax - (if (tramp--test-expensive-test) + (if (tramp--test-expensive-test-p) (tramp-syntax-values) `(,orig-syntax))) (tramp-change-syntax syntax) ;; This has cleaned up all connection data, which are used @@ -4352,7 +4349,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-change-syntax orig-syntax)))) (dolist (non-essential '(nil t)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect @@ -4419,7 +4416,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `load'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -4448,7 +4445,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) (fnnd (file-name-nondirectory tmp-name)) (default-directory tramp-test-temporary-file-directory) @@ -4524,11 +4521,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ert-deftest tramp-test29-start-file-process () "Check `start-file-process'." - :tags '(:expensive-test) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) kill-buffer-query-functions proc) @@ -4680,7 +4677,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ignore-errors (make-process :file-handler t))) `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () ,docstring - :tags (if ,unstable '(:expensive-test :unstable) '(:expensive-test)) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and ,unstable '(:unstable))) (skip-unless (tramp--test-enabled)) (let ((default-directory tramp-test-temporary-file-directory) (ert-test (ert-get-test ',test)) @@ -4703,13 +4701,13 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ert-deftest tramp-test30-make-process () "Check `make-process'." - :tags '(:expensive-test) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; `make-process' supports file name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) kill-buffer-query-functions proc) @@ -4946,8 +4944,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." - :tags (if (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) - '(:expensive-test :unstable) '(:expensive-test)) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) + '(:unstable))) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) @@ -5012,7 +5011,7 @@ INPUT, if non-nil, is a string sent to the process." (when (tramp--test-adb-p) (skip-unless (tramp--test-emacs27-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) (default-directory tramp-test-temporary-file-directory) ;; Suppress nasty messages. @@ -5020,10 +5019,12 @@ INPUT, if non-nil, is a string sent to the process." kill-buffer-query-functions) (dolist (this-shell-command - '(;; Synchronously. - shell-command - ;; Asynchronously. - tramp--test-async-shell-command)) + (append + ;; Synchronously. + '(shell-command) + ;; Asynchronously. + (and (tramp--test-asynchronous-processes-p) + '(tramp--test-async-shell-command)))) ;; Test ordinary `{async-}shell-command'. (unwind-protect @@ -5064,31 +5065,34 @@ INPUT, if non-nil, is a string sent to the process." (ignore-errors (kill-buffer stderr)))))) ;; Test sending string to `async-shell-command'. - (unwind-protect - (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (tramp--test-async-shell-command - "read line; ls $line" (current-buffer) nil - ;; String to be sent. - (format "%s\n" (file-name-nondirectory tmp-name))) - (should - (string-equal - ;; tramp-adb.el echoes, so we must add the string. - (if (and (tramp--test-adb-p) (not (tramp-direct-async-process-p))) - (format - "%s\n%s\n" - (file-name-nondirectory tmp-name) - (file-name-nondirectory tmp-name)) - (format "%s\n" (file-name-nondirectory tmp-name))) - (buffer-string)))) + (when (tramp--test-asynchronous-processes-p) + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (tramp--test-async-shell-command + "read line; ls $line" (current-buffer) nil + ;; String to be sent. + (format "%s\n" (file-name-nondirectory tmp-name))) + (should + (string-equal + ;; tramp-adb.el echoes, so we must add the string. + (if (and (tramp--test-adb-p) + (not (tramp-direct-async-process-p))) + (format + "%s\n%s\n" + (file-name-nondirectory tmp-name) + (file-name-nondirectory tmp-name)) + (format "%s\n" (file-name-nondirectory tmp-name))) + (buffer-string)))) - ;; Cleanup. - (ignore-errors (delete-file tmp-name))))) + ;; Cleanup. + (ignore-errors (delete-file tmp-name)))))) ;; Test `async-shell-command-width'. It exists since Emacs 26.1, ;; but seems to work since Emacs 27.1 only. - (when (and (tramp--test-sh-p) (tramp--test-emacs27-p)) + (when (and (tramp--test-asynchronous-processes-p) + (tramp--test-sh-p) (tramp--test-emacs27-p)) (let* ((async-shell-command-width 1024) (default-directory tramp-test-temporary-file-directory) (cols (ignore-errors @@ -5235,10 +5239,12 @@ INPUT, if non-nil, is a string sent to the process." (skip-unless (not (tramp--test-crypt-p))) (dolist (this-shell-command-to-string - '(;; Synchronously. - shell-command-to-string - ;; Asynchronously. - tramp--test-shell-command-to-string-asynchronously)) + (append + ;; Synchronously. + '(shell-command-to-string) + ;; Asynchronously. + (and (tramp--test-asynchronous-processes-p) + '(tramp--test-shell-command-to-string-asynchronously)))) (let ((default-directory tramp-test-temporary-file-directory) (shell-file-name "/bin/sh") @@ -5422,7 +5428,7 @@ Use direct async.") (ert-deftest tramp-test34-explicit-shell-file-name () "Check that connection-local `explicit-shell-file-name' is set." - :tags '(:expensive-test) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for @@ -5587,7 +5593,7 @@ Use direct async.") (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, in ;; order to establish the connection prior running an asynchronous ;; process. @@ -5657,7 +5663,7 @@ Use direct async.") "Check `make-auto-save-file-name'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) tramp-allow-unsafe-temporary-files) @@ -5780,7 +5786,7 @@ Use direct async.") "Check `find-backup-file-name'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (ange-ftp-make-backup-files t) @@ -5931,7 +5937,7 @@ Use direct async.") ;; `lock-file', `unlock-file', `file-locked-p' and ;; `make-lock-file-name' exists since Emacs 28.1. We don't want to ;; see compiler warnings for older Emacsen. - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (remote-file-name-inhibit-cache t) @@ -6111,6 +6117,15 @@ This requires restrictions of file name syntax." (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) 'tramp-ftp-file-name-handler)) +(defun tramp--test-asynchronous-processes-p () + "Whether asynchronous processes tests are run. +This is used in tests which we dont't want to tag +`:tramp-asynchronous-processes' completely." + (ert-select-tests + (ert--stats-selector ert--current-run-stats) + (list (make-ert-test :name (ert-test-name (ert-running-test)) + :body nil :tags '(:tramp-asynchronous-processes))))) + (defun tramp--test-crypt-p () "Check, whether the remote directory is crypted." (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) @@ -6121,6 +6136,15 @@ This does not support some special file names." (string-equal "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-expensive-test-p () + "Whether expensive tests are run. +This is used in tests which we dont't want to tag `:expensive' +completely." + (ert-select-tests + (ert--stats-selector ert--current-run-stats) + (list (make-ert-test :name (ert-test-name (ert-running-test)) + :body nil :tags '(:expensive-test))))) + (defun tramp--test-ftp-p () "Check, whether an FTP-like method is used. This does not support globbing characters in file names (yet)." @@ -6264,8 +6288,9 @@ This requires restrictions of file name syntax." (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -6425,7 +6450,7 @@ This requires restrictions of file name syntax." ;; Check, that environment variables are set correctly. ;; We do not run on macOS due to encoding problems. See ;; Bug#36940. - (when (and (tramp--test-expensive-test) (tramp--test-sh-p) + (when (and (tramp--test-expensive-test-p) (tramp--test-sh-p) (not (tramp--test-crypt-p)) (not (eq system-type 'darwin))) (dolist (elt files) @@ -6507,7 +6532,7 @@ This requires restrictions of file name syntax." "{foo}bar{baz}"))) ;; Simplify test in order to speed up. (apply #'tramp--test-check-files - (if (tramp--test-expensive-test) + (if (tramp--test-expensive-test-p) files (list (mapconcat #'identity files "")))))) ;; These tests are inspired by Bug#17238. @@ -6606,7 +6631,7 @@ Use the \"ls\" command." ;; to U+1FFFF). "🌈🍒👋") - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (delete-dups (mapcar ;; Use all available language specific snippets. @@ -6778,8 +6803,8 @@ This is needed in timer functions as well as process filters and sentinels." "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." - :tags (if (getenv "EMACS_EMBA_CI") - '(:expensive-test :unstable) '(:expensive-test)) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and (getenv "EMACS_HYDRA_CI") '(:unstable))) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for commit b6fac9aaaf21c12a25e1cbec9cb8b8d14d2dc8a8 Author: Sebastian Fieber Date: Fri Dec 24 10:43:52 2021 +0100 verify signed content in smime encrypted and signed message * lisp/gnus/gnus-art.el (gnus-mime-display-part): Parse pkcs7 parts (bug#40397). (gnus-mime-security-verify-or-decrypt): (gnus-insert-mime-security-button): Handle these parts. * lisp/gnus/mm-decode.el (mm-verify-function-alist): Add pkcs7 functions. (mm-decrypt-function-alist): Handle them. (mm-possibly-verify-or-decrypt): Ditto. * lisp/gnus/mm-view.el (mm-view-pkcs7-decrypt): Handle pkcs7. Changes: - structure the result of mm-dissect-buffer of application/pkcs7-mime like a multipart mail so there is no loosing of information of verification and decryption results which can now be displayed by gnus-mime-display-security - adjust gnus-mime-display-part to handle application/pkcs7-mime like multipart/encrypted or multipart/signed - add dummy entries to mm-verify-function-alist and mm-decrypt-function-alist so gnus-mime-display-security correctly displays "S/MIME" and not "unknown protocol" - don't just check for multipart/signed in gnus-insert-mime-security-button but also for the pkcs7-mime mimetypes to print "Encrypted" or "Signed" accordingly in the security button - adjust mm-possibly-verify-or-decrypt to check for smime-type to ask wether to verify or decrypt the part and not to always ask to decrypt - adjust mm-view-pkcs7-decrypt and verify to call mm-sec-status so success information can be displayed by gnus-mime-display-security - adjust gnus-mime-security-verify-or-decrypt to handle pkcs7-mime right with the done changes diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index b7701f10a5..3b3564fc30 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -6084,6 +6084,34 @@ If nil, don't show those extra buttons." ((equal (car handle) "multipart/encrypted") (gnus-add-wash-type 'encrypted) (gnus-mime-display-security handle)) + ;; pkcs7-mime handling: + ;; + ;; although not really multipart these are structured internally by + ;; mm-dissect-buffer like multipart to not discard the decryption + ;; and verification results + ;; + ;; application/pkcs7-mime + ((and (equal (car handle) "application/pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_signed-data")) + (gnus-add-wash-type 'signed) + (gnus-mime-display-security handle)) + ((and (equal (car handle) "application/pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_enveloped-data")) + (gnus-add-wash-type 'encrypted) + (gnus-mime-display-security handle)) + ;; application/x-pkcs7-mime + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_signed-data")) + (gnus-add-wash-type 'signed) + (gnus-mime-display-security handle)) + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_enveloped-data")) + (gnus-add-wash-type 'encrypted) + (gnus-mime-display-security handle)) ;; Other multiparts are handled like multipart/mixed. (t (gnus-mime-display-mixed (cdr handle))))) @@ -8833,11 +8861,19 @@ For example: (setq point (point)) (with-current-buffer (mm-handle-multipart-original-buffer handle) (let* ((mm-verify-option 'known) - (mm-decrypt-option 'known) - (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle))) - (unless (eq nparts (cdr handle)) - (mm-destroy-parts (cdr handle)) - (setcdr handle nparts)))) + (mm-decrypt-option 'known) + (pkcs7-mime-p (or (equal (car handle) "application/pkcs7-mime") + (equal (car handle) "application/x-pkcs7-mime"))) + (nparts (if pkcs7-mime-p + (list (mm-possibly-verify-or-decrypt + (cadr handle) (cadadr handle))) + (mm-possibly-verify-or-decrypt (cdr handle) handle)))) + (unless (eq nparts (cdr handle)) + ;; if pkcs7-mime don't destroy the parts as the buffer in + ;; the cdr still needs to be accessible + (when (not pkcs7-mime-p) + (mm-destroy-parts (cdr handle))) + (setcdr handle nparts)))) (gnus-mime-display-security handle) (when region (delete-region (point) (cdr region)) @@ -8891,14 +8927,35 @@ For example: (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) (gnus-tmp-type (concat - (or (nth 2 (assoc protocol mm-verify-function-alist)) - (nth 2 (assoc protocol mm-decrypt-function-alist)) - "Unknown") - (if (equal (car handle) "multipart/signed") - " Signed" " Encrypted") - " Part")) - (gnus-tmp-info - (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown") + (cond ((equal (car handle) "multipart/signed") " Signed") + ((equal (car handle) "multipart/encrypted") " Encrypted") + ((and (equal (car handle) "application/pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_signed-data")) + " Signed") + ((and (equal (car handle) "application/pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_enveloped-data")) + " Encrypted") + ;; application/x-pkcs7-mime + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_signed-data")) + " Signed") + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_enveloped-data")) + " Encrypted")) + " Part")) + (gnus-tmp-info + (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) "Undecided")) (gnus-tmp-details (mm-handle-multipart-ctl-parameter handle 'gnus-details)) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index d781407cdc..d2889a50c0 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -474,6 +474,7 @@ The file will be saved in the directory `mm-tmp-directory'.") (autoload 'mml2015-verify-test "mml2015") (autoload 'mml-smime-verify "mml-smime") (autoload 'mml-smime-verify-test "mml-smime") +(autoload 'mm-view-pkcs7-verify "mm-view") (defvar mm-verify-function-alist '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test) @@ -482,7 +483,15 @@ The file will be saved in the directory `mm-tmp-directory'.") ("application/pkcs7-signature" mml-smime-verify "S/MIME" mml-smime-verify-test) ("application/x-pkcs7-signature" mml-smime-verify "S/MIME" - mml-smime-verify-test))) + mml-smime-verify-test) + ("application/x-pkcs7-signature" mml-smime-verify "S/MIME" + mml-smime-verify-test) + ;; these are only used for security-buttons and contain the + ;; smime-type after the underscore + ("application/pkcs7-mime_signed-data" mm-view-pkcs7-verify "S/MIME" + nil) + ("application/x-pkcs7-mime_signed-data" mml-view-pkcs7-verify "S/MIME" + nil))) (defcustom mm-verify-option 'never "Option of verifying signed parts. @@ -501,11 +510,17 @@ result of the verification." (autoload 'mml2015-decrypt "mml2015") (autoload 'mml2015-decrypt-test "mml2015") +(autoload 'mm-view-pkcs7-decrypt "mm-view") (defvar mm-decrypt-function-alist '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test) ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP" - mm-uu-pgp-encrypted-test))) + mm-uu-pgp-encrypted-test) + ;; these are only used for security-buttons and contain the + ;; smime-type after the underscore + ("application/pkcs7-mime_enveloped-data" mm-view-pkcs7-decrypt "S/MIME" nil) + ("application/x-pkcs7-mime_enveloped-data" + mm-view-pkcs7-decrypt "S/MIME" nil))) (defcustom mm-decrypt-option nil "Option of decrypting encrypted parts. @@ -682,18 +697,35 @@ MIME-Version header before proceeding." 'start start) (car ctl)) (cons (car ctl) (mm-dissect-multipart ctl from)))) - (t - (mm-possibly-verify-or-decrypt - (mm-dissect-singlepart - ctl - (and cte (intern (downcase (mail-header-strip-cte cte)))) - no-strict-mime - (and cd (mail-header-parse-content-disposition cd)) - description id) - ctl from)))) - (when id - (when (string-match " *<\\(.*\\)> *" id) - (setq id (match-string 1 id))) + (t + (let* ((handle + (mm-dissect-singlepart + ctl + (and cte (intern (downcase (mail-header-strip-cte cte)))) + no-strict-mime + (and cd (mail-header-parse-content-disposition cd)) + description id)) + (intermediate-result + (mm-possibly-verify-or-decrypt handle ctl from))) + (when (and (equal type "application") + (or (equal subtype "pkcs7-mime") + (equal subtype "x-pkcs7-mime"))) + (add-text-properties + 0 (length (car ctl)) + (list 'protocol + (concat (substring-no-properties (car ctl)) + "_" + (cdr (assoc 'smime-type ctl)))) + (car ctl)) + ;; If this is a pkcs7-mime lets treat this special and + ;; more like multipart so the pkcs7-mime part does not + ;; get ignored. + (setq intermediate-result + (cons (car ctl) (list intermediate-result)))) + intermediate-result)))) + (when id + (when (string-match " *<\\(.*\\)> *" id) + (setq id (match-string 1 id))) (push (cons id result) mm-content-id-alist)) result)))) @@ -1677,43 +1709,40 @@ If RECURSIVE, search recursively." (cond ((or (equal type "application/x-pkcs7-mime") (equal type "application/pkcs7-mime")) - (with-temp-buffer - (when (and (cond - ((equal smime-type "signed-data") t) - ((eq mm-decrypt-option 'never) nil) - ((eq mm-decrypt-option 'always) t) - ((eq mm-decrypt-option 'known) t) - (t (y-or-n-p "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. - (save-restriction - (mail-narrow-to-head) - (unless (mail-fetch-field "content-type") - (goto-char (point-max)) - (insert "Content-type: text/plain\n\n"))) - (setq parts - (if (equal smime-type "signed-data") - (list (propertize - "multipart/signed" - 'protocol "application/pkcs7-signature" - 'gnus-info - (format - "%s:%s" - (get-text-property 0 'gnus-info - (car mm-security-handle)) - (get-text-property 0 'gnus-details - (car mm-security-handle)))) - (mm-dissect-buffer t) - parts) - (mm-dissect-buffer t)))))) + (add-text-properties 0 (length (car ctl)) + (list 'buffer (car parts)) + (car ctl)) + (let* ((envelope-p (string= smime-type "enveloped-data")) + (decrypt-or-verify-option (if envelope-p + mm-decrypt-option + mm-verify-option)) + (question (if envelope-p + "Decrypt (S/MIME) part? " + "Verify signed (S/MIME) part? "))) + (with-temp-buffer + (when (and (cond + ((equal smime-type "signed-data") t) + ((eq decrypt-or-verify-option 'never) nil) + ((eq decrypt-or-verify-option 'always) t) + ((eq decrypt-or-verify-option 'known) t) + (t (y-or-n-p (format question)))) + (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. + (save-restriction + (mail-narrow-to-head) + (unless (mail-fetch-field "content-type") + (goto-char (point-max)) + (insert "Content-type: text/plain\n\n"))) + (setq parts (mm-dissect-buffer t)))))) ((equal subtype "signed") (unless (and (setq protocol (mm-handle-multipart-ctl-parameter ctl 'protocol)) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index d2a6d2cf5d..319bc745ff 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -634,12 +634,9 @@ If MODE is not set, try to find mode automatically." (context (epg-make-context 'CMS))) (prog1 (epg-verify-string context part) - (let ((result (car (epg-context-result-for context 'verify)))) + (let ((result (epg-context-result-for context 'verify))) (mm-sec-status - 'gnus-info (epg-signature-status result) - 'gnus-details - (format "%s:%s" (epg-signature-validity result) - (epg-signature-key-id result)))))))) + 'gnus-info (epg-verify-result-to-string result))))))) (with-temp-buffer (insert "MIME-Version: 1.0\n") (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") @@ -659,7 +656,11 @@ If MODE is not set, try to find mode automatically." ;; Use EPG/gpgsm (let ((part (base64-decode-string (buffer-string)))) (erase-buffer) - (insert (epg-decrypt-string (epg-make-context 'CMS) part))) + (insert + (let ((context (epg-make-context 'CMS))) + (prog1 + (epg-decrypt-string context part) + (mm-sec-status 'gnus-info "OK"))))) ;; Use openssl (insert "MIME-Version: 1.0\n") (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") commit b9015606d169d3a70c0c690e8107b894fe62b7cb Author: Lars Ingebrigtsen Date: Fri Dec 24 10:23:35 2021 +0100 Simplify whitespace stripping in shr-expand-url * lisp/net/shr.el (shr-expand-url): Simplify whitespace stripping. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index bd16a77959..676f609c24 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -857,11 +857,9 @@ size, and full-buffer size." shr-base)) (when (zerop (length url)) (setq url nil)) - ;; Strip leading/trailing whitespace - (and url (string-match "\\`\\s-+" url) - (setq url (substring url (match-end 0)))) - (and url (string-match "\\s-+\\'" url) - (setq url (substring url 0 (match-beginning 0)))) + ;; Strip leading/trailing whitespace. + (when url + (setq url (string-trim url))) (cond ((zerop (length url)) (nth 3 base)) ((or (not base)