commit e27004c5fe3c227476ea210ff5bee2efb783ae17 (HEAD, refs/remotes/origin/master) Author: Eric Abrahamsen Date: Tue May 9 19:17:29 2017 +0800 Obsolete gnus-copy-sequence and gnus-last-element (Bug#28856, Bug#28867) * lisp/gnus/gnus-range.el: Leave gnus-last-element in place, but obsolete it and point to car of last. Remove gnus-copy-sequence and define as an obsolete alias for copy-tree. (gnus-remove-from-range): * lisp/gnus/gnus-cache.el (gnus-cache-generate-active): * lisp/gnus/gnus-sum.el (gnus-summary-insert-articles, gnus-select-newsgroup, gnus-summary-read-group-1, gnus-select-newsgroup, gnus-update-marks, gnus-summary-insert-articles, gnus-summary-insert-new-articles): Replace calls in these locations. * lisp/gnus/gnus-agent.el (gnus-agent-catchup, gnus-agent-summary-fetch-series, gnus-category-copy): * lisp/gnus/gnus-cus.el (gnus-group-customize): * lisp/gnus/gnus-group.el (gnus-group-edit-group-done, gnus-group-make-useful-group): * lisp/gnus/gnus-score.el (gnus-score-adaptive): * lisp/gnus/gnus-srvr.el (gnus-server-copy-server): Replace calls in these locations. diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 6e7cc57a4c..466da53560 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -1108,7 +1108,7 @@ downloadable." gnus-newsgroup-cached) (setq articles (gnus-sorted-ndifference (gnus-sorted-ndifference - (gnus-copy-sequence articles) + (copy-tree articles) gnus-newsgroup-downloadable) gnus-newsgroup-cached))) @@ -1123,7 +1123,7 @@ downloadable." (when gnus-newsgroup-processable (setq gnus-newsgroup-downloadable (let* ((dl gnus-newsgroup-downloadable) - (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) + (processable (sort (copy-tree gnus-newsgroup-processable) '<)) (gnus-newsgroup-downloadable processable)) (gnus-agent-summary-fetch-group) @@ -2833,7 +2833,7 @@ The following commands are available: "Copy the current category." (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) (let ((info (assq category gnus-category-alist))) - (push (let ((newcat (gnus-copy-sequence info))) + (push (let ((newcat (copy-tree info))) (setf (gnus-agent-cat-name newcat) to) (setf (gnus-agent-cat-groups newcat) nil) newcat) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 12c8903d02..801728d2f2 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -735,7 +735,7 @@ If LOW, update the lower bound instead." ;; `gnus-cache-unified-group-names' needless. (gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names)) group) - (cons (car nums) (gnus-last-element nums)) + (cons (car nums) (car (last nums))) gnus-cache-active-hashtb)) ;; Go through all the other files. (dolist (file alphs) diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index 600b33f226..c22c9c1d5a 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -406,7 +406,7 @@ category.")) ;; every duplicate ends up being displayed. So, rather than ;; display them, remove them from the list. - (let ((tmp (setq values (gnus-copy-sequence values))) + (let ((tmp (setq values (copy-tree values))) elem) (while (cdr tmp) (while (setq elem (assq (caar tmp) (cdr tmp))) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 3b6ff0ab81..63e59e94e2 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -3000,7 +3000,7 @@ and NEW-NAME will be prompted for." ;; Set the info. (if (not (and info new-group)) (gnus-group-set-info form (or new-group group) part) - (setq info (gnus-copy-sequence info)) + (setq info (copy-tree info)) (setcar info new-group) (unless (gnus-server-equal method "native") (unless (nthcdr 3 info) @@ -3023,7 +3023,7 @@ and NEW-NAME will be prompted for." ;; Don't use `caddr' here since macros within the `interactive' ;; form won't be expanded. (car (cddr entry))))) - (setq method (gnus-copy-sequence method)) + (setq method (copy-tree method)) (let (entry) (while (setq entry (memq (assq 'eval method) method)) (setcar entry (eval (cadar entry))))) diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index b30b2e9099..70548d0280 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -38,17 +38,9 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE." (while (cdr list) (setq list (cdr list))) (car list)) +(make-obsolete 'gnus-last-element "use `car' of `last' instead." "27.1") -(defun gnus-copy-sequence (list) - "Do a complete, total copy of a list." - (let (out) - (while (consp list) - (if (consp (car list)) - (push (gnus-copy-sequence (pop list)) out) - (push (pop list) out))) - (if list - (nconc (nreverse out) list) - (nreverse out)))) +(define-obsolete-function-alias 'gnus-copy-sequence 'copy-tree "27.1") (defun gnus-set-difference (list1 list2) "Return a list of elements of LIST1 that do not appear in LIST2." @@ -455,7 +447,7 @@ modified." (if (or (null range1) (null range2)) range1 (let (out r1 r2 r1_min r1_max r2_min r2_max - (range2 (gnus-copy-sequence range2))) + (range2 (copy-tree range2))) (setq range1 (if (listp (cdr range1)) range1 (list range1)) range2 (sort (if (listp (cdr range2)) range2 (list range2)) (lambda (e1 e2) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 6c3a8b4cec..765dfab570 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -2318,7 +2318,7 @@ score in `gnus-newsgroup-scored' by SCORE." (when (or (not (listp gnus-newsgroup-adaptive)) (memq 'line gnus-newsgroup-adaptive)) (save-excursion - (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist)) + (let* ((malist (copy-tree gnus-adaptive-score-alist)) (alist malist) (date (current-time-string)) (data gnus-newsgroup-data) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 23d8b02efd..a3341470fa 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -609,7 +609,7 @@ The following commands are available: (error "%s already exists" to)) (unless (gnus-server-to-method from) (error "%s: no such server" from)) - (let ((to-entry (cons from (gnus-copy-sequence + (let ((to-entry (cons from (copy-tree (gnus-server-to-method from))))) (setcar to-entry to) (setcar (nthcdr 2 to-entry) to) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index f1a3600288..e599a8460f 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -3992,7 +3992,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (spam-initialize)) ;; Save the active value in effect when the group was entered. (setq gnus-newsgroup-active - (gnus-copy-sequence + (copy-tree (gnus-active gnus-newsgroup-name))) (setq gnus-newsgroup-highest (cdr gnus-newsgroup-active)) ;; You can change the summary buffer in some way with this hook. @@ -5737,7 +5737,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (mail-header-number (car gnus-newsgroup-headers)) gnus-newsgroup-end (mail-header-number - (gnus-last-element gnus-newsgroup-headers)))) + (car (last gnus-newsgroup-headers))))) ;; GROUP is successfully selected. (or gnus-newsgroup-headers t))))) @@ -6076,12 +6076,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." (del (gnus-list-range-intersection gnus-newsgroup-articles - (gnus-remove-from-range (gnus-copy-sequence old) list))) + (gnus-remove-from-range (copy-tree old) list))) (add (gnus-list-range-intersection gnus-newsgroup-articles (gnus-remove-from-range - (gnus-copy-sequence list) old)))) + (copy-tree list) old)))) (when add (push (list add 'add (list (cdr type))) delta-marks)) (when del @@ -12915,7 +12915,7 @@ returned." (mail-header-number (car gnus-newsgroup-headers)) gnus-newsgroup-end (mail-header-number - (gnus-last-element gnus-newsgroup-headers)))) + (car (last gnus-newsgroup-headers))))) (when gnus-use-scoring (gnus-possibly-score-headers)))) @@ -13002,7 +13002,7 @@ If ALL is a number, fetch this number of articles." i new) (unless new-active (error "Couldn't fetch new data")) - (setq gnus-newsgroup-active (gnus-copy-sequence new-active)) + (setq gnus-newsgroup-active (copy-tree new-active)) (setq i (cdr gnus-newsgroup-active) gnus-newsgroup-highest i) (while (> i old-high) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 0b6f72870e..3458fdea71 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -2769,7 +2769,6 @@ gnus-registry.el will populate this if it's loaded.") gnus-check-reasonable-setup) ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article gnus-dup-enter-articles) - ("gnus-range" gnus-copy-sequence) ("gnus-eform" gnus-edit-form) ("gnus-logic" gnus-score-advanced) ("gnus-undo" gnus-undo-mode gnus-undo-register) commit d1000fb48bb941c5336051f20fe7d46e60260605 Author: Stefan Monnier Date: Fri Nov 24 16:15:09 2017 -0500 * src/data.c: Fix regression in last clone-buffer change * src/data.c (Fmake_local_variable, Fmake_variable_buffer_local): Signal more precise error when applied to read-only variable. diff --git a/src/data.c b/src/data.c index 4a3afed6f7..7ca1892f64 100644 --- a/src/data.c +++ b/src/data.c @@ -1852,7 +1852,7 @@ The function `default-value' gets the default value and `set-default' sets it. } if (SYMBOL_CONSTANT_P (variable)) - error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); + xsignal1 (Qsetting_constant, variable); if (!blv) { @@ -1915,8 +1915,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) } if (sym->u.s.trapped_write == SYMBOL_NOWRITE) - error ("Symbol %s may not be buffer-local", - SDATA (SYMBOL_NAME (variable))); + xsignal1 (Qsetting_constant, variable); if (blv ? blv->local_if_set : (forwarded && BUFFER_OBJFWDP (valcontents.fwd))) commit 74b5103511dd41dbc0eda5ee848131eed6debc9a Author: Sam Steingold Date: Fri Nov 24 14:25:41 2017 -0500 Fix last patch: ensure the return value of tags-verify-table. * lisp/progmodes/etags.el (tags-verify-table): Since `(tags-table-mode)' always return nil now that it is a derived mode, call `verify-tags-table-function' explicitly. diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 50a9f8190d..9b21ee67ed 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -436,25 +436,25 @@ Returns non-nil if it is a valid table." (progn (set-buffer (get-file-buffer file)) (or verify-tags-table-function (tags-table-mode)) - (if (or (verify-visited-file-modtime (current-buffer)) - ;; Decide whether to revert the file. - ;; revert-without-query can say to revert - ;; or the user can say to revert. - (not (or (let ((tail revert-without-query) - (found nil)) - (while tail - (if (string-match (car tail) buffer-file-name) - (setq found t)) - (setq tail (cdr tail))) - found) - tags-revert-without-query - (yes-or-no-p - (format "Tags file %s has changed, read new contents? " - file))))) - (and verify-tags-table-function - (funcall verify-tags-table-function)) + (unless (or (verify-visited-file-modtime (current-buffer)) + ;; Decide whether to revert the file. + ;; revert-without-query can say to revert + ;; or the user can say to revert. + (not (or (let ((tail revert-without-query) + (found nil)) + (while tail + (if (string-match (car tail) buffer-file-name) + (setq found t)) + (setq tail (cdr tail))) + found) + tags-revert-without-query + (yes-or-no-p + (format "Tags file %s has changed, read new contents? " + file))))) (revert-buffer t t) - (tags-table-mode))) + (tags-table-mode)) + (and verify-tags-table-function + (funcall verify-tags-table-function))) (when (file-exists-p file) (let* ((buf (find-file-noselect file)) (newfile (buffer-file-name buf))) @@ -467,7 +467,9 @@ Returns non-nil if it is a valid table." ;; Only change buffer now that we're done using potentially ;; buffer-local variables. (set-buffer buf) - (tags-table-mode))))) + (tags-table-mode) + (and verify-tags-table-function + (funcall verify-tags-table-function)))))) ;; Subroutine of visit-tags-table-buffer. Search the current tags tables ;; for one that has tags for THIS-FILE (or that includes a table that commit a45a33097fc9f748a96226d6ebc2c872445348b0 Author: Pip Cet Date: Fri Nov 24 10:07:49 2017 -0800 Use NULL for NULL rather than false * src/xdisp.c (x_draw_bottom_divider): Fix type typo. diff --git a/src/xdisp.c b/src/xdisp.c index 016e7044ca..7e47c06c2d 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -31872,7 +31872,7 @@ x_draw_bottom_divider (struct window *w) int x1 = WINDOW_RIGHT_EDGE_X (w); int y0 = WINDOW_BOTTOM_EDGE_Y (w) - WINDOW_BOTTOM_DIVIDER_WIDTH (w); int y1 = WINDOW_BOTTOM_EDGE_Y (w); - struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : false; + struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : NULL; /* If W is vertically combined and has a sibling below, don't draw over any right divider. */ commit 4f779ff8e6445d9b46a87f494396ccb5f72b0350 Author: Stefan Monnier Date: Fri Nov 24 11:32:14 2017 -0500 * lisp/macros.el (insert-kbd-macro): Recognize kmacros reliably * lisp/macros.el (name-last-kbd-macro): Make it an alias of kmacro-name-last-macro. (insert-kbd-macro): Use kmacro-keyboard-macro-p so it also works for kmacros that fail to have a `kmacro' property. (see https://emacs.stackexchange.com/questions/37065, for an example). * lisp/kmacro.el: Remove redundant :group args. (kmacro-insert-counter): Simplify. (kmacro-extract-lambda): Use car/cdr-safe. (kmacro-p, kmacro-keyboard-macro-p): New functions. (kmacro-name-last-macro): Use them. diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 5729f2fc8d..da02ab5aca 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -124,13 +124,11 @@ (defcustom kmacro-call-mouse-event 'S-mouse-3 "The mouse event used by kmacro to call a macro. Set to nil if no mouse binding is desired." - :type 'symbol - :group 'kmacro) + :type 'symbol) (defcustom kmacro-ring-max 8 "Maximum number of keyboard macros to save in macro ring." - :type 'integer - :group 'kmacro) + :type 'integer) (defcustom kmacro-execute-before-append t @@ -141,32 +139,27 @@ execute the macro. Otherwise, a single \\[universal-argument] prefix does not execute the macro, while more than one \\[universal-argument] prefix causes the macro to be executed before appending to it." - :type 'boolean - :group 'kmacro) + :type 'boolean) (defcustom kmacro-repeat-no-prefix t "Allow repeating certain macro commands without entering the C-x C-k prefix." - :type 'boolean - :group 'kmacro) + :type 'boolean) (defcustom kmacro-call-repeat-key t "Allow repeating macro call using last key or a specific key." :type '(choice (const :tag "Disabled" nil) (const :tag "Last key" t) (character :tag "Character" :value ?e) - (symbol :tag "Key symbol" :value RET)) - :group 'kmacro) + (symbol :tag "Key symbol" :value RET))) (defcustom kmacro-call-repeat-with-arg nil "Repeat macro call with original arg when non-nil; repeat once if nil." - :type 'boolean - :group 'kmacro) + :type 'boolean) (defcustom kmacro-step-edit-mini-window-height 0.75 "Override `max-mini-window-height' when step edit keyboard macro." - :type 'number - :group 'kmacro) + :type 'number) ;; Keymap @@ -261,7 +254,7 @@ previous `kmacro-counter', and do not modify counter." (if kmacro-initial-counter-value (setq kmacro-counter kmacro-initial-counter-value kmacro-initial-counter-value nil)) - (if (and arg (listp arg)) + (if (consp arg) (insert (format kmacro-counter-format kmacro-last-counter)) (insert (format kmacro-counter-format kmacro-counter)) (kmacro-add-counter (prefix-numeric-value arg)))) @@ -280,8 +273,8 @@ previous `kmacro-counter', and do not modify counter." (defun kmacro-display-counter (&optional value) "Display current counter value." (unless value (setq value kmacro-counter)) - (message "New macro counter value: %s (%d)" (format kmacro-counter-format value) value)) - + (message "New macro counter value: %s (%d)" + (format kmacro-counter-format value) value)) (defun kmacro-set-counter (arg) "Set `kmacro-counter' to ARG or prompt if missing. @@ -774,19 +767,18 @@ If kbd macro currently being defined end it before activating it." (defun kmacro-extract-lambda (mac) "Extract kmacro from a kmacro lambda form." - (and (consp mac) - (eq (car mac) 'lambda) + (and (eq (car-safe mac) 'lambda) (setq mac (assoc 'kmacro-exec-ring-item mac)) - (consp (cdr mac)) - (consp (car (cdr mac))) - (consp (cdr (car (cdr mac)))) - (setq mac (car (cdr (car (cdr mac))))) + (setq mac (car-safe (cdr-safe (car-safe (cdr-safe mac))))) (listp mac) (= (length mac) 3) (arrayp (car mac)) mac)) +(defalias 'kmacro-p #'kmacro-extract-lambda + "Return non-nil if MAC is a kmacro keyboard macro.") + (defun kmacro-bind-to-key (_arg) "When not defining or executing a macro, offer to bind last macro to a key. The key sequences [C-x C-k 0] through [C-x C-k 9] and [C-x C-k A] @@ -827,6 +819,13 @@ The ARG parameter is unused." (kmacro-lambda-form (kmacro-ring-head))) (message "Keyboard macro bound to %s" (format-kbd-macro key-seq)))))) +(defun kmacro-keyboard-macro-p (symbol) + "Return non-nil if SYMBOL is the name of some sort of keyboard macro." + (let ((f (symbol-function symbol))) + (when f + (or (stringp f) + (vectorp f) + (kmacro-p f))))) (defun kmacro-name-last-macro (symbol) "Assign a name to the last keyboard macro defined. @@ -837,14 +836,18 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command (or last-kbd-macro (error "No keyboard macro defined")) (and (fboundp symbol) - (not (get symbol 'kmacro)) - (not (stringp (symbol-function symbol))) - (not (vectorp (symbol-function symbol))) + (not (kmacro-keyboard-macro-p symbol)) (error "Function %s is already defined and not a keyboard macro" symbol)) (if (string-equal symbol "") (error "No command name given")) + ;; FIXME: Use plain old `last-kbd-macro' for kmacros where it doesn't + ;; make a difference? (fset symbol (kmacro-lambda-form (kmacro-ring-head))) + ;; This used to be used to detect when a symbol corresponds to a kmacro. + ;; Nowadays it's unused because we used `kmacro-p' instead to see if the + ;; symbol's function definition matches that of a kmacro, which is more + ;; reliable. (put symbol 'kmacro t)) @@ -1203,7 +1206,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (setq kmacro-step-edit-key-index next-index))) (defun kmacro-step-edit-pre-command () - (remove-hook 'post-command-hook 'kmacro-step-edit-post-command) + (remove-hook 'post-command-hook #'kmacro-step-edit-post-command) (when kmacro-step-edit-active (cond ((eq kmacro-step-edit-active 'ignore) @@ -1223,17 +1226,17 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (setq kmacro-step-edit-appending nil kmacro-step-edit-active 'ignore))))) (when (eq kmacro-step-edit-active t) - (add-hook 'post-command-hook 'kmacro-step-edit-post-command t))) + (add-hook 'post-command-hook #'kmacro-step-edit-post-command t))) (defun kmacro-step-edit-minibuf-setup () - (remove-hook 'pre-command-hook 'kmacro-step-edit-pre-command t) + (remove-hook 'pre-command-hook #'kmacro-step-edit-pre-command t) (when kmacro-step-edit-active - (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil t))) + (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil t))) (defun kmacro-step-edit-post-command () - (remove-hook 'pre-command-hook 'kmacro-step-edit-pre-command) + (remove-hook 'pre-command-hook #'kmacro-step-edit-pre-command) (when kmacro-step-edit-active - (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil nil) + (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil nil) (if kmacro-step-edit-key-index (setq executing-kbd-macro-index kmacro-step-edit-key-index) (setq kmacro-step-edit-key-index executing-kbd-macro-index)))) @@ -1256,9 +1259,9 @@ To customize possible responses, change the \"bindings\" in `kmacro-step-edit-ma (pre-command-hook pre-command-hook) (post-command-hook post-command-hook) (minibuffer-setup-hook minibuffer-setup-hook)) - (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil) - (add-hook 'post-command-hook 'kmacro-step-edit-post-command t) - (add-hook 'minibuffer-setup-hook 'kmacro-step-edit-minibuf-setup t) + (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil) + (add-hook 'post-command-hook #'kmacro-step-edit-post-command t) + (add-hook 'minibuffer-setup-hook #'kmacro-step-edit-minibuf-setup t) (call-last-kbd-macro nil nil) (when (and kmacro-step-edit-replace kmacro-step-edit-new-macro diff --git a/lisp/macros.el b/lisp/macros.el index 34e81f693f..5583c02f68 100644 --- a/lisp/macros.el +++ b/lisp/macros.el @@ -1,4 +1,4 @@ -;;; macros.el --- non-primitive commands for keyboard macros +;;; macros.el --- non-primitive commands for keyboard macros -*- lexical-binding:t -*- ;; Copyright (C) 1985-1987, 1992, 1994-1995, 2001-2017 Free Software ;; Foundation, Inc. @@ -31,23 +31,10 @@ ;;; Code: +(require 'kmacro) + ;;;###autoload -(defun name-last-kbd-macro (symbol) - "Assign a name to the last keyboard macro defined. -Argument SYMBOL is the name to define. -The symbol's function definition becomes the keyboard macro string. -Such a \"function\" cannot be called from Lisp, but it is a valid editor command." - (interactive "SName for last kbd macro: ") - (or last-kbd-macro - (user-error "No keyboard macro defined")) - (and (fboundp symbol) - (not (stringp (symbol-function symbol))) - (not (vectorp (symbol-function symbol))) - (user-error "Function %s is already defined and not a keyboard macro" - symbol)) - (if (string-equal symbol "") - (user-error "No command name given")) - (fset symbol last-kbd-macro)) +(defalias 'name-last-kbd-macro #'kmacro-name-last-macro) ;;;###autoload (defun insert-kbd-macro (macroname &optional keys) @@ -66,11 +53,7 @@ To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', use this command, and then save the file." (interactive (list (intern (completing-read "Insert kbd macro (name): " obarray - (lambda (elt) - (and (fboundp elt) - (or (stringp (symbol-function elt)) - (vectorp (symbol-function elt)) - (get elt 'kmacro)))) + #'kmacro-keyboard-macro-p t)) current-prefix-arg)) (let (definition) @@ -137,6 +120,9 @@ use this command, and then save the file." (prin1 char (current-buffer)) (princ (prin1-char char) (current-buffer)))) (insert ?\])) + ;; FIXME: For kmacros, we shouldn't write the (lambda ...) + ;; gunk but instead we should write something more abstract like + ;; (kmacro-create [] 0 "%d"). (prin1 definition (current-buffer)))) (insert ")\n") (if keys commit b407c521f24b07b76eee0cd06d471e629cef18e8 Author: Daiki Ueno Date: Fri Nov 24 16:11:48 2017 +0100 Remove pinentry.el * lisp/epg.el (epg--start): Remove the use of pinentry.el. * lisp/net/pinentry.el: Remove (bug#27445). diff --git a/lisp/epg.el b/lisp/epg.el index fee6ad7511..903cbd62ee 100644 --- a/lisp/epg.el +++ b/lisp/epg.el @@ -551,8 +551,6 @@ callback data (if any)." (defun epg-errors-to-string (errors) (mapconcat #'epg-error-to-string errors "; ")) -(declare-function pinentry-start "pinentry" (&optional quiet)) - (defun epg--start (context args) "Start `epg-gpg-program' in a subprocess with given ARGS." (if (and (epg-context-process context) @@ -604,23 +602,6 @@ callback data (if any)." (setq process-environment (cons (concat "GPG_TTY=" terminal-name) (cons "TERM=xterm" process-environment)))) - ;; Automatically start the Emacs Pinentry server if appropriate. - (when (and (fboundp 'pinentry-start) - ;; Emacs Pinentry is useless if Emacs has no interactive session. - (not noninteractive) - ;; Prefer pinentry-mode over Emacs Pinentry. - (null (epg-context-pinentry-mode context)) - ;; Check if the allow-emacs-pinentry option is set. - (executable-find epg-gpgconf-program) - (with-temp-buffer - (when (= (call-process epg-gpgconf-program nil t nil - "--list-options" "gpg-agent") - 0) - (goto-char (point-min)) - (re-search-forward - "^allow-emacs-pinentry:\\(?:.*:\\)\\{8\\}1" - nil t)))) - (pinentry-start 'quiet)) (setq process-environment (cons (format "INSIDE_EMACS=%s,epg" emacs-version) process-environment)) diff --git a/lisp/net/pinentry.el b/lisp/net/pinentry.el deleted file mode 100644 index f8d81fde91..0000000000 --- a/lisp/net/pinentry.el +++ /dev/null @@ -1,460 +0,0 @@ -;;; pinentry.el --- GnuPG Pinentry server implementation -*- lexical-binding: t -*- - -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. - -;; Author: Daiki Ueno -;; Version: 0.1 -;; Keywords: GnuPG - -;; 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 . - -;;; Commentary: - -;; This package allows GnuPG passphrase to be prompted through the -;; minibuffer instead of graphical dialog. -;; -;; To use, add "allow-emacs-pinentry" to "~/.gnupg/gpg-agent.conf", -;; reload the configuration with "gpgconf --reload gpg-agent", and -;; start the server with M-x pinentry-start. -;; -;; The actual communication path between the relevant components is -;; as follows: -;; -;; gpg --> gpg-agent --> pinentry --> Emacs -;; -;; where pinentry and Emacs communicate through a Unix domain socket -;; created at: -;; -;; ${TMPDIR-/tmp}/emacs$(id -u)/pinentry -;; -;; under the same directory which server.el uses. The protocol is a -;; subset of the Pinentry Assuan protocol described in (info -;; "(pinentry) Protocol"). -;; -;; NOTE: As of August 2015, this feature requires newer versions of -;; GnuPG (2.1.5+) and Pinentry (0.9.5+). - -;;; Code: - -(eval-when-compile (require 'cl-lib)) - -(defgroup pinentry nil - "The Pinentry server" - :version "25.1" - :group 'external) - -(defcustom pinentry-popup-prompt-window t - "If non-nil, display multiline prompt in another window." - :type 'boolean - :group 'pinentry) - -(defcustom pinentry-prompt-window-height 5 - "Number of lines used to display multiline prompt." - :type 'integer - :group 'pinentry) - -(defvar pinentry-debug nil) -(defvar pinentry-debug-buffer nil) -(defvar pinentry--server-process nil) -(defvar pinentry--connection-process-list nil) - -(defvar pinentry--labels nil) -(put 'pinentry-read-point 'permanent-local t) -(defvar pinentry--read-point nil) -(put 'pinentry--read-point 'permanent-local t) - -(defvar pinentry--prompt-buffer nil) - -;; We use the same location as `server-socket-dir', when local sockets -;; are supported. -(defvar pinentry--socket-dir - (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid)) - "The directory in which to place the server socket. -If local sockets are not supported, this is nil.") - -(defconst pinentry--set-label-commands - '("SETPROMPT" "SETTITLE" "SETDESC" - "SETREPEAT" "SETREPEATERROR" - "SETOK" "SETCANCEL" "SETNOTOK")) - -;; These error codes are defined in libgpg-error/src/err-codes.h.in. -(defmacro pinentry--error-code (code) - (logior (lsh 5 24) code)) -(defconst pinentry--error-not-implemented - (cons (pinentry--error-code 69) "not implemented")) -(defconst pinentry--error-cancelled - (cons (pinentry--error-code 99) "cancelled")) -(defconst pinentry--error-not-confirmed - (cons (pinentry--error-code 114) "not confirmed")) - -(autoload 'server-ensure-safe-dir "server") - -(defvar pinentry-prompt-mode-map - (let ((keymap (make-sparse-keymap))) - (define-key keymap "q" 'quit-window) - keymap)) - -(define-derived-mode pinentry-prompt-mode special-mode "Pinentry" - "Major mode for `pinentry--prompt-buffer'." - (buffer-disable-undo) - (setq truncate-lines t - buffer-read-only t)) - -(defun pinentry--prompt (labels query-function &rest query-args) - (let ((desc (cdr (assq 'desc labels))) - (error (cdr (assq 'error labels))) - (prompt (cdr (assq 'prompt labels)))) - (when (string-match "[ \n]*\\'" prompt) - (setq prompt (concat - (substring - prompt 0 (match-beginning 0)) " "))) - (when error - (setq desc (concat "Error: " (propertize error 'face 'error) - "\n" desc))) - (if (and desc pinentry-popup-prompt-window) - (save-window-excursion - (delete-other-windows) - (unless (and pinentry--prompt-buffer - (buffer-live-p pinentry--prompt-buffer)) - (setq pinentry--prompt-buffer (generate-new-buffer "*Pinentry*"))) - (if (get-buffer-window pinentry--prompt-buffer) - (delete-window (get-buffer-window pinentry--prompt-buffer))) - (with-current-buffer pinentry--prompt-buffer - (let ((inhibit-read-only t) - buffer-read-only) - (erase-buffer) - (insert desc)) - (pinentry-prompt-mode) - (goto-char (point-min))) - (if (> (window-height) - pinentry-prompt-window-height) - (set-window-buffer (split-window nil - (- (window-height) - pinentry-prompt-window-height)) - pinentry--prompt-buffer) - (pop-to-buffer pinentry--prompt-buffer) - (if (> (window-height) pinentry-prompt-window-height) - (shrink-window (- (window-height) - pinentry-prompt-window-height)))) - (prog1 (apply query-function prompt query-args) - (quit-window))) - (apply query-function (concat desc "\n" prompt) query-args)))) - -;;;###autoload -(defun pinentry-start (&optional quiet) - "Start a Pinentry service. - -Once the environment is properly set, subsequent invocations of -the gpg command will interact with Emacs for passphrase input. - -If the optional QUIET argument is non-nil, messages at startup -will not be shown." - (interactive) - (unless (featurep 'make-network-process '(:family local)) - (error "local sockets are not supported")) - (if (process-live-p pinentry--server-process) - (unless quiet - (message "Pinentry service is already running")) - (let* ((server-file (expand-file-name "pinentry" pinentry--socket-dir))) - (server-ensure-safe-dir pinentry--socket-dir) - ;; Delete the socket files made by previous server invocations. - (ignore-errors - (let (delete-by-moving-to-trash) - (delete-file server-file))) - (cl-letf (((default-file-modes) ?\700)) - (setq pinentry--server-process - (make-network-process - :name "pinentry" - :server t - :noquery t - :sentinel #'pinentry--process-sentinel - :filter #'pinentry--process-filter - :coding 'no-conversion - :family 'local - :service server-file)) - (process-put pinentry--server-process :server-file server-file))))) - -(defun pinentry-stop () - "Stop a Pinentry service." - (interactive) - (when (process-live-p pinentry--server-process) - (delete-process pinentry--server-process)) - (setq pinentry--server-process nil) - (dolist (process pinentry--connection-process-list) - (when (buffer-live-p (process-buffer process)) - (kill-buffer (process-buffer process)))) - (setq pinentry--connection-process-list nil)) - -(defun pinentry--labels-to-shortcuts (labels) - "Convert strings in LABEL by stripping mnemonics." - (mapcar (lambda (label) - (when label - (let (c) - (if (string-match "\\(?:\\`\\|[^_]\\)_\\([[:alnum:]]\\)" label) - (let ((key (match-string 1 label))) - (setq c (downcase (aref key 0))) - (setq label (replace-match - (propertize key 'face 'underline) - t t label))) - (setq c (if (= (length label) 0) - ?? - (downcase (aref label 0))))) - ;; Double underscores mean a single underscore. - (when (string-match "__" label) - (setq label (replace-match "_" t t label))) - (cons c label)))) - labels)) - -(defun pinentry--escape-string (string) - "Escape STRING in the Assuan percent escape." - (let ((length (length string)) - (index 0) - (count 0)) - (while (< index length) - (if (memq (aref string index) '(?\n ?\r ?%)) - (setq count (1+ count))) - (setq index (1+ index))) - (setq index 0) - (let ((result (make-string (+ length (* count 2)) ?\0)) - (result-index 0) - c) - (while (< index length) - (setq c (aref string index)) - (if (memq c '(?\n ?\r ?%)) - (let ((hex (format "%02X" c))) - (aset result result-index ?%) - (setq result-index (1+ result-index)) - (aset result result-index (aref hex 0)) - (setq result-index (1+ result-index)) - (aset result result-index (aref hex 1)) - (setq result-index (1+ result-index))) - (aset result result-index c) - (setq result-index (1+ result-index))) - (setq index (1+ index))) - result))) - -(defun pinentry--unescape-string (string) - "Unescape STRING in the Assuan percent escape." - (let ((length (length string)) - (index 0)) - (let ((result (make-string length ?\0)) - (result-index 0) - c) - (while (< index length) - (setq c (aref string index)) - (if (and (eq c '?%) (< (+ index 2) length)) - (progn - (aset result result-index - (string-to-number (substring string - (1+ index) - (+ index 3)) - 16)) - (setq result-index (1+ result-index)) - (setq index (+ index 2))) - (aset result result-index c) - (setq result-index (1+ result-index))) - (setq index (1+ index))) - (substring result 0 result-index)))) - -(defun pinentry--send-data (process escaped) - "Send a string ESCAPED to a process PROCESS. -ESCAPED will be split if it exceeds the line length limit of the -Assuan protocol." - (let ((length (length escaped)) - (index 0)) - (if (= length 0) - (process-send-string process "D \n") - (while (< index length) - ;; 997 = ASSUAN_LINELENGTH (= 1000) - strlen ("D \n") - (let* ((sub-length (min (- length index) 997)) - (sub (substring escaped index (+ index sub-length)))) - (unwind-protect - (progn - (process-send-string process "D ") - (process-send-string process sub) - (process-send-string process "\n")) - (clear-string sub)) - (setq index (+ index sub-length))))))) - -(defun pinentry--send-error (process error) - (process-send-string process (format "ERR %d %s\n" (car error) (cdr error)))) - -(defun pinentry--process-filter (process input) - (unless (buffer-live-p (process-buffer process)) - (let ((buffer (generate-new-buffer " *pinentry*"))) - (set-process-buffer process buffer) - (with-current-buffer buffer - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) - (make-local-variable 'pinentry--read-point) - (setq pinentry--read-point (point-min)) - (make-local-variable 'pinentry--labels)))) - (with-current-buffer (process-buffer process) - (when pinentry-debug - (with-current-buffer - (or pinentry-debug-buffer - (setq pinentry-debug-buffer (generate-new-buffer - " *pinentry-debug*"))) - (goto-char (point-max)) - (insert input))) - (save-excursion - (goto-char (point-max)) - (insert input) - (goto-char pinentry--read-point) - (beginning-of-line) - (while (looking-at ".*\n") ;the input line finished - (if (looking-at "\\([A-Z_]+\\) ?\\(.*\\)") - (let ((command (match-string 1)) - (string (pinentry--unescape-string (match-string 2)))) - (pcase command - ((and set (guard (member set pinentry--set-label-commands))) - (when (> (length string) 0) - (let* ((symbol (intern (downcase (substring set 3)))) - (entry (assq symbol pinentry--labels)) - (label (decode-coding-string string 'utf-8))) - (if entry - (setcdr entry label) - (push (cons symbol label) pinentry--labels)))) - (ignore-errors - (process-send-string process "OK\n"))) - ("NOP" - (ignore-errors - (process-send-string process "OK\n"))) - ("GETPIN" - (let ((confirm (not (null (assq 'repeat pinentry--labels)))) - passphrase escaped-passphrase encoded-passphrase) - (unwind-protect - (condition-case err - (progn - (setq passphrase - (pinentry--prompt - pinentry--labels - #'read-passwd confirm)) - (setq escaped-passphrase - (pinentry--escape-string - passphrase)) - (setq encoded-passphrase (encode-coding-string - escaped-passphrase - 'utf-8)) - (ignore-errors - (pinentry--send-data - process encoded-passphrase) - (process-send-string process "OK\n"))) - (error - (message "GETPIN error %S" err) - (ignore-errors - (pinentry--send-error - process - pinentry--error-cancelled)))) - (if passphrase - (clear-string passphrase)) - (if escaped-passphrase - (clear-string escaped-passphrase)) - (if encoded-passphrase - (clear-string encoded-passphrase)))) - (setq pinentry--labels nil)) - ("CONFIRM" - (let ((prompt - (or (cdr (assq 'prompt pinentry--labels)) - "Confirm? ")) - (buttons - (delq nil - (pinentry--labels-to-shortcuts - (list (cdr (assq 'ok pinentry--labels)) - (cdr (assq 'notok pinentry--labels)) - (cdr (assq 'cancel pinentry--labels)))))) - entry) - (if buttons - (progn - (setq prompt - (concat prompt " (" - (mapconcat #'cdr buttons - ", ") - ") ")) - (if (setq entry (assq 'prompt pinentry--labels)) - (setcdr entry prompt) - (setq pinentry--labels (cons (cons 'prompt prompt) - pinentry--labels))) - (condition-case nil - (let ((result (pinentry--prompt pinentry--labels - #'read-char))) - (if (eq result (caar buttons)) - (ignore-errors - (process-send-string process "OK\n")) - (if (eq result (car (nth 1 buttons))) - (ignore-errors - (pinentry--send-error - process - pinentry--error-not-confirmed)) - (ignore-errors - (pinentry--send-error - process - pinentry--error-cancelled))))) - (error - (ignore-errors - (pinentry--send-error - process - pinentry--error-cancelled))))) - (if (setq entry (assq 'prompt pinentry--labels)) - (setcdr entry prompt) - (setq pinentry--labels (cons (cons 'prompt prompt) - pinentry--labels))) - (if (condition-case nil - (pinentry--prompt pinentry--labels #'y-or-n-p) - (quit)) - (ignore-errors - (process-send-string process "OK\n")) - (ignore-errors - (pinentry--send-error - process - pinentry--error-not-confirmed)))) - (setq pinentry--labels nil))) - (_ (ignore-errors - (pinentry--send-error - process - pinentry--error-not-implemented)))) - (forward-line) - (setq pinentry--read-point (point)))))))) - -(defun pinentry--process-sentinel (process _status) - "The process sentinel for Emacs server connections." - ;; If this is a new client process, set the query-on-exit flag to nil - ;; for this process (it isn't inherited from the server process). - (when (and (eq (process-status process) 'open) - (process-query-on-exit-flag process)) - (push process pinentry--connection-process-list) - (set-process-query-on-exit-flag process nil) - (ignore-errors - (process-send-string process "OK Your orders please\n"))) - ;; Kill the process buffer of the connection process. - (when (and (not (process-contact process :server)) - (eq (process-status process) 'closed)) - (when (buffer-live-p (process-buffer process)) - (kill-buffer (process-buffer process))) - (setq pinentry--connection-process-list - (delq process pinentry--connection-process-list))) - ;; Delete the associated connection file, if applicable. - ;; Although there's no 100% guarantee that the file is owned by the - ;; running Emacs instance, server-start uses server-running-p to check - ;; for possible servers before doing anything, so it *should* be ours. - (and (process-contact process :server) - (eq (process-status process) 'closed) - (ignore-errors - (delete-file (process-get process :server-file))))) - -(provide 'pinentry) - -;;; pinentry.el ends here