diff options
Diffstat (limited to 'lisp')
187 files changed, 2934 insertions, 3650 deletions
diff --git a/lisp/align.el b/lisp/align.el index c1a2b691312..61387b23dc7 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -129,6 +129,8 @@ "Hook that gets run after the aligner has been loaded." :type 'hook :group 'align) +(make-obsolete-variable 'align-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom align-indent-before-aligning nil "If non-nil, indent the marked region before aligning it." diff --git a/lisp/allout.el b/lisp/allout.el index 174f1e3dc21..dedad45f827 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -1675,10 +1675,8 @@ valid values." ;; least in emacs 21, 22.1, and xemacs 21.4. (put 'allout-exposure-category 'isearch-open-invisible 'allout-isearch-end-handler) - (if (featurep 'xemacs) - (put 'allout-exposure-category 'start-open t) - (put 'allout-exposure-category 'insert-in-front-hooks - '(allout-overlay-insert-in-front-handler))) + (put 'allout-exposure-category 'insert-in-front-hooks + '(allout-overlay-insert-in-front-handler)) (put 'allout-exposure-category 'modification-hooks '(allout-overlay-interior-modification-handler))) ;;;_ > define-minor-mode allout-mode @@ -2115,9 +2113,7 @@ internal functions use this feature cohesively bunch changes." (allout-show-to-offshoot))) (when (not first) (setq first (point)))) - (goto-char (if (featurep 'xemacs) - (next-property-change (1+ (point)) nil end) - (next-char-property-change (1+ (point)) end)))) + (goto-char (next-char-property-change (1+ (point)) end))) (when first (goto-char first) (condition-case nil @@ -2141,18 +2137,7 @@ See `allout-overlay-interior-modification-handler' for details." (when (and (allout-mode-p) undo-in-progress) (setq allout-just-did-undo t) (if (allout-hidden-p) - (allout-show-children))) - - ;; allout-overlay-interior-modification-handler on an overlay handles - ;; this in other emacs, via `allout-exposure-category's 'modification-hooks. - (when (and (featurep 'xemacs) (allout-mode-p)) - ;; process all of the pending overlays: - (save-excursion - (goto-char beg) - (let ((overlay (allout-get-invisibility-overlay))) - (if overlay - (allout-overlay-interior-modification-handler - overlay nil beg end nil)))))) + (allout-show-children)))) ;;;_ > allout-isearch-end-handler (&optional overlay) (defun allout-isearch-end-handler (&optional _overlay) "Reconcile allout outline exposure on arriving in hidden text after isearch. @@ -2453,7 +2438,7 @@ Outermost is first." (progn (if (and (not (bolp)) (allout-hidden-p (1- (point)))) - (goto-char (allout-previous-single-char-property-change + (goto-char (previous-single-char-property-change (1- (point)) 'invisible))) (move-beginning-of-line 1)) (allout-depth) @@ -3443,7 +3428,7 @@ Offer one suitable for current depth DEPTH as default." (format-message "Select bullet: %s (`%s' default): " sans-escapes - (allout-substring-no-properties default-bullet)) + (substring-no-properties default-bullet)) sans-escapes t))) (message "") @@ -4458,9 +4443,9 @@ Topic exposure is marked with text-properties, to be used by (if (not (allout-hidden-p)) (setq next (max (1+ (point)) - (allout-next-single-char-property-change (point) - 'invisible - nil end)))) + (next-single-char-property-change (point) + 'invisible + nil end)))) (if (or (not next) (eq prev next)) ;; still not at start of hidden area -- must not be any left. (setq done t) @@ -4499,7 +4484,7 @@ Topic exposure is marked with text-properties, to be used by (while (not done) ;; at or advance to start of next annotation: (if (not (get-text-property (point) 'allout-was-hidden)) - (setq next (allout-next-single-char-property-change + (setq next (next-single-char-property-change (point) 'allout-was-hidden nil end))) (if (or (not next) (eq prev next)) ;; no more or not advancing -- must not be any left. @@ -4510,7 +4495,7 @@ Topic exposure is marked with text-properties, to be used by ;; still not at start of annotation. (setq done t) ;; advance to just after end of this annotation: - (setq next (allout-next-single-char-property-change + (setq next (next-single-char-property-change (point) 'allout-was-hidden nil end)) (let ((o (make-overlay prev next nil 'front-advance))) (overlay-put o 'category 'allout-exposure-category) @@ -4543,12 +4528,12 @@ however, are left exactly like normal, non-allout-specific yanks." (interactive "*P") ; Get to beginning, leaving ; region around subject: - (if (< (allout-mark-marker t) (point)) + (if (< (mark-marker) (point)) (exchange-point-and-mark)) (save-match-data (let* ((subj-beg (point)) (into-bol (bolp)) - (subj-end (allout-mark-marker t)) + (subj-end (mark-marker)) ;; 'resituate' if yanking an entire topic into topic header: (resituate (and (let ((allout-inhibit-aberrance-doublecheck t)) (allout-e-o-prefix-p)) @@ -4642,8 +4627,8 @@ however, are left exactly like normal, non-allout-specific yanks." t))) (message "")))) (if (or into-bol resituate) - (allout-hide-by-annotation (point) (allout-mark-marker t)) - (allout-deannotate-hidden (allout-mark-marker t) (point))) + (allout-hide-by-annotation (point) (mark-marker)) + (allout-deannotate-hidden (mark-marker) (point))) (if (not resituate) (exchange-point-and-mark)) (run-hook-with-args 'allout-structure-added-functions subj-beg subj-end)))) @@ -4752,14 +4737,7 @@ this function." (when flag (let ((o (make-overlay from to nil 'front-advance))) (overlay-put o 'category 'allout-exposure-category) - (overlay-put o 'evaporate t) - (when (featurep 'xemacs) - (let ((props (symbol-plist 'allout-exposure-category))) - (while props - (condition-case nil - ;; as of 2008-02-27, xemacs lacks modification-hooks - (overlay-put o (pop props) (pop props)) - (error nil)))))) + (overlay-put o 'evaporate t)) (setq allout-this-command-hid-text t)) (run-hook-with-args 'allout-exposure-change-functions from to flag)) ;;;_ > allout-flag-current-subtree (flag) @@ -5946,7 +5924,7 @@ See `allout-toggle-current-subtree-encryption' for more details." ;; they're encrypted, so the coding system is set to accommodate ;; them. (setq buffer-file-coding-system - (allout-select-safe-coding-system subtree-beg subtree-end)) + (select-safe-coding-system subtree-beg subtree-end)) ;; if the coding system for the text being encrypted is different ;; from that prevailing, then there a real risk that the coding ;; system can't be noticed by emacs when the file is visited. to @@ -6542,204 +6520,15 @@ If BEG is bigger than END we return 0." (mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char))) string))) (define-obsolete-function-alias 'allout-flatten #'flatten-tree "27.1") -;;;_ : Compatibility: -;;;_ : xemacs undo-in-progress provision: -(unless (boundp 'undo-in-progress) - (defvar undo-in-progress nil - "Placeholder defvar for XEmacs compatibility from allout.el.") - (defadvice undo-more (around allout activate) - ;; This defadvice used only in emacs that lack undo-in-progress, eg xemacs. - (let ((undo-in-progress t)) ad-do-it))) - -;;;_ > allout-mark-marker to accommodate divergent emacsen: -(defun allout-mark-marker (&optional force buffer) - "Accommodate the different signature for `mark-marker' across Emacsen. - -XEmacs takes two optional args, while Emacs does not, -so pass them along when appropriate." - (if (featurep 'xemacs) - (apply 'mark-marker force buffer) - (mark-marker))) -;;;_ > subst-char-in-string if necessary -(if (not (fboundp 'subst-char-in-string)) - (defun subst-char-in-string (fromchar tochar string &optional inplace) - "Replace FROMCHAR with TOCHAR in STRING each time it occurs. -Unless optional argument INPLACE is non-nil, return a new string." - (let ((i (length string)) - (newstr (if inplace string (copy-sequence string)))) - (while (> i 0) - (setq i (1- i)) - (if (eq (aref newstr i) fromchar) - (aset newstr i tochar))) - newstr))) -;;;_ > wholenump if necessary -(if (not (fboundp 'wholenump)) - (defalias 'wholenump 'natnump)) -;;;_ > remove-overlays if necessary -(if (not (fboundp 'remove-overlays)) - (defun remove-overlays (&optional beg end name val) - "Clear BEG and END of overlays whose property NAME has value VAL. -Overlays might be moved and/or split. -BEG and END default respectively to the beginning and end of buffer." - (unless beg (setq beg (point-min))) - (unless end (setq end (point-max))) - (if (< end beg) - (setq beg (prog1 end (setq end beg)))) - (save-excursion - (dolist (o (overlays-in beg end)) - (when (eq (overlay-get o name) val) - ;; Either push this overlay outside beg...end - ;; or split it to exclude beg...end - ;; or delete it entirely (if it is contained in beg...end). - (if (< (overlay-start o) beg) - (if (> (overlay-end o) end) - (progn - (move-overlay (copy-overlay o) - (overlay-start o) beg) - (move-overlay o end (overlay-end o))) - (move-overlay o (overlay-start o) beg)) - (if (> (overlay-end o) end) - (move-overlay o end (overlay-end o)) - (delete-overlay o))))))) - ) -;;;_ > copy-overlay if necessary -- xemacs ~ 21.4 -(if (not (fboundp 'copy-overlay)) - (defun copy-overlay (o) - "Return a copy of overlay O." - (let ((o1 (make-overlay (overlay-start o) (overlay-end o) - ;; FIXME: there's no easy way to find the - ;; insertion-type of the two markers. - (overlay-buffer o))) - (props (overlay-properties o))) - (while props - (overlay-put o1 (pop props) (pop props))) - o1))) -;;;_ > add-to-invisibility-spec if necessary -- xemacs ~ 21.4 -(if (not (fboundp 'add-to-invisibility-spec)) - (defun add-to-invisibility-spec (element) - "Add ELEMENT to `buffer-invisibility-spec'. -See documentation for `buffer-invisibility-spec' for the kind of elements -that can be added." - (if (eq buffer-invisibility-spec t) - (setq buffer-invisibility-spec (list t))) - (setq buffer-invisibility-spec - (cons element buffer-invisibility-spec)))) -;;;_ > remove-from-invisibility-spec if necessary -- xemacs ~ 21.4 -(if (not (fboundp 'remove-from-invisibility-spec)) - (defun remove-from-invisibility-spec (element) - "Remove ELEMENT from `buffer-invisibility-spec'." - (if (consp buffer-invisibility-spec) - (setq buffer-invisibility-spec (delete element - buffer-invisibility-spec))))) -;;;_ > move-beginning-of-line if necessary -- older emacs, xemacs -(if (not (fboundp 'move-beginning-of-line)) - (defun move-beginning-of-line (arg) - "Move point to beginning of current line as displayed. -\(This disregards invisible newlines such as those -which are part of the text that an image rests on.) - -With argument ARG not nil or 1, move forward ARG - 1 lines first. -If point reaches the beginning or end of buffer, it stops there. -To ignore intangibility, bind `inhibit-point-motion-hooks' to t." - (interactive "p") - (or arg (setq arg 1)) - (if (/= arg 1) - (condition-case nil (line-move (1- arg)) (error nil))) - - ;; Move to beginning-of-line, ignoring fields and invisible text. - (skip-chars-backward "^\n") - (while (and (not (bobp)) - (let ((prop - (get-char-property (1- (point)) 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec))))) - (goto-char (if (featurep 'xemacs) - (previous-property-change (point)) - (previous-char-property-change (point)))) - (skip-chars-backward "^\n")) - (vertical-motion 0)) -) -;;;_ > move-end-of-line if necessary -- Emacs < 22.1, xemacs -(if (not (fboundp 'move-end-of-line)) - (defun move-end-of-line (arg) - "Move point to end of current line as displayed. -\(This disregards invisible newlines such as those -which are part of the text that an image rests on.) - -With argument ARG not nil or 1, move forward ARG - 1 lines first. -If point reaches the beginning or end of buffer, it stops there. -To ignore intangibility, bind `inhibit-point-motion-hooks' to t." - (interactive "p") - (or arg (setq arg 1)) - (let (done) - (while (not done) - (let ((newpos - (save-excursion - (let ((goal-column 0)) - (and (condition-case nil - (or (line-move arg) t) - (error nil)) - (not (bobp)) - (progn - (while - (and - (not (bobp)) - (let ((prop - (get-char-property (1- (point)) - 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop - buffer-invisibility-spec) - (assq prop - buffer-invisibility-spec))))) - (goto-char - (previous-char-property-change (point)))) - (backward-char 1))) - (point))))) - (goto-char newpos) - (if (and (> (point) newpos) - (eq (preceding-char) ?\n)) - (backward-char 1) - (if (and (> (point) newpos) (not (eobp)) - (not (eq (following-char) ?\n))) - ;; If we skipped something intangible - ;; and now we're not really at eol, - ;; keep going. - (setq arg 1) - (setq done t))))))) - ) -;;;_ > allout-next-single-char-property-change -- alias unless lacking -(defalias 'allout-next-single-char-property-change - (if (fboundp 'next-single-char-property-change) - 'next-single-char-property-change - 'next-single-property-change) - ;; No docstring because xemacs defalias doesn't support it. - ) -;;;_ > allout-previous-single-char-property-change -- alias unless lacking -(defalias 'allout-previous-single-char-property-change - (if (fboundp 'previous-single-char-property-change) - 'previous-single-char-property-change - 'previous-single-property-change) - ;; No docstring because xemacs defalias doesn't support it. - ) -;;;_ > allout-select-safe-coding-system -(defalias 'allout-select-safe-coding-system - (if (fboundp 'select-safe-coding-system) - 'select-safe-coding-system - 'detect-coding-region) - ) -;;;_ > allout-substring-no-properties -;; define as alias first, so byte compiler is happy. -(defalias 'allout-substring-no-properties 'substring-no-properties) -;; then supplant with definition if underlying alias absent. -(if (not (fboundp 'substring-no-properties)) - (defun allout-substring-no-properties (string &optional start end) - (substring string (or start 0) end)) - ) - +(define-obsolete-function-alias 'allout-mark-marker #'mark-marker "28.1") +(define-obsolete-function-alias 'allout-substring-no-properties + #'substring-no-properties "28.1") +(define-obsolete-function-alias 'allout-select-safe-coding-system + #'select-safe-coding-system "28.1") +(define-obsolete-function-alias 'allout-previous-single-char-property-change + #'previous-single-char-property-change "28.1") +(define-obsolete-function-alias 'allout-next-single-char-property-change + #'next-single-char-property-change "28.1") ;;;_ #10 Unfinished ;;;_ > allout-bullet-isearch (&optional bullet) (defun allout-bullet-isearch (&optional bullet) diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index d6e85bf3835..677483e49f2 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1797,8 +1797,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (maxlen 8) (totalsize 0) files - visual - emacs-int-has-32bits) + visual) (when (= p -1) ;; If the offset of end-of-central-directory is -1, this is a ;; Zip64 extended ZIP file format, and we need to glean the info diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 3151b6e590d..e023c8fc7a6 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -242,6 +242,8 @@ For more information, see Info node `(emacs)Autorevert'." :tag "Load Hook" :group 'auto-revert :type 'hook) +(make-obsolete-variable 'auto-revert-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom auto-revert-check-vc-info nil "If non-nil Auto-Revert Mode reliably updates version control info. diff --git a/lisp/battery.el b/lisp/battery.el index 1d3390070c3..7027b254480 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -1,8 +1,9 @@ -;;; battery.el --- display battery status information +;;; battery.el --- display battery status information -*- lexical-binding:t -*- ;; Copyright (C) 1997-1998, 2000-2020 Free Software Foundation, Inc. ;; Author: Ralph Schleicher <rs@ralph-schleicher.de> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: hardware ;; This file is part of GNU Emacs. @@ -22,15 +23,19 @@ ;;; Commentary: -;; There is at present support for GNU/Linux, macOS and Windows. This -;; library supports both the `/proc/apm' file format of Linux version -;; 1.3.58 or newer and the `/proc/acpi/' directory structure of Linux -;; 2.4.20 and 2.6. Darwin (macOS) is supported by using the `pmset' -;; program. Windows is supported by the GetSystemPowerStatus API call. +;; There is at present support for GNU/Linux, macOS, and Windows. +;; This library supports: +;; - UPower (https://upower.freedesktop.org) via D-Bus API. +;; - the `/sys/class/power_supply/' files of Linux >= 2.6.39. +;; - the `/proc/acpi/' directory structure of Linux 2.4.20 and 2.6. +;; - the `/proc/apm' file format of Linux version 1.3.58 or newer. +;; - Darwin (macOS) by using the `pmset' program. +;; - Windows via the GetSystemPowerStatus API call. ;;; Code: (require 'timer) +(require 'dbus) (eval-when-compile (require 'cl-lib)) (defgroup battery nil @@ -38,11 +43,22 @@ :prefix "battery-" :group 'hardware) -(defcustom battery-upower-device "battery_BAT1" - "Upower battery device name." - :version "26.1" - :type 'string - :group 'battery) +(defcustom battery-upower-device nil + "UPower device of the `:battery' type. +Use `battery-upower-device-list' to list all available UPower devices. +If set to nil, then autodetect `:battery' device." + :version "28.1" + :type '(choice string (const :tag "Autodetect" nil))) + +(defcustom battery-upower-line-power-device nil + "UPower device of the `:line-power' type. +Use `battery-upower-device-list' to list all available UPower devices. +If set to nil, then autodetect `:battery' device." + :version "28.1" + :type '(choice string (const :tag "Autodetect" nil))) + +(defconst battery-upower-dbus-service "org.freedesktop.UPower" + "Well-known UPower service name for the D-Bus system.") (defun battery--find-linux-sysfs-batteries () (let ((dirs nil)) @@ -54,7 +70,9 @@ (nreverse dirs))) (defcustom battery-status-function - (cond ((and (eq system-type 'gnu/linux) + (cond ((dbus-ping :system battery-upower-dbus-service) + #'battery-upower) + ((and (eq system-type 'gnu/linux) (file-readable-p "/proc/apm")) #'battery-linux-proc-apm) ((and (eq system-type 'gnu/linux) @@ -84,8 +102,7 @@ Its cons cells are of the form CONVERSION is the character code of a \"conversion specification\" introduced by a `%' character in a control string." - :type '(choice (const nil) function) - :group 'battery) + :type '(choice (const nil) function)) (defcustom battery-echo-area-format "Power %L, battery %B (%p%% load, remaining time %t)" @@ -105,8 +122,7 @@ string are substituted as defined by the current value of the variable %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - :type '(choice string (const nil)) - :group 'battery) + :type '(choice string (const nil))) (defvar battery-mode-line-string nil "String to display in the mode line.") @@ -115,8 +131,7 @@ string are substituted as defined by the current value of the variable (defcustom battery-mode-line-limit 100 "Percentage of full battery load below which display battery status." :version "24.1" - :type 'integer - :group 'battery) + :type 'integer) (defcustom battery-mode-line-format (cond ((eq battery-status-function 'battery-linux-proc-acpi) @@ -139,25 +154,21 @@ string are substituted as defined by the current value of the variable %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - :type '(choice string (const nil)) - :group 'battery) + :type '(choice string (const nil))) (defcustom battery-update-interval 60 "Seconds after which the battery status will be updated." - :type 'integer - :group 'battery) + :type 'integer) (defcustom battery-load-low 25 "Upper bound of low battery load percentage. A battery load percentage below this number is considered low." - :type 'integer - :group 'battery) + :type 'integer) (defcustom battery-load-critical 10 "Upper bound of critical battery load percentage. A battery load percentage below this number is considered critical." - :type 'integer - :group 'battery) + :type 'integer) (defvar battery-update-timer nil "Interval timer object.") @@ -181,7 +192,7 @@ The text displayed in the mode line is controlled by `battery-mode-line-format' and `battery-status-function'. The mode line is be updated every `battery-update-interval' seconds." - :global t :group 'battery + :global t (setq battery-mode-line-string "") (or global-mode-string (setq global-mode-string '(""))) (and battery-update-timer (cancel-timer battery-update-timer)) @@ -537,17 +548,68 @@ The following %-sequences are provided: (t "N/A")))))) -(declare-function dbus-get-property "dbus.el" - (bus service path interface property)) - ;;; `upowerd' interface. -(defsubst battery-upower-prop (pname &optional device) +(defconst battery-upower-dbus-interface "org.freedesktop.UPower" + "The interface to UPower. +See URL `https://upower.freedesktop.org/docs/'.") + +(defconst battery-upower-dbus-path "/org/freedesktop/UPower" + "D-Bus path to talk to UPower service.") + +(defconst battery-upower-dbus-device-interface + (concat battery-upower-dbus-interface ".Device") + "The Device interface of the UPower. +See URL `https://upower.freedesktop.org/docs/Device.html'.") + +(defconst battery-upower-dbus-device-path + (concat battery-upower-dbus-path "/devices") + "D-Bus path to talk to devices part of the UPower service.") + +(defconst battery-upower-types + '((0 . :unknown) (1 . :line-power) (2 . :battery) + (3 . :ups) (4 . :monitor) (5 . :mouse) + (6 . :keyboard) (7 . :pda) (8 . :phone)) + "Type of the device.") + +(defconst battery-upower-states + '((0 . "unknown") (1 . "charging") (2 . "discharging") + (3 . "empty") (4 . "fully-charged") (5 . "pending-charge") + (6 . "pending-discharge")) + "Alist of battery power states. +Only valid for `:battery' devices.") + +(defun battery-upower-device-property (device property) + "Get value of the single PROPERTY for the UPower DEVICE." (dbus-get-property - :system - "org.freedesktop.UPower" - (concat "/org/freedesktop/UPower/devices/" (or device battery-upower-device)) - "org.freedesktop.UPower" - pname)) + :system battery-upower-dbus-service + (expand-file-name device battery-upower-dbus-device-path) + battery-upower-dbus-device-interface + property)) + +(defun battery-upower-device-all-properties (device) + "Return value for all available properties for the UPower DEVICE." + (dbus-get-all-properties + :system battery-upower-dbus-service + (expand-file-name device battery-upower-dbus-device-path) + battery-upower-dbus-device-interface)) + +(defun battery-upower-device-list () + "Return list of all available UPower devices. +Each element is the cons cell in form: (DEVICE . DEVICE-TYPE)." + (mapcar (lambda (device-path) + (let* ((device (file-relative-name + device-path battery-upower-dbus-device-path)) + (type-num (battery-upower-device-property device "Type"))) + (cons device (or (cdr (assq type-num battery-upower-types)) + :unknown)))) + (dbus-call-method :system battery-upower-dbus-service + battery-upower-dbus-path + battery-upower-dbus-interface + "EnumerateDevices"))) + +(defun battery-upower-device-autodetect (device-type) + "Return first matching UPower device of DEVICE-TYPE." + (car (rassq device-type (battery-upower-device-list)))) (defun battery-upower () "Get battery status from dbus Upower interface. @@ -559,45 +621,49 @@ The following %-sequences are provided: %p Battery load percentage %r Current rate %B Battery status (verbose) +%b Battery status: empty means high, `-' means low, + `!' means critical, and `+' means charging %L AC line status (verbose) %s Remaining time (to charge or discharge) in seconds %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - (let ((percents (battery-upower-prop "Percentage")) - (time-to-empty (battery-upower-prop "TimeToEmpty")) - (time-to-full (battery-upower-prop "TimeToFull")) - (state (battery-upower-prop "State")) - (online (battery-upower-prop "Online" "line_power_ACAD")) - (energy (battery-upower-prop "Energy")) - (energy-rate (battery-upower-prop "EnergyRate")) - (battery-states '((0 . "unknown") (1 . "charging") - (2 . "discharging") (3 . "empty") - (4 . "fully-charged") (5 . "pending-charge") - (6 . "pending-discharge"))) - seconds minutes hours remaining-time) - (cond ((and online time-to-full) - (setq seconds time-to-full)) - ((and (not online) time-to-empty) - (setq seconds time-to-empty))) - (when seconds - (setq minutes (/ seconds 60) - hours (/ minutes 60) - remaining-time (format "%d:%02d" hours (mod minutes 60)))) - (list (cons ?c (or (and energy - (number-to-string (round (* 1000 energy)))) - "N/A")) - (cons ?p (or (and percents (number-to-string (round percents))) - "N/A")) - (cons ?r (or (and energy-rate - (concat (number-to-string energy-rate) " W")) - "N/A")) - (cons ?B (or (and state (cdr (assoc state battery-states))) - "unknown")) - (cons ?L (or (and online "on-line") "off-line")) - (cons ?s (or (and seconds (number-to-string seconds)) "N/A")) - (cons ?m (or (and minutes (number-to-string minutes)) "N/A")) - (cons ?h (or (and hours (number-to-string hours)) "N/A")) + (let* ((bat-device (or battery-upower-device + (battery-upower-device-autodetect :battery))) + (bat-props (when bat-device + (battery-upower-device-all-properties bat-device))) + (percents (cdr (assoc "Percentage" bat-props))) + (time-to-empty (cdr (assoc "TimeToEmpty" bat-props))) + (time-to-full (cdr (assoc "TimeToFull" bat-props))) + (state (cdr (assoc "State" bat-props))) + (level (cdr (assoc "BatteryLevel" bat-props))) + (energy (cdr (assoc "Energy" bat-props))) + (energy-rate (cdr (assoc "EnergyRate" bat-props))) + (lp-device (or battery-upower-line-power-device + (battery-upower-device-autodetect :line-power))) + (online-p (when lp-device + (battery-upower-device-property lp-device "Online"))) + (seconds (if online-p time-to-full time-to-empty)) + (minutes (when seconds (/ seconds 60))) + (hours (when minutes (/ minutes 60))) + (remaining-time (when hours + (format "%d:%02d" hours (mod minutes 60))))) + (list (cons ?c (if energy (number-to-string (round (* 1000 energy))) "N/A")) + (cons ?p (if percents (number-to-string (round percents)) "N/A")) + (cons ?r (if energy-rate + (concat (number-to-string energy-rate) " W") + "N/A")) + (cons ?B (if state + (cdr (assq state battery-upower-states)) + "unknown")) + (cons ?b (cond ((= level 3) "-") + ((= level 4) "!") + (online-p "+") + (t ""))) + (cons ?L (if online-p "on-line" (if lp-device "off-line" "unknown"))) + (cons ?s (if seconds (number-to-string seconds) "N/A")) + (cons ?m (if minutes (number-to-string minutes) "N/A")) + (cons ?h (if hours (number-to-string hours) "N/A")) (cons ?t (or remaining-time "N/A"))))) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 6cd624cb333..720ad18c16f 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -2321,6 +2321,8 @@ strings returned are not." ;; Load Hook (defvar bookmark-load-hook nil "Hook run at the end of loading library `bookmark.el'.") +(make-obsolete-variable 'bookmark-load-hook + "use `with-eval-after-load' instead." "28.1") ;; Exit Hook, called from kill-emacs-hook (defvar bookmark-exit-hook nil diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index b519559330e..4b2a938a5f1 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -884,6 +884,8 @@ Used by `calc-user-invocation'.") (defvar calc-load-hook nil "Hook run when calc.el is loaded.") +(make-obsolete-variable 'calc-load-hook + "use `with-eval-after-load' instead." "28.1") (defvar calc-window-hook nil "Hook called to create the Calc window.") diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 6d262088479..da98e44926e 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -98,7 +98,7 @@ specifies which face attribute (e.g. `:foreground') to modify, or that this is a face (`:face') to apply. TYPE is the type of attribute being applied. Available TYPES (see `diary-attrtype-convert') are: `string', `symbol', `int', `tnil', `stringtnil'." - :type '(repeat (list (string :tag "Regular expression") + :type '(repeat (list (regexp :tag "Regular expression") (integer :tag "Sub-expression") (symbol :tag "Attribute (e.g. :foreground)") (choice (const string :tag "A string") diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el index ae1dab17252..906c29b15f4 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -69,6 +69,8 @@ "\\([+-]?[0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)") (defconst iso8601--outdated-date-match "--\\([0-9][0-9]\\)-?\\([0-9][0-9]\\)") +(defconst iso8601--outdated-reduced-precision-date-match + "---?\\([0-9][0-9]\\)") (defconst iso8601--week-date-match "\\([+-]?[0-9][0-9][0-9][0-9]\\)-?W\\([0-9][0-9]\\)-?\\([0-9]\\)?") (defconst iso8601--ordinal-date-match @@ -79,6 +81,7 @@ iso8601--full-date-match iso8601--without-day-match iso8601--outdated-date-match + iso8601--outdated-reduced-precision-date-match iso8601--week-date-match iso8601--ordinal-date-match))) @@ -136,7 +139,8 @@ See `decode-time' for the meaning of FORM." (when zone-string (setf (decoded-time-zone date) ;; The time zone in decoded times are in seconds. - (* (iso8601-parse-zone zone-string) 60))) + (* (iso8601-parse-zone zone-string) 60)) + (setf (decoded-time-dst date) nil)) date))) (defun iso8601-parse-date (string) @@ -201,6 +205,12 @@ See `decode-time' for the meaning of FORM." (iso8601--decoded-time :year year :month (decoded-time-month month-day) :day (decoded-time-day month-day)))) + ;; Obsolete format with implied year: --MM + ((iso8601--match "--\\([0-9][0-9]\\)" string) + (iso8601--decoded-time :month (string-to-number (match-string 1 string)))) + ;; Obsolete format with implied year and month: ---DD + ((iso8601--match "---\\([0-9][0-9]\\)" string) + (iso8601--decoded-time :day (string-to-number (match-string 1 string)))) (t (signal 'wrong-type-argument string)))) @@ -332,6 +342,9 @@ Return the number of minutes." (list start end (or duration ;; FIXME: Support subseconds. + ;; FIXME: It makes no sense to decode a time difference + ;; according to (decoded-time-zone end), or according to + ;; any other time zone for that matter. (decode-time (time-subtract (iso8601--encode-time end) (iso8601--encode-time start)) (or (decoded-time-zone end) 0) 'integer))))) @@ -354,7 +367,7 @@ Return the number of minutes." (iso8601--value month) (iso8601--value year) nil - dst + (if (or dst zone) dst -1) zone)) (defun iso8601--encode-time (time) diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el index 616d2b0c4ed..3d5a0a236b4 100644 --- a/lisp/calendar/lunar.el +++ b/lisp/calendar/lunar.el @@ -91,6 +91,7 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, (* -0.0016528 time time) (* -0.00000239 time time time)) 360.0)) + (eclipse (eclipse-check moon-lat phase)) (adjustment (if (memq phase '(0 2)) (+ (* (- 0.1734 (* 0.000393 time)) @@ -146,7 +147,26 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, (time (* 24 (- date (truncate date)))) (date (calendar-gregorian-from-absolute (truncate date))) (adj (dst-adjust-time date time))) - (list (car adj) (apply 'solar-time-string (cdr adj)) phase))) + (list (car adj) (apply 'solar-time-string (cdr adj)) phase eclipse))) + +;; from "Astronomy with your Personal Computer", Subroutine Eclipse +;; Line 7000 Peter Duffett-Smith Cambridge University Press 1990 +(defun eclipse-check (moon-lat phase) + (let* ((moon-lat (* (/ float-pi 180) moon-lat)) + (moon-lat (abs (- moon-lat (* (floor (/ moon-lat float-pi)) + float-pi)))) + (moon-lat (if (> moon-lat 0.37) + (- float-pi moon-lat) + moon-lat)) + (phase-name (cond ((= phase 0) "Solar") + ((= phase 2) "Lunar") + (t "")))) + (cond ((< moon-lat 2.42600766e-1) + (concat "** " phase-name " Eclipse **")) + ((< moon-lat 0.37) + (concat "** " phase-name " Eclipse possible **")) + (t + "")))) (defconst lunar-cycles-per-year 12.3685 ; 365.25/29.530588853 "Mean number of lunar cycles per 365.25 day year.") @@ -222,9 +242,10 @@ use instead of point." (insert (mapconcat (lambda (x) - (format "%s: %s %s" (calendar-date-string (car x)) + (format "%s: %s %s %s" (calendar-date-string (car x)) (lunar-phase-name (nth 2 x)) - (cadr x))) + (cadr x) + (car (last x)))) (lunar-phase-list m1 y1) "\n"))) (message "Computing phases of the moon...done")))) diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el index 7110a81f0de..b199fca2db5 100644 --- a/lisp/calendar/parse-time.el +++ b/lisp/calendar/parse-time.el @@ -149,62 +149,62 @@ letters, digits, plus or minus signs or colons." ;;;###autoload (defun parse-time-string (string) "Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). -STRING should be something resembling an RFC 822 (or later) date-time, e.g., -\"Fri, 25 Mar 2016 16:24:56 +0100\", but this function is +STRING should be an ISO 8601 time string, e.g., \"2020-01-15T16:12:21-08:00\", +or something resembling an RFC 822 (or later) date-time, e.g., +\"Wed, 15 Jan 2020 16:12:21 -0800\". This function is somewhat liberal in what format it accepts, and will attempt to return a \"likely\" value even for somewhat malformed strings. The values returned are identical to those of `decode-time', but any unknown values other than DST are returned as nil, and an unknown DST value is returned as -1." - (let ((time (list nil nil nil nil nil nil nil -1 nil)) - (temp (parse-time-tokenize (downcase string)))) - (while temp - (let ((parse-time-elt (pop temp)) - (rules parse-time-rules) - (exit nil)) - (while (and rules (not exit)) - (let* ((rule (pop rules)) - (slots (pop rule)) - (predicate (pop rule)) - (parse-time-val)) - (when (and (not (nth (car slots) time)) ;not already set - (setq parse-time-val - (cond ((and (consp predicate) - (not (functionp predicate))) - (and (numberp parse-time-elt) - (<= (car predicate) parse-time-elt) - (or (not (cdr predicate)) - (<= parse-time-elt - (cadr predicate))) - parse-time-elt)) - ((symbolp predicate) - (cdr (assoc parse-time-elt - (symbol-value predicate)))) - ((funcall predicate))))) - (setq exit t) - (while slots - (let ((new-val (if rule - (let ((this (pop rule))) - (if (vectorp this) - (cl-parse-integer - parse-time-elt - :start (aref this 0) - :end (aref this 1)) - (funcall this))) - parse-time-val))) - (setf (nth (pop slots) time) new-val)))))))) - time)) + (condition-case () + (iso8601-parse string) + (wrong-type-argument + (let ((time (list nil nil nil nil nil nil nil -1 nil)) + (temp (parse-time-tokenize (downcase string)))) + (while temp + (let ((parse-time-elt (pop temp)) + (rules parse-time-rules) + (exit nil)) + (while (and rules (not exit)) + (let* ((rule (pop rules)) + (slots (pop rule)) + (predicate (pop rule)) + (parse-time-val)) + (when (and (not (nth (car slots) time)) ;not already set + (setq parse-time-val + (cond ((and (consp predicate) + (not (functionp predicate))) + (and (numberp parse-time-elt) + (<= (car predicate) parse-time-elt) + (or (not (cdr predicate)) + (<= parse-time-elt + (cadr predicate))) + parse-time-elt)) + ((symbolp predicate) + (cdr (assoc parse-time-elt + (symbol-value predicate)))) + ((funcall predicate))))) + (setq exit t) + (while slots + (let ((new-val (if rule + (let ((this (pop rule))) + (if (vectorp this) + (cl-parse-integer + parse-time-elt + :start (aref this 0) + :end (aref this 1)) + (funcall this))) + parse-time-val))) + (setf (nth (pop slots) time) new-val)))))))) + time)))) (defun parse-iso8601-time-string (date-string) - "Parse an ISO 8601 time string, such as 2016-12-01T23:35:06-05:00. -If DATE-STRING cannot be parsed, it falls back to -`parse-time-string'." - (when-let ((time - (if (iso8601-valid-p date-string) - (decoded-time-set-defaults (iso8601-parse date-string)) - ;; Fall back to having `parse-time-string' do fancy - ;; things for us. - (parse-time-string date-string)))) + "Parse an ISO 8601 time string, such as \"2020-01-15T16:12:21-08:00\". +Fall back on parsing something resembling an RFC 822 (or later) date-time. +This function is like `parse-time-string' except that it returns +a Lisp timestamp when successful." + (when-let ((time (parse-time-string date-string))) (encode-time time))) (provide 'parse-time) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 1e589ece29d..e2402de8010 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -515,15 +515,14 @@ TIME is modified and returned." (unless (decoded-time-year time) (setf (decoded-time-year time) 0)) - ;; When we don't have a time zone and we don't have a DST, then mark - ;; it as unknown. - (when (and (not (decoded-time-zone time)) - (not (decoded-time-dst time))) - (setf (decoded-time-dst time) -1)) - - (when (and (not (decoded-time-zone time)) - default-zone) - (setf (decoded-time-zone time) 0)) + ;; When we don't have a time zone, default to DEFAULT-ZONE without + ;; DST if DEFAULT-ZONE if given, and to unknown DST otherwise. + (unless (decoded-time-zone time) + (if default-zone + (progn (setf (decoded-time-zone time) default-zone) + (setf (decoded-time-dst time) nil)) + (setf (decoded-time-dst time) -1))) + time) (provide 'time-date) diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el index f3a5d9cd60d..d12feaae8c3 100644 --- a/lisp/calendar/timeclock.el +++ b/lisp/calendar/timeclock.el @@ -193,6 +193,8 @@ to today." (defcustom timeclock-load-hook nil "Hook that gets run after timeclock has been loaded." :type 'hook) +(make-obsolete-variable 'timeclock-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom timeclock-in-hook nil "A hook run every time an \"in\" event is recorded." diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el index 1418ad9539d..c2036878288 100644 --- a/lisp/cedet/ede.el +++ b/lisp/cedet/ede.el @@ -1527,8 +1527,7 @@ It does not apply the value to buffers." ;; If this does not occur after the provide, we can get a recursive ;; load. Yuck! -(if (featurep 'speedbar) - (ede-speedbar-file-setup) - (add-hook 'speedbar-load-hook 'ede-speedbar-file-setup)) +(with-eval-after-load 'speedbar + (ede-speedbar-file-setup)) ;;; ede.el ends here diff --git a/lisp/cedet/ede/cpp-root.el b/lisp/cedet/ede/cpp-root.el index ee8aa5db1b7..f0dbccb7fc1 100644 --- a/lisp/cedet/ede/cpp-root.el +++ b/lisp/cedet/ede/cpp-root.el @@ -478,21 +478,6 @@ Argument COMMAND is the command to use for compiling the target." "Don't rescan this project from the sources." (message "cpp-root has nothing to rescan.")) -;;; Quick Hack -(defun ede-create-lots-of-projects-under-dir (dir projfile &rest attributes) - "Create a bunch of projects under directory DIR. -PROJFILE is a file name sans directory that indicates a subdirectory -is a project directory. -Generic ATTRIBUTES, such as :include-path can be added. -Note: This needs some work." - (let ((files (directory-files dir t))) - (dolist (F files) - (if (file-exists-p (expand-file-name projfile F)) - `(ede-cpp-root-project (file-name-nondirectory F) - :name (file-name-nondirectory F) - :file (expand-file-name projfile F) - attributes))))) - (provide 'ede/cpp-root) ;; Local variables: diff --git a/lisp/cedet/ede/pconf.el b/lisp/cedet/ede/pconf.el index 63fb62b5a57..b85b397af2d 100644 --- a/lisp/cedet/ede/pconf.el +++ b/lisp/cedet/ede/pconf.el @@ -56,8 +56,9 @@ don't do it. A value of nil means to just do it.") (and (eq ede-pconf-create-file-query 'ask) (not (eq ede-pconf-create-file-query 'never)) (not (y-or-n-p - (format "I had to create the %s file for you. Ok? " file))) - (error "Quit"))))))) + (format "I had to create the %s file for you. Ok? " + file)))) + (error "Quit")))))) (cl-defmethod ede-proj-configure-synchronize ((this ede-proj-project)) diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el index 55e755dc363..214291797db 100644 --- a/lisp/cedet/semantic/db-ebrowse.el +++ b/lisp/cedet/semantic/db-ebrowse.el @@ -74,7 +74,7 @@ By default, include only headers since the semantic use of EBrowse is only for searching via semanticdb, and thus only headers would be searched." :group 'semanticdb - :type 'string) + :type 'regexp) ;;; SEMANTIC Database related Code ;;; Classes: diff --git a/lisp/cedet/semantic/imenu.el b/lisp/cedet/semantic/imenu.el index 19e0515ac63..cdf0a23fa07 100644 --- a/lisp/cedet/semantic/imenu.el +++ b/lisp/cedet/semantic/imenu.el @@ -44,9 +44,8 @@ ;; Because semantic imenu tags will hose the current imenu handling ;; code in speedbar, force semantic/sb in. -(if (featurep 'speedbar) - (require 'semantic/sb) - (add-hook 'speedbar-load-hook (lambda () (require 'semantic/sb)))) +(with-eval-after-load 'speedbar + (require 'semantic/sb)) (defgroup semantic-imenu nil "Semantic interface to Imenu." diff --git a/lisp/cedet/srecode/document.el b/lisp/cedet/srecode/document.el index 4151b17c885..fdb44695918 100644 --- a/lisp/cedet/srecode/document.el +++ b/lisp/cedet/srecode/document.el @@ -89,7 +89,7 @@ versions of names. This is an alist with each element of the form: MATCH is a regexp to match in the type field. RESULT is a string." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-function-alist @@ -145,7 +145,7 @@ see how best to describe what can be returned. Doesn't always work correctly, but that is just because English doesn't always work correctly." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-common-nouns-abbrevs @@ -176,7 +176,7 @@ versions of names. This is an alist with each element of the form: MATCH is a regexp to match in the type field. RESULT is a string." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-return-first-alist @@ -193,7 +193,7 @@ This is an alist with each element of the form: MATCH is a regexp to match in the type field. RESULT is a string." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-return-last-alist @@ -214,7 +214,7 @@ MATCH is a regexp to match in the type field. RESULT is a string, which can contain %s, which is replaced with `match-string' 1." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-param-alist @@ -234,7 +234,7 @@ RESULT is a string of text to use to describe MATCH. When one is encountered, document-insert-parameters will automatically place this comment after the parameter name." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-param-type-alist @@ -259,7 +259,7 @@ This is an alist with each element of the form: MATCH is a regexp to match in the type field. RESULT is a string." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) ;;;###autoload diff --git a/lisp/cedet/srecode/semantic.el b/lisp/cedet/srecode/semantic.el index 26c14892efd..5b2dd034743 100644 --- a/lisp/cedet/srecode/semantic.el +++ b/lisp/cedet/srecode/semantic.el @@ -201,7 +201,7 @@ variable default values, and other things." (let ((tag (or srecode-semantic-selected-tag (srecode-semantic-tag-from-kill-ring)))) (when (not tag) - "No tag for current template. Use the semantic kill-ring.") + (error "No tag for current template. Use the semantic kill-ring.")) (srecode-semantic-apply-tag-to-dict (srecode-semantic-tag (semantic-tag-name tag) :prime tag) diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el index d590b9ecf61..d4bec95ebad 100644 --- a/lisp/cmuscheme.el +++ b/lisp/cmuscheme.el @@ -517,6 +517,8 @@ command to run." This is a good place to put keybindings." :type 'hook :group 'cmuscheme) +(make-obsolete-variable 'cmuscheme-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'cmuscheme-load-hook) diff --git a/lisp/desktop.el b/lisp/desktop.el index 7745b50b64c..de601a4de8c 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -344,7 +344,7 @@ to the value obtained by evaluating FORM." Each element is a regular expression. Buffers with a name matched by any of these won't be deleted." :version "23.3" ; added Warnings - bug#6336 - :type '(repeat string) + :type '(repeat regexp) :group 'desktop) ;;;###autoload diff --git a/lisp/dired.el b/lisp/dired.el index 689ad1fbfab..a4de51f6091 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -230,6 +230,8 @@ The target is used in the prompt for file copy, rename etc." You can customize key bindings or load extensions with this." :group 'dired :type 'hook) +(make-obsolete-variable 'dired-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom dired-mode-hook nil "Run at the very end of `dired-mode'." @@ -849,7 +851,6 @@ If a directory or nothing is found at point, return nil." (if (and file-name (not (file-directory-p file-name))) file-name))) -(put 'dired-mode 'grep-read-files 'dired-grep-read-files) ;;;###autoload (define-key ctl-x-map "d" 'dired) ;;;###autoload @@ -2149,6 +2150,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." ;; Dired mode is suitable only for specially formatted data. (put 'dired-mode 'mode-class 'special) +(defvar grep-read-files-function) ;; Autoload cookie needed by desktop.el ;;;###autoload (defun dired-mode (&optional dirname switches) @@ -2210,7 +2212,6 @@ Hooks (use \\[describe-variable] to see their documentation): `dired-before-readin-hook' `dired-after-readin-hook' `dired-mode-hook' - `dired-load-hook' Keybindings: \\{dired-mode-map}" @@ -2243,6 +2244,7 @@ Keybindings: (setq-local font-lock-defaults '(dired-font-lock-keywords t nil nil beginning-of-line)) (setq-local desktop-save-buffer 'dired-desktop-buffer-misc-data) + (setq-local grep-read-files-function #'dired-grep-read-files) (setq dired-switches-alist nil) (hack-dir-local-variables-non-file-buffer) ; before sorting (dired-sort-other dired-actual-switches t) @@ -3857,28 +3859,31 @@ With prefix argument, unmark or unflag these files." (if fn (backup-file-name-p fn)))) "backup file"))) -(defun dired-change-marks (&optional old new) +(defun dired-change-marks (old new) "Change all OLD marks to NEW marks. OLD and NEW are both characters used to mark files." + (declare (advertised-calling-convention '(old new) "28.1")) (interactive (let* ((cursor-in-echo-area t) (old (progn (message "Change (old mark): ") (read-char))) (new (progn (message "Change %c marks to (new mark): " old) (read-char)))) (list old new))) - (if (or (eq old ?\r) (eq new ?\r)) - (ding) - (let ((string (format "\n%c" old)) - (inhibit-read-only t)) - (save-excursion - (goto-char (point-min)) - (while (search-forward string nil t) - (if (if (= old ?\s) - (save-match-data - (dired-get-filename 'no-dir t)) - t) - (subst-char-in-region (match-beginning 0) - (match-end 0) old new))))))) + (dolist (c (list new old)) + (if (or (not (char-displayable-p c)) + (eq c ?\r)) + (user-error "Invalid mark character: `%c'" c))) + (let ((string (format "\n%c" old)) + (inhibit-read-only t)) + (save-excursion + (goto-char (point-min)) + (while (search-forward string nil t) + (if (if (= old ?\s) + (save-match-data + (dired-get-filename 'no-dir t)) + t) + (subst-char-in-region (match-beginning 0) + (match-end 0) old new)))))) (defun dired-unmark-all-marks () "Remove all marks from all files in the Dired buffer." diff --git a/lisp/disp-table.el b/lisp/disp-table.el index fe63573c0a3..2e88d350245 100644 --- a/lisp/disp-table.el +++ b/lisp/disp-table.el @@ -221,7 +221,7 @@ for a graphical frame." (defun make-glyph-code (char &optional face) "Return a glyph code representing char CHAR with face FACE." ;; Due to limitations on Emacs integer values, faces with - ;; face id greater that 512 are silently ignored. + ;; face id greater than 512 are silently ignored. (if (not face) char (let ((fid (face-id face))) diff --git a/lisp/elide-head.el b/lisp/elide-head.el index 57940456660..2c42a191e0a 100644 --- a/lisp/elide-head.el +++ b/lisp/elide-head.el @@ -64,8 +64,8 @@ elided with an invisible overlay from the end of the line where the first match is found to the end of the match for the corresponding cdr." :group 'elide-head - :type '(alist :key-type (string :tag "Start regexp") - :value-type (string :tag "End regexp"))) + :type '(alist :key-type (regexp :tag "Start regexp") + :value-type (regexp :tag "End regexp"))) (defvar elide-head-overlay nil) (make-variable-buffer-local 'elide-head-overlay) diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 850af93571f..b5d99e34518 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -149,9 +149,6 @@ ;; | ip -- 4 byte vector ;; | bits LEN -- List with bits set in LEN bytes. ;; -;; -- Note: 32 bit values may be limited by emacs' INTEGER -;; implementation limits. -;; ;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13) ;; and 0x1c 0x28 to (3 5 10 11 12). diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 90ab8911c39..fe0930c684b 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -480,6 +480,13 @@ backwards))))) (cons fn (mapcar 'byte-optimize-form (cdr form))))) + ((eq fn 'while) + (unless (consp (cdr form)) + (byte-compile-warn "too few arguments for `while'")) + (cons fn + (cons (byte-optimize-form (cadr form) nil) + (byte-optimize-body (cddr form) t)))) + ((eq fn 'interactive) (byte-compile-warn "misplaced interactive spec: `%s'" (prin1-to-string form)) @@ -491,15 +498,12 @@ form) ((eq fn 'condition-case) - (if byte-compile--use-old-handlers - ;; Will be optimized later. - form - `(condition-case ,(nth 1 form) ;Not evaluated. - ,(byte-optimize-form (nth 2 form) for-effect) - ,@(mapcar (lambda (clause) - `(,(car clause) - ,@(byte-optimize-body (cdr clause) for-effect))) - (nthcdr 3 form))))) + `(condition-case ,(nth 1 form) ;Not evaluated. + ,(byte-optimize-form (nth 2 form) for-effect) + ,@(mapcar (lambda (clause) + `(,(car clause) + ,@(byte-optimize-body (cdr clause) for-effect))) + (nthcdr 3 form)))) ((eq fn 'unwind-protect) ;; the "protected" part of an unwind-protect is compiled (and thus @@ -514,12 +518,7 @@ ((eq fn 'catch) (cons fn (cons (byte-optimize-form (nth 1 form) nil) - (if byte-compile--use-old-handlers - ;; The body of a catch is compiled (and thus - ;; optimized) as a top-level form, so don't do it - ;; here. - (cdr (cdr form)) - (byte-optimize-body (cdr form) for-effect))))) + (byte-optimize-body (cdr form) for-effect)))) ((eq fn 'ignore) ;; Don't treat the args to `ignore' as being diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 73bbc2fe182..fce5e4aed6d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -719,14 +719,15 @@ otherwise pop it") "to make a binding to record entire window configuration") (byte-defop 140 0 byte-save-restriction "to make a binding to record the current buffer clipping restrictions") -(byte-defop 141 -1 byte-catch +(byte-defop 141 -1 byte-catch-OBSOLETE ; Not generated since Emacs 25. "for catch. Takes, on stack, the tag and an expression for the body") (byte-defop 142 -1 byte-unwind-protect "for unwind-protect. Takes, on stack, an expression for the unwind-action") ;; For condition-case. Takes, on stack, the variable to bind, ;; an expression for the body, and a list of clauses. -(byte-defop 143 -2 byte-condition-case) +;; Not generated since Emacs 25. +(byte-defop 143 -2 byte-condition-case-OBSOLETE) (byte-defop 144 0 byte-temp-output-buffer-setup-OBSOLETE) (byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE) @@ -1201,7 +1202,7 @@ message buffer `default-directory'." byte-compile-last-warned-form)))) (insert (format "\nIn %s:\n" form))) (when level - (insert (format "%s%s" file pos)))) + (insert (format "%s%s " file pos)))) (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form byte-compile-current-form) entry) @@ -2152,42 +2153,41 @@ With argument ARG, insert value in current buffer after the form." (when (< (point-max) (position-bytes (point-max))) (goto-char (point-min)) ;; Find the comment that describes the version condition. - (search-forward "\n;;; This file uses") - (narrow-to-region (line-beginning-position) (point-max)) - ;; Find the first line of ballast semicolons. - (search-forward ";;;;;;;;;;") - (beginning-of-line) - (narrow-to-region (point-min) (point)) - (let ((old-header-end (point)) - (minimum-version "23") - delta) - (delete-region (point-min) (point-max)) - (insert - ";;; This file contains utf-8 non-ASCII characters,\n" - ";;; and so cannot be loaded into Emacs 22 or earlier.\n" - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "(and (boundp 'emacs-version)\n" - ;; If there is a name at the end of emacs-version, - ;; don't try to check the version number. - " (< (aref emacs-version (1- (length emacs-version))) ?A)\n" - (format " (string-lessp emacs-version \"%s\")\n" minimum-version) - ;; Because the header must fit in a fixed width, we cannot - ;; insert arbitrary-length file names (Bug#11585). - " (error \"`%s' was compiled for " - (format "Emacs %s or later\" #$))\n\n" minimum-version)) - ;; Now compensate for any change in size, to make sure all - ;; positions in the file remain valid. - (setq delta (- (point-max) old-header-end)) - (goto-char (point-max)) - (widen) - (delete-char delta)))) + (when (search-forward "\n;;; This file does not contain utf-8" nil t) + (narrow-to-region (line-beginning-position) (point-max)) + ;; Find the first line of ballast semicolons. + (search-forward ";;;;;;;;;;") + (beginning-of-line) + (narrow-to-region (point-min) (point)) + (let ((old-header-end (point)) + (minimum-version "23") + delta) + (delete-region (point-min) (point-max)) + (insert + ";;; This file contains utf-8 non-ASCII characters,\n" + ";;; and so cannot be loaded into Emacs 22 or earlier.\n" + ;; Have to check if emacs-version is bound so that this works + ;; in files loaded early in loadup.el. + "(and (boundp 'emacs-version)\n" + ;; If there is a name at the end of emacs-version, + ;; don't try to check the version number. + " (< (aref emacs-version (1- (length emacs-version))) ?A)\n" + (format " (string-lessp emacs-version \"%s\")\n" minimum-version) + ;; Because the header must fit in a fixed width, we cannot + ;; insert arbitrary-length file names (Bug#11585). + " (error \"`%s' was compiled for " + (format "Emacs %s or later\" #$))\n\n" minimum-version)) + ;; Now compensate for any change in size, to make sure all + ;; positions in the file remain valid. + (setq delta (- (point-max) old-header-end)) + (goto-char (point-max)) + (widen) + (delete-char delta))))) (defun byte-compile-insert-header (_filename outbuffer) "Insert a header at the start of OUTBUFFER. Call from the source buffer." - (let ((dynamic-docstrings byte-compile-dynamic-docstrings) - (dynamic byte-compile-dynamic) + (let ((dynamic byte-compile-dynamic) (optimize byte-optimize)) (with-current-buffer outbuffer (goto-char (point-min)) @@ -2213,11 +2213,7 @@ Call from the source buffer." ".\n" (if dynamic ";;; Function definitions are lazy-loaded.\n" "") - "\n;;; This file uses " - (if dynamic-docstrings - "dynamic docstrings, first added in Emacs 19.29" - "opcodes that do not exist in Emacs 18") - ".\n\n" + "\n" ;; Note that byte-compile-fix-header may change this. ";;; This file does not contain utf-8 non-ASCII characters,\n" ";;; and so can be loaded in Emacs versions earlier than 23.\n\n" @@ -2225,6 +2221,7 @@ Call from the source buffer." ;; can delete them so as to keep the buffer positions ;; constant for the actual compiled code. ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" + ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) (defun byte-compile-output-file-form (form) @@ -3462,7 +3459,7 @@ for symbols generated by the byte compiler itself." (if (equal-including-properties (car elt) ,const) (setq result elt))) result) - (assq ,const byte-compile-constants)) + (assoc ,const byte-compile-constants #'eql)) (car (setq byte-compile-constants (cons (list ,const) byte-compile-constants))))) @@ -4529,96 +4526,25 @@ binding slots have been popped." ;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro. ;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. -(defvar byte-compile--use-old-handlers nil - "If nil, use new byte codes introduced in Emacs-24.4.") - (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) - (if (not byte-compile--use-old-handlers) - (let ((endtag (byte-compile-make-tag))) - (byte-compile-goto 'byte-pushcatch endtag) - (byte-compile-body (cddr form) nil) - (byte-compile-out 'byte-pophandler) - (byte-compile-out-tag endtag)) - (pcase (cddr form) - (`(:fun-body ,f) - (byte-compile-form `(list 'funcall ,f))) - (body - (byte-compile-push-constant - (byte-compile-top-level (cons 'progn body) byte-compile--for-effect)))) - (byte-compile-out 'byte-catch 0))) + (let ((endtag (byte-compile-make-tag))) + (byte-compile-goto 'byte-pushcatch endtag) + (byte-compile-body (cddr form) nil) + (byte-compile-out 'byte-pophandler) + (byte-compile-out-tag endtag))) (defun byte-compile-unwind-protect (form) (pcase (cddr form) (`(:fun-body ,f) - (byte-compile-form - (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f))) + (byte-compile-form f)) (handlers - (if byte-compile--use-old-handlers - (byte-compile-push-constant - (byte-compile-top-level-body handlers t)) - (byte-compile-form `#'(lambda () ,@handlers))))) + (byte-compile-form `#'(lambda () ,@handlers)))) (byte-compile-out 'byte-unwind-protect 0) (byte-compile-form-do-effect (car (cdr form))) (byte-compile-out 'byte-unbind 1)) (defun byte-compile-condition-case (form) - (if byte-compile--use-old-handlers - (byte-compile-condition-case--old form) - (byte-compile-condition-case--new form))) - -(defun byte-compile-condition-case--old (form) - (let* ((var (nth 1 form)) - (fun-bodies (eq var :fun-body)) - (byte-compile-bound-variables - (if (and var (not fun-bodies)) - (cons var byte-compile-bound-variables) - byte-compile-bound-variables))) - (byte-compile-set-symbol-position 'condition-case) - (unless (symbolp var) - (byte-compile-warn - "`%s' is not a variable-name or nil (in condition-case)" var)) - (if fun-bodies (setq var (make-symbol "err"))) - (byte-compile-push-constant var) - (if fun-bodies - (byte-compile-form `(list 'funcall ,(nth 2 form))) - (byte-compile-push-constant - (byte-compile-top-level (nth 2 form) byte-compile--for-effect))) - (let ((compiled-clauses - (mapcar - (lambda (clause) - (let ((condition (car clause))) - (cond ((not (or (symbolp condition) - (and (listp condition) - (let ((ok t)) - (dolist (sym condition) - (if (not (symbolp sym)) - (setq ok nil))) - ok)))) - (byte-compile-warn - "`%S' is not a condition name or list of such (in condition-case)" - condition)) - ;; (not (or (eq condition 't) - ;; (and (stringp (get condition 'error-message)) - ;; (consp (get condition - ;; 'error-conditions))))) - ;; (byte-compile-warn - ;; "`%s' is not a known condition name - ;; (in condition-case)" - ;; condition)) - ) - (if fun-bodies - `(list ',condition (list 'funcall ,(cadr clause) ',var)) - (cons condition - (byte-compile-top-level-body - (cdr clause) byte-compile--for-effect))))) - (cdr (cdr (cdr form)))))) - (if fun-bodies - (byte-compile-form `(list ,@compiled-clauses)) - (byte-compile-push-constant compiled-clauses))) - (byte-compile-out 'byte-condition-case 0))) - -(defun byte-compile-condition-case--new (form) (let* ((var (nth 1 form)) (body (nth 2 form)) (depth byte-compile-depth) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index e2e59337d7b..351a097ad19 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -462,20 +462,7 @@ places where they originally did not directly appear." ;; and may be an invalid expression (e.g. ($# . 678)). (cdr forms))))) - ;condition-case - ((and `(condition-case ,var ,protected-form . ,handlers) - (guard byte-compile--use-old-handlers)) - (let ((newform (cconv--convert-function - () (list protected-form) env form))) - `(condition-case :fun-body ,newform - ,@(mapcar (lambda (handler) - (list (car handler) - (cconv--convert-function - (list (or var cconv--dummy-var)) - (cdr handler) env form))) - handlers)))) - - ; condition-case with new byte-codes. + ; condition-case (`(condition-case ,var ,protected-form . ,handlers) `(condition-case ,var ,(cconv-convert protected-form env extend) @@ -496,10 +483,8 @@ places where they originally did not directly appear." `((let ((,var (list ,var))) ,@body)))))) handlers)))) - (`(,(and head (or (and 'catch (guard byte-compile--use-old-handlers)) - 'unwind-protect)) - ,form . ,body) - `(,head ,(cconv-convert form env extend) + (`(unwind-protect ,form . ,body) + `(unwind-protect ,(cconv-convert form env extend) :fun-body ,(cconv--convert-function () body env form))) (`(setq . ,forms) ; setq special form @@ -718,15 +703,6 @@ and updates the data stored in ENV." (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote - ((and `(condition-case ,var ,protected-form . ,handlers) - (guard byte-compile--use-old-handlers)) - ;; FIXME: The bytecode for condition-case forces us to wrap the - ;; form and handlers in closures. - (cconv--analyze-function () (list protected-form) env form) - (dolist (handler handlers) - (cconv--analyze-function (if var (list var)) (cdr handler) - env form))) - (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) @@ -741,9 +717,7 @@ and updates the data stored in ENV." form "variable")))) ;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind. - (`(,(or (and 'catch (guard byte-compile--use-old-handlers)) - 'unwind-protect) - ,form . ,body) + (`(unwind-protect ,form . ,body) (cconv-analyze-form form env) (cconv--analyze-function () body env form)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c4f69120ff7..4c2f58907de 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1037,9 +1037,10 @@ For more details, see Info node `(cl)Loop Facility'. (defmacro cl--push-clause-loop-body (clause) "Apply CLAUSE to both `cl--loop-conditions' and `cl--loop-body'." - `(progn - (push ,clause cl--loop-conditions) - (push ,clause cl--loop-body))) + (macroexp-let2 nil sym clause + `(progn + (push ,sym cl--loop-conditions) + (push ,sym cl--loop-body)))) ;; Below is a complete spec for cl-loop, in several parts that correspond ;; to the syntax given in CLtL2. The specs do more than specify where @@ -1318,7 +1319,10 @@ For more details, see Info node `(cl)Loop Facility'. (nreverse cl--loop-conditions))) ,then ,var)) loop-for-steps)) - (push `(,var (if ,first-assign ,start ,then)) loop-for-sets)))) + (push (if (eq start then) + `(,var ,then) + `(,var (if ,first-assign ,start ,then))) + loop-for-sets)))) ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index e6aed3a1202..85cc8c8e7ad 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1714,6 +1714,7 @@ contains a circular object." (cl-macrolet-body . edebug-match-cl-macrolet-body) (¬ . edebug-match-¬) (&key . edebug-match-&key) + (&error . edebug-match-&error) (place . edebug-match-place) (gate . edebug-match-gate) ;; (nil . edebug-match-nil) not this one - special case it. @@ -1847,6 +1848,15 @@ contains a circular object." (car (cdr pair)))) specs)))) +(defun edebug-match-&error (cursor specs) + ;; Signal an error, using the following string in the spec as argument. + (let ((error-string (car specs)) + (edebug-error-point (edebug-before-offset cursor))) + (goto-char edebug-error-point) + (error "%s" + (if (stringp error-string) + error-string + "String expected after &error in edebug-spec")))) (defun edebug-match-gate (_cursor) ;; Simply set the gate to prevent backtracking at this level. @@ -2216,6 +2226,8 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." (def-edebug-spec nested-backquote-form (&or + ("`" &error "Triply nested backquotes (without commas \"between\" them) \ +are too difficult to instrument") ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or ;; (\,@ ...) matched on the next line. ([&or "," ",@"] backquote-form) @@ -3708,7 +3720,6 @@ Return the result of the last expression." (prin1-to-string edebug-arg)) (cdr value) ", "))) -(defvar print-readably) ; defined by lemacs ;; Alternatively, we could change the definition of ;; edebug-safe-prin1-to-string to only use these if defined. @@ -3716,8 +3727,7 @@ Return the result of the last expression." (let ((print-escape-newlines t) (print-length (or edebug-print-length print-length)) (print-level (or edebug-print-level print-level)) - (print-circle (or edebug-print-circle print-circle)) - (print-readably nil)) ; lemacs uses this. + (print-circle (or edebug-print-circle print-circle))) (edebug-prin1-to-string value))) (defun edebug-compute-previous-result (previous-value) @@ -4520,17 +4530,6 @@ With prefix argument, make it a temporary breakpoint." (edebug-modify-breakpoint t condition arg)) (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus) - -;;; Autoloading of Edebug accessories - -;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu -(defun edebug--require-cl-read () - (require 'edebug-cl-read)) - -(if (featurep 'cl-read) - (add-hook 'edebug-setup-hook #'edebug--require-cl-read) - ;; The following causes edebug-cl-read to be loaded when you load cl-read.el. - (add-hook 'cl-read-load-hooks #'edebug--require-cl-read)) ;;; Finalize Loading @@ -4566,7 +4565,6 @@ With prefix argument, make it a temporary breakpoint." (run-with-idle-timer 0 nil #'(lambda () (unload-feature 'edebug))))) (remove-hook 'called-interactively-p-functions #'edebug--called-interactively-skip) - (remove-hook 'cl-read-load-hooks #'edebug--require-cl-read) (edebug-uninstall-read-eval-functions) ;; Continue standard unloading. nil) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index dda90373069..59af7e12d21 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -278,14 +278,7 @@ are not abstract." (if eieio-class-speedbar-key-map nil - (if (not (featurep 'speedbar)) - (add-hook 'speedbar-load-hook (lambda () - (eieio-class-speedbar-make-map) - (speedbar-add-expansion-list - '("EIEIO" - eieio-class-speedbar-menu - eieio-class-speedbar-key-map - eieio-class-speedbar)))) + (with-eval-after-load 'speedbar (eieio-class-speedbar-make-map) (speedbar-add-expansion-list '("EIEIO" eieio-class-speedbar-menu diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index c11608da5d8..5c6e0e516d1 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -140,11 +140,7 @@ MENU-VAR is the symbol containing an easymenu compatible menu part to use. MODENAME is a string used to identify this browser mode. FETCHER is a generic function used to fetch the base object list used when creating the speedbar display." - (if (not (featurep 'speedbar)) - (add-hook 'speedbar-load-hook - (list 'lambda nil - (list 'eieio-speedbar-create-engine - map-fn map-var menu-var modename fetcher))) + (with-eval-after-load 'speedbar (eieio-speedbar-create-engine map-fn map-var menu-var modename fetcher))) (defun eieio-speedbar-create-engine (map-fn map-var menu-var modename fetcher) diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 8a9b01d580f..27ed29925b3 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -155,7 +155,7 @@ DYNAMIC-VAR bound to STATIC-VAR." (defun cps--add-state (kind body) "Create a new CPS state with body BODY and return the state's name." (declare (indent 1)) - (let* ((state (cps--gensym "cps-state-%s-" kind))) + (let ((state (cps--gensym "cps-state-%s-" kind))) (push (list state body cps--cleanup-function) cps--states) (push state cps--bindings) state)) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index ceb9b6bea5f..0d57bc16a3a 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -485,7 +485,18 @@ absent, return nil." (lm-with-file file (let ((start (lm-commentary-start))) (when start - (buffer-substring-no-properties start (lm-commentary-end)))))) + (replace-regexp-in-string ; Get rid of... + "[[:blank:]]*$" "" ; trailing white-space + (replace-regexp-in-string + (format "%s\\|%s\\|%s" + ;; commentary header + (concat "^;;;[[:blank:]]*\\(" + lm-commentary-header + "\\):[[:blank:]\n]*") + "^;;[[:blank:]]*" ; double semicolon prefix + "[[:blank:]\n]*\\'") ; trailing new-lines + "" (buffer-substring-no-properties + start (lm-commentary-end)))))))) (defun lm-homepage (&optional file) "Return the homepage in file FILE, or current buffer if FILE is nil." diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index fbbd389bf96..f66122d6d72 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -747,6 +747,7 @@ Blank lines separate paragraphs. Semicolons start comments. Note that `run-lisp' may be used either to start an inferior Lisp job or to switch back to an existing one." (lisp-mode-variables nil t) + (setq-local lisp-indent-function 'common-lisp-indent-function) (setq-local find-tag-default-function 'lisp-find-tag-default) (setq-local comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 67f5b3cf24e..9c23344baca 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: convenience, map, hash-table, alist, array -;; Version: 2.0 +;; Version: 2.1 ;; Package-Requires: ((emacs "25")) ;; Package: map @@ -56,8 +56,10 @@ evaluated and searched for in the map. The match fails if for any KEY found in the map, the corresponding PAT doesn't match the value associated to the KEY. -Each element can also be a SYMBOL, which is an abbreviation of a (KEY -PAT) tuple of the form (\\='SYMBOL SYMBOL). +Each element can also be a SYMBOL, which is an abbreviation of +a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL +is a keyword, it is an abbreviation of the form (:SYMBOL SYMBOL), +useful for binding plist values. Keys in ARGS not found in the map are ignored, and the match doesn't fail." @@ -486,9 +488,12 @@ Example: (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." (seq-map (lambda (elt) - (if (consp elt) - `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt)) - `(app (pcase--flip map-elt ',elt) ,elt))) + (cond ((consp elt) + `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (pcase--flip map-elt ,elt) ,var))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) args)) (defun map--make-pcase-patterns (args) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 10ce19525a0..c91ee445e13 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -926,7 +926,6 @@ untar into a directory named DIR; otherwise, signal an error." (if (> (length file-list) 1) 'tar 'single)))) ('tar (make-directory package-user-dir t) - ;; FIXME: should we delete PKG-DIR if it exists? (let* ((default-directory (file-name-as-directory package-user-dir))) (package-untar-buffer dirname))) ('single @@ -2377,18 +2376,9 @@ The description is read from the installed package files." result ;; Look for Commentary header. - (let ((mainsrcfile (expand-file-name (format "%s.el" (package-desc-name desc)) - srcdir))) - (when (file-readable-p mainsrcfile) - (with-temp-buffer - (insert (or (lm-commentary mainsrcfile) "")) - (goto-char (point-min)) - (when (re-search-forward "^;;; Commentary:\n" nil t) - (replace-match "")) - (while (re-search-forward "^\\(;+ ?\\)" nil t) - (replace-match "")) - (buffer-string)))) - ))) + (lm-commentary (expand-file-name + (format "%s.el" (package-desc-name desc)) srcdir)) + ""))) (defun describe-package-1 (pkg) "Insert the package description for PKG. @@ -2583,16 +2573,10 @@ Helper function for `describe-package'." (if built-in ;; For built-in packages, get the description from the ;; Commentary header. - (let ((fn (locate-file (format "%s.el" name) load-path - load-file-rep-suffixes)) - (opoint (point))) - (insert (or (lm-commentary fn) "")) - (save-excursion - (goto-char opoint) - (when (re-search-forward "^;;; Commentary:\n" nil t) - (replace-match "")) - (while (re-search-forward "^\\(;+ ?\\)" nil t) - (replace-match "")))) + (insert (or (lm-commentary (locate-file (format "%s.el" name) + load-path + load-file-rep-suffixes)) + "")) (if (package-installed-p desc) ;; For installed packages, get the description from the @@ -2695,15 +2679,18 @@ either a full name or nil, and EMAIL is a valid email address." (define-key map "i" 'package-menu-mark-install) (define-key map "U" 'package-menu-mark-upgrades) (define-key map "r" 'revert-buffer) - (define-key map (kbd "/ k") 'package-menu-filter-by-keyword) - (define-key map (kbd "/ n") 'package-menu-filter-by-name) - (define-key map (kbd "/ /") 'package-menu-clear-filter) (define-key map "~" 'package-menu-mark-obsolete-for-deletion) (define-key map "x" 'package-menu-execute) (define-key map "h" 'package-menu-quick-help) (define-key map "H" #'package-menu-hide-package) (define-key map "?" 'package-menu-describe-package) (define-key map "(" #'package-menu-toggle-hiding) + (define-key map (kbd "/ /") 'package-menu-clear-filter) + (define-key map (kbd "/ a") 'package-menu-filter-by-archive) + (define-key map (kbd "/ k") 'package-menu-filter-by-keyword) + (define-key map (kbd "/ n") 'package-menu-filter-by-name) + (define-key map (kbd "/ s") 'package-menu-filter-by-status) + (define-key map (kbd "/ v") 'package-menu-filter-by-version) map) "Local keymap for `package-menu-mode' buffers.") @@ -2729,8 +2716,11 @@ either a full name or nil, and EMAIL is a valid email address." "--" ("Filter Packages" + ["Filter by Archive" package-menu-filter-by-archive :help "Filter packages by archive"] ["Filter by Keyword" package-menu-filter-by-keyword :help "Filter packages by keyword"] ["Filter by Name" package-menu-filter-by-name :help "Filter packages by name"] + ["Filter by Status" package-menu-filter-by-status :help "Filter packages by status"] + ["Filter by Version" package-menu-filter-by-version :help "Filter packages by version"] ["Clear Filter" package-menu-clear-filter :help "Clear package list filter"]) ["Hide by Regexp" package-menu-hide-package :help "Hide all packages matching a regexp"] @@ -3036,22 +3026,31 @@ When none are given, the package matches." found) t)) -(defun package-menu--generate (remember-pos packages &optional keywords) - "Populate the Package Menu. +(defun package-menu--display (remember-pos suffix) + "Display the Package Menu. If REMEMBER-POS is non-nil, keep point on the same entry. + +If SUFFIX is non-nil, append that to \"Package\" for the first +column in the header line." + (setf (car (aref tabulated-list-format 0)) + (if suffix + (concat "Package[" suffix "]") + "Package")) + (tabulated-list-init-header) + (tabulated-list-print remember-pos)) + +(defun package-menu--generate (remember-pos &optional packages keywords) + "Populate and display the Package Menu. PACKAGES should be t, which means to display all known packages, or a list of package names (symbols) to display. With KEYWORDS given, only packages with those keywords are shown." (package-menu--refresh packages keywords) - (setf (car (aref tabulated-list-format 0)) - (if keywords - (let ((filters (mapconcat #'identity keywords ","))) - (concat "Package[" filters "]")) - "Package")) - (tabulated-list-init-header) - (tabulated-list-print remember-pos)) + (package-menu--display remember-pos + (when keywords + (let ((filters (mapconcat #'identity keywords ","))) + (concat "Package[" filters "]"))))) (defun package-menu--print-info (pkg) "Return a package entry suitable for `tabulated-list-entries'. @@ -3174,12 +3173,15 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (defun package-menu--refresh-contents (&optional _arg _noconfirm) "In Package Menu, download the Emacs Lisp package archive. Fetch the contents of each archive specified in -`package-archives', and then refresh the package menu. +`package-archives', and then refresh the package menu. Signal a +user-error if there is already a refresh running asynchronously. `package-menu-mode' sets `revert-buffer-function' to this function. The args ARG and NOCONFIRM, passed from `revert-buffer', are ignored." (package--ensure-package-menu-mode) + (when (and package-menu-async package--downloads-in-progress) + (user-error "Package refresh is already in progress, please wait...")) (setq package-menu--old-archive-contents package-archive-contents) (setq package-menu--new-package-list nil) (package-refresh-contents package-menu-async)) @@ -3687,45 +3689,160 @@ shown." (select-window win) (switch-to-buffer buf)))) +(defun package-menu--filter-by (predicate suffix) + "Filter \"*Packages*\" buffer by PREDICATE and add SUFFIX to header. +PREDICATE is a function which will be called with one argument, a +`package-desc' object, and returns t if that object should be +listed in the Package Menu. + +SUFFIX is passed on to `package-menu--display' and is added to +the header line of the first column." + ;; Update `tabulated-list-entries' so that it contains all + ;; packages before searching. + (package-menu--refresh t nil) + (let (found-entries) + (dolist (entry tabulated-list-entries) + (when (funcall predicate (car entry)) + (push entry found-entries))) + (if found-entries + (progn + (setq tabulated-list-entries found-entries) + (package-menu--display t suffix)) + (user-error "No packages found")))) + +(defun package-menu-filter-by-archive (archive) + "Filter the \"*Packages*\" buffer by ARCHIVE. +Display only packages from package archive ARCHIVE. + +When called interactively, prompt for ARCHIVE, which can be a +comma-separated string. If ARCHIVE is empty, show all packages. + +When called from Lisp, ARCHIVE can be a string or a list of +strings. If ARCHIVE is nil or the empty string, show all +packages." + (interactive (list (completing-read-multiple + "Filter by archive (comma separated): " + (mapcar #'car package-archives)))) + (package--ensure-package-menu-mode) + (let ((re (if (listp archive) + (regexp-opt archive) + archive))) + (package-menu--filter-by (lambda (pkg-desc) + (let ((pkg-archive (package-desc-archive pkg-desc))) + (and pkg-archive + (string-match-p re pkg-archive)))) + (concat "archive:" (if (listp archive) + (string-join archive ",") + archive))))) + (defun package-menu-filter-by-keyword (keyword) "Filter the \"*Packages*\" buffer by KEYWORD. -Show only those items that relate to the specified KEYWORD. - -KEYWORD can be a string or a list of strings. If it is a list, a -package will be displayed if it matches any of the keywords. -Interactively, it is a list of strings separated by commas. - -KEYWORD can also be used to filter by status or archive name by -using keywords like \"arc:gnu\" and \"status:available\". -Statuses available include \"incompat\", \"available\", -\"built-in\" and \"installed\"." - (interactive - (list (completing-read-multiple - "Keywords (comma separated): " (package-all-keywords)))) +Display only packages with specified KEYWORD. + +When called interactively, prompt for KEYWORD, which can be a +comma-separated string. If KEYWORD is empty, show all packages. + +When called from Lisp, KEYWORD can be a string or a list of +strings. If KEYWORD is nil or the empty string, show all +packages." + (interactive (list (completing-read-multiple + "Keywords (comma separated): " + (package-all-keywords)))) + (when (stringp keyword) + (setq keyword (list keyword))) (package--ensure-package-menu-mode) - (package-show-package-list t (if (stringp keyword) - (list keyword) - keyword))) + (if (not keyword) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (package--has-keyword-p pkg-desc keyword)) + (concat "keyword:" (string-join keyword ","))))) (defun package-menu-filter-by-name (name) - "Filter the \"*Packages*\" buffer by NAME. -Show only those items whose name matches the regular expression -NAME. If NAME is nil or the empty string, show all packages." - (interactive (list (read-from-minibuffer "Filter by name (regexp): "))) + "Filter the \"*Packages*\" buffer by NAME regexp. +Display only packages with name that matches regexp NAME. + +When called interactively, prompt for NAME. + +If NAME is nil or the empty string, show all packages." + (interactive (list (read-regexp "Filter by name (regexp)"))) (package--ensure-package-menu-mode) (if (or (not name) (string-empty-p name)) - (package-show-package-list t nil) - ;; Update `tabulated-list-entries' so that it contains all - ;; packages before searching. - (package-menu--refresh t nil) - (let (matched) - (dolist (entry tabulated-list-entries) - (let* ((pkg-name (package-desc-name (car entry)))) - (when (string-match name (symbol-name pkg-name)) - (push pkg-name matched)))) - (if matched - (package-show-package-list matched nil) - (user-error "No packages found"))))) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (string-match-p name (symbol-name + (package-desc-name pkg-desc)))) + (format "name:%s" name)))) + +(defun package-menu-filter-by-status (status) + "Filter the \"*Packages*\" buffer by STATUS. +Display only packages with specified STATUS. + +When called interactively, prompt for STATUS, which can be a +comma-separated string. If STATUS is empty, show all packages. + +When called from Lisp, STATUS can be a string or a list of +strings. If STATUS is nil or the empty string, show all +packages." + (interactive (list (completing-read "Filter by status: " + '("avail-obso" + "available" + "built-in" + "dependency" + "disabled" + "external" + "held" + "incompat" + "installed" + "new" + "unsigned")))) + (package--ensure-package-menu-mode) + (if (or (not status) (string-empty-p status)) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (string-match-p status (package-desc-status pkg-desc))) + (format "status:%s" status)))) + +(defun package-menu-filter-by-version (version predicate) + "Filter the \"*Packages*\" buffer by VERSION and PREDICATE. +Display only packages with a matching version. + +When called interactively, prompt for one of the qualifiers `<', +`>' or `=', and a package version. Show only packages that has a +lower (`<'), equal (`=') or higher (`>') version than the +specified one. + +When called from Lisp, VERSION should be a version string and +PREDICATE should be the symbol `=', `<' or `>'. + +If VERSION is nil or the empty string, show all packages." + (interactive (let ((choice (intern + (char-to-string + (read-char-choice + "Filter by version? [Type =, <, > or q] " + '(?< ?> ?= ?q)))))) + (if (eq choice 'q) + '(quit nil) + (list (read-from-minibuffer + (concat "Filter by version (" + (pcase choice + ('= "= equal to") + ('< "< less than") + ('> "> greater than")) + "): ")) + choice)))) + (unless (equal predicate 'quit) + (if (or (not version) (string-empty-p version)) + (package-menu--generate t t) + (package-menu--filter-by + (let ((fun (pcase predicate + ('= 'version-list-=) + ('< 'version-list-<) + ('> '(lambda (a b) (not (version-list-<= a b)))) + (_ (error "Unknown predicate: %s" predicate)))) + (ver (version-to-list version))) + (lambda (pkg-desc) + (funcall fun (package-desc-version pkg-desc) ver))) + (format "versions:%s%s" predicate version))))) (defun package-menu-clear-filter () "Clear any filter currently applied to the \"*Packages*\" buffer." @@ -3774,6 +3891,7 @@ The return value is a string (or nil in case we can't find it)." (or (lm-header "package-version") (lm-header "version"))))))))) + ;;;; Quickstart: precompute activation actions for faster start up. ;; Activating packages via `package-initialize' is costly: for N installed diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 501cc3a29e0..b13f609f882 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -547,10 +547,10 @@ Return the column number after insertion." ;; Don't truncate to `width' if the next column is align-right ;; and has some space left, truncate to `available-space' instead. (when (and not-last-col - (> label-width available-space) - (setq label (truncate-string-to-width - label available-space nil nil t t) - label-width available-space))) + (> label-width available-space)) + (setq label (truncate-string-to-width + label available-space nil nil t t) + label-width available-space)) (setq label (bidi-string-mark-left-to-right label)) (when (and right-align (> width label-width)) (let ((shift (- width label-width))) diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index 511c68f24a7..6c4afe519f2 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -922,6 +922,8 @@ Should be set in `viper-custom-file-name'." "Hooks run just after loading Viper." :type 'hook :group 'viper-hooks) +(make-obsolete-variable 'viper-load-hook + "use `with-eval-after-load' instead." "28.1") (defun viper-restore-cursor-type () (condition-case nil diff --git a/lisp/epa.el b/lisp/epa.el index 47c177e6cd5..8ec42187358 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -361,7 +361,10 @@ If ARG is non-nil, mark the key." 'start-open t 'end-open t))))) -(defun epa--list-keys (name secret) +(defun epa--list-keys (name secret &optional doc) + "NAME specifies which key to list. +SECRET says list data on the secret key (default, the public key). +DOC is documentation text to insert at the start." (unless (and epa-keys-buffer (buffer-live-p epa-keys-buffer)) (setq epa-keys-buffer (generate-new-buffer "*Keys*"))) @@ -371,13 +374,28 @@ If ARG is non-nil, mark the key." buffer-read-only (point (point-min)) (context (epg-make-context epa-protocol))) + + ;; Find the end of the documentation text at the start. + ;; Set POINT to where it ends, or nil if ends at eob. (unless (get-text-property point 'epa-list-keys) (setq point (next-single-property-change point 'epa-list-keys))) + + ;; If caller specified documentation text for that, replace the old + ;; documentation text (if any) with what was specified. + ;; Otherwise, preserve whatever intro text is present. + (when doc + (if (or point (not (eobp))) + (delete-region (point-min) point)) + (insert doc) + (setq point (point))) + + ;; Now delete the key description text, if any. (when point (delete-region point (or (next-single-property-change point 'epa-list-keys) (point-max))) (goto-char point)) + (epa--insert-keys (epg-list-keys context name secret)) (widget-setup) (set-keymap-parent (current-local-map) widget-keymap)) @@ -396,7 +414,13 @@ If ARG is non-nil, mark the key." (car epa-list-keys-arguments))))) (list (if (equal name "") nil name))) (list nil))) - (epa--list-keys name nil)) + (epa--list-keys name nil + "The letters at the start of a line have these meanings. +e expired key. n never trust. m trust marginally. u trust ultimately. +f trust fully (keys you have signed, usually). +q trust status questionable. - trust status unspecified. + See GPG documentaion for more explanation. +\n")) ;;;###autoload (defun epa-list-secret-keys (&optional name) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index ffa72204f43..b1a829cde7a 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -375,7 +375,7 @@ Example: If you know that the channel #linux-ru uses the coding-system `cyrillic-koi8', then add (\"#linux-ru\" . cyrillic-koi8) to the alist." :group 'erc-server - :type '(repeat (cons (string :tag "Target") + :type '(repeat (cons (regexp :tag "Target") coding-system))) (defcustom erc-server-connect-function #'erc-open-network-stream diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el index 7e58469ddae..a2d58e927e9 100644 --- a/lisp/erc/erc-ezbounce.el +++ b/lisp/erc/erc-ezbounce.el @@ -34,7 +34,7 @@ (defcustom erc-ezb-regexp "^ezbounce!srv$" "Regexp used by the EZBouncer to identify itself to the user." :group 'erc-ezbounce - :type 'string) + :type 'regexp) (defcustom erc-ezb-login-alist '() "Alist of logins suitable for the server we're connecting to. diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 0fde3bf7cc3..1c0635c528c 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -90,9 +90,8 @@ nil - Do not sort users" "Additional menu-items to add to speedbar frame.") ;; Make sure our special speedbar major mode is loaded -(if (featurep 'speedbar) - (erc-install-speedbar-variables) - (add-hook 'speedbar-load-hook 'erc-install-speedbar-variables)) +(with-eval-after-load 'speedbar + (erc-install-speedbar-variables)) ;;; ERC hierarchy display method ;;;###autoload diff --git a/lisp/expand.el b/lisp/expand.el index 1417c90fdb4..77e4fc2657c 100644 --- a/lisp/expand.el +++ b/lisp/expand.el @@ -55,10 +55,8 @@ ;; ;; you can also init some post-process hooks : ;; -;; (add-hook 'expand-load-hook -;; (lambda () -;; (add-hook 'expand-expand-hook 'indent-according-to-mode) -;; (add-hook 'expand-jump-hook 'indent-according-to-mode))) +;; (add-hook 'expand-expand-hook 'indent-according-to-mode) +;; (add-hook 'expand-jump-hook 'indent-according-to-mode) ;; ;; Remarks: ;; @@ -78,6 +76,8 @@ "Hooks run when `expand.el' is loaded." :type 'hook :group 'expand) +(make-obsolete-variable 'expand-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom expand-expand-hook nil "Hooks run when an abbrev made by `expand-add-abbrevs' is expanded." diff --git a/lisp/ffap.el b/lisp/ffap.el index 66ef0824d8a..ead79b45c0e 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -1080,7 +1080,7 @@ If a given RFC isn't in these then `ffap-rfc-path' is offered." ;; Slightly controversial decisions: ;; * strip trailing "@", ":" and enclosing "{"/"}". ;; * no commas (good for latex) - (file "--:\\\\${}+<>@-Z_[:alpha:]~*?" "{<@" "@>;.,!:}") + (file "--:\\\\${}+<>@-Z_[:alpha:]~*?#" "{<@" "@>;.,!:}") ;; An url, or maybe an email/news message-id: (url "--:=&?$+@-Z_[:alpha:]~#,%;*()!'" "^[0-9a-zA-Z]" ":;.,!?") ;; Find a string that does *not* contain a colon: diff --git a/lisp/files.el b/lisp/files.el index 38536a92da7..683f4a8ce7c 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -405,7 +405,7 @@ editing a remote file. On MS-DOS filesystems without long names this variable is always ignored." :group 'auto-save - :type '(repeat (list (string :tag "Regexp") (string :tag "Replacement") + :type '(repeat (list (regexp :tag "Regexp") (string :tag "Replacement") (boolean :tag "Uniquify"))) :initialize 'custom-initialize-delay :version "21.1") diff --git a/lisp/filesets.el b/lisp/filesets.el index 9834bcf0587..1ec0d24b539 100644 --- a/lisp/filesets.el +++ b/lisp/filesets.el @@ -1645,10 +1645,10 @@ Replace <file-name> or <<file-name>> with filename." (dolist (this args txt) (setq txt (concat txt + (if (equal txt "") "" " ") (filesets-run-cmd--repl-fn this (lambda (this) - (if (equal txt "") "" " ") (format "%s" this)))))))) (cmd (concat fn " " args))) (filesets-cmd-show-result diff --git a/lisp/finder.el b/lisp/finder.el index 96359b0b4fe..dc14b27a753 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -394,13 +394,6 @@ FILE should be in a form suitable for passing to `locate-library'." (erase-buffer) (insert str) (goto-char (point-min)) - (delete-blank-lines) - (goto-char (point-max)) - (delete-blank-lines) - (goto-char (point-min)) - (while (re-search-forward "^;+ ?" nil t) - (replace-match "" nil nil)) - (goto-char (point-min)) (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t) (if (locate-library (match-string 1)) (make-text-button (match-beginning 1) (match-end 1) diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index 82dbbab5e0d..0ce4a7d2928 100644 --- a/lisp/gnus/deuglify.el +++ b/lisp/gnus/deuglify.el @@ -266,21 +266,21 @@ "\\(On \\|Am \\)?\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),[^,]+, " "Regular expression matching the beginning of an attribution line that should be cut off." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-verb-regexp "wrote\\|writes\\|says\\|schrieb\\|schreibt\\|meinte\\|skrev\\|a écrit\\|schreef\\|escribió" "Regular expression matching the verb used in an attribution line." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-end-regexp ": *\\|\\.\\.\\." "Regular expression matching the end of an attribution line." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-display-hook nil diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 9f22b7df0ff..80bf21bb443 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -799,7 +799,7 @@ be a select method." (let ((gnus-command-method method) (gnus-agent nil)) (when (file-exists-p (gnus-agent-lib-file "flags")) - (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) + (set-buffer (gnus-get-buffer-create " *Gnus Agent flag synchronize*")) (erase-buffer) (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) (cond ((null gnus-plugged) diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index ea4af2df0c4..1b00bbbc69c 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -242,7 +242,7 @@ So the cdr of each bookmark is an alist too.") (save-window-excursion ;; Avoid warnings? ;; (message "Saving Gnus bookmarks to file %s..." gnus-bookmark-default-file) - (set-buffer (get-buffer-create " *Gnus bookmarks*")) + (set-buffer (gnus-get-buffer-create " *Gnus bookmarks*")) (erase-buffer) (gnus-bookmark-insert-file-format-version-stamp) (pp gnus-bookmark-alist (current-buffer)) @@ -357,8 +357,8 @@ deletion, or > if it is flagged for displaying." (interactive) (gnus-bookmark-maybe-load-default-file) (if (called-interactively-p 'any) - (switch-to-buffer (get-buffer-create "*Gnus Bookmark List*")) - (set-buffer (get-buffer-create "*Gnus Bookmark List*"))) + (switch-to-buffer (gnus-get-buffer-create "*Gnus Bookmark List*")) + (set-buffer (gnus-get-buffer-create "*Gnus Bookmark List*"))) (let ((inhibit-read-only t) alist name start end) (erase-buffer) @@ -648,7 +648,7 @@ reposition and try again, else return nil." (details gnus-bookmark-bookmark-details) detail) (save-excursion - (pop-to-buffer (get-buffer-create "*Gnus Bookmark Annotation*") t) + (pop-to-buffer (gnus-get-buffer-create "*Gnus Bookmark Annotation*") t) (erase-buffer) (while details (setq detail (pop details)) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index cecfaef2f4f..4d8764bacca 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -243,10 +243,10 @@ Use old data if FORCE-OLDER is not nil." (when (or (not gnus-cloud-interactive) (gnus-y-or-n-p (format "%s has older different info in the cloud as of %s, update it here? " - group date)))) - (gnus-message 2 "Installing cloud update of group %s" group) - (gnus-set-info group contents) - (gnus-group-update-group group))) + group date))) + (gnus-message 2 "Installing cloud update of group %s" group) + (gnus-set-info group contents) + (gnus-group-update-group group)))) (gnus-error 1 "Sorry, group %s is not subscribed" group)) (gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)" group elem)))) diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 1b25d247389..3a9bf2a7e8f 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -248,7 +248,7 @@ If DONT-POP is nil, display the buffer after setting it up." (let ((article narticle)) (message-mail nil nil nil nil (if dont-pop - (lambda (buf) (set-buffer (get-buffer-create buf))))) + (lambda (buf) (set-buffer (gnus-get-buffer-create buf))))) (let ((inhibit-read-only t)) (erase-buffer)) (if (not (gnus-request-restore-buffer article group)) diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 33cbf4a54a9..c95449762e4 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -40,7 +40,7 @@ "Regexp to match faces in `gnus-x-face-directory' to be omitted." :version "25.1" :group 'gnus-fun - :type '(choice (const nil) string)) + :type '(choice (const nil) regexp)) (defcustom gnus-face-directory (expand-file-name "faces" gnus-directory) "Directory where Face PNG files are stored." @@ -52,7 +52,7 @@ "Regexp to match faces in `gnus-face-directory' to be omitted." :version "25.1" :group 'gnus-fun - :type '(choice (const nil) string)) + :type '(choice (const nil) regexp)) (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface" "Command for converting a PBM to an X-Face." diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index b89f040b435..da7db589ec3 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -3761,10 +3761,10 @@ group line." (newsrc ;; Toggle subscription flag. (gnus-group-change-level - newsrc (if level level (if (<= (gnus-info-level (nth 1 newsrc)) - gnus-level-subscribed) - (1+ gnus-level-subscribed) - gnus-level-default-subscribed))) + newsrc (or level (if (<= (gnus-info-level (nth 1 newsrc)) + gnus-level-subscribed) + (1+ gnus-level-subscribed) + gnus-level-default-subscribed))) (unless silent (gnus-group-update-group group))) ((and (stringp group) @@ -3773,7 +3773,7 @@ group line." ;; Add new newsgroup. (gnus-group-change-level group - (if level level gnus-level-default-subscribed) + (or level gnus-level-default-subscribed) (or (and (member group gnus-zombie-list) gnus-level-zombie) gnus-level-killed) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index ee556a32080..305e17fd8fc 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -814,7 +814,7 @@ These will be used to retrieve the RSVP information from ical events." (let ((subject (concat (capitalize (symbol-name status)) ": " (gnus-icalendar-event:summary event)))) - (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname) + (with-current-buffer (gnus-get-buffer-create gnus-icalendar-reply-bufname) (delete-region (point-min) (point-max)) (insert reply) (fold-icalendar-buffer) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index c304f575d92..60ebc07c343 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -253,7 +253,7 @@ If it is down, start it up (again)." (defun gnus-backend-trace (type form) (when gnus-backend-trace - (with-current-buffer (get-buffer-create "*gnus trace*") + (with-current-buffer (gnus-get-buffer-create "*gnus trace*") (buffer-disable-undo) (goto-char (point-max)) (insert (format-time-string "%H:%M:%S") diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index d58bd7a73b5..095e05408d6 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -309,7 +309,7 @@ The following commands are available: ;; `gnus-server-buffer' selected as the current buffer, but not always (I ;; bumped into it when starting from a dedicated *Group* frame, and ;; gnus-configure-windows opened *Server* into its own dedicated frame). - (with-current-buffer (get-buffer-create gnus-server-buffer) + (with-current-buffer (gnus-get-buffer-create gnus-server-buffer) (gnus-server-mode) (gnus-server-prepare))) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 61319266ced..1fd2575ea1f 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -1256,19 +1256,19 @@ INFO-LIST), otherwise it's a list in the format of the `gnus-newsrc-hashtb' entries. LEVEL is the new level of the group, OLDLEVEL is the old level and PREVIOUS is the group (a string name) to insert this group before." - (let (group info active num) - ;; Glean what info we can from the arguments. - (if (consp entry) - (setq group (if fromkilled (nth 1 entry) (car (nth 1 entry)))) - (setq group entry)) + ;; Glean what info we can from the arguments. + (let ((group (if (consp entry) + (if fromkilled (nth 1 entry) (car (nth 1 entry))) + entry)) + info active num) (when (and (stringp entry) oldlevel (< oldlevel gnus-level-zombie)) (setq entry (gnus-group-entry entry))) - (if (and (not oldlevel) - (consp entry)) - (setq oldlevel (gnus-info-level (nth 1 entry))) - (setq oldlevel (or oldlevel gnus-level-killed))) + (setq oldlevel (if (and (not oldlevel) + (consp entry)) + (gnus-info-level (nth 1 entry)) + (or oldlevel gnus-level-killed))) ;; This table is used for completion, so put a dummy entry there. (unless (gethash group gnus-active-hashtb) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index a40e563e755..a47e6576230 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -12310,7 +12310,7 @@ no matter what the properties `:decode' and `:headers' are." (buffer-string)))))) (put 'gnus-summary-save-in-pipe :headers headers)) (unless (zerop (length result)) - (if (with-current-buffer (get-buffer-create result-buffer) + (if (with-current-buffer (gnus-get-buffer-create result-buffer) (erase-buffer) (insert result) (prog1 @@ -12498,7 +12498,7 @@ save those articles instead." (gnus-activate-group to-newsgroup nil nil to-method) (gnus-subscribe-group to-newsgroup)) (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup)) + (user-error "No such group: %s" to-newsgroup)) to-newsgroup))) (defvar gnus-summary-save-parts-counter) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 23c62b4f939..eb0fd2522d3 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -950,7 +950,7 @@ FILENAME exists and is Babyl format." (setq rmail-default-rmail-file filename) ; 22 (setq rmail-default-file filename)) ; 23 (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*")) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*")) ;; Babyl rmail.el defines this, mbox does not. (babyl (fboundp 'rmail-insert-rmail-file-header))) (save-excursion @@ -1036,7 +1036,7 @@ FILENAME exists and is Babyl format." (require 'nnmail) (setq filename (expand-file-name filename)) (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*"))) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*"))) (save-excursion ;; Create the file, if it doesn't exist. (when (and (not (get-file-buffer filename)) @@ -1457,7 +1457,7 @@ CHOICE is a list of the choice char and help message at IDX." (setq tchar (read-char)) (when (not (assq tchar choice)) (setq tchar nil) - (setq buf (get-buffer-create "*Gnus Help*")) + (setq buf (gnus-get-buffer-create "*Gnus Help*")) (pop-to-buffer buf) (fundamental-mode) (buffer-disable-undo) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 6df26b4af8c..caeab7f55af 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -660,7 +660,7 @@ be used directly.") (defun gnus-add-buffer () "Add the current buffer to the list of Gnus buffers." (gnus-prune-buffers) - (push (current-buffer) gnus-buffers)) + (cl-pushnew (current-buffer) gnus-buffers)) (defmacro gnus-kill-buffer (buffer) "Kill BUFFER and remove from the list of Gnus buffers." diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 52343d4fa37..f5b68789b85 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -740,9 +740,11 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (when delay (sleep-for delay))) +(declare-function gnus-get-buffer-create "gnus" (name)) (defun mail-source-call-script (script) + (require 'gnus) (let ((background nil) - (stderr (get-buffer-create " *mail-source-stderr*")) + (stderr (gnus-get-buffer-create " *mail-source-stderr*")) result) (when (string-match "& *$" script) (setq script (substring script 0 (match-beginning 0)) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index adefa0efd65..3abeec7e2f2 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -1986,6 +1986,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'gnus-delay-article "gnus-delay") (autoload 'gnus-extract-address-components "gnus-util") (autoload 'gnus-find-method-for-group "gnus") +(autoload 'gnus-get-buffer-create "gnus") (autoload 'gnus-group-name-charset "gnus-group") (autoload 'gnus-group-name-decode "gnus-group") (autoload 'gnus-groups-from-server "gnus") @@ -7310,7 +7311,7 @@ If ARG, allow editing of the cancellation message." ;; Make control message. (if arg (message-news) - (setq buf (set-buffer (get-buffer-create " *message cancel*")))) + (setq buf (set-buffer (gnus-get-buffer-create " *message cancel*")))) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" "From: " from "\n" @@ -7731,7 +7732,7 @@ is for the internal use." gcc beg) ;; We first set up a normal mail buffer. (unless (message-mail-user-agent) - (set-buffer (get-buffer-create " *message resend*")) + (set-buffer (gnus-get-buffer-create " *message resend*")) (let ((inhibit-read-only t)) (erase-buffer))) (let ((message-this-is-mail t) diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el index 6b4308e9790..71676c12a46 100644 --- a/lisp/gnus/mm-archive.el +++ b/lisp/gnus/mm-archive.el @@ -24,6 +24,7 @@ (require 'mm-decode) (autoload 'gnus-recursive-directory-files "gnus-util") +(autoload 'gnus-get-buffer-create "gnus") (autoload 'mailcap-extension-to-mime "mailcap") (defvar mm-archive-decoders @@ -56,7 +57,7 @@ (append (cdr decoder) (list dir))) (delete-file file)) (apply 'call-process-region (point-min) (point-max) (car decoder) - nil (get-buffer-create "*tnef*") + nil (gnus-get-buffer-create "*tnef*") nil (append (cdr decoder) (list dir))))) `("multipart/mixed" ,handle diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index e6fdc93da24..61bf0a78c0e 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -251,19 +251,23 @@ The value should be nil on displays where the face (((type tty) (class color) (background dark)) - (:background "dark blue")) + (:background "dark blue" + :extend t)) (((class color) (background dark)) (:foreground "light yellow" - :background "dark green")) + :background "dark green" + :extend t)) (((type tty) (class color) (background light)) - (:foreground "dark blue")) + (:foreground "dark blue" + :extend t)) (((class color) (background light)) (:foreground "dark green" - :background "light yellow")) + :background "light yellow" + :extend t)) (t ())) "Face for extracted buffers." diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index 3cc463d5d4c..4754f37a2da 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -154,14 +154,9 @@ Whether the passphrase is cached at all is controlled by (write-region (point-min) (point-max) file)) (push file certfiles) (push file tmpfiles))) - (if (smime-encrypt-buffer certfiles) - (progn - (while (setq tmp (pop tmpfiles)) - (delete-file tmp)) - t) - (while (setq tmp (pop tmpfiles)) - (delete-file tmp)) - nil)) + (smime-encrypt-buffer certfiles) + (while (setq tmp (pop tmpfiles)) + (delete-file tmp))) (goto-char (point-max))) (defvar gnus-extract-address-components) diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 1e72f681797..d1d150ad2ee 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -293,6 +293,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (substring alg (match-end 0)) alg)))) +(autoload 'gnus-get-buffer-create "gnus") + (defun mml2015-mailcrypt-verify (handle ctl) (catch 'error (let (part) @@ -330,7 +332,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (replace-match "-----BEGIN PGP SIGNATURE-----" t t)) (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t) (replace-match "-----END PGP SIGNATURE-----" t t))) - (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*"))) (unless (condition-case err (prog1 (funcall mml2015-verify-function) @@ -359,7 +361,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." handle))) (defun mml2015-mailcrypt-clear-verify () - (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*"))) (if (condition-case err (prog1 (funcall mml2015-verify-function) @@ -725,6 +727,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa") +(autoload 'gnus-create-image "gnus-util") + (defun mml2015-epg-key-image (key-id) "Return the image of a key, if any." (with-temp-buffer @@ -949,7 +953,6 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." ;;; General wrapper (autoload 'gnus-buffer-live-p "gnus-util") -(autoload 'gnus-get-buffer-create "gnus") (defun mml2015-clean-buffer () (if (gnus-buffer-live-p mml2015-result-buffer) diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index 6890f1dceeb..cb22933b529 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -293,7 +293,7 @@ (deffoo nnbabyl-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnbabyl move*")) + (let ((buf (gnus-get-buffer-create " *nnbabyl move*")) result) (and (nnbabyl-request-article article group server) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 24a3df1e27a..ac394ae53d7 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -597,7 +597,7 @@ all. This may very well take some time.") (deffoo nndiary-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nndiary move*")) + (let ((buf (gnus-get-buffer-create " *nndiary move*")) result) (nndiary-possibly-change-directory group server) (nndiary-update-file-alist) @@ -831,7 +831,7 @@ all. This may very well take some time.") ;; Find an article number in the current group given the Message-ID. (defun nndiary-find-group-number (id) - (with-current-buffer (get-buffer-create " *nndiary id*") + (with-current-buffer (gnus-get-buffer-create " *nndiary id*") (let ((alist nndiary-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -999,8 +999,8 @@ all. This may very well take some time.") (defun nndiary-open-nov (group) (or (cdr (assoc group nndiary-nov-buffer-alist)) - (let ((buffer (get-buffer-create (format " *nndiary overview %s*" - group)))) + (let ((buffer (gnus-get-buffer-create + (format " *nndiary overview %s*" group)))) (with-current-buffer buffer (set (make-local-variable 'nndiary-nov-buffer-file-name) (expand-file-name @@ -1086,7 +1086,7 @@ all. This may very well take some time.") (defun nndiary-generate-nov-file (dir files) (let* ((dir (file-name-as-directory dir)) (nov (concat dir nndiary-nov-file-name)) - (nov-buffer (get-buffer-create " *nov*")) + (nov-buffer (gnus-get-buffer-create " *nov*")) chars file headers) ;; Init the nov buffer. (with-current-buffer nov-buffer diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index 0ba63915c94..36b67a8fd13 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -347,7 +347,7 @@ from the document.") (file-exists-p nndoc-address) (not (file-directory-p nndoc-address)))) (push (cons group (setq nndoc-current-buffer - (get-buffer-create + (gnus-get-buffer-create (concat " *nndoc " group "*")))) nndoc-group-alist) (setq nndoc-dissection-alist nil) diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index 3ee86a696cb..e5dda990d6b 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -231,7 +231,7 @@ are generated if and only if they are also in `message-draft-headers'." (deffoo nndraft-request-move-article (article group server accept-form &optional last move-is-internal) (nndraft-possibly-change-group group) - (let ((buf (get-buffer-create " *nndraft move*")) + (let ((buf (gnus-get-buffer-create " *nndraft move*")) result) (and (nndraft-request-article article group server) @@ -325,7 +325,7 @@ are generated if and only if they are also in `message-draft-headers'." (save-excursion (prog1 (progn - (set-buffer (get-buffer-create " *draft tmp*")) + (set-buffer (gnus-get-buffer-create " *draft tmp*")) (setq buffer-file-name file) (make-auto-save-file-name)) (kill-buffer (current-buffer))))) diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index 9e190515f18..9f1fdbae5ae 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -381,7 +381,7 @@ included.") (defun nneething-get-head (file) "Either find the head in FILE or make a head for FILE." - (with-current-buffer (get-buffer-create nneething-work-buffer) + (with-current-buffer (gnus-get-buffer-create nneething-work-buffer) (setq case-fold-search nil) (buffer-disable-undo) (erase-buffer) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 342ac48ba85..d1eeb04697e 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -465,7 +465,7 @@ all. This may very well take some time.") (deffoo nnfolder-request-move-article (article group server accept-form &optional last move-is-internal) (save-excursion - (let ((buf (get-buffer-create " *nnfolder move*")) + (let ((buf (gnus-get-buffer-create " *nnfolder move*")) result) (and (nnfolder-request-article article group server) @@ -1096,7 +1096,7 @@ This command does not work if you use short group names." (defun nnfolder-open-nov (group) (or (cdr (assoc group nnfolder-nov-buffer-alist)) - (let ((buffer (get-buffer-create (format " *nnfolder overview %s*" group)))) + (let ((buffer (gnus-get-buffer-create (format " *nnfolder overview %s*" group)))) (with-current-buffer buffer (set (make-local-variable 'nnfolder-nov-buffer-file-name) (nnfolder-group-nov-pathname group)) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 03b08854b11..fee7a169ff9 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -209,7 +209,7 @@ on your system, you could say something like: ;; about twice as fast, even though it looks messier. You ;; can't have everything, I guess. Speed and elegance don't ;; always go hand in hand. - (vector + (make-full-mail-header ;; Number. (or number 0) ;; Subject. @@ -487,8 +487,8 @@ the line could be found." (< num article))) (forward-line 1) (setq found (point)) - (or (eobp) - (= (setq num (read cur)) article))) + (unless (eobp) + (setq num (read cur)))) (unless (eq num article) (goto-char found))) (beginning-of-line) @@ -502,10 +502,12 @@ the line could be found." "Coding system used in file backends of Gnus.") (defvar nnheader-callback-function nil) +(autoload 'gnus-get-buffer-create "gnus") + (defun nnheader-init-server-buffer () "Initialize the Gnus-backend communication buffer." (unless (gnus-buffer-live-p nntp-server-buffer) - (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) + (setq nntp-server-buffer (gnus-get-buffer-create " *nntpd*"))) (with-current-buffer nntp-server-buffer (erase-buffer) (mm-enable-multibyte) @@ -630,7 +632,7 @@ the line could be found." (defun nnheader-set-temp-buffer (name &optional noerase) "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." - (set-buffer (get-buffer-create name)) + (set-buffer (gnus-get-buffer-create name)) (buffer-disable-undo) (unless noerase (erase-buffer)) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index c383e0146f3..3c4e75ede82 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1937,7 +1937,7 @@ Return the server's response to the SELECT or EXAMINE command." (defun nnimap-log-buffer () (let ((name "*imap log*")) (or (get-buffer name) - (with-current-buffer (get-buffer-create name) + (with-current-buffer (gnus-get-buffer-create name) (setq-local window-point-insertion-type t) (current-buffer))))) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 823bc2b423e..0277524a8c6 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -617,7 +617,8 @@ A non-nil `specs' arg must be an alist with `nnir-query-spec' and (list (gnus-group-group-name)) (mapcar (lambda (entry) (gnus-info-group (cadr entry))) - (gnus-topic-find-groups (gnus-group-topic-name))))) + (gnus-topic-find-groups (gnus-group-topic-name) + nil t nil t)))) gnus-group-server)))) (query-spec (or (cdr (assq 'nnir-query-spec specs)) @@ -1234,7 +1235,7 @@ Windows NT 4.0." (when (equal "" qstring) (error "swish++: You didn't enter anything")) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (if groupspec @@ -1316,7 +1317,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." (when (equal "" qstring) (error "swish-e: You didn't enter anything")) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (message "Doing swish-e query %s..." query) @@ -1401,7 +1402,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." (setq groupspec (regexp-opt (mapcar (lambda (x) (gnus-group-real-name x)) group)))) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (message "Doing hyrex-search query %s..." query) (let* ((cp-list @@ -1480,7 +1481,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." score group article (process-environment (copy-sequence process-environment))) (setenv "LC_MESSAGES" "C") - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (let* ((cp-list `( ,nnir-namazu-program @@ -1561,7 +1562,7 @@ construct path: search terms (see the variable (when (equal "" qstring) (error "notmuch: You didn't enter anything")) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (if groups @@ -1635,7 +1636,7 @@ construct path: search terms (see the variable (message "Searching %s using find-grep..." (or group server)) (save-window-excursion - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (if (> gnus-verbose 6) (pop-to-buffer (current-buffer))) (cd directory) ; Using relative paths simplifies diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index d64d0ed0006..6e01b5c4d0b 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -1047,7 +1047,7 @@ will be copied over from that buffer." (list (list group "")) nnmail-split-methods))) ;; Insert the incoming file. - (with-current-buffer (get-buffer-create nnmail-article-buffer) + (with-current-buffer (gnus-get-buffer-create nnmail-article-buffer) (erase-buffer) (if (bufferp incoming) (insert-buffer-substring incoming) @@ -1574,7 +1574,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." () ; The buffer is open. (with-current-buffer (setq nnmail-cache-buffer - (get-buffer-create " *nnmail message-id cache*")) + (gnus-get-buffer-create " *nnmail message-id cache*")) (gnus-add-buffer) (when (file-exists-p nnmail-message-id-cache-file) (nnheader-insert-file-contents nnmail-message-id-cache-file)) @@ -2065,7 +2065,7 @@ Doesn't change point." (when nnmail-split-tracing (push split nnmail-split-trace)) (when nnmail-debug-splitting - (with-current-buffer (get-buffer-create "*nnmail split*") + (with-current-buffer (gnus-get-buffer-create "*nnmail split*") (goto-char (point-max)) (insert (format-time-string "%FT%T") " " diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index b0e79d4f238..9c7b1254413 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -1,4 +1,4 @@ -;;; nnmaildir.el --- maildir backend for Gnus +;;; nnmaildir.el --- maildir backend for Gnus -*- lexical-binding:t -*- ;; This file is in the public domain. @@ -261,7 +261,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir--param (pgname param) (setq param (gnus-group-find-parameter pgname param 'allow-list)) (if (vectorp param) (setq param (aref param 0))) - (eval param)) + (eval param t)) (defmacro nnmaildir--with-nntp-buffer (&rest body) (declare (debug (body))) @@ -269,15 +269,15 @@ This variable is set by `nnmaildir-request-article'.") ,@body)) (defmacro nnmaildir--with-work-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir work*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir work*") ,@body)) (defmacro nnmaildir--with-nov-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir nov*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir nov*") ,@body)) (defmacro nnmaildir--with-move-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir move*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir move*") ,@body)) (defsubst nnmaildir--subdir (dir subdir) @@ -690,7 +690,7 @@ This variable is set by `nnmaildir-request-article'.") "You must set \"directory\" in the select method") (throw 'return nil)) (setq dir (cadr dir) - dir (eval dir) + dir (eval dir t) ;FIXME: Why `eval'? dir (expand-file-name dir) dir (file-name-as-directory dir)) (unless (file-exists-p dir) @@ -717,13 +717,13 @@ This variable is set by `nnmaildir-request-article'.") (if x (progn (setq x (cadr x) - x (eval x)) + x (eval x t)) ;FIXME: Why `eval'? (setf (nnmaildir--srv-target-prefix server) x)) (setq x (assq 'create-directory defs)) (if x (progn (setq x (cadr x) - x (eval x) + x (eval x t) ;FIXME: Why `eval'? x (file-name-as-directory x)) (setf (nnmaildir--srv-target-prefix server) x)) (setf (nnmaildir--srv-target-prefix server) ""))) @@ -1428,7 +1428,7 @@ This variable is set by `nnmaildir-request-article'.") (nnmaildir--with-move-buffer (erase-buffer) (nnheader-insert-file-contents nnmaildir--file) - (setq result (eval accept-form))) + (setq result (eval accept-form t))) (unless (or (null result) (nnmaildir--param pgname 'read-only)) (nnmaildir--unlink nnmaildir--file) (nnmaildir--expired-article group article)) @@ -1544,7 +1544,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir-request-expire-articles (ranges &optional gname server force) (let ((no-force (not force)) (group (nnmaildir--prepare server gname)) - pgname time boundary high low target dir nlist + pgname time boundary target dir nlist didnt nnmaildir--file nnmaildir-article-file-name deactivate-mark) (catch 'return @@ -1720,18 +1720,23 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir-close-group (gname &optional server) (let ((group (nnmaildir--prepare server gname)) - pgname ls dir msgdir files flist dirs) + pgname ls dir msgdir files dirs + (fset (make-hash-table :test #'equal))) (if (null group) (progn (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) nil) + ;; Delete the now obsolete NOV files. + ;; FIXME: This can take a somewhat long time, so maybe it's better + ;; to do it asynchronously (i.e. in an idle timer). (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) msgdir (if (nnmaildir--param pgname 'read-only) (nnmaildir--new dir) (nnmaildir--cur dir)) + ;; The dir with the NOV files. dir (nnmaildir--nndir dir) dirs (cons (nnmaildir--nov-dir dir) (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" @@ -1744,14 +1749,15 @@ This variable is set by `nnmaildir-request-article'.") (save-match-data (dolist (file files) (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) - (push (match-string 1 file) flist))) + (puthash (match-string 1 file) t fset))) + ;; Not sure why, but we specifically avoid deleting the `:' file. + (puthash ":" t fset) (dolist (dir dirs) (setq files (cdr dir) dir (file-name-as-directory (car dir))) (dolist (file files) - (unless (or (member file flist) (string= file ":")) - (setq file (concat dir file)) - (delete-file file)))) + (unless (gethash file fset) + (delete-file (concat dir file))))) t))) (defun nnmaildir-close-server (&optional server _defs) diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index b3329212f84..dcecfcf6519 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -1249,7 +1249,7 @@ Marks propagation has to be enabled for this to work." If THREADS is non-nil, enable full threads." (let ((args (cons (car command) '(nil t nil)))) (with-current-buffer - (get-buffer-create nnmairix-mairix-output-buffer) + (gnus-get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1267,7 +1267,7 @@ If THREADS is non-nil, enable full threads." "Call mairix binary with COMMAND and QUERY in raw mode." (let ((args (cons (car command) '(nil t nil)))) (with-current-buffer - (get-buffer-create nnmairix-mairix-output-buffer) + (gnus-get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1404,7 +1404,7 @@ TYPE is either `nov' or `headers'." (nnheader-message 7 "nnmairix: Rewriting headers...") (cond ((eq type 'nov) - (let ((buf (get-buffer-create " *nnmairix buffer*")) + (let ((buf (gnus-get-buffer-create " *nnmairix buffer*")) (corr (not (zerop numc))) (name (buffer-name nntp-server-buffer)) header cur xref) diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index eb8fcf37a25..a191f887c78 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -280,7 +280,7 @@ (deffoo nnmbox-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnmbox move*")) + (let ((buf (gnus-get-buffer-create " *nnmbox move*")) result) (and (nnmbox-request-article article group server) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index c075f298986..d2f63bd3db1 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -296,7 +296,7 @@ as unread by Gnus.") (deffoo nnmh-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnmh move*")) + (let ((buf (gnus-get-buffer-create " *nnmh move*")) result) (and (nnmh-deletable-article-p group article) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 6c7b25b5e76..2c39ab8e36a 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -361,7 +361,7 @@ non-nil.") (deffoo nnml-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnml move*")) + (let ((buf (gnus-get-buffer-create " *nnml move*")) (file-name-coding-system nnmail-pathname-coding-system) result) (nnml-possibly-change-directory group server) @@ -572,7 +572,7 @@ non-nil.") ;; Find an article number in the current group given the Message-ID. (defun nnml-find-group-number (id server) - (with-current-buffer (get-buffer-create " *nnml id*") + (with-current-buffer (gnus-get-buffer-create " *nnml id*") (let ((alist nnml-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -772,11 +772,10 @@ article number. This function is called narrowed to an article." headers)))) (defun nnml-get-nov-buffer (group &optional incrementalp) - (let ((buffer (get-buffer-create (format " *nnml %soverview %s*" - (if incrementalp - "incremental " - "") - group))) + (let ((buffer (gnus-get-buffer-create + (format " *nnml %soverview %s*" + (if incrementalp "incremental " "") + group))) (file-name-coding-system nnmail-pathname-coding-system)) (with-current-buffer buffer (set (make-local-variable 'nnml-nov-buffer-file-name) @@ -873,7 +872,7 @@ Unless no-active is non-nil, update the active file too." (defun nnml-generate-nov-file (dir files) (let* ((dir (file-name-as-directory dir)) (nov (concat dir nnml-nov-file-name)) - (nov-buffer (get-buffer-create " *nov*")) + (nov-buffer (gnus-get-buffer-create " *nov*")) chars file headers) (with-current-buffer nov-buffer ;; Init the nov buffer. diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index fa4d22fb1cc..116d7ee9fb2 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -739,7 +739,7 @@ Read the file and attempt to subscribe to each Feed in the file." "OPML subscription export. Export subscriptions to a buffer in OPML Format." (interactive) - (with-current-buffer (get-buffer-create "*OPML Export*") + (with-current-buffer (gnus-get-buffer-create "*OPML Export*") (set-buffer-file-coding-system 'utf-8) (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" "<!-- OPML generated by Emacs Gnus' nnrss.el -->\n" diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 6ce8724cbbb..6be6d11a48d 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -309,7 +309,7 @@ backend doesn't catch this error.") (defun nntp-record-command (string) "Record the command STRING." - (with-current-buffer (get-buffer-create "*nntp-log*") + (with-current-buffer (gnus-get-buffer-create "*nntp-log*") (goto-char (point-max)) (insert (format-time-string "%Y%m%dT%H%M%S.%3N") " " nntp-address " " string "\n"))) diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index e1290a9c774..54c2f7be820 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -97,7 +97,7 @@ component group will show up when you enter the virtual group.") (if (stringp (car articles)) 'headers (let ((vbuf (nnheader-set-temp-buffer - (get-buffer-create " *virtual headers*"))) + (gnus-get-buffer-create " *virtual headers*"))) (carticles (nnvirtual-partition-sequence articles)) (sysname (system-name)) cgroup carticle article result prefix) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 5632bdaf250..96a7da2313c 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -579,7 +579,7 @@ This must be a list. For example, `(\"-C\" \"configfile\")'." (defcustom spam-spamassassin-positive-spam-flag-header "YES" "The regex on `spam-spamassassin-spam-flag-header' for positive spam identification." - :type 'string + :type 'regexp :group 'spam-spamassassin) (defcustom spam-spamassassin-spam-status-header "X-Spam-Status" diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 0e2ae6b3c3c..36c2a8b186d 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -1562,6 +1562,103 @@ BUFFER should be a buffer or a buffer name." (insert "\nThe parent category table is:") (describe-vector table 'help-describe-category-set)))))) +(defun help-fns-find-keymap-name (keymap) + "Find the name of the variable with value KEYMAP. +Return nil if KEYMAP is not a valid keymap, or if there is no +variable with value KEYMAP." + (when (keymapp keymap) + (let ((name (catch 'found-keymap + (mapatoms (lambda (symb) + (when (and (boundp symb) + (eq (symbol-value symb) keymap) + (not (eq symb 'keymap)) + (throw 'found-keymap symb))))) + nil))) + ;; Follow aliasing. + (or (ignore-errors (indirect-variable name)) name)))) + +(defun help-fns--most-relevant-active-keymap () + "Return the name of the most relevant active keymap. +The heuristic to determine which keymap is most likely to be +relevant to a user follows this order: + +1. 'keymap' text property at point +2. 'local-map' text property at point +3. the `current-local-map' + +This is used to set the default value for the interactive prompt +in `describe-keymap'. See also `Searching the Active Keymaps'." + (help-fns-find-keymap-name (or (get-char-property (point) 'keymap) + (if (get-text-property (point) 'local-map) + (get-char-property (point) 'local-map) + (current-local-map))))) + +;;;###autoload +(defun describe-keymap (keymap) + "Describe key bindings in KEYMAP. +When called interactively, prompt for a variable that has a +keymap value." + (interactive + (let* ((km (help-fns--most-relevant-active-keymap)) + (val (completing-read + (format "Keymap (default %s): " km) + obarray + (lambda (m) (and (boundp m) (keymapp (symbol-value m)))) + t nil 'keymap-name-history + (symbol-name km)))) + (unless (equal val "") + (setq km (intern val))) + (unless (and km (keymapp (symbol-value km))) + (user-error "Not a keymap: %s" km)) + (list km))) + (let (used-gentemp) + (unless (and (symbolp keymap) + (boundp keymap) + (keymapp (symbol-value keymap))) + (when (not (keymapp keymap)) + (if (symbolp keymap) + (error "Not a keymap variable: %S" keymap) + (error "Not a keymap"))) + (let ((sym nil)) + (unless sym + (setq sym (cl-gentemp "KEYMAP OBJECT (no variable) ")) + (setq used-gentemp t) + (set sym keymap)) + (setq keymap sym))) + ;; Follow aliasing. + (setq keymap (or (ignore-errors (indirect-variable keymap)) keymap)) + (help-setup-xref (list #'describe-keymap keymap) + (called-interactively-p 'interactive)) + (let* ((name (symbol-name keymap)) + (doc (documentation-property keymap 'variable-documentation)) + (file-name (find-lisp-object-file-name keymap 'defvar))) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (unless used-gentemp + (princ (format-message "%S is a keymap variable" keymap)) + (if (not file-name) + (princ ".\n\n") + (princ (format-message + " defined in `%s'.\n\n" + (if (eq file-name 'C-source) + "C source code" + (file-name-nondirectory file-name)))) + (save-excursion + (re-search-backward (substitute-command-keys + "`\\([^`']+\\)'") + nil t) + (help-xref-button 1 'help-variable-def + keymap file-name)))) + (when (and (not (equal "" doc)) doc) + (princ "Documentation:\n") + (princ (format-message "%s\n\n" doc))) + ;; Use `insert' instead of `princ', so control chars (e.g. \377) + ;; insert correctly. + (insert (substitute-command-keys (concat "\\{" name "}")))))) + ;; Cleanup. + (when used-gentemp + (makunbound keymap)))) + ;;; Replacements for old lib-src/ programs. Don't seem especially useful. diff --git a/lisp/hexl.el b/lisp/hexl.el index 2535d581db4..58518e74169 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -701,10 +701,7 @@ With prefix arg N, puts point N bytes of the way from the true beginning." (defun hexl-end-of-line () "Goto end of line in Hexl mode." (interactive) - (hexl-goto-address (let ((address (logior (hexl-current-address) 15))) - (if (> address hexl-max-address) - (setq address hexl-max-address)) - address))) + (hexl-goto-address (min hexl-max-address (logior (hexl-current-address) 15)))) (defun hexl-scroll-down (arg) "Scroll hexl buffer window upward ARG lines; or near full window if no ARG." @@ -749,7 +746,7 @@ If there's no byte at the target address, move to the first or last line." "Go to end of 1KB boundary." (interactive) (hexl-goto-address - (max hexl-max-address (logior (hexl-current-address) 1023)))) + (min hexl-max-address (logior (hexl-current-address) 1023)))) (defun hexl-beginning-of-512b-page () "Go to beginning of 512 byte boundary." @@ -760,7 +757,7 @@ If there's no byte at the target address, move to the first or last line." "Go to end of 512 byte boundary." (interactive) (hexl-goto-address - (max hexl-max-address (logior (hexl-current-address) 511)))) + (min hexl-max-address (logior (hexl-current-address) 511)))) (defun hexl-quoted-insert (arg) "Read next input character and insert it. @@ -935,7 +932,7 @@ CH must be a unibyte character whose value is between 0 and 255." (goto-char ascii-position) (delete-char 1) (insert (hexl-printable-character ch)) - (or (eq address hexl-max-address) + (or (= address hexl-max-address) (setq address (1+ address))) (hexl-goto-address address) (if at-ascii-position diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 152c70a64e2..466f6f5ee0e 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -197,7 +197,7 @@ It takes only one argument, the filename." "Regex to remove from the `<style> a' variant of an htmlfontify CSS class." :group 'htmlfontify :tag "src-doc-link-unstyle" - :type '(string)) + :type '(regexp)) (defcustom hfy-link-extn nil "File extension used for href links. diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 851b25f9ec0..c9a748830c1 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -339,6 +339,8 @@ directory, like `default-directory'." (defcustom ibuffer-load-hook nil "Hook run when Ibuffer is loaded." :type 'hook) +(make-obsolete-variable 'ibuffer-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom ibuffer-marked-face 'warning "Face used for displaying marked buffers." diff --git a/lisp/info-look.el b/lisp/info-look.el index fb3237efbb1..4e379cadef1 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -75,7 +75,7 @@ List elements are cons cells of the form If a file name matches REGEXP, then use help mode MODE instead of the buffer's major mode." - :group 'info-lookup :type '(repeat (cons (string :tag "Regexp") + :group 'info-lookup :type '(repeat (cons (regexp :tag "Regexp") (symbol :tag "Mode")))) (defvar info-lookup-history nil diff --git a/lisp/info.el b/lisp/info.el index 7a11bb3ff9d..3015e60a4f9 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -3780,20 +3780,8 @@ Build a menu of the possible matches." ;; there is no "nxml.el" (it's nxml-mode.el). ;; But package.el makes the same assumption. ;; I think nxml is the only exception - maybe it should be just be renamed. - (let ((str (ignore-errors (lm-commentary (find-library-name nodename))))) - (if (null str) - (insert "Can’t find package description.\n\n") - (insert - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (delete-blank-lines) - (goto-char (point-max)) - (delete-blank-lines) - (goto-char (point-min)) - (while (re-search-forward "^;+ ?" nil t) - (replace-match "" nil nil)) - (buffer-string)))))))) + (insert (or (ignore-errors (lm-commentary (find-library-name nodename))) + (insert "Can’t find package description.\n\n")))))) ;;;###autoload (defun info-finder (&optional keywords) @@ -5135,9 +5123,8 @@ first line or header line, and for breadcrumb links.") "Additional menu-items to add to speedbar frame.") ;; Make sure our special speedbar major mode is loaded -(if (featurep 'speedbar) - (Info-install-speedbar-variables) - (add-hook 'speedbar-load-hook 'Info-install-speedbar-variables)) +(with-eval-after-load 'speedbar + (Info-install-speedbar-variables)) ;;; Info hierarchy display method ;;;###autoload diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index c86b1da0ae7..5436aaa4fa0 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -283,8 +283,42 @@ wrong, use this command again to toggle back to the right mode." (interactive) (view-file (expand-file-name "HELLO" data-directory))) +(defvar mule-cmds--prefixed-command-next-coding-system nil) +(defvar mule-cmds--prefixed-command-last-coding-system nil) + +(defun mule-cmds--prefixed-command-pch () + (if (not mule-cmds--prefixed-command-next-coding-system) + (progn + (remove-hook 'pre-command-hook #'mule-cmds--prefixed-command-pch) + (remove-hook 'prefix-command-echo-keystrokes-functions + #'mule-cmds--prefixed-command-echo) + (remove-hook 'prefix-command-preserve-state-hook + #'mule-cmds--prefixed-command-preserve)) + (setq this-command + (let ((cmd this-command) + (coding-system mule-cmds--prefixed-command-next-coding-system)) + (lambda () + (interactive) + (setq this-command cmd) + (let ((coding-system-for-read coding-system) + (coding-system-for-write coding-system) + (coding-system-require-warning t)) + (call-interactively cmd))))) + (setq mule-cmds--prefixed-command-last-coding-system + mule-cmds--prefixed-command-next-coding-system) + (setq mule-cmds--prefixed-command-next-coding-system nil))) + +(defun mule-cmds--prefixed-command-echo () + (when mule-cmds--prefixed-command-next-coding-system + (format "With coding-system %S" + mule-cmds--prefixed-command-next-coding-system))) + +(defun mule-cmds--prefixed-command-preserve () + (setq mule-cmds--prefixed-command-next-coding-system + mule-cmds--prefixed-command-last-coding-system)) + (defun universal-coding-system-argument (coding-system) - "Execute an I/O command using the specified coding system." + "Execute an I/O command using the specified CODING-SYSTEM." (interactive (let ((default (and buffer-file-coding-system (not (eq (coding-system-type buffer-file-coding-system) @@ -295,41 +329,13 @@ wrong, use this command again to toggle back to the right mode." (format "Coding system for following command (default %s): " default) "Coding system for following command: ") default)))) - ;; FIXME: This "read-key-sequence + call-interactively" loop is trying to - ;; reproduce the normal command loop, but this "can't" be done faithfully so - ;; it necessarily suffers from breakage in corner cases (e.g. it fails to run - ;; pre/post-command-hook, doesn't properly set this-command/last-command, it - ;; doesn't handle keyboard macros, ...). - (let* ((keyseq (read-key-sequence - (format "Command to execute with %s:" coding-system))) - (cmd (key-binding keyseq))) - ;; read-key-sequence ignores quit, so make an explicit check. - (if (equal last-input-event (nth 3 (current-input-mode))) - (keyboard-quit)) - (when (memq cmd '(universal-argument digit-argument)) - (call-interactively cmd) - - ;; Process keys bound in `universal-argument-map'. - (while (progn - (setq keyseq (read-key-sequence nil t) - cmd (key-binding keyseq t)) - (memq cmd '(negative-argument digit-argument - universal-argument-more))) - (setq current-prefix-arg prefix-arg prefix-arg nil) - ;; Have to bind `last-command-event' here so that - ;; `digit-argument', for instance, can compute the - ;; `prefix-arg'. - (setq last-command-event (aref keyseq 0)) - (call-interactively cmd))) - - (let ((coding-system-for-read coding-system) - (coding-system-for-write coding-system) - (coding-system-require-warning t)) - (setq current-prefix-arg prefix-arg prefix-arg nil) - ;; Have to bind `last-command-event' e.g. for `self-insert-command'. - (setq last-command-event (aref keyseq 0)) - (message "") - (call-interactively cmd)))) + (prefix-command-preserve-state) + (setq mule-cmds--prefixed-command-next-coding-system coding-system) + (add-hook 'pre-command-hook #'mule-cmds--prefixed-command-pch) + (add-hook 'prefix-command-echo-keystrokes-functions + #'mule-cmds--prefixed-command-echo) + (add-hook 'prefix-command-preserve-state-hook + #'mule-cmds--prefixed-command-preserve)) (defun set-default-coding-systems (coding-system) "Set default value of various coding systems to CODING-SYSTEM. @@ -700,8 +706,8 @@ DEFAULT is the coding system to use by default in the query." ;; buffer is displayed. (when (and unsafe (not (stringp from))) (pop-to-buffer bufname) - (goto-char (apply 'min (mapcar #'(lambda (x) (car (cadr x))) - unsafe)))) + (goto-char (apply #'min (mapcar (lambda (x) (or (car (cadr x)) (point-max))) + unsafe)))) ;; Then ask users to select one from CODINGS while showing ;; the reason why none of the defaults are not used. (with-output-to-temp-buffer "*Warning*" @@ -1402,13 +1408,13 @@ The commands `describe-input-method' and `list-input-methods' need these duplicated values to show some information about input methods without loading the relevant Quail packages. \n(fn INPUT-METHOD LANG-ENV ACTIVATE-FUNC TITLE DESCRIPTION &rest ARGS)" - (if (symbolp lang-env) - (setq lang-env (symbol-name lang-env)) - (setq lang-env (purecopy lang-env))) - (if (symbolp input-method) - (setq input-method (symbol-name input-method)) - (setq input-method (purecopy input-method))) - (setq args (mapcar 'purecopy args)) + (setq lang-env (if (symbolp lang-env) + (symbol-name lang-env) + (purecopy lang-env))) + (setq input-method (if (symbolp input-method) + (symbol-name input-method) + (purecopy input-method))) + (setq args (mapcar #'purecopy args)) (let ((info (cons lang-env args)) (slot (assoc input-method input-method-alist))) (if slot diff --git a/lisp/international/rfc1843.el b/lisp/international/rfc1843.el index 7f09eb41d17..c59538f5469 100644 --- a/lisp/international/rfc1843.el +++ b/lisp/international/rfc1843.el @@ -60,7 +60,7 @@ e-mail transmission, news posting, etc." (defcustom rfc1843-newsgroups-regexp "chinese\\|hz" "Regexp of newsgroups in which might be HZ encoded." - :type 'string + :type 'regexp :group 'mime) (defun rfc1843-decode-region (from to) diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el index 2a80d75fe7e..eec20ee3294 100644 --- a/lisp/international/titdic-cnv.el +++ b/lisp/international/titdic-cnv.el @@ -1,4 +1,4 @@ -;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding: utf-8-emacs; lexical-binding:t -*- +;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding:iso-2022-7bit; lexical-binding:t -*- ;; Copyright (C) 1997-1998, 2000-2020 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -83,9 +83,9 @@ ;; how to select a translation from a list of candidates. (defvar quail-cxterm-package-ext-info - '(("chinese-4corner" "四角") - ("chinese-array30" "３０") - ("chinese-ccdospy" "缩拼" + '(("chinese-4corner" "$(0(?-F(B") + ("chinese-array30" "$(0#R#O(B") + ("chinese-ccdospy" "$AKuF4(B" "Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). Pinyin is the standard Roman transliteration method for Chinese. @@ -94,10 +94,10 @@ method `chinese-py'. This input method works almost the same way as `chinese-py'. The difference is that you type a single key for these Pinyin spelling. - Pinyin: zh en eng ang ch an ao ai ong sh ing yu(ü) + Pinyin: zh en eng ang ch an ao ai ong sh ing yu($A(9(B) keyseq: a f g h i j k l s u y v For example: - Chinese: 啊 果 中 文 光 玉 全 + Chinese: $A0!(B $A9{(B $AVP(B $AND(B $A9b(B $ASq(B $AH+(B Pinyin: a guo zhong wen guang yu quan Keyseq: a1 guo4 as1 wf4 guh1 yu..6 qvj6 @@ -106,14 +106,14 @@ For example: For double-width GB2312 characters corresponding to ASCII, use the input method `chinese-qj'.") - ("chinese-ecdict" "英漢" + ("chinese-ecdict" "$(05CKH(B" "In this input method, you enter a Chinese (Big5) character or word by typing the corresponding English word. For example, if you type -\"computer\", \"電腦\" is input. +\"computer\", \"$(0IZH+(B\" is input. \\<quail-translation-docstring>") - ("chinese-etzy" "倚注" + ("chinese-etzy" "$(06/0D(B" "Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1', `chinese-big5-2'). @@ -122,20 +122,20 @@ compose one Chinese character. In this input method, you enter a Chinese character by first typing keys corresponding to Zhuyin symbols (see the above table) followed by -SPC, 1, 2, 3, or 4 specifying a tone (SPC:陰平, 1:輕聲, 2:陽平, 3: 上聲, -4:去聲). +SPC, 1, 2, 3, or 4 specifying a tone (SPC:$(0?v(N(B, 1:$(0M=Vy(B, 2:$(0Dm(N(B, 3: $(0&9Vy(B, +4:$(0(+Vy(B). \\<quail-translation-docstring>") - ("chinese-punct-b5" "標B" + ("chinese-punct-b5" "$(0O:(BB" "Input method for Chinese punctuation and symbols of Big5 \(`chinese-big5-1' and `chinese-big5-2').") - ("chinese-punct" "标G" + ("chinese-punct" "$A1j(BG" "Input method for Chinese punctuation and symbols of GB2312 \(`chinese-gb2312').") - ("chinese-py-b5" "拼B" + ("chinese-py-b5" "$(03<(BB" "Pinyin base input method for Chinese Big5 characters \(`chinese-big5-1', `chinese-big5-2'). @@ -153,28 +153,28 @@ method `chinese-qj-b5'. The input method `chinese-py' and `chinese-tonepy' are also Pinyin based, but for the character set GB2312 (`chinese-gb2312').") - ("chinese-qj-b5" "全B") + ("chinese-qj-b5" "$(0)A(BB") - ("chinese-qj" "全G") + ("chinese-qj" "$AH+(BG") - ("chinese-sw" "首尾" + ("chinese-sw" "$AJWN2(B" "Radical base input method for Chinese charset GB2312 (`chinese-gb2312'). In this input method, you enter a Chinese character by typing two -keys. The first key corresponds to the first (首) radical, the second -key corresponds to the last (尾) radical. The correspondence of keys +keys. The first key corresponds to the first ($AJW(B) radical, the second +key corresponds to the last ($AN2(B) radical. The correspondence of keys and radicals is as below: first radical: a b c d e f g h i j k l m n o p q r s t u v w x y z - 心 冖 尸 丶 火 口 扌 氵 讠 艹 亻 木 礻 饣 月 纟 石 王 八 丿 日 辶 犭 竹 一 人 + $APD(B $AZ"(B $AJ,(B $AX<(B $A;p(B $A?Z(B $A^P(B $Ac_(B $AZ%(B $A\3(B $AXi(B $AD>(B $Alj(B $Ab;(B $ATB(B $Afy(B $AJ/(B $AMu(B $A0K(B $AX/(B $AHU(B $AeA(B $Aak(B $AVq(B $AR;(B $AHK(B last radical: a b c d e f g h i j k l m n o p q r s t u v w x y z - 又 山 土 刀 阝 口 衣 疋 大 丁 厶 灬 十 歹 冂 门 今 丨 女 乙 囗 小 厂 虫 弋 卜 + $ASV(B $AI=(B $AMA(B $A56(B $AZb(B $A?Z(B $ARB(B $Aqb(B $A4s(B $A6!(B $A[L(B $Ala(B $AJ.(B $A4u(B $AXg(B $ACE(B $A=q(B $AX-(B $AE.(B $ARR(B $A`m(B $AP!(B $A3'(B $A3f(B $A_.(B $A27(B \\<quail-translation-docstring>") - ("chinese-tonepy" "调拼" + ("chinese-tonepy" "$A5wF4(B" "Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). Pinyin is the standard roman transliteration method for Chinese. @@ -183,18 +183,18 @@ method `chinese-py'. This input method works almost the same way as `chinese-py'. The difference is that you must type 1..5 after each Pinyin spelling to -specify a tone (1:阴平, 2:阳平, 3:上声, 4下声, 5:轻声). +specify a tone (1:$ARuF=(B, 2:$AQtF=(B, 3:$AIOIy(B, 4$AOBIy(B, 5:$AGaIy(B). \\<quail-translation-docstring> -For instance, to input 你, you type \"n i 3 3\", the first \"n i\" is +For instance, to input $ADc(B, you type \"n i 3 3\", the first \"n i\" is a Pinyin, the next \"3\" specifies tone, and the last \"3\" selects the third character from the candidate list. For double-width GB2312 characters corresponding to ASCII, use the input method `chinese-qj'.") - ("chinese-zozy" "零注" + ("chinese-zozy" "$(0I\0D(B" "Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1', `chinese-big5-2'). @@ -203,8 +203,8 @@ compose a Chinese character. In this input method, you enter a Chinese character by first typing keys corresponding to Zhuyin symbols (see the above table) followed by -SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, -7:輕聲). +SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy(B, 4:$(0(+Vy(B, +7:$(0M=Vy(B). \\<quail-translation-docstring>"))) @@ -354,7 +354,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, (princ (nth 2 (assoc tit-encode tit-encode-list))) (princ "\" \"") (princ (or title - (if (string-match "[:∷：【]+\\([^:∷：】]+\\)" tit-prompt) + (if (string-match "[:$A!K$(0!(!J(B]+\\([^:$A!K$(0!(!K(B]+\\)" tit-prompt) (substring tit-prompt (match-beginning 1) (match-end 1)) tit-prompt))) (princ "\"\n")) @@ -580,7 +580,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; ) (defvar quail-misc-package-ext-info - '(("chinese-b5-tsangchi" "倉B" + '(("chinese-b5-tsangchi" "$(06A(BB" "cangjie-table.b5" big5 "tsang-b5.el" tsang-b5-converter "\ @@ -590,7 +590,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-b5-quick" "簡B" + ("chinese-b5-quick" "$(0X|(BB" "cangjie-table.b5" big5 "quick-b5.el" quick-b5-converter "\ @@ -600,7 +600,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-cns-tsangchi" "倉C" + ("chinese-cns-tsangchi" "$(GT?(BC" "cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el" tsang-cns-converter "\ @@ -610,7 +610,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-cns-quick" "簡C" + ("chinese-cns-quick" "$(Gv|(BC" "cangjie-table.cns" iso-2022-cn-ext "quick-cns.el" quick-cns-converter "\ @@ -620,7 +620,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-py" "拼G" + ("chinese-py" "$AF4(BG" "pinyin.map" cn-gb-2312 "PY.el" py-converter "\ @@ -648,7 +648,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; You should have received a copy of the GNU General Public License along with ;; CCE. If not, see <https://www.gnu.org/licenses/>.") - ("chinese-ziranma" "自然" + ("chinese-ziranma" "$AWTH;(B" "ziranma.cin" cn-gb-2312 "ZIRANMA.el" ziranma-converter "\ @@ -676,7 +676,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; You should have received a copy of the GNU General Public License along with ;; CCE. If not, see <https://www.gnu.org/licenses/>.") - ("chinese-ctlau" "刘粤" + ("chinese-ctlau" "$AAuTA(B" "CTLau.html" cn-gb-2312 "CTLau.el" ctlau-gb-converter "\ @@ -701,7 +701,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # You should have received a copy of the GNU General Public License ;; # along with this program. If not, see <https://www.gnu.org/licenses/>.") - ("chinese-ctlaub" "劉粵" + ("chinese-ctlaub" "$(0N,Gn(B" "CTLau-b5.html" big5 "CTLau-b5.el" ctlau-b5-converter "\ @@ -731,38 +731,38 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; dictionary in the buffer DICBUF. The input method name of the ;; Quail package is NAME, and the title string is TITLE. -;; TSANG-P is non-nil, generate 倉頡 input method. Otherwise -;; generate 簡易 (simple version of 倉頡). If BIG5-P is non-nil, the +;; TSANG-P is non-nil, generate $(06AQo(B input method. Otherwise +;; generate $(0X|/y(B (simple version of $(06AQo(B). If BIG5-P is non-nil, the ;; input method is for inputting Big5 characters. Otherwise the input ;; method is for inputting CNS characters. (defun tsang-quick-converter (dicbuf tsang-p big5-p) - (let ((fulltitle (if tsang-p (if big5-p "倉頡" "倉頡") - (if big5-p "簡易" "簡易"))) + (let ((fulltitle (if tsang-p (if big5-p "$(06AQo(B" "$(GT?on(B") + (if big5-p "$(0X|/y(B" "$(Gv|Mx(B"))) dic) (goto-char (point-max)) (if big5-p - (insert (format "\"中文輸入【%s】BIG5 + (insert (format "\"$(0&d'GTT&,!J(B%s$(0!K(BBIG5 - 漢語%s輸入鍵盤 + $(0KHM$(B%s$(0TT&,WoOu(B - [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心] + [Q $(0'D(B] [W $(0(q(B] [E $(0'V(B] [R $(0&H(B] [T $(0'>(B] [Y $(0&4(B] [U $(0&U(B] [I $(0'B(B] [O $(0&*(B] [P $(0'A(B] - [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中] + [A $(0'K(B] [S $(0&T(B] [D $(0'N(B] [F $(0'W(B] [G $(0&I(B] [H $(0*M(B] [J $(0&3(B] [L $(0&d(B] - [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] + [Z ] [X $(0[E(B] [C $(01[(B] [V $(0&M(B] [B $(0'M(B] [N $(0&_(B] [M $(0&"(B] \\\\<quail-translation-docstring>\"\n" fulltitle fulltitle)) - (insert (format "\"中文輸入【%s】CNS + (insert (format "\"$(GDcEFrSD+!J(B%s$(G!K(BCNS - 漢語%s輸入鍵盤 + $(GiGk#(B%s$(GrSD+uomu(B - [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心] + [Q $(GEC(B] [W $(GFp(B] [E $(GEU(B] [R $(GDG(B] [T $(GE=(B] [Y $(GD3(B] [U $(GDT(B] [I $(GEA(B] [O $(GD)(B] [P $(GE@(B] - [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中] + [A $(GEJ(B] [S $(GDS(B] [D $(GEM(B] [F $(GEV(B] [G $(GDH(B] [H $(GHL(B] [J $(GD2(B] [L $(GDc(B] - [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] + [Z ] [X $(GyE(B] [C $(GOZ(B] [V $(GDL(B] [B $(GEL(B] [N $(GD^(B] [M $(GD!(B] \\\\<quail-translation-docstring>\"\n" fulltitle fulltitle))) @@ -798,35 +798,35 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (setq dic (sort dic (function (lambda (x y) (string< (car x ) (car y)))))) (dolist (elt dic) (insert (format "(%S\t%S)\n" (car elt) (cdr elt)))) - (let ((punctuation '((";" "；﹔，、﹐﹑" "；﹔，、﹐﹑") - (":" "：︰﹕．。‧﹒·" "：︰﹕．。・﹒·") - ("'" "’‘" "’‘") - ("\"" "”“〝〞〃" "”“〝〞〃") - ("\\" "＼﹨╲" "＼﹨╲") - ("|" "｜︱︳∣" "︱︲｜") - ("/" "／∕╱" "／∕╱") - ("?" "？﹖" "？﹖") - ("<" "〈＜﹤︿∠" "〈＜﹤︿∠") - (">" "〉＞﹥﹀" "〉＞﹦﹀") - ("[" "〔【﹝︹︻「『﹁﹃" "〔【﹝︹︻「『﹁﹃") - ("]" "〕】﹞︺︼」』﹂﹄" "〕】﹞︺︼」』﹂﹄") - ("{" "｛﹛︷ " "｛﹛︷ ") - ("}" "｝﹜︸" "｝﹜︸") - ("`" "‵′" "′‵") - ("~" "～﹋﹌︴﹏" "∼﹋﹌") - ("!" "！﹗" "！﹗") - ("@" "＠﹫" "＠﹫") - ("#" "＃﹟" "＃﹟") - ("$" "＄﹩" "＄﹩") - ("%" "％﹪" "％﹪") - ("&" "＆﹠" "＆﹠") - ("*" "＊﹡※☆★" "＊﹡※☆★") - ("(" "（﹙︵" "（﹙︵") - (")" "）﹚︶" "）﹚︶") - ("-" "–—¯￣－﹣" "—–‾－﹣") - ("_" "＿ˍ" "＿") - ("=" "＝﹦" "＝﹥") - ("+" "＋﹢" "＋﹢")))) + (let ((punctuation '((";" "$(0!'!2!"!#!.!/(B" "$(G!'!2!"!#!.!/(B") + (":" "$(0!(!+!3!%!$!&!0!1(B" "$(G!(!+!3!%!$!&!0!1(B") + ("'" "$(0!e!d(B" "$(G!e!d(B") + ("\"" "$(0!g!f!h!i!q(B" "$(G!g!f!h!i!q(B") + ("\\" "$(0"`"b#M(B" "$(G"`"b#M(B") + ("|" "$(0!6!8!:"^(B" "$(G!6!8!:"^(B") + ("/" "$(0"_"a#L(B" "$(G"_"a#L(B") + ("?" "$(0!)!4(B" "$(G!)!4(B") + ("<" "$(0!R"6"A!T"H(B" "$(G!R"6"A!T"H(B") + (">" "$(0!S"7"B!U(B" "$(G!S"7"B!U(B") + ("[" "$(0!F!J!b!H!L!V!Z!X!\(B" "$(G!F!J!b!H!L!V!Z!X!\(B") + ("]" "$(0!G!K!c!I!M!W![!Y!](B" "$(G!G!K!c!I!M!W![!Y!](B") + ("{" "$(0!B!`!D(B " "$(G!B!`!D(B ") + ("}" "$(0!C!a!E(B" "$(G!C!a!E(B") + ("`" "$(0!j!k(B" "$(G!j!k(B") + ("~" "$(0"D"+",!<!=(B" "$(G"D"+",!<!=(B") + ("!" "$(0!*!5(B" "$(G!*!5(B") + ("@" "$(0"i"n(B" "$(G"i"n(B") + ("#" "$(0!l"-(B" "$(G!l"-(B") + ("$" "$(0"c"l(B" "$(G"c"l(B") + ("%" "$(0"h"m(B" "$(G"h"m(B") + ("&" "$(0!m".(B" "$(G!m".(B") + ("*" "$(0!n"/!o!w!x(B" "$(G!n"/!o!w!x(B") + ("(" "$(0!>!^!@(B" "$(G!>!^!@(B") + (")" "$(0!?!_!A(B" "$(G!?!_!A(B") + ("-" "$(0!7!9"#"$"1"@(B" "$(G!7!9"#"$"1"@(B") + ("_" "$(0"%"&(B" "$(G"%"&(B") + ("=" "$(0"8"C(B" "$(G"8"C(B") + ("+" "$(0"0"?(B" "$(G"0"?(B")))) (dolist (elt punctuation) (insert (format "(%S %S)\n" (concat "z" (car elt)) (if big5-p (nth 1 elt) (nth 2 elt)))))) @@ -850,11 +850,11 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (defun py-converter (dicbuf) (goto-char (point-max)) - (insert (format "%S\n" "汉字输入∷拼音∷ + (insert (format "%S\n" "$A::WVJdHk!KF4Rt!K(B - 拼音方案 + $AF4Rt7=08(B - 小写英文字母代表「拼音」符号， \"u(yu) 则用 u: 表示∶ + $AP!P4S"NDWVD84z1m!8F4Rt!97{:E#,(B \"u(yu) $ATrSC(B u: $A1mJ>!C(B Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). @@ -868,14 +868,14 @@ character. The sequence is made by the combination of the initials iang ing iong u ua uo uai ui uan un uan ueng yu yue yuan yun (Note: In the correct Pinyin writing, the sequence \"yu\" in the last - four finals should be written by the character u-umlaut `ü'.) + four finals should be written by the character u-umlaut `$A(9(B'.) With this input method, you enter a Chinese character by first entering its pinyin spelling. \\<quail-translation-docstring> -For instance, to input 你, you type \"n i C-n 3\". The first \"n i\" +For instance, to input $ADc(B, you type \"n i C-n 3\". The first \"n i\" is a Pinyin, \"C-n\" selects the next group of candidates (each group contains at most 10 characters), \"3\" select the third character in that group. @@ -958,22 +958,22 @@ method `chinese-tonepy' with which you must specify tones by digits table))) (setq dic (sort dic (function (lambda (x y) (string< (car x) (car y)))))) (goto-char (point-max)) - (insert (format "%S\n" "汉字输入∷【自然】∷ - - 键盘对照表: - ┏━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┓ - ┃Ｑ ┃Ｗ ┃Ｅ ┃Ｒ ┃Ｔ ┃Ｙ ┃Ｕsh┃Ｉch┃Ｏ ┃Ｐ ┃ - ┃ iu┃ ua┃ e┃ uan┃ ue┃ uai┃ u┃ i┃ o┃ un┃ - ┃ ┃ ia┃ ┃ van┃ ve┃ ing┃ ┃ ┃ uo┃ vn┃ - ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┛ - ┃Ａ ┃Ｓ ┃Ｄ ┃Ｆ ┃Ｇ ┃Ｈ ┃Ｊ ┃Ｋ ┃Ｌ ┃ - ┃ a┃iong┃uang┃ en┃ eng┃ ang┃ an┃ ao┃ ai┃ - ┃ ┃ ong┃iang┃ ┃ ng┃ ┃ ┃ ┃ ┃ - ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━━┓ - ┃Ｚ ┃Ｘ ┃Ｃ ┃Ｖzh┃Ｂ ┃Ｎ ┃Ｍ ┃， ┃． ┃ ／ ┃ - ┃ ei┃ ie┃ iao┃ ui┃ ou┃ in┃ ian┃前页┃后页┃符号┃ - ┃ ┃ ┃ ┃ v┃ ┃ ┃ ┃ ┃ ┃ ┃ - ┗━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┛ + (insert (format "%S\n" "$A::WVJdHk!K!>WTH;!?!K(B + + $A<|EL6TUU1m(B: + $A)3)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)7(B + $A)'#Q(B $A)'#W(B $A)'#E(B $A)'#R(B $A)'#T(B $A)'#Y(B $A)'#U(Bsh$A)'#I(Bch$A)'#O(B $A)'#P(B $A)'(B + $A)'(B iu$A)'(B ua$A)'(B e$A)'(B uan$A)'(B ue$A)'(B uai$A)'(B u$A)'(B i$A)'(B o$A)'(B un$A)'(B + $A)'(B $A)'(B ia$A)'(B $A)'(B van$A)'(B ve$A)'(B ing$A)'(B $A)'(B $A)'(B uo$A)'(B vn$A)'(B + $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)?(B + $A)'#A(B $A)'#S(B $A)'#D(B $A)'#F(B $A)'#G(B $A)'#H(B $A)'#J(B $A)'#K(B $A)'#L(B $A)'(B + $A)'(B a$A)'(Biong$A)'(Buang$A)'(B en$A)'(B eng$A)'(B ang$A)'(B an$A)'(B ao$A)'(B ai$A)'(B + $A)'(B $A)'(B ong$A)'(Biang$A)'(B $A)'(B ng$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B + $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)%)7(B + $A)'#Z(B $A)'#X(B $A)'#C(B $A)'#V(Bzh$A)'#B(B $A)'#N(B $A)'#M(B $A)'#,(B $A)'#.(B $A)'(B $A#/(B $A)'(B + $A)'(B ei$A)'(B ie$A)'(B iao$A)'(B ui$A)'(B ou$A)'(B in$A)'(B ian$A)'G0R3)':sR3)'7{:E)'(B + $A)'(B $A)'(B $A)'(B $A)'(B v$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B + $A);)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)?(B Pinyin base input method for Chinese GB2312 characters (`chinese-gb2312'). @@ -985,34 +985,34 @@ method `chinese-py'. Unlike the standard spelling of Pinyin, in this input method all initials and finals are assigned to single keys (see the above table). For instance, the initial \"ch\" is assigned to the key `i', the final -\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and 轻声 are +\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and $AGaIy(B are assigned to the keys `q', `w', `e', `r', `t' respectively. \\<quail-translation-docstring> To input one-letter words, you type 4 keys, the first two for the Pinyin of the letter, next one for tone, and the last one is always a -quote ('). For instance, \"vsq'\" input 中. Exceptions are these +quote ('). For instance, \"vsq'\" input $AVP(B. Exceptions are these letters. You can input them just by typing a single key. - Character: 按 不 次 的 二 发 个 和 出 及 可 了 没 + Character: $A04(B $A2;(B $A4N(B $A5D(B $A6~(B $A7"(B $A8v(B $A:M(B $A3v(B $A<0(B $A?I(B $AAK(B $AC;(B Key: a b c d e f g h i j k l m - Character: 你 欧 片 七 人 三 他 是 着 我 小 一 在 + Character: $ADc(B $AE7(B $AF,(B $AF_(B $AHK(B $AH}(B $AK{(B $AJG(B $AWE(B $ANR(B $AP!(B $AR;(B $ATZ(B Key: n o p q r s t u v w x y z To input two-letter words, you have two ways. One way is to type 4 keys, two for the first Pinyin, two for the second Pinyin. For -instance, \"vsgo\" inputs 中国. Another way is to type 3 keys: 2 +instance, \"vsgo\" inputs $AVP9z(B. Another way is to type 3 keys: 2 initials of two letters, and quote ('). For instance, \"vg'\" also -inputs 中国. +inputs $AVP9z(B. To input three-letter words, you type 4 keys: initials of three -letters, and the last is quote ('). For instance, \"bjy'2\" inputs 北 -京鸭 (the last `2' is to select one of the candidates). +letters, and the last is quote ('). For instance, \"bjy'2\" inputs $A11(B +$A>)Q<(B (the last `2' is to select one of the candidates). To input words of more than three letters, you type 4 keys, initials of the first three letters and the last letter. For instance, -\"bjdt\" inputs 北京电视台. +\"bjdt\" inputs $A11>)5gJSL((B. To input symbols and punctuation, type `/' followed by one of `a' to `z', then select one of the candidates.")) @@ -1059,7 +1059,7 @@ To input symbols and punctuation, type `/' followed by one of `a' to ;; which the file is converted have no Big5 equivalent. Go ;; through and delete them. (goto-char pos) - (while (search-forward "□" nil t) + (while (search-forward "$(0!{(B" nil t) (delete-char -1)) ;; Uppercase keys in dictionary need to be downcased. Backslashes ;; at the beginning of keys need to be turned into double @@ -1083,31 +1083,31 @@ To input symbols and punctuation, type `/' followed by one of `a' to (defun ctlau-gb-converter (dicbuf) (ctlau-converter dicbuf -"汉字输入∷刘锡祥式粤音∷ +"$A::WVJdHk!KAuN}OiJ=TARt!K(B - 刘锡祥式粤语注音方案 + $AAuN}OiJ=TASoW"Rt7=08(B Sidney Lau's Cantonese transcription scheme as described in his book \"Elementary Cantonese\", The Government Printer, Hong Kong, 1972. - This file was prepared by Fung Fung Lee (李枫峰). + This file was prepared by Fung Fung Lee ($A@n7c7e(B). Originally converted from CTCPS3.tit Last modified: June 2, 1993. Some infrequent GB characters are accessed by typing \\, followed by - the Cantonese romanization of the respective radical (部首).")) + the Cantonese romanization of the respective radical ($A2?JW(B).")) (defun ctlau-b5-converter (dicbuf) (ctlau-converter dicbuf -"漢字輸入：劉錫祥式粵音： +"$(0KH)tTT&,!(N,Tg>A*#Gn5x!((B - 劉錫祥式粵語注音方案 + $(0N,Tg>A*#GnM$0D5x'J7{(B Sidney Lau's Cantonese transcription scheme as described in his book \"Elementary Cantonese\", The Government Printer, Hong Kong, 1972. - This file was prepared by Fung Fung Lee (李楓峰). + This file was prepared by Fung Fung Lee ($(0,XFS76(B). Originally converted from CTCPS3.tit Last modified: June 2, 1993. Some infrequent characters are accessed by typing \\, followed by - the Cantonese romanization of the respective radical (部首).")) + the Cantonese romanization of the respective radical ($(0?f5}(B).")) (declare-function dos-8+3-filename "dos-fns.el" (filename)) diff --git a/lisp/json.el b/lisp/json.el index 18d7fda8822..055f3f5be11 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -227,6 +227,7 @@ Unlike `reverse', this keeps the property-value pairs intact." (define-error 'json-string-format "Bad string format" 'json-error) (define-error 'json-key-format "Bad JSON object key" 'json-error) (define-error 'json-object-format "Bad JSON object" 'json-error) +(define-error 'json-array-format "Bad JSON array" 'json-error) (define-error 'json-end-of-file "End of file while parsing JSON" '(end-of-file json-error)) @@ -640,7 +641,7 @@ become JSON objects." (when (/= (json-peek) ?\]) (if (= (json-peek) ?,) (json-advance) - (signal 'json-error (list 'bleah))))) + (signal 'json-array-format (list ?, (json-peek)))))) ;; Skip over the "]" (json-advance) (pcase json-array-type diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 240e02e72f9..2246e5f6eaf 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -7626,7 +7626,6 @@ Hooks (use \\[describe-variable] to see their documentation): `dired-before-readin-hook' `dired-after-readin-hook' `dired-mode-hook' - `dired-load-hook' Keybindings: \\{dired-mode-map} @@ -8965,7 +8964,7 @@ an EDE controlled project. ;;;;;; "cedet/ede/cpp-root.el" (0 0 0 0)) ;;; Generated autoloads from cedet/ede/cpp-root.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/cpp-root" '("ede-c"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/cpp-root" '("ede-cpp-root-"))) ;;;*** @@ -17138,7 +17137,6 @@ The main features of this mode are 8. Hooks ----- - Loading idlwave.el runs `idlwave-load-hook'. Turning on `idlwave-mode' runs `idlwave-mode-hook'. 9. Documentation and Customization @@ -19811,7 +19809,7 @@ This function is suitable for execution in an init file. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "lunar-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "eclipse-check" "lunar-"))) ;;;*** @@ -24718,8 +24716,9 @@ matching parenthesis is highlighted in `show-paren-style' after (autoload 'parse-time-string "parse-time" "\ Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). -STRING should be something resembling an RFC 822 (or later) date-time, e.g., -\"Fri, 25 Mar 2016 16:24:56 +0100\", but this function is +STRING should be an ISO 8601 time string, e.g., \"2020-01-15T16:12:21-08:00\", +or something resembling an RFC 822 (or later) date-time, e.g., +\"Wed, 15 Jan 2020 16:12:21 -0800\". This function is somewhat liberal in what format it accepts, and will attempt to return a \"likely\" value even for somewhat malformed strings. The values returned are identical to those of `decode-time', but @@ -28651,6 +28650,14 @@ For more details, see Info node `(elisp) Extending Rx'. ;;;*** +;;;### (autoloads nil "sasl-scram-sha256" "net/sasl-scram-sha256.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from net/sasl-scram-sha256.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sasl-scram-sha256" '("sasl-scram-sha"))) + +;;;*** + ;;;### (autoloads nil "savehist" "savehist.el" (0 0 0 0)) ;;; Generated autoloads from savehist.el (push (purecopy '(savehist 24)) package--builtin-versions) @@ -28752,13 +28759,6 @@ file: ;;;*** -;;;### (autoloads nil "sb-image" "sb-image.el" (0 0 0 0)) -;;; Generated autoloads from sb-image.el - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sb-image" '("defimage-speedbar" "speedbar-"))) - -;;;*** - ;;;### (autoloads nil "scheme" "progmodes/scheme.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/scheme.el @@ -34466,7 +34466,7 @@ the output buffer or changing the window configuration. ;;;### (autoloads nil "tramp" "net/tramp.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp.el -(push (purecopy '(tramp 2 4 3)) package--builtin-versions) +(push (purecopy '(tramp 2 5 0 -1)) package--builtin-versions) (defvar tramp-mode t "\ Whether Tramp is enabled. @@ -34496,18 +34496,15 @@ match file names at root of the underlying local file system, like \"/sys\" or \"/C:\".") (defun tramp-autoload-file-name-handler (operation &rest args) "\ -Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (if tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage))) (apply operation args)) +Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (when tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage))) (apply operation args)) (defun tramp-register-autoload-file-name-handlers nil "\ -Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) (put 'tramp-autoload-file-name-handler 'safe-magic t)) +Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t)) (tramp-register-autoload-file-name-handlers) (defun tramp-unload-file-name-handlers nil "\ Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh file-name-handler-alist) (when (and (symbolp (cdr fnh)) (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) (setq file-name-handler-alist (delq fnh file-name-handler-alist))))) -(defvar tramp-completion-mode nil "\ -If non-nil, external packages signal that they are in file name completion.") - (defun tramp-unload-tramp nil "\ Discard Tramp from loading remote files." (interactive) (ignore-errors (unload-feature 'tramp 'force))) @@ -34543,7 +34540,7 @@ Regular expression matching archive file names." '(concat "\\`" "\\(" ".+" "\\." (defalias 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler) (defun tramp-register-archive-file-name-handler nil "\ -Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put 'tramp-archive-autoload-file-name-handler 'safe-magic t))) +Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put #'tramp-archive-autoload-file-name-handler 'safe-magic t))) (add-hook 'after-init-hook #'tramp-register-archive-file-name-handler) @@ -38846,10 +38843,19 @@ Zone out, completely." t nil) ;;;;;; "eshell/em-unix.el" "eshell/em-xtra.el" "facemenu.el" "faces.el" ;;;;;; "files.el" "font-core.el" "font-lock.el" "format.el" "frame.el" ;;;;;; "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el" "international/characters.el" -;;;;;; "international/charscript.el" "international/cp51932.el" -;;;;;; "international/eucjp-ms.el" "international/mule-cmds.el" -;;;;;; "international/mule-conf.el" "international/mule.el" "isearch.el" -;;;;;; "jit-lock.el" "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" +;;;;;; "international/charprop.el" "international/charscript.el" +;;;;;; "international/cp51932.el" "international/eucjp-ms.el" "international/mule-cmds.el" +;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el" +;;;;;; "international/uni-brackets.el" "international/uni-category.el" +;;;;;; "international/uni-combining.el" "international/uni-comment.el" +;;;;;; "international/uni-decimal.el" "international/uni-decomposition.el" +;;;;;; "international/uni-digit.el" "international/uni-lowercase.el" +;;;;;; "international/uni-mirrored.el" "international/uni-name.el" +;;;;;; "international/uni-numeric.el" "international/uni-old-name.el" +;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el" +;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el" +;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el" +;;;;;; "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" ;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" ;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" ;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" diff --git a/lisp/leim/quail/latin-ltx.el b/lisp/leim/quail/latin-ltx.el index 35a9adbe29b..78ffca9e2fa 100644 --- a/lisp/leim/quail/latin-ltx.el +++ b/lisp/leim/quail/latin-ltx.el @@ -727,7 +727,9 @@ system, including many technical ones. Examples: ("\\ldq" ?\“) ("\\rdq" ?\”) ("\\defs" ?≙) ; per fuzz/zed - ;; ("\\sqrt[3]" ?∛) + ("\\sqrt" ?√) + ("\\sqrt[3]" ?∛) + ("\\sqrt[4]" ?∜) ("\\llbracket" ?\〚) ; stmaryrd ("\\rrbracket" ?\〛) ;; ("\\lbag" ?\〚) ; fuzz diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index b9920023d82..0d7193c1be0 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -1203,7 +1203,7 @@ no longer matches to transformed string. Used by function feedmail-tidy-up-slug and indirectly by feedmail-queue-subject-slug-maker." :version "24.1" :group 'feedmail-queue - :type 'string + :type 'regexp ) diff --git a/lisp/mail/rmail-spam-filter.el b/lisp/mail/rmail-spam-filter.el index 1755f4eb467..db518482591 100644 --- a/lisp/mail/rmail-spam-filter.el +++ b/lisp/mail/rmail-spam-filter.el @@ -133,7 +133,7 @@ If any element matches the \"From\" header, the message is flagged as a valid, non-spam message. E.g., if your domain is \"emacs.com\" then including \"emacs\\\\.com\" in this list would flag all mail (purporting to be) from your colleagues as valid." - :type '(repeat string) + :type '(repeat regexp) :group 'rmail-spam-filter) (defcustom rsf-definitions-alist nil @@ -157,22 +157,22 @@ A rule matches only if all the specified elements match." (list :format "%v" (cons :format "%v" :value (from . "") (const :format "" from) - (string :tag "From" "")) + (regexp :tag "From" "")) (cons :format "%v" :value (to . "") (const :format "" to) - (string :tag "To" "")) + (regexp :tag "To" "")) (cons :format "%v" :value (subject . "") (const :format "" subject) - (string :tag "Subject" "")) + (regexp :tag "Subject" "")) (cons :format "%v" :value (content-type . "") (const :format "" content-type) - (string :tag "Content-Type" "")) + (regexp :tag "Content-Type" "")) (cons :format "%v" :value (contents . "") (const :format "" contents) - (string :tag "Contents" "")) + (regexp :tag "Contents" "")) (cons :format "%v" :value (x-spam-status . "") (const :format "" x-spam-status) - (string :tag "X-Spam-Status" "")) + (regexp :tag "X-Spam-Status" "")) (cons :format "%v" :value (action . output-and-delete) (const :format "" action) (choice :tag "Action selection" diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index d798ffa0516..d79cea987e9 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -4392,9 +4392,8 @@ browsing, and moving of messages." (text face mouse function &optional token prevline)) ;; Make sure our special speedbar major mode is loaded -(if (featurep 'speedbar) - (rmail-install-speedbar-variables) - (add-hook 'speedbar-load-hook 'rmail-install-speedbar-variables)) +(with-eval-after-load 'speedbar + (rmail-install-speedbar-variables)) (defun rmail-speedbar-buttons (buffer) "Create buttons for BUFFER containing rmail messages. diff --git a/lisp/man.el b/lisp/man.el index 4406ac5d642..5278a1a84dd 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -253,7 +253,7 @@ the associated section number." "Regexp that matches the text that precedes the command's name. Used in `bookmark-set' to get the default bookmark name." :version "24.1" - :type 'string :group 'bookmark) + :type 'regexp :group 'bookmark) (defcustom manual-program "man" "Program used by `man' to produce man pages." diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 8f825a19adc..731da193ef1 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1476,6 +1476,18 @@ mail status in mode line")) (bindings--define-key menu [cursor-separator] menu-bar-separator) + (bindings--define-key menu [save-desktop] + (menu-bar-make-toggle + toggle-save-desktop-globally desktop-save-mode + "Save State between Sessions" + "Saving desktop state %s" + "Visit desktop of previous session when restarting Emacs" + (require 'desktop) + ;; Do it by name, to avoid a free-variable + ;; warning during byte compilation. + (set-default + 'desktop-save-mode (not (symbol-value 'desktop-save-mode))))) + (bindings--define-key menu [save-place] (menu-bar-make-toggle toggle-save-place-globally save-place-mode diff --git a/lisp/msb.el b/lisp/msb.el index ebaf98cbe83..15aeaa2e73f 100644 --- a/lisp/msb.el +++ b/lisp/msb.el @@ -372,6 +372,8 @@ This is instead of the groups in `msb-menu-cond'." :type 'hook :set 'msb-custom-set :group 'msb) +(make-obsolete-variable 'msb-after-load-hook + "use `with-eval-after-load' instead." "28.1") ;;; ;;; Internal variables diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 1d456044901..f28394260dd 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -838,7 +838,7 @@ If nil, prompt the user for a password." "If non-nil, regexp matching hosts on which `dir' command lists directory." :group 'ange-ftp :type '(choice (const :tag "Default" nil) - string)) + regexp)) (defcustom ange-ftp-binary-file-name-regexp "" "If a file matches this regexp then it is transferred in binary mode." diff --git a/lisp/net/dns.el b/lisp/net/dns.el index cefe0851f03..78d48271629 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -258,10 +258,8 @@ If TCP-P, the first two bytes of the package with be the length field." (nreverse spec)))) (defun dns-read-int32 () - ;; Full 32 bit Integers can't be handled by 32-bit Emacsen. If we - ;; use floats, it works. - (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0) - (dns-read-bytes 3)))) + (declare (obsolete nil "28.1")) + (number-to-string (dns-read-bytes 4))) (defun dns-read-type (string type) (let ((buffer (current-buffer)) @@ -286,11 +284,11 @@ If TCP-P, the first two bytes of the package with be the length field." ((eq type 'SOA) (list (list 'mname (dns-read-name buffer)) (list 'rname (dns-read-name buffer)) - (list 'serial (dns-read-int32)) - (list 'refresh (dns-read-int32)) - (list 'retry (dns-read-int32)) - (list 'expire (dns-read-int32)) - (list 'minimum (dns-read-int32)))) + (list 'serial (dns-read-bytes 4)) + (list 'refresh (dns-read-bytes 4)) + (list 'retry (dns-read-bytes 4)) + (list 'expire (dns-read-bytes 4)) + (list 'minimum (dns-read-bytes 4)))) ((eq type 'SRV) (list (list 'priority (dns-read-bytes 2)) (list 'weight (dns-read-bytes 2)) diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index e42a7655ef3..700653250fb 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -727,7 +727,7 @@ an alist of attribute/value pairs." (setq record nil) (skip-chars-forward " \t\n") (message "Parsing results... %d" numres) - (1+ numres)) + (setq numres (1+ numres))) (message "Parsing results... done") (nreverse result))))) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index eb61d7a6796..b8f1bccd788 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -363,7 +363,7 @@ description are marked as immortal." (const :tag "Title" title) (const :tag "Description" description) (const :tag "All" all)) - (string :tag "Regexp"))))) + (regexp :tag "Regexp"))))) :group 'newsticker-headline-processing) ;; ====================================================================== diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index e94947bc7f1..2d36c5e2571 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -311,9 +311,9 @@ See also: `network-security-protocol-checks' and `nsm-noninteractive'" (map-values results) "\n") "\n") - "\n* "))))) - (delete-process process) - (setq process nil))) + "\n* ")))))) + (delete-process process) + (setq process nil)) (run-hook-with-args 'nsm-tls-post-check-functions host port status settings results))) process) @@ -371,7 +371,7 @@ Reference: Sheffer, Holz, Saint-Andre (May 2015). \"Recommendations for Secure Use of Transport Layer Security (TLS) and Datagram Transport Layer Security (DTLS)\", \"(4.1. General Guidelines)\" -`https://tools.ietf.org/html/rfc7525\#section-4.1'" +`https://tools.ietf.org/html/rfc7525#section-4.1'" (let ((kx (plist-get status :key-exchange))) (and (string-match "^\\bRSA\\b" kx) (format-message @@ -468,7 +468,7 @@ Reference: GnuTLS authors (2018). \"GnuTLS Manual 4.3.3 Anonymous authentication\", -`https://www.gnutls.org/manual/gnutls.html\#Anonymous-authentication'" +`https://www.gnutls.org/manual/gnutls.html#Anonymous-authentication'" (let ((kx (plist-get status :key-exchange))) (and (string-match "\\bANON\\b" kx) (format-message @@ -603,7 +603,7 @@ References: full SHA-1\", `https://shattered.io/static/shattered.pdf' [2]: Chromium Security Education TLS/SSL. \"Deprecated and Removed Features (SHA-1 Certificate Signatures)\", -`https://www.chromium.org/Home/chromium-security/education/tls\#TOC-SHA-1-Certificate-Signatures' +`https://www.chromium.org/Home/chromium-security/education/tls#TOC-SHA-1-Certificate-Signatures' [3]: Jones J.C (2017). \"The end of SHA-1 on the Public Web\", `https://blog.mozilla.org/security/2017/02/23/the-end-of-sha-1-on-the-public-web/' [4]: Apple Support (2017). \"Move to SHA-256 signed certificates to diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index fff640bb675..ad06d31cf9a 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -254,7 +254,7 @@ Examples: (\"bitlbee\" bitlbee \"robert\" \"sekrit\") (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\") (\"quakenet.org\" quakenet \"bobby\" \"sekrit\"))" - :type '(alist :key-type (string :tag "Server") + :type '(alist :key-type (regexp :tag "Server") :value-type (choice (list :tag "NickServ" (const nickserv) (string :tag "Nick") @@ -359,9 +359,9 @@ If VAL is a coding system, it is used for both decoding and encoding messages. If VAL is a cons of coding systems, the car part is used for decoding, and the cdr part is used for encoding." - :type '(alist :key-type (choice (string :tag "Channel Regexp") - (cons (string :tag "Channel Regexp") - (string :tag "Server Regexp"))) + :type '(alist :key-type (choice (regexp :tag "Channel Regexp") + (cons (regexp :tag "Channel Regexp") + (regexp :tag "Server Regexp"))) :value-type (choice coding-system (cons (coding-system :tag "Decode") (coding-system :tag "Encode"))))) diff --git a/lisp/net/sasl-scram-sha256.el b/lisp/net/sasl-scram-sha256.el new file mode 100644 index 00000000000..e50a032c233 --- /dev/null +++ b/lisp/net/sasl-scram-sha256.el @@ -0,0 +1,59 @@ +;;; sasl-scram-sha256.el --- SCRAM-SHA-256 module for the SASL client framework -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <simon@josefsson.org> +;; Package: sasl + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Implement the SCRAM-SHA-256 mechanism from RFC 7677. + +;;; Code: + +(require 'cl-lib) +(require 'sasl) +(require 'hex-util) +(require 'rfc2104) +(require 'sasl-scram-rfc) + +;;; SCRAM-SHA-256 + +(defconst sasl-scram-sha-256-steps + '(sasl-scram-client-first-message + sasl-scram-sha-256-client-final-message + sasl-scram-sha-256-authenticate-server)) + +(defun sasl-scram-sha256 (object &optional start end binary) + (secure-hash 'sha256 object start end binary)) + +(defun sasl-scram-sha-256-client-final-message (client step) + (sasl-scram--client-final-message + ;; HMAC-SHA256 uses block length 64 and hash length 32; see RFC 4634. + 'sasl-scram-sha256 64 32 client step)) + +(defun sasl-scram-sha-256-authenticate-server (client step) + (sasl-scram--authenticate-server + 'sasl-scram-sha256 64 32 client step)) + +(put 'sasl-scram-sha256 'sasl-mechanism + (sasl-make-mechanism "SCRAM-SHA-256" sasl-scram-sha-256-steps)) + +(provide 'sasl-scram-sha256) + +;;; sasl-scram-sha256.el ends here diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index 4405c904cd3..ab118e1f982 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -35,8 +35,8 @@ ;;; Code: (defvar sasl-mechanisms - '("SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" - "NTLM")) + '("SCRAM-SHA-256" "SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" + "ANONYMOUS" "NTLM")) (defvar sasl-mechanism-alist '(("CRAM-MD5" sasl-cram) @@ -45,6 +45,7 @@ ("LOGIN" sasl-login) ("ANONYMOUS" sasl-anonymous) ("NTLM" sasl-ntlm) + ("SCRAM-SHA-256" sasl-scram-sha256) ("SCRAM-SHA-1" sasl-scram-rfc))) (defvar sasl-unique-id-function #'sasl-unique-id-function) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 241180d471a..55c189baa85 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1265,7 +1265,9 @@ START, and END. Note that START and END should be markers." (format "%s (%s)" iri title) iri)) 'follow-link t - 'mouse-face 'highlight)) + ;; Make separate regions not `eq' so that they'll get + ;; separate mouse highlights. + 'mouse-face (list 'highlight))) ;; Don't overwrite any keymaps that are already in the buffer (i.e., ;; image keymaps). (while (and start diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 5cfcb81708f..aa7fe147c20 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -181,10 +181,9 @@ It is used for TCP/IP devices." "Invoke the ADB handler for OPERATION. First arg specifies the OPERATION, second arg is a list of ARGUMENTS to pass to the OPERATION." - (let ((fn (assoc operation tramp-adb-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) arguments)) - (tramp-run-real-handler operation arguments)))) + (if-let ((fn (assoc operation tramp-adb-file-name-handler-alist))) + (save-match-data (apply (cdr fn) arguments)) + (tramp-run-real-handler operation arguments))) ;;;###tramp-autoload (tramp--with-startup @@ -234,8 +233,7 @@ ARGUMENTS to pass to the OPERATION." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -719,14 +717,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter v 0 (format "Copying %s to %s" filename newname) (if (and t1 t2 (tramp-equal-remote filename newname)) - (let ((l1 (tramp-compat-file-local-name filename)) - (l2 (tramp-compat-file-local-name newname))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. @@ -739,39 +737,37 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-shell-quote-argument l2)) "Error copying %s to %s" filename newname)) - (let ((tmpfile (file-local-copy filename))) - - (if tmpfile - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. - (when (and (file-directory-p newname) - (tramp-compat-directory-name-p newname)) - (setq newname - (expand-file-name - (file-name-nondirectory filename) newname))) - - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - - ;; We must also flush the cache of the directory, - ;; because `file-attributes' reads the values from - ;; there. - (tramp-flush-file-properties v localname) - (when (tramp-adb-execute-adb-command - v "push" - (tramp-compat-file-name-unquote filename) - (tramp-compat-file-name-unquote localname)) - (tramp-error - v 'file-error - "Cannot copy `%s' `%s'" filename newname))))))))) + (if-let ((tmpfile (file-local-copy filename))) + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (and (file-directory-p newname) + (directory-name-p newname)) + (setq newname + (expand-file-name + (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) + (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + + ;; We must also flush the cache of the directory, + ;; because `file-attributes' reads the values from + ;; there. + (tramp-flush-file-properties v localname) + (when (tramp-adb-execute-adb-command + v "push" + (tramp-compat-file-name-unquote filename) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error + "Cannot copy `%s' `%s'" filename newname)))))))) ;; KEEP-DATE handling. (when keep-date @@ -801,7 +797,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -809,8 +805,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (if (and t1 t2 (tramp-equal-remote filename newname) (not (file-directory-p filename))) - (let ((l1 (tramp-compat-file-local-name filename)) - (l2 (tramp-compat-file-local-name newname))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-properties v l1) @@ -846,7 +842,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input)) @@ -877,8 +873,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setcar (cdr destination) (expand-file-name (cadr destination))) (if (tramp-equal-remote default-directory (cadr destination)) ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) + (setq stderr (tramp-file-local-name (cadr destination))) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) @@ -936,6 +931,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. +;; The complete STDERR buffer is available only when the process has +;; terminated. (defun tramp-adb-handle-make-process (&rest args) "Like `make-process' for Tramp files." (when args @@ -969,17 +966,29 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) (let* ((buffer (if buffer (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) (args (cdr command)) (command - (format "cd %s && exec %s" + (format "cd %s && exec %s %s" (tramp-shell-quote-argument localname) + (if tmpstderr (format "2>'%s'" tmpstderr) "") (mapconcat #'tramp-shell-quote-argument (cons program args) " "))) (tramp-process-connection-type @@ -1029,6 +1038,18 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) ;; Read initial output. Remove the first line, ;; which is the command echo. (while @@ -1037,6 +1058,23 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (not (re-search-forward "[\n]" nil t))) (tramp-accept-process-output p 0)) (delete-region (point-min) (point)) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the process + ;; is deleted. The temporary file will exist + ;; until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) ;; Return process. p)))) @@ -1062,7 +1100,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (read (current-buffer))) ":" 'omit))) ;; The equivalent to `exec-directory'. - `(,(tramp-compat-file-local-name default-directory)))) + `(,(tramp-file-local-name (expand-file-name default-directory))))) (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index b9bf6180a5d..95cbfb8c22a 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -350,7 +350,7 @@ arguments to pass to the OPERATION." (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) - (put 'tramp-archive-autoload-file-name-handler 'safe-magic t)))) + (put #'tramp-archive-autoload-file-name-handler 'safe-magic t)))) ;;;###autoload (progn @@ -366,7 +366,7 @@ arguments to pass to the OPERATION." (tramp-register-archive-file-name-handler) ;; Mark `operations' the handler is responsible for. -(put 'tramp-archive-file-name-handler 'operations +(put #'tramp-archive-file-name-handler 'operations (mapcar #'car tramp-archive-file-name-handler-alist)) ;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'. @@ -517,13 +517,16 @@ offered." (declare (debug (form symbolp body)) (indent 2)) (let ((bindings - (mapcar (lambda (elem) - `(,(if var (intern (format "%s-%s" var elem)) elem) - (,(intern (format "tramp-file-name-%s" elem)) - ,(or var 'v)))) - `,(cons - 'archive - (delete 'hop (tramp-compat-tramp-file-name-slots)))))) + (mapcar + (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + (cons + 'archive + (delete + 'hop + (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))))))) `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename)) ,@bindings) ;; We don't know which of those vars will be used, so we bind them all, diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 62e25fa1f08..91ed5465695 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -130,13 +130,8 @@ Returns DEFAULT if not set." (or (null remote-file-name-inhibit-cache) (and (integerp remote-file-name-inhibit-cache) (time-less-p - ;; `current-time' can be nil once we get rid of Emacs 24. - (current-time) - (time-add - (car value) - ;; `seconds-to-time' can be removed once we get - ;; rid of Emacs 24. - (seconds-to-time remote-file-name-inhibit-cache)))) + nil + (time-add (car value) remote-file-name-inhibit-cache))) (and (consp remote-file-name-inhibit-cache) (time-less-p remote-file-name-inhibit-cache (car value))))) @@ -146,7 +141,7 @@ Returns DEFAULT if not set." (tramp-message key 8 "%s %s %s" file property value) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-get-count-" property))) - (val (or (bound-and-true-p var) + (val (or (numberp (bound-and-true-p var)) (progn (add-hook 'tramp-cache-unload-hook (lambda () (makunbound var))) @@ -170,7 +165,7 @@ Returns VALUE." (tramp-message key 8 "%s %s %s" file property value) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-set-count-" property))) - (val (or (bound-and-true-p var) + (val (or (numberp (bound-and-true-p var)) (progn (add-hook 'tramp-cache-unload-hook (lambda () (makunbound var))) @@ -202,13 +197,11 @@ Returns VALUE." key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) file (tramp-file-name-hop key) nil) - (maphash - (lambda (property _value) - (when (string-match-p - "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" - property) - (tramp-flush-file-property key file property))) - (tramp-get-hash-table key))))) + (dolist (property (hash-table-keys (tramp-get-hash-table key))) + (when (string-match-p + "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" + property) + (tramp-flush-file-property key file property)))))) ;;;###tramp-autoload (defun tramp-flush-file-properties (key file) @@ -239,14 +232,12 @@ Remove also properties of all files in subdirectories." #'directory-file-name (list directory))) (truename (tramp-get-file-property key directory "file-truename" nil))) (tramp-message key 8 "%s" directory) - (maphash - (lambda (key _value) - (when (and (tramp-file-name-p key) - (stringp (tramp-file-name-localname key)) - (string-match-p (regexp-quote directory) - (tramp-file-name-localname key))) - (remhash key tramp-cache-data))) - tramp-cache-data) + (dolist (key (hash-table-keys tramp-cache-data)) + (when (and (tramp-file-name-p key) + (stringp (tramp-file-name-localname key)) + (string-match-p (regexp-quote directory) + (tramp-file-name-localname key))) + (remhash key tramp-cache-data))) ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal directory (directory-file-name truename)))) @@ -370,11 +361,8 @@ used to cache connection properties of the local machine." (tramp-file-name-hop key) nil)) (tramp-message key 7 "%s %s" key - (let ((hash (gethash key tramp-cache-data)) - properties) - (when (hash-table-p hash) - (maphash (lambda (x _y) (push x properties)) hash)) - properties)) + (let ((hash (gethash key tramp-cache-data))) + (when (hash-table-p hash) (hash-table-keys hash)))) (setq tramp-cache-data-changed t) (remhash key tramp-cache-data)) @@ -386,20 +374,15 @@ used to cache connection properties of the local machine." (maphash (lambda (key value) ;; Remove text properties from KEY and VALUE. - ;; `cl-struct-slot-*' functions exist since Emacs 25 only; we - ;; ignore errors. (when (tramp-file-name-p key) - ;; (dolist - ;; (slot - ;; (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) - ;; (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) - ;; (setf (cl-struct-slot-value 'tramp-file-name slot key) - ;; (substring-no-properties - ;; (cl-struct-slot-value 'tramp-file-name slot key)))))) - (dotimes (i (length key)) - (when (stringp (elt key i)) - (setf (elt key i) (substring-no-properties (elt key i)))))) - (when (stringp key) + (dolist + (slot + (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) + (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) + (setf (cl-struct-slot-value 'tramp-file-name slot key) + (substring-no-properties + (cl-struct-slot-value 'tramp-file-name slot key)))))) + (when (stringp key) (setq key (substring-no-properties key))) (when (stringp value) (setq value (substring-no-properties value))) @@ -421,15 +404,14 @@ used to cache connection properties of the local machine." ;;;###tramp-autoload (defun tramp-list-connections () "Return all known `tramp-file-name' structs according to `tramp-cache'." - (let (result tramp-verbose) - (maphash - (lambda (key _value) - (when (and (tramp-file-name-p key) - (null (tramp-file-name-localname key)) - (tramp-connection-property-p key "process-buffer")) - (push key result))) - tramp-cache-data) - result)) + (let ((tramp-verbose 0)) + (delq nil (mapcar + (lambda (key) + (and (tramp-file-name-p key) + (null (tramp-file-name-localname key)) + (tramp-connection-property-p key "process-buffer") + key)) + (hash-table-keys tramp-cache-data))))) (defun tramp-dump-connection-properties () "Write persistent connection properties into file `tramp-persistency-file-name'." @@ -490,17 +472,14 @@ used to cache connection properties of the local machine." "Return a list of (user host) tuples allowed to access for METHOD. This function is added always in `tramp-get-completion-function' for all methods. Resulting data are derived from connection history." - (let (res) - (maphash - (lambda (key _value) - (if (and (tramp-file-name-p key) - (string-equal method (tramp-file-name-method key)) - (not (tramp-file-name-localname key))) - (push (list (tramp-file-name-user key) - (tramp-file-name-host key)) - res))) - tramp-cache-data) - res)) + (mapcar + (lambda (key) + (and (tramp-file-name-p key) + (string-equal method (tramp-file-name-method key)) + (not (tramp-file-name-localname key)) + (list (tramp-file-name-user key) + (tramp-file-name-host key)))) + (hash-table-keys tramp-cache-data))) ;; When "emacs -Q" has been called, both variables are nil. We do not ;; load the persistency file then, in order to have a clean test environment. @@ -514,7 +493,7 @@ for all methods. Resulting data are derived from connection history." tramp-cache-read-persistent-data) (condition-case err (with-temp-buffer - (insert-file-contents tramp-persistency-file-name) + (insert-file-contents-literally tramp-persistency-file-name) (let ((list (read (current-buffer))) (tramp-verbose 0) element key item) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 9d1025b9072..b4dca2321c1 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -358,7 +358,7 @@ The remote connection identified by SOURCE is flushed by ;; Append local file name if none is specified. (when (string-equal (file-remote-p target) target) - (setq target (concat target (file-remote-p source 'localname)))) + (setq target (concat target (tramp-file-local-name source)))) ;; Make them directory names. (setq source (directory-file-name source) target (directory-file-name target)) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 723b8cfa1e3..87bcd08b85a 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,15 +23,15 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 27. This -;; package provides compatibility functions for Emacs 24, Emacs 25 and -;; Emacs 26. +;; Tramp's main Emacs version for development is Emacs 28. This +;; package provides compatibility functions for Emacs 25, Emacs 26 and +;; Emacs 27. ;;; Code: -;; In Emacs 24 and 25, `tramp-unload-file-name-handlers' is not -;; autoloaded. So we declare it here in order to avoid recursive -;; load. This will be overwritten in tramp.el. +;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded. +;; So we declare it here in order to avoid recursive load. This will +;; be overwritten in tramp.el. (defun tramp-unload-file-name-handlers () ".") (require 'auth-source) @@ -41,6 +41,7 @@ (require 'shell) (require 'subr-x) +;; `temporary-file-directory' as function is introduced with Emacs 26.1. (declare-function tramp-handle-temporary-file-directory "tramp") ;; For not existing functions, obsolete functions, or functions with a @@ -51,6 +52,8 @@ `(when (functionp ,function) (with-no-warnings (funcall ,function ,@arguments)))) +(put #'tramp-compat-funcall 'tramp-suppress-trace t) + (defsubst tramp-compat-temporary-file-directory () "Return name of directory for temporary files. It is the default value of `temporary-file-directory'." @@ -74,31 +77,7 @@ Add the extension of F, if existing." #'temporary-file-directory #'tramp-handle-temporary-file-directory)) -(defun tramp-compat-process-running-p (process-name) - "Return t if system process PROCESS-NAME is running for `user-login-name'." - (when (stringp process-name) - (cond - ;; GNU Emacs 22 on w32. - ((fboundp 'w32-window-exists-p) - (tramp-compat-funcall 'w32-window-exists-p process-name process-name)) - - ;; GNU Emacs 23+. - ((and (fboundp 'list-system-processes) (fboundp 'process-attributes)) - (let (result) - (dolist (pid (tramp-compat-funcall 'list-system-processes) result) - (let ((attributes (process-attributes pid))) - (when (and (string-equal - (cdr (assoc 'user attributes)) (user-login-name)) - (let ((comm (cdr (assoc 'comm attributes)))) - ;; The returned command name could be truncated - ;; to 15 characters. Therefore, we cannot check - ;; for `string-equal'. - (and comm (string-match-p - (concat "^" (regexp-quote comm)) - process-name)))) - (setq result t))))))))) - -;; `file-attribute-*' are introduced in Emacs 25.1. +;; `file-attribute-*' are introduced in Emacs 26.1. (defalias 'tramp-compat-file-attribute-type (if (fboundp 'file-attribute-type) @@ -180,24 +159,6 @@ and later, and is a float in Emacs 26 and earlier." This is a string of ten letters or dashes as in ls -l." (nth 8 attributes)))) -;; `format-message' is new in Emacs 25.1. -(unless (fboundp 'format-message) - (defalias 'format-message #'format)) - -;; `directory-name-p' is new in Emacs 25.1. -(defalias 'tramp-compat-directory-name-p - (if (fboundp 'directory-name-p) - #'directory-name-p - (lambda (name) - "Return non-nil if NAME ends with a directory separator character." - (let ((len (length name)) - (lastc ?.)) - (if (> len 0) - (setq lastc (aref name (1- len)))) - (or (= lastc ?/) - (and (memq system-type '(windows-nt ms-dos)) - (= lastc ?\\))))))) - ;; `file-missing' is introduced in Emacs 26.1. (defconst tramp-file-missing (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) @@ -265,13 +226,6 @@ NAME is unquoted." ((eq tramp-syntax 'sep) 'separate) (t tramp-syntax))) -;; `cl-struct-slot-info' has been introduced with Emacs 25. -(defmacro tramp-compat-tramp-file-name-slots () - "Return a list of slot names." - (if (fboundp 'cl-struct-slot-info) - '(cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name))) - '(cdr (mapcar #'car (get 'tramp-file-name 'cl-struct-slots))))) - ;; The signature of `tramp-make-tramp-file-name' has been changed. ;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior ;; Emacs 26.1. We use `temporary-file-directory' as indicator. @@ -284,10 +238,9 @@ NAME is unquoted." #'exec-path (lambda () "List of directories to search programs to run in remote subprocesses." - (let ((handler (find-file-name-handler default-directory 'exec-path))) - (if handler - (funcall handler 'exec-path) - exec-path))))) + (if-let ((handler (find-file-name-handler default-directory 'exec-path))) + (funcall handler 'exec-path) + exec-path)))) ;; `time-equal-p' has appeared in Emacs 27.1. (defalias 'tramp-compat-time-equal-p @@ -327,11 +280,11 @@ A nil value for either argument stands for the current time." (unload-feature 'tramp-loaddefs 'force) (unload-feature 'tramp-compat 'force))) +(provide 'tramp-compat) + ;;; TODO: ;; -;; * Starting with Emacs 25.1, replace `tramp-message-show-message' by -;; the reverse of `inhibit-message'. - -(provide 'tramp-compat) +;; * Starting with Emacs 27.1, there's no need to escape open +;; parentheses with a backslash in docstrings anymore. ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 34a234c47f0..762c4fe4b3b 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -49,11 +49,15 @@ ;; The user option `tramp-gvfs-methods' contains the list of supported ;; connection methods. Per default, these are "afp", "dav", "davs", -;; "gdrive", "nextcloud" and "sftp". +;; "gdrive", "media", "nextcloud" and "sftp". ;; "gdrive" and "nextcloud" connection methods require a respective ;; account in GNOME Online Accounts, with enabled "Files" service. +;; The "media" connection method is responsible for media devices, +;; like cell phones, tablets, cameras etc. The device must already be +;; connected via USB, before accessing it. + ;; Other possible connection methods are "ftp", "http", "https" and ;; "smb". When one of these methods is added to the list, the remote ;; access for that method is performed via GVFS instead of the native @@ -121,16 +125,16 @@ (autoload 'zeroconf-init "zeroconf") (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) - (or (tramp-compat-process-running-p "gvfs-fuse-daemon") - (tramp-compat-process-running-p "gvfsd-fuse")))) + (or (tramp-process-running-p "gvfs-fuse-daemon") + (tramp-process-running-p "gvfsd-fuse")))) "Non-nil when GVFS is available.") ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "nextcloud" "sftp") + '("afp" "dav" "davs" "gdrive" "media" "nextcloud" "sftp") "List of methods for remote files, accessed with GVFS." :group 'tramp - :version "27.1" + :version "28.1" :type '(repeat (choice (const "afp") (const "dav") (const "davs") @@ -138,10 +142,12 @@ (const "gdrive") (const "http") (const "https") + (const "media") (const "nextcloud") (const "sftp") (const "smb")))) +;;;###tramp-autoload (defconst tramp-goa-methods '("gdrive" "nextcloud") "List of methods which require registration at GNOME Online Accounts.") @@ -151,15 +157,23 @@ (dolist (method tramp-goa-methods) (setq tramp-gvfs-methods (delete method tramp-gvfs-methods)))) -;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'. ;;;###tramp-autoload -(tramp--with-startup - (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)" - user-mail-address) - (add-to-list 'tramp-default-user-alist - `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address))) - (add-to-list 'tramp-default-host-alist - '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address))))) +(defvar tramp-media-methods '("afc" "gphoto2" "mtp") + "List of GVFS methods which are covered by the \"media\" method. +They are checked during start up via +`tramp-gvfs-interface-remotevolumemonitor'.") + +(defsubst tramp-gvfs-service-volumemonitor (method) + "Return the well known name of the volume monitor responsible for METHOD." + (symbol-value + (intern-soft (format "tramp-gvfs-service-%s-volumemonitor" method)))) + +;; Remove media methods if not supported. +(when tramp-gvfs-enabled + (dolist (method tramp-media-methods) + (unless (member (tramp-gvfs-service-volumemonitor method) + (dbus-list-known-names :session)) + (setq tramp-media-methods (delete method tramp-media-methods))))) ;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" @@ -169,13 +183,15 @@ :type 'string) ;; Add the methods to `tramp-methods', in order to allow minibuffer -;; completion. +;; completion. Add defaults for `tramp-default-host-alist'. ;;;###tramp-autoload (when (featurep 'dbusbind) (tramp--with-startup - (dolist (elt tramp-gvfs-methods) - (unless (assoc elt tramp-methods) - (add-to-list 'tramp-methods (cons elt nil)))))) + (dolist (method tramp-gvfs-methods) + (unless (assoc method tramp-methods) + (add-to-list 'tramp-methods `(,method))) + (when (member method tramp-goa-methods) + (add-to-list 'tramp-default-host-alist `(,method nil "")))))) (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") "The preceding object path for own objects.") @@ -457,8 +473,209 @@ It has been changed in GVFS 1.14.") ;; </interface> ;; The basic structure for GNOME Online Accounts. We use a list :type, -;; in order to be compatible with Emacs 24 and 25. -(cl-defstruct (tramp-goa-name (:type list) :named) method user host port) +;; in order to be compatible with Emacs 25. +(cl-defstruct (tramp-goa-account (:type list) :named) method user host port) + +;;;###tramp-autoload +(defconst tramp-gvfs-service-afc-volumemonitor "org.gtk.vfs.AfcVolumeMonitor" + "The well known name of the AFC volume monitor.") + +;; This one is not needed yet. +(defconst tramp-gvfs-service-goa-volumemonitor "org.gtk.vfs.GoaVolumeMonitor" + "The well known name of the GOA volume monitor.") + +;;;###tramp-autoload +(defconst tramp-gvfs-service-gphoto2-volumemonitor + "org.gtk.vfs.GPhoto2VolumeMonitor" + "The well known name of the GPhoto2 volume monitor.") + +;;;###tramp-autoload +(defconst tramp-gvfs-service-mtp-volumemonitor "org.gtk.vfs.MTPVolumeMonitor" + "The well known name of the MTP volume monitor.") + +(defconst tramp-gvfs-path-remotevolumemonitor + "/org/gtk/Private/RemoteVolumeMonitor" + "The object path of the remote volume monitor.") + +(defconst tramp-gvfs-interface-remotevolumemonitor + "org.gtk.Private.RemoteVolumeMonitor" + "The volume monitor interface.") + +;; <interface name='org.gtk.Private.RemoteVolumeMonitor'> +;; <method name="IsSupported"> +;; <arg type='b' name='is_supported' direction='out'/> +;; </method> +;; <method name="List"> +;; <arg type='a(ssssbbbbbbbbuasa{ss}sa{sv})' name='drives' direction='out'/> +;; <arg type='a(ssssssbbssa{ss}sa{sv})' name='volumes' direction='out'/> +;; <arg type='a(ssssssbsassa{sv})' name='mounts' direction='out'/> +;; </method> +;; <method name="CancelOperation"> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='b' name='was_cancelled' direction='out'/> +;; </method> +;; <method name="MountUnmount"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='unmount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="VolumeMount"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='mount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="DriveEject"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='unmount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="DrivePollForMedia"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; </method> +;; <method name="DriveStart"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="DriveStop"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='unmount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="MountOpReply"> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; <arg type='i' name='result' direction='in'/> +;; <arg type='s' name='user_name' direction='in'/> +;; <arg type='s' name='domain' direction='in'/> +;; <arg type='s' name='encoded_password' direction='in'/> +;; <arg type='i' name='password_save' direction='in'/> +;; <arg type='i' name='choice' direction='in'/> +;; <arg type='b' name='anonymous' direction='in'/> +;; </method> +;; <signal name="DriveChanged"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveConnected"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveDisconnected"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveEjectButton"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveStopButton"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="VolumeChanged"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/> +;; </signal> +;; <signal name="VolumeAdded"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/> +;; </signal> +;; <signal name="VolumeRemoved"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/> +;; </signal> +;; <signal name="MountChanged"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountAdded"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountPreUnmount"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountRemoved"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountOpAskPassword"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='s' name='default_user'/> +;; <arg type='s' name='default_domain'/> +;; <arg type='u' name='flags'/> +;; </signal> +;; <signal name="MountOpAskQuestion"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='as' name='choices'/> +;; </signal> +;; <signal name="MountOpShowProcesses"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='ai' name='pid'/> +;; <arg type='as' name='choices'/> +;; </signal> +;; <signal name="MountOpShowUnmountProgress"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='x' name='time_left'/> +;; <arg type='x' name='bytes_left'/> +;; </signal> +;; <signal name="MountOpAborted"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; </signal> +;; </interface> + +;; STRUCT volume +;; STRING id +;; STRING name +;; STRING gicon_data +;; STRING symbolic_gicon_data +;; STRING uuid +;; STRING activation_uri +;; BOOLEAN can-mount +;; BOOLEAN should-automount +;; STRING drive-id +;; STRING mount-id +;; ARRAY identifiers +;; DICT +;; STRING key (unix-device, class, uuid, ...) +;; STRING value +;; STRING sort_key +;; ARRAY expansion +;; DICT +;; STRING key (always-call-mount, is-removable, ...) +;; VARIANT value (boolean?) + +;; The basic structure for media devices. We use a list :type, in +;; order to be compatible with Emacs 25. +(cl-defstruct (tramp-media-device (:type list) :named) method host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We ;; must use "gio <command>" tool instead. @@ -470,6 +687,7 @@ It has been changed in GVFS 1.14.") ("gvfs-monitor-file" . "monitor") ("gvfs-mount" . "mount") ("gvfs-move" . "move") + ("gvfs-rename" . "rename") ("gvfs-rm" . "remove") ("gvfs-set-attribute" . "set") ("gvfs-trash" . "trash")) @@ -625,10 +843,9 @@ First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (unless tramp-gvfs-enabled (tramp-user-error nil "Package `tramp-gvfs' not supported")) - (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (when (featurep 'dbusbind) @@ -649,13 +866,12 @@ pass to the OPERATION." "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists. Return nil for null BYTE-ARRAY." ;; The byte array could be a variant. Take care. - (let ((byte-array - (if (and (consp byte-array) (atom (car byte-array))) - byte-array (car byte-array)))) - (and byte-array - (dbus-byte-array-to-string - (if (and (consp byte-array) (zerop (car (last byte-array)))) - (butlast byte-array) byte-array))))) + (when-let ((byte-array + (if (and (consp byte-array) (atom (car byte-array))) + byte-array (car byte-array)))) + (dbus-byte-array-to-string + (if (and (consp byte-array) (zerop (car (last byte-array)))) + (butlast byte-array) byte-array)))) (defun tramp-gvfs-stringify-dbus-message (message) "Convert a D-Bus MESSAGE into readable UTF8 strings, used for traces." @@ -680,6 +896,8 @@ The call will be traced by Tramp with trace level 6." (tramp-message vec 6 "%s" result(tramp-gvfs-stringify-dbus-message result)) result)) +(put #'tramp-dbus-function 'tramp-suppress-trace t) + (defmacro with-tramp-dbus-call-method (vec synchronous bus service path interface method &rest args) "Apply a D-Bus call on bus BUS. @@ -689,14 +907,13 @@ it is an asynchronous call, with `ignore' as callback function. The other arguments have the same meaning as with `dbus-call-method' or `dbus-call-method-asynchronously'." + (declare (indent 2) (debug t)) `(let ((func (if ,synchronous #'dbus-call-method #'dbus-call-method-asynchronously)) (args (append (list ,bus ,service ,path ,interface ,method) (if ,synchronous (list ,@args) (list 'ignore ,@args))))) (tramp-dbus-function ,vec func args))) -(put 'with-tramp-dbus-call-method 'lisp-indent-function 2) -(put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) (defmacro with-tramp-dbus-get-all-properties @@ -704,6 +921,7 @@ or `dbus-call-method-asynchronously'." "Return all properties of INTERFACE. The call will be traced by Tramp with trace level 6." ;; Check, that interface exists at object path. Retrieve properties. + (declare (indent 1) (debug t)) `(when (member ,interface (tramp-dbus-function @@ -712,8 +930,6 @@ The call will be traced by Tramp with trace level 6." (tramp-dbus-function ,vec #'dbus-get-all-properties (list ,bus ,service ,path ,interface)))) -(put 'with-tramp-dbus-get-all-properties 'lisp-indent-function 1) -(put 'with-tramp-dbus-get-all-properties 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>")) (defvar tramp-gvfs-dbus-event-vector nil @@ -758,11 +974,15 @@ file names." (copy-directory filename newname keep-date t) (when (eq op 'rename) (delete-directory filename 'recursive))) - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (equal-remote (tramp-equal-remote filename newname)) - (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move")) - (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + (let* ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (equal-remote (tramp-equal-remote filename newname)) + (gvfs-operation + (cond + ((eq op 'copy) "gvfs-copy") + (equal-remote "gvfs-rename") + (t "gvfs-move"))) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) @@ -772,7 +992,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and equal-remote @@ -833,8 +1053,8 @@ file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -1301,10 +1521,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) (free (cdr (assoc "filesystem::free" attr)))) - (when (and (stringp size) (stringp used) (stringp free)) - (list (string-to-number size) - (- (string-to-number size) (string-to-number used)) - (string-to-number free)))))) + (when (or size used free) + (list (string-to-number (or size "0")) + (string-to-number (or free "0")) + (- (string-to-number (or size "0")) + (string-to-number (or used "0")))))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1330,8 +1551,8 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Like `rename-file' for Tramp files." ;; Check if both files are local -- invoke normal rename-file. ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -1383,36 +1604,51 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; File name conversions. +(defun tramp-gvfs-activation-uri (filename) + "Return activation URI to be used in gio commands." + (if (tramp-tramp-file-p filename) + (with-parsed-tramp-file-name filename nil + ;; Ensure that media devices are cached. + (when (string-equal method "media") + (tramp-get-media-device v)) + (with-tramp-connection-property v "activation-uri" + (setq localname "/") + (when (string-equal "gdrive" method) + (setq method "google-drive")) + (when (string-equal "nextcloud" method) + (setq method "davs" + localname + (concat (tramp-gvfs-get-remote-prefix v) localname))) + (when (string-equal "media" method) + (when-let + ((media (tramp-get-connection-property v "media-device" nil))) + (setq method (tramp-media-device-method media) + host (tramp-media-device-host media) + port (tramp-media-device-port media)))) + (when (and user domain) + (setq user (concat domain ";" user))) + (url-recreate-url + (url-parse-make-urlobj + method (and user (url-hexify-string user)) + nil (and host (url-hexify-string host)) + (if (stringp port) (string-to-number port) port) + localname nil nil t)))) + ;; Local URI. + (url-recreate-url + (url-parse-make-urlobj "file" nil nil nil nil nil nil nil t)))) + (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." - ;; "/" must NOT be hexified. (setq filename (tramp-compat-file-name-unquote filename)) - (let ((url-unreserved-chars (cons ?/ url-unreserved-chars)) - result) - (setq - result - (url-recreate-url - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (when (string-equal "gdrive" method) - (setq method "google-drive")) - (when (string-equal "nextcloud" method) - (setq method "davs" - localname - (concat (tramp-gvfs-get-remote-prefix v) localname))) - (when (and user domain) - (setq user (concat domain ";" user))) - (url-parse-make-urlobj - method (and user (url-hexify-string user)) - nil (and host (url-hexify-string host)) - (if (stringp port) (string-to-number port) port) - (and localname (url-hexify-string localname)) nil nil t)) - (url-parse-make-urlobj - "file" nil nil nil nil - (url-hexify-string (file-truename filename)) nil nil t)))) + (let* (;; "/" must NOT be hexified. + (url-unreserved-chars (cons ?/ url-unreserved-chars)) + (result + (concat (substring (tramp-gvfs-activation-uri filename) 0 -1) + (url-hexify-string (tramp-file-local-name filename))))) (when (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (tramp-message v 10 "remote file `%s' is URL `%s'" filename result))) + (tramp-message + (tramp-dissect-file-name filename) 10 + "remote file `%s' is URL `%s'" filename result)) result)) (defun tramp-gvfs-object-path (filename) @@ -1424,6 +1660,14 @@ If FILE-SYSTEM is non-nil, return file system attributes." (dbus-unescape-from-identifier (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) +(defun tramp-gvfs-url-host (url) + "Return the host name part of URL, a string. +We cannot use `url-host', because `url-generic-parse-url' returns +a downcased host name only." + (and (stringp url) + (string-match "^[[:alnum:]]+://\\([^/:]+\\)" url) + (match-string 1 url))) + ;; D-Bus GVFS functions. @@ -1564,11 +1808,22 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when (string-equal "google-drive" method) (setq method "gdrive")) (when (and (string-equal "http" method) (stringp uri)) - (setq uri (url-generic-parse-url uri) + (setq host (tramp-gvfs-url-host uri) + uri (url-generic-parse-url uri) method (url-type uri) user (url-user uri) - host (url-host uri) port (url-portspec uri))) + (when (member method tramp-media-methods) + ;; Ensure that media devices are cached. + (tramp-get-media-devices nil) + (let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) + (when v + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) (with-parsed-tramp-file-name (tramp-make-tramp-file-name method user domain host port "") nil @@ -1654,11 +1909,22 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when (string-equal "google-drive" method) (setq method "gdrive")) (when (and (string-equal "http" method) (stringp uri)) - (setq uri (url-generic-parse-url uri) + (setq host (tramp-gvfs-url-host uri) + uri (url-generic-parse-url uri) method (url-type uri) user (url-user uri) - host (url-host uri) port (url-portspec uri))) + (when (member method tramp-media-methods) + ;; Ensure that media devices are cached. + (tramp-get-media-devices vec) + (let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) + (when v + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v))))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) @@ -1696,11 +1962,16 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (defun tramp-gvfs-mount-spec (vec) "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." - (let* ((method (tramp-file-name-method vec)) + (let* ((media (tramp-get-media-device vec)) + (method (if media + (tramp-media-device-method media) + (tramp-file-name-method vec))) (user (tramp-file-name-user vec)) (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) + (host (if media + (tramp-media-device-host media) (tramp-file-name-host vec))) + (port (if media + (tramp-media-device-port media) (tramp-file-name-port vec))) (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match "^/?\\([^/]+\\)" localname) (match-string 1 localname))) @@ -1751,6 +2022,38 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ;; Return. `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) +(defun tramp-gvfs-handler-volumeadded-volumeremoved (_dbus-name _id volume) + "Signal handler for the \"org.gtk.Private.RemoteVolumeMonitor.VolumeAdded\" \ +and \"org.gtk.Private.RemoteVolumeMonitor.VolumeRemoved\" signals." + (ignore-errors + (let* ((signal-name (dbus-event-member-name last-input-event)) + (uri (url-generic-parse-url (nth 5 volume))) + (method (url-type uri)) + (vec (make-tramp-file-name + :method "media" + ;; A host name cannot contain spaces. + :host (replace-regexp-in-string " " "_" (nth 1 volume)))) + (media (make-tramp-media-device + :method method + :host (tramp-gvfs-url-host (nth 5 volume)) + :port (and (url-portspec uri))))) + (when (member method tramp-media-methods) + (tramp-message + vec 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message volume)) + (tramp-flush-connection-properties vec) + (tramp-flush-connection-properties media) + (tramp-get-media-devices nil))))) + +(when tramp-gvfs-enabled + (dbus-register-signal + :session nil tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "VolumeAdded" + #'tramp-gvfs-handler-volumeadded-volumeremoved) + (dbus-register-signal + :session nil tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "VolumeRemoved" + #'tramp-gvfs-handler-volumeadded-volumeremoved)) + ;; Connection functions. @@ -1794,7 +2097,7 @@ This is relevant for GNOME Online Accounts." ;; Ensure that GNOME Online Accounts are cached. (when (member (tramp-file-name-method vec) tramp-goa-methods) (tramp-get-goa-accounts vec)) - (tramp-get-connection-property (tramp-make-goa-name vec) "prefix" "/"))) + (tramp-get-connection-property (tramp-get-goa-account vec) "prefix" "/"))) (defun tramp-gvfs-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -1843,7 +2146,7 @@ connection if a previous connection has died for some reason." ;; Ensure that GNOME Online Accounts are cached. (tramp-get-goa-accounts vec) (when (tramp-get-connection-property - (tramp-make-goa-name vec) "FilesDisabled" t) + (tramp-get-goa-account vec) "FilesDisabled" t) (tramp-user-error vec "There is no Online Account `%s'" (tramp-make-tramp-file-name vec 'noloc)))) @@ -1968,12 +2271,12 @@ is applied, and it returns t if the return code is zero." (and (tramp-flush-file-properties vec "/") nil))))) -;; D-Bus GNOME Online Accounts functions. +;; GNOME Online Accounts functions. -(defun tramp-make-goa-name (vec) - "Transform VEC into a `tramp-goa-name' structure." +(defun tramp-get-goa-account (vec) + "Transform VEC into a `tramp-goa-account' structure." (when (tramp-file-name-p vec) - (make-tramp-goa-name + (make-tramp-goa-account :method (tramp-file-name-method vec) :user (tramp-file-name-user vec) :host (tramp-file-name-host vec) @@ -1981,12 +2284,12 @@ is applied, and it returns t if the return code is zero." (defun tramp-get-goa-accounts (vec) "Retrieve GNOME Online Accounts, and cache them. -The hash key is a `tramp-goa-name' structure. The value is an +The hash key is a `tramp-goa-account' structure. The value is an alist of the properties of `tramp-goa-interface-account' and -`tramp-goa-interface-files' of the corresponding GNOME online -account. Additionally, a property \"prefix\" is added. +`tramp-goa-interface-files' of the corresponding GNOME Online +Account. Additionally, a property \"prefix\" is added. VEC is used only for traces." - (with-tramp-connection-property (tramp-make-goa-name vec) "goa-accounts" + (with-tramp-connection-property nil "goa-accounts" (dolist (object-path (mapcar @@ -2012,15 +2315,15 @@ VEC is used only for traces." (cdr (assoc "ProviderType" account-properties)) '("google" "owncloud")) (string-match tramp-goa-identity-regexp identity)) - (setq key (make-tramp-goa-name + (setq key (make-tramp-goa-account :method (cdr (assoc "ProviderType" account-properties)) :user (match-string 1 identity) :host (match-string 2 identity) :port (match-string 3 identity))) - (when (string-equal (tramp-goa-name-method key) "google") - (setf (tramp-goa-name-method key) "gdrive")) - (when (string-equal (tramp-goa-name-method key) "owncloud") - (setf (tramp-goa-name-method key) "nextcloud")) + (when (string-equal (tramp-goa-account-method key) "google") + (setf (tramp-goa-account-method key) "gdrive")) + (when (string-equal (tramp-goa-account-method key) "owncloud") + (setf (tramp-goa-account-method key) "nextcloud")) ;; Cache all properties. (dolist (prop (nconc account-properties files-properties)) (tramp-set-connection-property key (car prop) (cdr prop))) @@ -2036,6 +2339,80 @@ VEC is used only for traces." ;; Mark, that goa accounts have been cached. "cached")) +(defun tramp-parse-goa-accounts (service) + "Return a list of (user host) tuples allowed to access. +It checks for registered GNOME Online Accounts." + ;; SERVICE might be encoded as a DNS-SD service. + (and (string-match tramp-dns-sd-service-regexp service) + (setq service (match-string 1 service))) + (mapcar + (lambda (key) + (and (tramp-goa-account-p key) + (string-equal service (tramp-goa-account-method key)) + (list (tramp-goa-account-user key) + (tramp-goa-account-host key)))) + (hash-table-keys tramp-cache-data))) + + +;; Media devices functions. + +(defun tramp-get-media-device (vec) + "Transform VEC into a `tramp-media-device' structure. +Check, that respective cache values do exist." + (if-let ((media (tramp-get-connection-property vec "media-device" nil)) + (prop (tramp-get-connection-property media "vector" nil))) + media + (tramp-get-media-devices vec) + (tramp-get-connection-property vec "media-device" nil))) + +(defun tramp-get-media-devices (vec) + "Retrieve media devices, and cache them. +The hash key is a `tramp-media-device' structure. +VEC is used only for traces." + (let (devices) + (dolist (method tramp-media-methods) + (dolist (volume (cadr (with-tramp-dbus-call-method vec t + :session (tramp-gvfs-service-volumemonitor method) + tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "List"))) + (let* ((uri (url-generic-parse-url (nth 5 volume))) + (vec (make-tramp-file-name + :method "media" + ;; A host name cannot contain spaces. + :host (replace-regexp-in-string " " "_" (nth 1 volume)))) + (media (make-tramp-media-device + :method method + :host (tramp-gvfs-url-host (nth 5 volume)) + :port (and (url-portspec uri) + (number-to-string (url-portspec uri)))))) + (push (tramp-file-name-host vec) devices) + (tramp-set-connection-property vec "activation-uri" (nth 5 volume)) + (tramp-set-connection-property vec "media-device" media) + (tramp-set-connection-property media "vector" vec)))) + + ;; Adapt default host name, supporting /media:: when possible. + (setq tramp-default-host-alist + (append + `(("media" nil ,(if (= (length devices) 1) (car devices) ""))) + (delete + (assoc "media" tramp-default-host-alist) + tramp-default-host-alist))))) + +(defun tramp-parse-media-names (service) + "Return a list of (user host) tuples allowed to access. +It checks for mounted media devices." + ;; SERVICE might be encoded as a DNS-SD service. + (and (string-match tramp-dns-sd-service-regexp service) + (setq service (match-string 1 service))) + (mapcar + (lambda (key) + (and (tramp-media-device-p key) + (string-equal service (tramp-media-device-method key)) + (tramp-get-connection-property key "vector" nil) + (list nil (tramp-file-name-host + (tramp-get-connection-property key "vector" nil))))) + (hash-table-keys tramp-cache-data))) + ;; D-Bus zeroconf functions. @@ -2080,39 +2457,62 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (list user host))) result)))) -;; Add completion functions for AFP, DAV, DAVS, SFTP and SMB methods. (when tramp-gvfs-enabled - ;; Suppress D-Bus error messages. - (let (tramp-gvfs-dbus-event-vector) + ;; Suppress D-Bus error messages and Tramp traces. + (let ((tramp-verbose 0) + tramp-gvfs-dbus-event-vector fun) + ;; Add completion functions for services announced by DNS-SD. + ;; See <http://www.dns-sd.org/ServiceTypes.html> for valid service types. (zeroconf-init tramp-gvfs-zeroconf-domain) - (if (zeroconf-list-service-types) - (progn - (tramp-set-completion-function - "afp" '((tramp-zeroconf-parse-device-names "_afpovertcp._tcp"))) - (tramp-set-completion-function - "dav" '((tramp-zeroconf-parse-device-names "_webdav._tcp"))) - (tramp-set-completion-function - "davs" '((tramp-zeroconf-parse-device-names "_webdav._tcp"))) - (tramp-set-completion-function - "sftp" '((tramp-zeroconf-parse-device-names "_ssh._tcp") - (tramp-zeroconf-parse-device-names "_workstation._tcp"))) - (when (member "smb" tramp-gvfs-methods) - (tramp-set-completion-function - "smb" '((tramp-zeroconf-parse-device-names "_smb._tcp"))))) - - (when (executable-find "avahi-browse") + (when (setq fun (or (and (zeroconf-list-service-types) + #'tramp-zeroconf-parse-device-names) + (and (executable-find "avahi-browse") + #'tramp-gvfs-parse-device-names))) + (when (member "afp" tramp-gvfs-methods) + (tramp-set-completion-function + "afp" `((,fun "_afpovertcp._tcp")))) + (when (member "dav" tramp-gvfs-methods) + (tramp-set-completion-function + "dav" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "davs" tramp-gvfs-methods) + (tramp-set-completion-function + "davs" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "ftp" tramp-gvfs-methods) + (tramp-set-completion-function + "ftp" `((,fun "_ftp._tcp")))) + (when (member "http" tramp-gvfs-methods) (tramp-set-completion-function - "afp" '((tramp-gvfs-parse-device-names "_afpovertcp._tcp"))) + "http" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "https" tramp-gvfs-methods) (tramp-set-completion-function - "dav" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "https" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "sftp" tramp-gvfs-methods) (tramp-set-completion-function - "davs" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "sftp" `((,fun "_sftp-ssh._tcp") + (,fun "_ssh._tcp") + (,fun "_workstation._tcp")))) + (when (member "smb" tramp-gvfs-methods) (tramp-set-completion-function - "sftp" '((tramp-gvfs-parse-device-names "_ssh._tcp") - (tramp-gvfs-parse-device-names "_workstation._tcp"))) - (when (member "smb" tramp-gvfs-methods) - (tramp-set-completion-function - "smb" '((tramp-gvfs-parse-device-names "_smb._tcp")))))))) + "smb" `((,fun "_smb._tcp"))))) + + ;; Add completion functions for GNOME Online Accounts. + (tramp-get-goa-accounts nil) + (dolist (method tramp-goa-methods) + (when (member method tramp-gvfs-methods) + (tramp-set-completion-function + method `((tramp-parse-goa-accounts ,(format "_%s._tcp" method)))))) + + ;; Add completion functions for media devices. + (tramp-get-media-devices nil) + (tramp-set-completion-function + "media" + (mapcar + (lambda (method) `(tramp-parse-media-names ,(format "_%s._tcp" method))) + tramp-media-methods)))) (add-hook 'tramp-unload-hook (lambda () @@ -2125,7 +2525,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." ;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. ;; ;; * Host name completion for existing mount points (afp-server, -;; smb-server, google-drive, nextcloud) or via smb-network or network. +;; smb-server) or via smb-network or network. ;; ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 9f539850139..445098a5bca 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -157,10 +157,9 @@ Operations not mentioned here will be handled by the default Emacs primitives.") "Invoke the rclone handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (tramp--with-startup @@ -220,7 +219,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and t1 (not (tramp-rclone-file-name-p filename))) @@ -271,8 +270,8 @@ file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -429,8 +428,8 @@ file names." (defun tramp-rclone-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -564,7 +563,7 @@ connection if a previous connection has died for some reason." ,(tramp-rclone-mount-point vec) ;; This could be nil. ,(tramp-get-method-parameter vec 'tramp-mount-args)))) - (while (not (file-exists-p (tramp-make-tramp-file-name vec 'localname))) + (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) (tramp-cleanup-connection vec 'keep-debug 'keep-password)) ;; Mark it as connected. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index af97328b3d3..5a3abc31ea6 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -491,8 +491,8 @@ The string is used in `tramp-methods'.") For every remote host, this variable will be set buffer local, keeping the list of existing directories on that host. -You can use `~' in this list, but when searching for a shell which groks -tilde expansion, all directory names starting with `~' will be ignored. +You can use \"~\" in this list, but when searching for a shell which groks +tilde expansion, all directory names starting with \"~\" will be ignored. `Default Directories' represent the list of directories given by the command \"getconf PATH\". It is recommended to use this @@ -537,12 +537,13 @@ based on the Tramp and Emacs versions, and should not be set here." ;;;###tramp-autoload (defcustom tramp-sh-extra-args - '(("/bash\\'" . "-norc -noprofile") + '(("/bash\\'" . "-noediting -norc -noprofile") ("/zsh\\'" . "-f +Z -V")) "Alist specifying extra arguments to pass to the remote shell. Entries are (REGEXP . ARGS) where REGEXP is a regular expression matching the shell file name and ARGS is a string specifying the -arguments. +arguments. These arguments shall disable line editing, see +`tramp-open-shell'. This variable is only used when Tramp needs to start up another shell for tilde expansion. The extra arguments should typically prevent the @@ -866,8 +867,12 @@ Escape sequence %s is replaced with name of Perl binary.") "Perl program to use for decoding a file. Escape sequence %s is replaced with name of Perl binary.") +(defconst tramp-hexdump-encode "%h -v -e '16/1 \" %%02x\" \"\\n\"'" + "`hexdump' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + (defconst tramp-awk-encode - "od -v -t x1 -A n | busybox awk '\\ + "%a '\\ BEGIN { b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" b16 = \"0123456789abcdef\" @@ -897,11 +902,25 @@ END { } printf tail }'" - "Awk program to use for encoding a file. + "`awk' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-hexdump-awk-encode + (format "%s | %s" tramp-hexdump-encode tramp-awk-encode) + "`hexdump' / `awk' pipe to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-od-encode "%o -v -t x1 -A n" + "`od' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-od-awk-encode + (format "%s | %s" tramp-od-encode tramp-awk-encode) + "`od' / `awk' pipe to use for encoding a file. This string is passed to `format', so percent characters need to be doubled.") (defconst tramp-awk-decode - "busybox awk '\\ + "%a '\\ BEGIN { b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" } @@ -926,12 +945,6 @@ BEGIN { "Awk program to use for decoding a file. This string is passed to `format', so percent characters need to be doubled.") -(defconst tramp-awk-coding-test - "test -c /dev/zero && \ -od -v -t x1 -A n </dev/null && \ -busybox awk '{}' </dev/null" - "Test command for checking `tramp-awk-encode' and `tramp-awk-decode'.") - (defconst tramp-vc-registered-read-file-names "echo \"(\" while read file; do @@ -1051,9 +1064,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1104,8 +1115,7 @@ component is used as the target of the symlink." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -1190,9 +1200,9 @@ component is used as the target of the symlink." (tramp-error v 'file-error "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result + (setq result (reverse result) + ;; Combine list to form string. + result (if result (string-join (cons "" result) "/") "/")) (when (string-empty-p result) (setq result "/"))))) @@ -1263,8 +1273,8 @@ component is used as the target of the symlink." (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) "Implement `file-attributes' for Tramp files using the ls(1) command." (let (symlinkp dirp - res-inode res-filemodes res-numlinks - res-uid res-gid res-size res-symlink-target) + res-inode res-filemodes res-numlinks + res-uid res-gid res-size res-symlink-target) (tramp-message vec 5 "file attributes with ls: %s" localname) ;; We cannot send all three commands combined, it could exceed ;; NAME_MAX or PATH_MAX. Happened on macOS, for example. @@ -1948,7 +1958,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" ;; scp or rsync DTRT. (progn (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) (setq dirname (directory-file-name (expand-file-name dirname)) newname (directory-file-name (expand-file-name newname))) @@ -1978,8 +1988,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" "Like `rename-file' for Tramp files." ;; Check if both files are local -- invoke normal rename-file. ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -2030,7 +2040,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -2171,8 +2181,8 @@ the uid and gid from FILENAME." v 'file-error "Unknown operation `%s', must be `copy' or `rename'" op)))) - (localname1 (tramp-compat-file-local-name filename)) - (localname2 (tramp-compat-file-local-name newname)) + (localname1 (tramp-file-local-name filename)) + (localname2 (tramp-file-local-name newname)) (prefix (file-remote-p (if t1 filename newname))) cmd-result) (when (and (eq op 'copy) (file-directory-p filename)) @@ -2714,7 +2724,7 @@ The method used must be an out-of-band method." (when (file-symlink-p filename) (goto-char (search-backward "->" beg 'noerror))) (search-backward - (if (tramp-compat-directory-name-p filename) + (if (directory-name-p filename) "." (file-name-nondirectory filename)) beg 'noerror) @@ -2724,12 +2734,11 @@ The method used must be an out-of-band method." (goto-char (point-min)) ;; First find the line to put it on. (when (re-search-forward "^\\([[:space:]]*total\\)" nil t) - (let ((available (get-free-disk-space "."))) - (when available - ;; Replace "total" with "total used", to avoid confusion. - (replace-match "\\1 used in directory") - (end-of-line) - (insert " available " available)))) + (when-let ((available (get-free-disk-space "."))) + ;; Replace "total" with "total used", to avoid confusion. + (replace-match "\\1 used in directory") + (end-of-line) + (insert " available " available))) (goto-char (point-max))))))) @@ -2796,8 +2805,11 @@ the result will be a local, non-Tramp, file name." ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. +;; The complete STDERR buffer is available only when the process has +;; terminated. (defun tramp-sh-handle-make-process (&rest args) - "Like `make-process' for Tramp files." + "Like `make-process' for Tramp files. +STDERR can also be a file name." (when args (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let ((name (plist-get args :name)) @@ -2829,14 +2841,23 @@ the result will be a local, non-Tramp, file name." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) (let* ((buffer (if buffer (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) - (stderr (and stderr (get-buffer-create stderr))) - (tmpstderr (and stderr (tramp-make-tramp-temp-file v))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) (args (cdr command)) ;; When PROGRAM matches "*sh", and the first arg is @@ -2965,21 +2986,35 @@ the result will be a local, non-Tramp, file name." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) ;; Provide error buffer. This shows only ;; initial error messages; messages arriving - ;; later on shall be inserted by `auto-revert'. - ;; The temporary file will still be existing. - ;; TODO: Write a sentinel, which deletes the - ;; temporary file. - (when tmpstderr - ;; We must flush them here already; otherwise - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") + ;; later on will be inserted when the process is + ;; deleted. The temporary file will exist until + ;; the process is deleted. + (when (bufferp stderr) (with-current-buffer stderr - (insert-file-contents - (tramp-make-tramp-file-name v tmpstderr) 'visit) - (auto-revert-mode))) + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) ;; Return process. p))) @@ -3028,7 +3063,7 @@ the result will be a local, non-Tramp, file name." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input 'nohop)) @@ -3059,8 +3094,7 @@ the result will be a local, non-Tramp, file name." (setcar (cdr destination) (expand-file-name (cadr destination))) (if (tramp-equal-remote default-directory (cadr destination)) ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) + (setq stderr (tramp-file-local-name (cadr destination))) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) @@ -3122,7 +3156,7 @@ the result will be a local, non-Tramp, file name." (append (tramp-get-remote-path (tramp-dissect-file-name default-directory)) ;; The equivalent to `exec-directory'. - `(,(tramp-compat-file-local-name default-directory)))) + `(,(tramp-file-local-name (expand-file-name default-directory))))) (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." @@ -3468,8 +3502,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sh-handle-vc-registered (file) "Like `vc-registered' for Tramp files." (when vc-handled-backends - (let ((tramp-message-show-message - (and (not revert-buffer-in-progress-p) tramp-message-show-message)) + (let ((inhibit-message (or revert-buffer-in-progress-p inhibit-message)) (temp-message (unless revert-buffer-in-progress-p ""))) (with-temp-message temp-message (with-parsed-tramp-file-name file nil @@ -3559,10 +3592,9 @@ the result will be a local, non-Tramp, file name." (defun tramp-sh-file-name-handler (operation &rest args) "Invoke remote-shell Tramp file name handler. Fall back to normal file name handler if no Tramp handler exists." - (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload @@ -3921,7 +3953,7 @@ hosts, or files, disagree." First arg VEC specifies the connection, PROGNAME is the program to search for, and DIRLIST gives the list of directories to search. If IGNORE-TILDE is non-nil, directory names starting -with `~' will be ignored. If IGNORE-PATH is non-nil, searches +with \"~\" will be ignored. If IGNORE-PATH is non-nil, searches only in DIRLIST. Returns the absolute file name of PROGNAME, if found, and nil otherwise. @@ -3947,8 +3979,8 @@ This function expects to be in the right *tramp* buffer." ;; Remove all ~/foo directories from dirlist. (let (newdl d) (while dirlist - (setq d (car dirlist)) - (setq dirlist (cdr dirlist)) + (setq d (car dirlist) + dirlist (cdr dirlist)) (unless (char-equal ?~ (aref d 0)) (setq newdl (cons d newdl)))) (setq dirlist (nreverse newdl)))) @@ -3995,8 +4027,7 @@ variable PATH." (setq tmpfile (tramp-make-tramp-file-name vec (tramp-make-tramp-temp-file vec))) (write-region command nil tmpfile) - (tramp-send-command - vec (format ". %s" (tramp-compat-file-local-name tmpfile))) + (tramp-send-command vec (format ". %s" (tramp-file-local-name tmpfile))) (delete-file tmpfile)))) ;; ------------------------------------------------------------ @@ -4072,7 +4103,28 @@ file exists and nonzero exit status otherwise." (with-tramp-progress-reporter vec 5 (format-message "Opening remote shell `%s'" shell) ;; Find arguments for this shell. - (let ((extra-args (tramp-get-sh-extra-args shell))) + (let ((extra-args (tramp-get-sh-extra-args shell)) + (p (tramp-get-connection-process vec))) + ;; The readline library can disturb Tramp. For example, the + ;; very recent version of libedit, the *BSD implementation of + ;; readline, confuses Tramp. So we disable line editing. Since + ;; $EDITRC is not supported on all target systems, we must move + ;; ~/.editrc temporarily somewhere else. For bash and zsh we + ;; have disabled this already during shell invocation, see + ;; `tramp-sh-extra-args' (Bug#39399). + ;; The shell prompt might not be set yet, so we must read any + ;; prompt via `tramp-barf-if-no-shell-prompt'. + (unless extra-args + (tramp-send-command vec "rm -f ~/.editrc.tramp" t t) + (tramp-barf-if-no-shell-prompt p 10 "Couldn't find remote shell prompt") + (tramp-send-command + vec "test -e ~/.editrc && mv -f ~/.editrc ~/.editrc.tramp" t t) + (tramp-barf-if-no-shell-prompt p 10 "Couldn't find remote shell prompt") + (tramp-send-command vec "echo 'edit off' >~/.editrc" t t) + (tramp-barf-if-no-shell-prompt + p 10 "Couldn't find remote shell prompt")) + ;; It is useful to set the prompt in the following command + ;; because some people have a setting for $PS1 which /bin/sh ;; doesn't know about and thus /bin/sh will display a strange ;; prompt. For example, if $PS1 has "${CWD}" in the value, then ;; ksh will display the current working directory but /bin/sh @@ -4106,6 +4158,11 @@ file exists and nonzero exit status otherwise." (tramp-shell-quote-argument tramp-end-of-output) shell (or extra-args "")) t) + ;; Reset ~/.editrc. + (unless extra-args + (tramp-send-command vec "rm -f ~/.editrc" t) + (tramp-send-command + vec "test -e ~/.editrc.tramp && mv -f ~/.editrc.tramp ~/.editrc" t)) ;; Check proper HISTFILE setting. We give up when not working. (when (and (stringp tramp-histfile-override) (file-name-directory tramp-histfile-override)) @@ -4383,7 +4440,7 @@ and end of region, and are expected to replace the region contents with the encoded or decoded results, respectively.") (defconst tramp-remote-coding-commands - `((b64 "base64" "base64 -d -i") + '((b64 "base64" "base64 -d -i") ;; "-i" is more robust with older base64 from GNU coreutils. ;; However, I don't know whether all base64 versions do supports ;; this option. @@ -4394,8 +4451,9 @@ with the encoded or decoded results, respectively.") (b64 "recode data..base64" "recode base64..data") (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) (b64 tramp-perl-encode tramp-perl-decode) - ;; This is painful slow, so we put it on the end. - (b64 tramp-awk-encode tramp-awk-decode ,tramp-awk-coding-test) + ;; These are painfully slow, so we put them on the end. + (b64 tramp-hexdump-awk-encode tramp-awk-decode) + (b64 tramp-od-awk-encode tramp-awk-decode) (uu "uuencode xxx" "uudecode -o /dev/stdout" "test -c /dev/stdout") (uu "uuencode xxx" "uudecode -o -") (uu "uuencode xxx" "uudecode -p") @@ -4421,6 +4479,8 @@ Perl or Shell implementation for this functionality. This program will be transferred to the remote host, and it is available as shell function with the same name. A \"%t\" format specifier in the variable value denotes a temporary file. +\"%a\", \"%h\" and \"%o\" format specifiers are replaced by the +respective `awk', `hexdump' and `od' commands. The optional TEST command can be used for further tests, whether ENCODING and DECODING are applicable.") @@ -4439,8 +4499,8 @@ Goes through the list `tramp-local-coding-commands' and (catch 'wont-work-local (let ((format (nth 0 litem)) (remote-commands tramp-remote-coding-commands)) - (setq loc-enc (nth 1 litem)) - (setq loc-dec (nth 2 litem)) + (setq loc-enc (nth 1 litem) + loc-dec (nth 2 litem)) ;; If the local encoder or decoder is a string, the ;; corresponding command has to work locally. (if (not (stringp loc-enc)) @@ -4462,20 +4522,15 @@ Goes through the list `tramp-local-coding-commands' and (setq ritem (pop remote-commands)) (catch 'wont-work-remote (when (equal format (nth 0 ritem)) - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq rem-test (nth 3 ritem)) + (setq rem-enc (nth 1 ritem) + rem-dec (nth 2 ritem) + rem-test (nth 3 ritem)) ;; Check the remote test command if exists. (when (stringp rem-test) (tramp-message vec 5 "Checking remote test command `%s'" rem-test) (unless (tramp-send-command-and-check vec rem-test t) (throw 'wont-work-remote nil))) - ;; Check if remote perl exists when necessary. - (when (and (symbolp rem-enc) - (string-match-p "perl" (symbol-name rem-enc)) - (not (tramp-get-remote-perl vec))) - (throw 'wont-work-remote nil)) ;; Check if remote encoding and decoding commands can be ;; called remotely with null input and output. This makes ;; sure there are no syntax errors and the command is really @@ -4485,10 +4540,36 @@ Goes through the list `tramp-local-coding-commands' and ;; redirecting "mimencode" output to /dev/null, then as root ;; it might change the permissions of /dev/null! (unless (stringp rem-enc) - (let ((name (symbol-name rem-enc))) + (let ((name (symbol-name rem-enc)) + (value (symbol-value rem-enc))) + ;; Check if remote perl exists when necessary. + (and (string-match-p "perl" name) + (not (tramp-get-remote-perl vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote awk exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%a" value) + (not (tramp-get-remote-awk vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote hexdump exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%h" value) + (not (tramp-get-remote-hexdump vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote od exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%o" value) + (not (tramp-get-remote-od vec)) + (throw 'wont-work-remote nil)) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value rem-enc) name) + (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value) + (setq value + (format-spec + value + (format-spec-make + ?a (tramp-get-remote-awk vec) + ?h (tramp-get-remote-hexdump vec) + ?o (tramp-get-remote-od vec))) + value (replace-regexp-in-string "%" "%%" value))) + (tramp-maybe-send-script vec value name) (setq rem-enc name))) (tramp-message vec 5 @@ -4503,6 +4584,15 @@ Goes through the list `tramp-local-coding-commands' and tmpfile) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) + (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value) + (setq value + (format-spec + value + (format-spec-make + ?a (tramp-get-remote-awk vec) + ?h (tramp-get-remote-hexdump vec) + ?o (tramp-get-remote-od vec))) + value (replace-regexp-in-string "%" "%%" value))) (when (string-match-p "\\(^\\|[^%]\\)%t" value) (setq tmpfile (make-temp-name @@ -4513,7 +4603,7 @@ Goes through the list `tramp-local-coding-commands' and (format-spec value (format-spec-make - ?t (tramp-compat-file-local-name tmpfile))))) + ?t (tramp-file-local-name tmpfile))))) (tramp-maybe-send-script vec value name) (setq rem-dec name))) (tramp-message @@ -4531,9 +4621,9 @@ Goes through the list `tramp-local-coding-commands' and (throw 'wont-work-remote nil))) ;; `rem-enc' and `rem-dec' could be a string meanwhile. - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq found t))))))) + (setq rem-enc (nth 1 ritem) + rem-dec (nth 2 ritem) + found t))))))) (when found ;; Set connection properties. Since the commands are risky @@ -4796,7 +4886,7 @@ If there is just some editing, retry it after 5 seconds." vec 5 "Cannot timeout session, trying it again in %s seconds." 5) (run-at-time 5 nil 'tramp-timeout-session vec)) (tramp-message - vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'localname)) + vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'noloc)) (tramp-cleanup-connection vec 'keep-debug))) (defun tramp-maybe-open-connection (vec) @@ -4818,11 +4908,8 @@ connection if a previous connection has died for some reason." (not (tramp-file-name-equal-p vec (car tramp-current-connection))) (time-less-p - ;; `current-time' can be removed once we get rid of Emacs 24. - (time-since (or (cdr tramp-current-connection) (current-time))) - ;; `seconds-to-time' can be removed once we get rid - ;; of Emacs 24. - (seconds-to-time (or tramp-connection-min-time-diff 0)))) + (time-since (cdr tramp-current-connection)) + (or tramp-connection-min-time-diff 0))) (throw 'suppress 'suppress)) ;; If too much time has passed since last command was sent, look @@ -4833,11 +4920,9 @@ connection if a previous connection has died for some reason." ;; try to send a command from time to time, then look again ;; whether the process is really alive. (condition-case nil - ;; `seconds-to-time' can be removed once we get rid of Emacs 24. - (when (and (time-less-p (seconds-to-time 60) - (time-since - (tramp-get-connection-property - p "last-cmd-time" (seconds-to-time 0)))) + (when (and (time-less-p + 60 (time-since + (tramp-get-connection-property p "last-cmd-time" 0))) (process-live-p p)) (tramp-send-command vec "echo are you awake" t t) (unless (and (process-live-p p) @@ -5594,7 +5679,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "%s -t %s %s" result (format-time-string "%Y%m%d%H%M.%S") - (tramp-compat-file-local-name tmpfile)))) + (tramp-file-local-name tmpfile)))) (delete-file tmpfile)) result))) @@ -5769,6 +5854,47 @@ ID-FORMAT valid values are `string' and `integer'." tramp-unknown-id-string) (t res))))) +(defun tramp-get-remote-busybox (vec) + "Determine remote `busybox' command." + (with-tramp-connection-property vec "busybox" + (tramp-message vec 5 "Finding a suitable `busybox' command") + (tramp-find-executable vec "busybox" (tramp-get-remote-path vec)))) + +(defun tramp-get-remote-awk (vec) + "Determine remote `awk' command." + (with-tramp-connection-property vec "awk" + (tramp-message vec 5 "Finding a suitable `awk' command") + (or (tramp-find-executable vec "awk" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "awk"))) + (and busybox + (tramp-send-command-and-check + vec (concat command " {} </dev/null")) + command))))) + +(defun tramp-get-remote-hexdump (vec) + "Determine remote `hexdump' command." + (with-tramp-connection-property vec "hexdump" + (tramp-message vec 5 "Finding a suitable `hexdump' command") + (or (tramp-find-executable vec "hexdump" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "hexdump"))) + (and busybox + (tramp-send-command-and-check vec (concat command " </dev/null")) + command))))) + +(defun tramp-get-remote-od (vec) + "Determine remote `od' command." + (with-tramp-connection-property vec "od" + (tramp-message vec 5 "Finding a suitable `od' command") + (or (tramp-find-executable vec "od" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "od"))) + (and busybox + (tramp-send-command-and-check + vec (concat command " -A n </dev/null")) + command))))) + (defun tramp-get-env-with-u-option (vec) "Check, whether the remote `env' command supports the -u option." (with-tramp-connection-property vec "env-u-option" @@ -5889,9 +6015,6 @@ function cell is returned to be applied on a buffer." ;; likely to produce long command lines, and some shells choke on ;; long command lines. ;; -;; * Don't search for perl5 and perl. Instead, only search for perl and -;; then look if it's the right version (with `perl -v'). -;; ;; * When editing a remote CVS controlled file as a different user, VC ;; gets confused about the file locking status. Try to find out why ;; the workaround doesn't work. diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index bf77ab9dee8..f02be394a7b 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -329,10 +329,9 @@ This can be used to disable echo etc." "Invoke the SMB related OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-smb-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-smb-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (unless (memq system-type '(cygwin windows-nt)) @@ -420,7 +419,7 @@ pass to the OPERATION." v tramp-file-missing "Copying directory" "No such file or directory" dirname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) (cond ;; We must use a local temporary directory. @@ -581,40 +580,39 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." tramp-file-missing "Copying file" "No such file or directory" filename)) - (let ((tmpfile (file-local-copy filename))) - (if tmpfile - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. + (if-let ((tmpfile (file-local-copy filename))) + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (and (file-directory-p newname) + (directory-name-p newname)) + (setq newname + (expand-file-name (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (tramp-compat-directory-name-p newname)) - (setq newname - (expand-file-name (file-name-nondirectory filename) newname))) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - (unless (tramp-smb-get-share v) - (tramp-error - v 'file-error "Target `%s' must contain a share name" newname)) - (unless (tramp-smb-send-command - v (format "put \"%s\" \"%s\"" - (tramp-compat-file-name-unquote filename) - (tramp-smb-get-localname v))) - (tramp-error - v 'file-error "Cannot copy `%s' to `%s'" filename newname)))))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (tramp-smb-get-share v) + (tramp-error + v 'file-error "Target `%s' must contain a share name" newname)) + (unless (tramp-smb-send-command + v (format "put \"%s\" \"%s\"" + (tramp-compat-file-name-unquote filename) + (tramp-smb-get-localname v))) + (tramp-error + v 'file-error "Cannot copy `%s' to `%s'" filename newname))))) ;; KEEP-DATE handling. (when keep-date @@ -1003,7 +1001,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq filename (expand-file-name filename)) (unless switches (setq switches "")) ;; Mark trailing "/". - (when (and (tramp-compat-directory-name-p filename) + (when (and (directory-name-p filename) (not full-directory-p)) (setq switches (concat switches "F"))) (if full-directory-p @@ -1188,9 +1186,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1244,7 +1240,7 @@ component is used as the target of the symlink." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input)) @@ -1357,7 +1353,7 @@ component is used as the target of the symlink." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -1924,11 +1920,9 @@ If ARGUMENT is non-nil, use it as argument for ;; connection timeout. (with-current-buffer buf (goto-char (point-min)) - ;; `seconds-to-time' can be removed once we get rid of Emacs 24. - (when (and (time-less-p (seconds-to-time 60) - (time-since - (tramp-get-connection-property - p "last-cmd-time" (seconds-to-time 0)))) + (when (and (time-less-p + 60 (time-since + (tramp-get-connection-property p "last-cmd-time" 0))) (process-live-p p) (re-search-forward tramp-smb-errors nil t)) (delete-process p) @@ -1994,7 +1988,7 @@ If ARGUMENT is non-nil, use it as argument for (set-process-query-on-exit-flag p nil) (condition-case err - (let (tramp-message-show-message) + (let ((inhibit-message t)) ;; Play login scenario. (tramp-process-actions p vec nil @@ -2132,7 +2126,5 @@ Removes smb prompt. Returns nil if an error message has appeared." ;; ;; * Try to remove the inclusion of dummy "" directory. Seems to be at ;; several places, especially in `tramp-smb-handle-insert-directory'. -;; -;; * Ignore case in file names. ;;; tramp-smb.el ends here diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 08188cefde3..f258ad6b931 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -153,10 +153,9 @@ See `tramp-actions-before-shell' for more info.") "Invoke the SUDOEDIT handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (tramp--with-startup @@ -248,7 +247,7 @@ absolute file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and (file-remote-p filename) (not t1)) @@ -265,10 +264,8 @@ absolute file names." v 0 (format "%s %s to %s" msg-operation filename newname) (unless (tramp-sudoedit-send-command v sudoedit-operation - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name filename)) - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name newname))) + (tramp-unquote-file-local-name filename) + (tramp-unquote-file-local-name newname)) (tramp-error v 'file-error "Error %s `%s' `%s'" msg-operation filename newname)))) @@ -305,8 +302,8 @@ absolute file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -543,8 +540,7 @@ the result will be a local, non-Tramp, file name." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -615,9 +611,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -646,8 +640,8 @@ component is used as the target of the symlink." (defun tramp-sudoedit-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -715,8 +709,7 @@ ID-FORMAT valid values are `string' and `integer'." (format "%d:%d" (or uid (tramp-sudoedit-get-remote-uid v 'integer)) (or gid (tramp-sudoedit-get-remote-gid v 'integer))) - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name filename))))) + (tramp-unquote-file-local-name filename)))) (defun tramp-sudoedit-handle-write-region (start end filename &optional append visit lockname mustbenew) diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el index 6a044e58840..f368f72a8dc 100644 --- a/lisp/net/tramp-uu.el +++ b/lisp/net/tramp-uu.el @@ -94,8 +94,3 @@ (provide 'tramp-uu) ;;; tramp-uu.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 0ad65fb8bd0..409e1f7499a 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.4.3 -;; Package-Requires: ((emacs "24.4")) +;; Version: 2.5.0-pre +;; Package-Requires: ((emacs "25.1")) ;; Package-Type: multi ;; URL: https://savannah.gnu.org/projects/tramp @@ -1258,7 +1258,7 @@ calling HANDLER.") ;; data structure. ;; The basic structure for remote file names. We use a list :type, -;; in order to be compatible with Emacs 24 and 25. +;; in order to be compatible with Emacs 25. (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1306,9 +1306,10 @@ entry does not exist, return nil." ;; We use the cached property. (tramp-get-connection-property vec hash-entry nil) ;; Use the static value from `tramp-methods'. - (let ((methods-entry - (assoc param (assoc (tramp-file-name-method vec) tramp-methods)))) - (when methods-entry (cadr methods-entry)))))) + (when-let ((methods-entry + (assoc + param (assoc (tramp-file-name-method vec) tramp-methods)))) + (cadr methods-entry))))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-file-name-unquote-localname (vec) @@ -1347,6 +1348,11 @@ of `process-file', `start-file-process', or `shell-command'." (match-string (nth 4 tramp-file-name-structure) name)) (tramp-compat-file-local-name name))) +;; The localname can be quoted with "/:". Extract this. +(defun tramp-unquote-file-local-name (name) + "Return unquoted localname of NAME." + (tramp-compat-file-name-unquote (tramp-file-local-name name))) + (defun tramp-find-method (method user host) "Return the right method string to use depending on USER and HOST. This is METHOD, if non-nil. Otherwise, do a lookup in @@ -1363,8 +1369,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or host "")) (string-match-p (or (nth 1 item) "") (or user ""))) - (setq lmethod (nth 2 item)) - (setq choices nil))) + (setq lmethod (nth 2 item) + choices nil))) lmethod) tramp-default-method))) ;; We must mark, whether a default value has been used. @@ -1384,8 +1390,8 @@ This is USER, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or method "")) (string-match-p (or (nth 1 item) "") (or host ""))) - (setq luser (nth 2 item)) - (setq choices nil))) + (setq luser (nth 2 item) + choices nil))) luser) tramp-default-user))) ;; We must mark, whether a default value has been used. @@ -1405,8 +1411,8 @@ This is HOST, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or method "")) (string-match-p (or (nth 1 item) "") (or user ""))) - (setq lhost (nth 2 item)) - (setq choices nil))) + (setq lhost (nth 2 item) + choices nil))) lhost) tramp-default-host))) ;; We must mark, whether a default value has been used. @@ -1468,7 +1474,7 @@ default values are used." :method method :user user :domain domain :host host :port port :localname localname :hop hop)) ;; The method must be known. - (unless (or nodefault (tramp-completion-mode-p) + (unless (or nodefault non-essential (string-equal method tramp-default-method-marker) (assoc method tramp-methods)) (tramp-user-error @@ -1592,7 +1598,7 @@ necessary only. This function will be used in file name completion." tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) host) tramp-postfix-host-format)) - (when localname localname))) + localname)) (defun tramp-get-buffer (vec &optional dont-create) "Get the connection buffer to be used for VEC. @@ -1648,7 +1654,7 @@ version, the function does nothing." "Set connection-local variables in the current buffer. If connection-local variables are not supported by this Emacs version, the function does nothing." - (when (file-remote-p default-directory) + (when (tramp-tramp-file-p default-directory) ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. (tramp-compat-funcall 'hack-connection-local-variables-apply @@ -1744,29 +1750,10 @@ ARGUMENTS to actually emit the message (if applicable)." (setq btf (nth 1 (backtrace-frame btn))) (if (not btf) (setq fn "") - (when (symbolp btf) - (setq fn (symbol-name btf)) - (unless - (and - (string-match-p "^tramp" fn) - (not - (string-match-p - (eval-when-compile - (concat - "^" - (regexp-opt - '("tramp-backtrace" - "tramp-compat-funcall" - "tramp-debug-message" - "tramp-error" - "tramp-error-with-buffer" - "tramp-message" - "tramp-signal-hook-function" - "tramp-user-error") - t) - "$")) - fn))) - (setq fn nil))) + (and (symbolp btf) (setq fn (symbol-name btf)) + (or (not (string-match-p "^tramp" fn)) + (get btf 'tramp-suppress-trace)) + (setq fn nil)) (setq btn (1+ btn)))) ;; The following code inserts filename and line number. Should ;; be inactive by default, because it is time consuming. @@ -1781,11 +1768,7 @@ ARGUMENTS to actually emit the message (if applicable)." ;; The message. (insert (apply #'format-message fmt-string arguments)))) -(defvar tramp-message-show-message (null noninteractive) - "Show Tramp message in the minibuffer. -This variable is used to suppress progress reporter output, and -to disable messages from `tramp-error'. Those messages are -visible anyway, because an error is raised.") +(put #'tramp-debug-message 'tramp-suppress-trace t) (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. @@ -1803,7 +1786,7 @@ applicable)." (ignore-errors (when (<= level tramp-verbose) ;; Display only when there is a minimum level. - (when (and tramp-message-show-message (<= level 3)) + (when (<= level 3) (apply #'message (concat (cond @@ -1835,6 +1818,8 @@ applicable)." (concat (format "(%d) # " level) fmt-string) arguments)))))) +(put #'tramp-message 'tramp-suppress-trace t) + (defsubst tramp-backtrace (&optional vec-or-proc) "Dump a backtrace into the debug buffer. If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This @@ -1845,13 +1830,16 @@ function is meant for debugging purposes." vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) +(put #'tramp-backtrace 'tramp-suppress-trace t) + (defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) "Emit an error. VEC-OR-PROC identifies the connection to use, SIGNAL is the signal identifier to be raised, remaining arguments passed to `tramp-message'. Finally, signal SIGNAL is raised with FMT-STRING and ARGUMENTS." - (let (tramp-message-show-message signal-hook-function) + (let ((inhibit-message t) + signal-hook-function) (tramp-backtrace vec-or-proc) (unless arguments ;; FMT-STRING could be just a file name, as in @@ -1869,6 +1857,8 @@ FMT-STRING and ARGUMENTS." (signal signal (list (substring-no-properties (apply #'format-message fmt-string arguments)))))) +(put #'tramp-error 'tramp-suppress-trace t) + (defsubst tramp-error-with-buffer (buf vec-or-proc signal fmt-string &rest arguments) "Emit an error, and show BUF. @@ -1886,13 +1876,13 @@ an input event arrives. The other arguments are passed to `tramp-error'." (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. (when (and buf - tramp-message-show-message (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. - (not (tramp-completion-mode-p)) + (not non-essential) ;; Show only when Emacs has started already. (current-message)) - (let ((enable-recursive-minibuffers t)) + (let ((enable-recursive-minibuffers t) + inhibit-message) ;; `tramp-error' does not show messages. So we must do it ;; ourselves. (apply #'message fmt-string arguments) @@ -1904,19 +1894,21 @@ an input event arrives. The other arguments are passed to `tramp-error'." (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +(put #'tramp-error-with-buffer 'tramp-suppress-trace t) + ;; We must make it a defun, because it is used earlier already. (defun tramp-user-error (vec-or-proc fmt-string &rest arguments) "Signal a user error (or \"pilot error\")." (unwind-protect (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) ;; Save exit. - (when (and tramp-message-show-message - (not (zerop tramp-verbose)) + (when (and (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. - (not (tramp-completion-mode-p)) + (not non-essential) ;; Show only when Emacs has started already. (current-message)) - (let ((enable-recursive-minibuffers t)) + (let ((enable-recursive-minibuffers t) + inhibit-message) ;; `tramp-error' does not show messages. So we must do it ourselves. (apply #'message fmt-string arguments) (discard-input) @@ -1926,18 +1918,21 @@ an input event arrives. The other arguments are passed to `tramp-error'." (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +(put #'tramp-user-error 'tramp-suppress-trace t) + (defmacro tramp-with-demoted-errors (vec-or-proc format &rest body) "Execute BODY while redirecting the error message to `tramp-message'. BODY is executed like wrapped by `with-demoted-errors'. FORMAT is a format-string containing a %-sequence meaning to substitute the resulting error message." - (declare (debug (symbolp body)) - (indent 2)) + (declare (indent 2) (debug (symbolp form body))) (let ((err (make-symbol "err"))) `(condition-case-unless-debug ,err (progn ,@body) (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) +(put #'tramp-with-demoted-errors 'tramp-suppress-trace t) + ;; This function provides traces in case of errors not triggered by ;; Tramp functions. (defun tramp-signal-hook-function (error-symbol data) @@ -1949,6 +1944,8 @@ the resulting error message." (car tramp-current-connection) error-symbol "%s" (mapconcat (lambda (x) (format "%s" x)) data " ")))) +(put #'tramp-signal-hook-function 'tramp-suppress-trace t) + (defmacro with-parsed-tramp-file-name (filename var &rest body) "Parse a Tramp filename and make components available in the body. @@ -1965,12 +1962,14 @@ Remaining args are Lisp expressions to be evaluated (inside an implicit If VAR is nil, then we bind `v' to the structure and `method', `user', `domain', `host', `port', `localname', `hop' to the components." + (declare (indent 2) (debug (form symbolp body))) (let ((bindings - (mapcar (lambda (elem) - `(,(if var (intern (format "%s-%s" var elem)) elem) - (,(intern (format "tramp-file-name-%s" elem)) - ,(or var 'v)))) - `,(tramp-compat-tramp-file-name-slots)))) + (mapcar + (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))))) `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename)) ,@bindings) ;; We don't know which of those vars will be used, so we bind them all, @@ -1979,8 +1978,6 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (ignore ,@(mapcar #'car bindings)) ,@body))) -(put 'with-parsed-tramp-file-name 'lisp-indent-function 2) -(put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) (defun tramp-progress-reporter-update (reporter &optional value suffix) @@ -1991,22 +1988,20 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (tramp-compat-progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) - "Execute BODY, spinning a progress reporter with MESSAGE. + "Execute BODY, spinning a progress reporter with MESSAGE in interactive mode. If LEVEL does not fit for visible messages, there are only traces without a visible progress reporter." (declare (indent 3) (debug t)) - `(progn + `(if (or noninteractive inhibit-message) + (progn ,@body) (tramp-message ,vec ,level "%s..." ,message) (let ((cookie "failed") (tm - ;; We start a pulsing progress reporter after 3 seconds. - (when (and tramp-message-show-message - ;; Display only when there is a minimum level. - (<= ,level (min tramp-verbose 3))) - (let ((pr (make-progress-reporter ,message nil nil))) - (when pr - (run-at-time - 3 0.1 #'tramp-progress-reporter-update pr)))))) + ;; We start a pulsing progress reporter after 3 + ;; seconds. Display only when there is a minimum level. + (when-let ((pr (and (<= ,level (min tramp-verbose 3)) + (make-progress-reporter ,message nil nil)))) + (run-at-time 3 0.1 #'tramp-progress-reporter-update pr)))) (unwind-protect ;; Execute the body. (prog1 (progn ,@body) (setq cookie "done")) @@ -2020,6 +2015,7 @@ without a visible progress reporter." (defmacro with-tramp-file-property (vec file property &rest body) "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. FILE must be a local file name on a connection identified via VEC." + (declare (indent 3) (debug t)) `(if (file-name-absolute-p ,file) (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) (when (eq value 'undef) @@ -2031,12 +2027,11 @@ FILE must be a local file name on a connection identified via VEC." value) ,@body)) -(put 'with-tramp-file-property 'lisp-indent-function 3) -(put 'with-tramp-file-property 'edebug-form-spec t) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>")) (defmacro with-tramp-connection-property (key property &rest body) "Check in Tramp for property PROPERTY, otherwise execute BODY and set." + (declare (indent 2) (debug t)) `(let ((value (tramp-get-connection-property ,key ,property 'undef))) (when (eq value 'undef) ;; We cannot pass ,@body as parameter to @@ -2046,8 +2041,6 @@ FILE must be a local file name on a connection identified via VEC." (tramp-set-connection-property ,key ,property value)) value)) -(put 'with-tramp-connection-property 'lisp-indent-function 2) -(put 'with-tramp-connection-property 'edebug-form-spec t) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-connection-property\\>")) @@ -2066,6 +2059,9 @@ letter into the file name. This function removes it." ;;; Config Manipulation Functions: +(defconst tramp-dns-sd-service-regexp "^_[-[:alnum:]]+\\._tcp$" + "DNS-SD service regexp.") + (defun tramp-set-completion-function (method function-list) "Set the list of completion functions for METHOD. FUNCTION-LIST is a list of entries of the form (FUNCTION FILE). @@ -2098,10 +2094,10 @@ Example: (zerop (tramp-call-process v "reg" nil nil nil "query" (nth 1 (car v)))))) - ;; Zeroconf service type. + ;; DNS-SD service type. ((string-match-p - "^_[[:alpha:]]+\\._[[:alpha:]]+$" (nth 1 (car v)))) - ;; Configuration file. + tramp-dns-sd-service-regexp (nth 1 (car v)))) + ;; Configuration file or empty string. (t (file-exists-p (nth 1 (car v)))))) (setq r (delete (car v) r))) (setq v (cdr v))) @@ -2267,10 +2263,7 @@ Must be handled by the callers." exec-path make-process)) default-directory) ;; PROC. - ((member operation - '(file-notify-rm-watch - ;; Emacs 25+ only. - file-notify-valid-p)) + ((member operation '(file-notify-rm-watch file-notify-valid-p)) (when (processp (nth 0 args)) (with-current-buffer (process-buffer (nth 0 args)) default-directory))) @@ -2390,7 +2383,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (cons operation args)) (tramp-run-real-handler operation args)) ((eq result 'suppress) - (let (tramp-message-show-message) + (let ((inhibit-message t)) (tramp-message v 1 "Suppress received in operation %s" (cons operation args)) @@ -2419,18 +2412,19 @@ Fall back to normal file name handler if no Tramp file name handler exists." (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler for OPERATION and ARGS. Falls back to normal file name handler if no Tramp file name handler exists." - (let ((fn (assoc operation tramp-completion-file-name-handler-alist))) - (if (and fn tramp-mode) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let + ((fn (and tramp-mode + (assoc operation tramp-completion-file-name-handler-alist)))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###autoload (progn (defun tramp-autoload-file-name-handler (operation &rest args) "Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) - (if tramp-mode - (let ((default-directory temporary-file-directory)) - (load "tramp" 'noerror 'nomessage))) + (when tramp-mode + (let ((default-directory temporary-file-directory)) + (load "tramp" 'noerror 'nomessage))) (apply operation args))) ;; `tramp-autoload-file-name-handler' must be registered before @@ -2442,7 +2436,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) - (put 'tramp-autoload-file-name-handler 'safe-magic t))) + (put #'tramp-autoload-file-name-handler 'safe-magic t))) ;;;###autoload (tramp-register-autoload-file-name-handlers) @@ -2483,29 +2477,28 @@ remote file names." ;; respective foreign handlers. (add-to-list 'file-name-handler-alist (cons tramp-file-name-regexp #'tramp-file-name-handler)) - (put 'tramp-file-name-handler 'safe-magic t) + (put #'tramp-file-name-handler 'safe-magic t) (add-to-list 'file-name-handler-alist (cons tramp-completion-file-name-regexp #'tramp-completion-file-name-handler)) - (put 'tramp-completion-file-name-handler 'safe-magic t) + (put #'tramp-completion-file-name-handler 'safe-magic t) ;; Mark `operations' the handler is responsible for. - (put 'tramp-completion-file-name-handler 'operations + (put #'tramp-completion-file-name-handler 'operations (mapcar #'car tramp-completion-file-name-handler-alist)) (when (bound-and-true-p tramp-archive-enabled) (add-to-list 'file-name-handler-alist (cons tramp-archive-file-name-regexp #'tramp-archive-file-name-handler)) - (put 'tramp-archive-file-name-handler 'safe-magic t)) + (put #'tramp-archive-file-name-handler 'safe-magic t)) ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. (dolist (fnh '(epa-file-handler jka-compr-handler)) - (let ((entry (rassoc fnh file-name-handler-alist))) - (when entry - (setq file-name-handler-alist - (cons entry (delete entry file-name-handler-alist))))))) + (when-let ((entry (rassoc fnh file-name-handler-alist))) + (setq file-name-handler-alist + (cons entry (delete entry file-name-handler-alist)))))) (tramp--with-startup (tramp-register-file-name-handlers)) @@ -2517,7 +2510,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (add-to-list 'tramp-foreign-file-name-handler-alist `(,func . ,handler) append) ;; Mark `operations' the handler is responsible for. - (put 'tramp-file-name-handler + (put #'tramp-file-name-handler 'operations (delete-dups (append @@ -2558,24 +2551,11 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." ;;; File name handler functions for completion mode: -;;;###autoload -(defvar tramp-completion-mode nil - "If non-nil, external packages signal that they are in file name completion.") -(make-obsolete-variable 'tramp-completion-mode 'non-essential "26.1") - -(defun tramp-completion-mode-p () - "Check, whether method / user name / host name completion is active." - (or - ;; Signal from outside. - non-essential - ;; This variable has been obsoleted in Emacs 26. - tramp-completion-mode)) - (defun tramp-connectable-p (vec-or-filename) "Check, whether it is possible to connect the remote host w/o side-effects. This is true, if either the remote host is already connected, or if we are not in completion mode." - (let (tramp-verbose + (let ((tramp-verbose 0) (vec (cond ((tramp-file-name-p vec-or-filename) vec-or-filename) @@ -2585,7 +2565,7 @@ not in completion mode." ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. (and vec (process-live-p (get-process (tramp-buffer-name vec)))) - (not (tramp-completion-mode-p))))) + (not non-essential)))) ;; Method, host name and user name completion. ;; `tramp-completion-dissect-file-name' returns a list of @@ -2864,7 +2844,7 @@ User is always nil." (let ((default-directory (tramp-compat-temporary-file-directory))) (when (file-readable-p filename) (with-temp-buffer - (insert-file-contents filename) + (insert-file-contents-literally filename) (goto-char (point-min)) (cl-loop while (not (eobp)) collect (funcall function)))))) @@ -2876,7 +2856,7 @@ Either user or host may be nil." (defun tramp-parse-rhosts-group () "Return a (user host) tuple allowed to access. Either user or host may be nil." - (let ((result) + (let (result (regexp (concat "^\\(" tramp-host-regexp "\\)" @@ -2961,7 +2941,7 @@ Host is always \"localhost\"." (defun tramp-parse-passwd-group () "Return a (user host) tuple allowed to access. Host is always \"localhost\"." - (let ((result) + (let (result (regexp (concat "^\\(" tramp-user-regexp "\\):"))) (when (re-search-forward regexp (point-at-eol) t) (setq result (list (match-string 1) "localhost"))) @@ -2983,7 +2963,7 @@ Host is always \"localhost\"." (defun tramp-parse-etc-group-group () "Return a (group host) tuple allowed to access. Host is always \"localhost\"." - (let ((result) + (let (result (split (split-string (buffer-substring (point) (point-at-eol)) ":"))) (when (member (user-login-name) (split-string (nth 3 split) "," 'omit)) (setq result (list (nth 0 split) "localhost"))) @@ -3020,7 +3000,7 @@ User is always nil." (defun tramp-parse-putty-group (registry) "Return a (user host) tuple allowed to access. User is always nil." - (let ((result) + (let (result (regexp (concat (regexp-quote registry) "\\\\\\(.+\\)"))) (when (re-search-forward regexp (point-at-eol) t) (setq result (list nil (match-string 1)))) @@ -3201,10 +3181,8 @@ User is always nil." (defun tramp-handle-file-modes (filename) "Like `file-modes' for Tramp files." - ;; Starting with Emacs 25.1, `when-let' can be used. - (let ((attrs (file-attributes (or (file-truename filename) filename)))) - (when attrs - (tramp-mode-string-to-int (tramp-compat-file-attribute-modes attrs))))) + (when-let ((attrs (file-attributes (or (file-truename filename) filename)))) + (tramp-mode-string-to-int (tramp-compat-file-attribute-modes attrs)))) ;; Localname manipulation functions that grok Tramp localnames... (defun tramp-handle-file-name-as-directory (file) @@ -3247,7 +3225,7 @@ User is always nil." ;; lower case letters. This avoids us to create a ;; temporary file. (while (and (string-match-p - "[a-z]" (tramp-compat-file-local-name candidate)) + "[a-z]" (tramp-file-local-name candidate)) (not (file-exists-p candidate))) (setq candidate (directory-file-name @@ -3257,8 +3235,7 @@ User is always nil." ;; to Emacs 26+ like `file-name-case-insensitive-p', ;; so there is no compatibility problem calling it. (unless - (string-match-p - "[a-z]" (tramp-compat-file-local-name candidate)) + (string-match-p "[a-z]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory (file-name-directory filename))) @@ -3271,7 +3248,7 @@ User is always nil." (file-exists-p (concat (file-remote-p candidate) - (upcase (tramp-compat-file-local-name candidate)))) + (upcase (tramp-file-local-name candidate)))) ;; Cleanup. (when tmpfile (delete-file tmpfile))))))))))) @@ -3323,21 +3300,18 @@ User is always nil." (cond ((not (file-exists-p file1)) nil) ((not (file-exists-p file2)) t) - (t (time-less-p (tramp-compat-file-attribute-modification-time - (file-attributes file2)) - (tramp-compat-file-attribute-modification-time - (file-attributes file1)))))) + (t (time-less-p + (tramp-compat-file-attribute-modification-time (file-attributes file2)) + (tramp-compat-file-attribute-modification-time + (file-attributes file1)))))) (defun tramp-handle-file-regular-p (filename) "Like `file-regular-p' for Tramp files." (and (file-exists-p filename) ;; Sometimes, `file-attributes' does not return a proper value ;; even if `file-exists-p' does. - (ignore-errors - (eq ?- - (aref - (tramp-compat-file-attribute-modes (file-attributes filename)) - 0))))) + (when-let ((attr (file-attributes filename))) + (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." @@ -3376,8 +3350,7 @@ User is always nil." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -3413,7 +3386,7 @@ User is always nil." (tramp-error v1 'file-error "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (tramp-compat-file-local-name (directory-file-name result))))))))) + (tramp-file-local-name (directory-file-name result))))))))) (defun tramp-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -3448,7 +3421,7 @@ User is always nil." "Like `insert-directory' for Tramp files." (unless switches (setq switches "")) ;; Mark trailing "/". - (when (and (tramp-compat-directory-name-p filename) + (when (and (directory-name-p filename) (not full-directory-p)) (setq switches (concat switches "F"))) ;; Check, whether directory is accessible. @@ -3458,7 +3431,7 @@ User is always nil." (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) (let (ls-lisp-use-insert-directory-program start) ;; Silence byte compiler. - ls-lisp-use-insert-directory-program + (ignore ls-lisp-use-insert-directory-program) (tramp-run-real-handler #'insert-directory (list filename switches wildcard full-directory-p)) @@ -3582,8 +3555,8 @@ User is always nil." ;; Save exit. (progn (when visit - (setq buffer-file-name filename) - (setq buffer-read-only (not (file-writable-p filename))) + (setq buffer-file-name filename + buffer-read-only (not (file-writable-p filename))) (set-visited-file-modtime) (set-buffer-modified-p nil)) (when (and (stringp local-copy) @@ -3617,7 +3590,7 @@ User is always nil." v tramp-file-missing "Cannot load nonexistent file `%s'" file)) (if (not (file-exists-p file)) nil - (let ((tramp-message-show-message (not nomessage))) + (let ((inhibit-message nomessage)) (with-tramp-progress-reporter v 0 (format "Loading %s" file) (let ((local-copy (file-local-copy file))) (unwind-protect @@ -3645,10 +3618,16 @@ support symbolic links." (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) (command (substring command 0 asynchronous)) current-buffer-p + (output-buffer-p output-buffer) (output-buffer (cond - ((bufferp output-buffer) output-buffer) - ((stringp output-buffer) (get-buffer-create output-buffer)) + ((bufferp output-buffer) + (setq current-buffer-p (eq (current-buffer) output-buffer)) + output-buffer) + ((stringp output-buffer) + (setq current-buffer-p + (eq (buffer-name (current-buffer)) output-buffer)) + (get-buffer-create output-buffer)) (output-buffer (setq current-buffer-p t) (current-buffer)) @@ -3660,13 +3639,19 @@ support symbolic links." (cond ((bufferp error-buffer) error-buffer) ((stringp error-buffer) (get-buffer-create error-buffer)))) + (error-file + (and error-buffer + (with-parsed-tramp-file-name default-directory nil + (tramp-make-tramp-file-name + v (tramp-make-tramp-temp-file v))))) (bname (buffer-name output-buffer)) (p (get-buffer-process output-buffer)) + (dir default-directory) buffer) ;; The following code is taken from `shell-command', slightly ;; adapted. Shouldn't it be factored out? - (when p + (when (and (integerp asynchronous) p) (cond ((eq async-shell-command-buffer 'confirm-kill-process) ;; If will kill a process, query first. @@ -3698,22 +3683,25 @@ support symbolic links." (rename-uniquely)) (setq output-buffer (get-buffer-create bname))))) - (setq buffer (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer - (tramp-make-tramp-file-name - v (tramp-make-tramp-temp-file v)))) - output-buffer)) - - (if current-buffer-p - (progn - (barf-if-buffer-read-only) - (push-mark nil t)) + (unless output-buffer-p (with-current-buffer output-buffer + (setq default-directory dir))) + + (setq buffer (if error-file (list output-buffer error-file) output-buffer)) + + (with-current-buffer output-buffer + (when current-buffer-p + (barf-if-buffer-read-only) + (push-mark nil t)) + ;; `shell-command-save-pos-or-erase' has been introduced with + ;; Emacs 27.1. + (if (fboundp 'shell-command-save-pos-or-erase) + (tramp-compat-funcall + 'shell-command-save-pos-or-erase current-buffer-p) (setq buffer-read-only nil) (erase-buffer))) - (if (and (not current-buffer-p) (integerp asynchronous)) + (if (integerp asynchronous) (let ((tramp-remote-process-environment ;; `async-shell-command-width' has been introduced with ;; Emacs 27.1. @@ -3726,42 +3714,68 @@ support symbolic links." ;; Run the process. (setq p (start-file-process-shell-command (buffer-name output-buffer) buffer command)) - ;; Display output. - (with-current-buffer output-buffer - (display-buffer output-buffer '(nil (allow-no-window . t))) - (setq mode-line-process '(":%s")) - (shell-mode) - (set-process-sentinel p #'shell-command-sentinel) - (set-process-filter p #'comint-output-filter)))) + ;; Insert error messages if they were separated. + (when error-file + (with-current-buffer error-buffer + (insert-file-contents-literally error-file))) + (if (process-live-p p) + ;; Display output. + (with-current-buffer output-buffer + (setq mode-line-process '(":%s")) + (unless (eq major-mode 'shell-mode) + (shell-mode)) + (set-process-filter p #'comint-output-filter) + (set-process-sentinel p #'shell-command-sentinel) + (when error-file + (add-function + :after (process-sentinel p) + (lambda (_proc _string) + (with-current-buffer error-buffer + (insert-file-contents-literally + error-file nil nil nil 'replace)) + (delete-file error-file)))) + (display-buffer output-buffer '(nil (allow-no-window . t)))) + + (when error-file + (delete-file error-file))))) (prog1 ;; Run the process. (process-file-shell-command command nil buffer nil) ;; Insert error messages if they were separated. - (when (listp buffer) + (when error-file (with-current-buffer error-buffer - (insert-file-contents (cadr buffer))) - (delete-file (cadr buffer))) + (insert-file-contents-literally error-file)) + (delete-file error-file)) (if current-buffer-p ;; This is like exchange-point-and-mark, but doesn't ;; activate the mark. It is cleaner to avoid activation, ;; even though the command loop would deactivate the mark ;; because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) - (current-buffer)))) + (progn + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) + (current-buffer)))) + ;; `shell-command-set-point-after-cmd' has been + ;; introduced with Emacs 27.1. + (if (fboundp 'shell-command-set-point-after-cmd) + (tramp-compat-funcall + 'shell-command-set-point-after-cmd))) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) (display-message-or-buffer output-buffer))))))) (defun tramp-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." + "Like `start-file-process' for Tramp files. +BUFFER might be a list, in this case STDERR is separated." ;; `make-process' knows the `:file-handler' argument since Emacs 27.1 only. (tramp-file-name-handler 'make-process :name name - :buffer buffer + :buffer (if (consp buffer) (car buffer) buffer) :command (and program (cons program args)) + ;; `shell-command' adds an errfile to `buffer'. + :stderr (when (consp buffer) (cadr buffer)) :noquery nil :file-handler t)) @@ -4083,9 +4097,9 @@ See `tramp-process-actions' for the format of ACTIONS." (while (tramp-accept-process-output proc 0)) (setq todo actions) (while todo - (setq item (pop todo)) - (setq pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item)))) - (setq action (nth 1 item)) + (setq item (pop todo) + pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item))) + action (nth 1 item)) (tramp-message vec 5 "Looking for regexp \"%s\" from remote shell" pattern) (when (tramp-check-for-regexp proc pattern) @@ -4135,9 +4149,8 @@ performed successfully. Any other value means an error." (catch 'tramp-action (tramp-process-one-action proc vec actions))))) (while (not exit) - (setq exit - (catch 'tramp-action - (tramp-process-one-action proc vec actions))))) + (setq exit (catch 'tramp-action + (tramp-process-one-action proc vec actions))))) (with-current-buffer (tramp-get-connection-buffer vec) (widen) (tramp-message vec 6 "\n%s" (buffer-string))) @@ -4362,7 +4375,7 @@ would yield t. On the other hand, the following check results in nil: (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\") If both files are local, the function returns t." - (or (and (null (file-remote-p file1)) (null (file-remote-p file2))) + (or (and (null (tramp-tramp-file-p file1)) (null (tramp-tramp-file-p file2))) (and (tramp-tramp-file-p file1) (tramp-tramp-file-p file2) (string-equal (file-remote-p file1) (file-remote-p file2))))) @@ -4455,9 +4468,9 @@ This is used to map a mode number to a permission string.") (suid (> (logand (ash mode -9) 4) 0)) (sgid (> (logand (ash mode -9) 2) 0)) (sticky (> (logand (ash mode -9) 1) 0))) - (setq user (tramp-file-mode-permissions user suid "s")) - (setq group (tramp-file-mode-permissions group sgid "s")) - (setq other (tramp-file-mode-permissions other sticky "t")) + (setq user (tramp-file-mode-permissions user suid "s") + group (tramp-file-mode-permissions group sgid "s") + other (tramp-file-mode-permissions other sticky "t")) (concat type user group other))) (defun tramp-file-mode-permissions (perm suid suid-text) @@ -4487,16 +4500,15 @@ If FILENAME is remote, a file name handler is called." (when (and modes (not (zerop (logand modes #o2000)))) (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) - (let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) - (if handler - (funcall handler #'tramp-set-file-uid-gid filename uid gid) - ;; On W32 systems, "chown" does not work. - (unless (memq system-type '(ms-dos windows-nt)) - (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) - (tramp-call-process - nil "chown" nil nil nil (format "%d:%d" uid gid) - (tramp-unquote-shell-quote-argument filename))))))) + (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) + (funcall handler #'tramp-set-file-uid-gid filename uid gid) + ;; On W32 systems, "chown" does not work. + (unless (memq system-type '(ms-dos windows-nt)) + (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) + (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-call-process + nil "chown" nil nil nil (format "%d:%d" uid gid) + (tramp-unquote-shell-quote-argument filename)))))) (defun tramp-get-local-uid (id-format) "The uid of the local user, in ID-FORMAT. @@ -4632,7 +4644,7 @@ This handles also chrooted environments, which are not regarded as local." (tramp-make-tramp-file-name vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) - (tramp-compat-file-local-name dir)) + (tramp-file-local-name dir)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) dir))) @@ -4655,7 +4667,7 @@ Return the local name of the temporary file." (set-file-modes result #o0700))) ;; Return the local part. - (with-parsed-tramp-file-name result nil localname))) + (tramp-file-local-name result))) (defun tramp-delete-temp-file-function () "Remove temporary files related to current buffer." @@ -4682,7 +4694,7 @@ this file, if that variable is non-nil." (let ((system-type (if (and (stringp tramp-auto-save-directory) - (file-remote-p tramp-auto-save-directory)) + (tramp-tramp-file-p tramp-auto-save-directory)) 'not-windows system-type)) (auto-save-file-name-transforms @@ -4820,11 +4832,29 @@ verbosity of 6." (tramp-message vec 6 "%s" result) result)) +(defun tramp-process-running-p (process-name) + "Return t if system process PROCESS-NAME is running for `user-login-name'." + (when (stringp process-name) + (catch 'result + (dolist (pid (tramp-compat-funcall 'list-system-processes)) + (let ((attributes (process-attributes pid))) + (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) + (when-let ((comm (cdr (assoc 'comm attributes)))) + ;; The returned command name could be truncated to 15 + ;; characters. Therefore, we cannot check for `string-equal'. + (string-prefix-p comm process-name)) + (throw 'result t))))))) + (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." - (let* ((case-fold-search t) + (let* (;; If `auth-sources' contains "~/.authinfo.gpg", and + ;; `exec-path' contains a relative file name like ".", it + ;; could happen that the "gpg" command is not found. So we + ;; adapt `default-directory'. (Bug#39389, Bug#39489) + (default-directory (tramp-compat-temporary-file-directory)) + (case-fold-search t) (key (tramp-make-tramp-file-name ;; In tramp-sh.el, we must use "password-vector" due to ;; multi-hop. @@ -4976,10 +5006,12 @@ name of a process or buffer, or nil to default to the current buffer." (tramp-error proc 'error "Process %s is not active" proc) (tramp-message proc 5 "Interrupt process %s with pid %s" proc pid) ;; This is for tramp-sh.el. Other backends do not support this (yet). + ;; Not all "kill" implementations support process groups by + ;; negative pid, so we try both variants. (tramp-compat-funcall 'tramp-send-command (process-get proc 'vector) - (format "kill -2 -%d" pid)) + (format "(\\kill -2 -%d || \\kill -2 %d) 2>/dev/null" pid pid)) ;; Wait, until the process has disappeared. If it doesn't, ;; fall back to the default implementation. (while (tramp-accept-process-output proc 0)) @@ -5034,16 +5066,5 @@ name of a process or buffer, or nil to default to the current buffer." ;; and friends, for most of the handlers this is the major ;; difference between the different backends. Other handlers but ;; *-process-file would profit from this as well. -;; -;; * Get rid of `shell-command'. In its primary implementation, it -;; uses `process-file-shell-command' and -;; `start-file-process-shell-command', which is sufficient due to -;; connection-local `shell-file-name'. - ;;; tramp.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index dacdd44102f..0a92e0d3202 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -35,11 +35,8 @@ ;; Emacs version check is defined in macro AC_EMACS_INFO of ;; aclocal.m4; should be changed only there. -;; Needed for Emacs 24. -(defvar inhibit-message) - ;;;###tramp-autoload -(defconst tramp-version "2.4.3.27.1" +(defconst tramp-version "2.5.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -71,9 +68,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-lessp emacs-version "24.4")) +(let ((x (if (not (string-lessp emacs-version "25.1")) "ok" - (format "Tramp 2.4.3.27.1 is not fit for %s" + (format "Tramp 2.5.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) @@ -102,8 +99,3 @@ (provide 'trampver) ;;; trampver.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/obsolete/cust-print.el b/lisp/obsolete/cust-print.el index fbf80692037..40532ea5b9d 100644 --- a/lisp/obsolete/cust-print.el +++ b/lisp/obsolete/cust-print.el @@ -156,10 +156,7 @@ If nil, printing proceeds recursively and may lead to If non-nil, shared substructures anywhere in the structure are printed with `#N=' before the first occurrence (in the order of the print representation) and `#N#' in place of each subsequent occurrence, -where N is a positive decimal integer. - -There is no way to read this representation in standard Emacs, -but if you need to do so, try the cl-read.el package." +where N is a positive decimal integer." :type 'boolean :group 'cust-print) diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el index 350eabdb0c1..96b063be701 100644 --- a/lisp/obsolete/iswitchb.el +++ b/lisp/obsolete/iswitchb.el @@ -1393,7 +1393,7 @@ Copied from `icomplete-tidy'." "Move the summaries to the end of the list. This is an example function which can be hooked on to `iswitchb-make-buflist-hook'. Any buffer matching the regexps -`Summary' or `output\*$'are put to the end of the list." +`Summary' or `output\\*$'are put to the end of the list." (let ((summaries (delq nil (mapcar (lambda (x) diff --git a/lisp/obsolete/old-whitespace.el b/lisp/obsolete/old-whitespace.el index 95010c00200..2f46d7ddda5 100644 --- a/lisp/obsolete/old-whitespace.el +++ b/lisp/obsolete/old-whitespace.el @@ -383,10 +383,10 @@ To disable timer scans, set this to zero." (defun whitespace-buffer (&optional quiet) "Find five different types of white spaces in buffer. These are: -1. Leading space \(empty lines at the top of a file\). -2. Trailing space \(empty lines at the end of a file\). -3. Indentation space \(8 or more spaces, that should be replaced with TABS\). -4. Spaces followed by a TAB. \(Almost always, we never want that\). +1. Leading space \(empty lines at the top of a file). +2. Trailing space \(empty lines at the end of a file). +3. Indentation space \(8 or more spaces, that should be replaced with TABS). +4. Spaces followed by a TAB. \(Almost always, we never want that). 5. Spaces or TABS at the end of a line. Check for whitespace only if this buffer really contains a non-empty file diff --git a/lisp/obsolete/rcompile.el b/lisp/obsolete/rcompile.el index 5ef8be20d98..6d95b7136b1 100644 --- a/lisp/obsolete/rcompile.el +++ b/lisp/obsolete/rcompile.el @@ -89,7 +89,7 @@ nil means use the value returned by \\[user-login-name]." "Command to run before compilation. This can be used for setting up environment variables, since rsh does not invoke the shell as a login shell and files like .login -\(tcsh\) and .bash_profile \(bash\) are not run. +\(tcsh) and .bash_profile \(bash) are not run. nil means run no commands." :type '(choice string (const nil)) :group 'remote-compile) diff --git a/lisp/obsolete/sb-image.el b/lisp/obsolete/sb-image.el new file mode 100644 index 00000000000..fd8884738d4 --- /dev/null +++ b/lisp/obsolete/sb-image.el @@ -0,0 +1,46 @@ +;;; sb-image --- Image management for speedbar + +;; Copyright (C) 1999-2003, 2005-2019 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: file, tags, tools +;; Obsolete-since: 28.1 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file is obsolete. +;; +;; Supporting Image display for Emacs 20 and less, Emacs 21, and XEmacs, +;; is a challenging task, which doesn't take kindly to being byte compiled. +;; When sharing speedbar.elc between these three applications, the Image +;; support can get lost. +;; +;; By splitting out that hard part into this file, and avoiding byte +;; compilation, one copy speedbar can support all these platforms together. +;; +;; This file requires the `image' package if it is available. + +(require 'ezimage) + +;;; Code: + +(defalias 'defimage-speedbar 'defezimage) + +(provide 'sb-image) + +;;; sb-image.el ends here diff --git a/lisp/obsolete/vi.el b/lisp/obsolete/vi.el index df5ddfdbcf9..eee00b43a26 100644 --- a/lisp/obsolete/vi.el +++ b/lisp/obsolete/vi.el @@ -1225,7 +1225,7 @@ SPECIAL FEATURE: char argument can be used to specify shift amount(1-9)." (defun vi-end-of-blank-delimited-word (count) "Forward to the end of the COUNT'th blank-delimited word." (interactive "p") - (if (re-search-forward "[^ \t\n\']+[ \t\n\']" nil t count) + (if (re-search-forward "[^ \t\n']+[ \t\n']" nil t count) (if (not (eobp)) (backward-char 2)))) (defun vi-home-window-line (arg) diff --git a/lisp/obsolete/vip.el b/lisp/obsolete/vip.el index 4a9b8fff264..37defd1c5a4 100644 --- a/lisp/obsolete/vip.el +++ b/lisp/obsolete/vip.el @@ -80,7 +80,7 @@ (defvar vip-current-major-mode nil "vip-current-major-mode is the major-mode vi considers it is now. -\(buffer specific\)") +\(buffer specific)") (make-variable-buffer-local 'vip-current-major-mode) @@ -1510,7 +1510,7 @@ used. This behavior is controlled by the sign of prefix numeric value." (* (/ (point-max) 100) arg) (/ (* (point-max) arg) 100))) (back-to-indentation)) - (cond ((looking-at "[\(\[{]") + (cond ((looking-at "[([{]") (if com (move-marker vip-com-point (point))) (forward-sexp 1) (if com @@ -1719,7 +1719,7 @@ STRING. Search will be forward if FORWARD, otherwise backward." (let (buffer) (setq buffer (read-buffer - (format "switch to buffer \(%s\): " + (format "switch to buffer (%s): " (buffer-name (other-buffer (current-buffer)))))) (switch-to-buffer buffer) (vip-change-mode-to-vi))) @@ -1730,7 +1730,7 @@ STRING. Search will be forward if FORWARD, otherwise backward." (let (buffer) (setq buffer (read-buffer - (format "Switch to buffer \(%s\): " + (format "Switch to buffer (%s): " (buffer-name (other-buffer (current-buffer)))))) (switch-to-buffer-other-window buffer) (vip-change-mode-to-vi))) @@ -1741,7 +1741,7 @@ STRING. Search will be forward if FORWARD, otherwise backward." (let (buffer buffer-name) (setq buffer-name (read-buffer - (format "Kill buffer \(%s\): " + (format "Kill buffer (%s): " (buffer-name (current-buffer))))) (setq buffer (if (null buffer-name) @@ -2162,7 +2162,7 @@ is a command.") (defun vip-get-ex-token () "get an ex-token which is either an address or a command. -a token has type \(command, address, end-mark\) and value." +a token has type \(command, address, end-mark) and value." (with-current-buffer " *ex-working-space*" (skip-chars-forward " \t") (cond ((looking-at "[k#]") @@ -2668,7 +2668,7 @@ a token has type \(command, address, end-mark\) and value." "ex-edit" (vip-get-ex-file) (if (and (not ex-variant) (buffer-modified-p) buffer-file-name) - (error "No write since last change \(:e! overrides\)")) + (error "No write since last change (:e! overrides)")) (vip-change-mode-to-emacs) (set-buffer (find-file-noselect (concat default-directory ex-file))) diff --git a/lisp/org/ol.el b/lisp/org/ol.el index baed23bc9a4..c9e4da598ff 100644 --- a/lisp/org/ol.el +++ b/lisp/org/ol.el @@ -845,8 +845,8 @@ E.g. \"%C3%B6\" becomes the german o-Umlaut." (insert link) (insert (make-string (- (skip-chars-backward "\\\\")) ?\\)) - (while (search-backward "\]" nil t) - (when (looking-at-p "\\]\\(?:[][]\\|\\'\\)") + (while (search-backward "]" nil t) + (when (looking-at-p "]\\(?:[][]\\|\\'\\)") (insert (make-string (1+ (- (skip-chars-backward "\\\\"))) ?\\)))) (buffer-string))) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 4f89ea54500..5fe140d00ef 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -1883,7 +1883,7 @@ Nil means don't hide any tags." :group 'org-agenda-line-format :type '(choice (const :tag "Hide none" nil) - (string :tag "Regexp "))) + (regexp :tag "Regexp "))) (defvaralias 'org-agenda-remove-tags-when-in-prefix 'org-agenda-remove-tags) @@ -1980,7 +1980,7 @@ category, you can use: (\"Emacs\" \\='(space . (:width (16))))" :group 'org-agenda-line-format :version "24.1" - :type '(alist :key-type (string :tag "Regexp matching category") + :type '(alist :key-type (regexp :tag "Regexp matching category") :value-type (choice (list :tag "Icon" (string :tag "File or data") (symbol :tag "Type") @@ -8981,7 +8981,6 @@ fold drawers." (narrow-to-region (org-entry-beginning-position) (org-entry-end-position)) (org-show-all '(drawers)))) - (when arg ) (setq org-agenda-show-window (selected-window))) (select-window win))) diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el index 4b5f9a19e6d..be74dfdbeff 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -4892,7 +4892,7 @@ with `org-element--cache-compare'. This cache is used in A request is a vector with the following pattern: - \[NEXT BEG END OFFSET PARENT PHASE] + [NEXT BEG END OFFSET PARENT PHASE] Processing a synchronization request consists of three phases: diff --git a/lisp/org/org-protocol.el b/lisp/org/org-protocol.el index 0ff0e401d27..55a534d0dcd 100644 --- a/lisp/org/org-protocol.el +++ b/lisp/org/org-protocol.el @@ -278,7 +278,7 @@ This should be a single regexp string." :group 'org-protocol :version "24.4" :package-version '(Org . "8.0") - :type 'string) + :type 'regexp) ;;; Helper functions: diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 49765472558..469e01be5d2 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -198,7 +198,7 @@ Other options offered by the customize interface are more restrictive." "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$") (const :tag "Very General Number-Like, including hex and Calc radix, allows comma as decimal mark" "^\\([<>]?[-+^.,0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$") - (string :tag "Regexp:"))) + (regexp :tag "Regexp:"))) (defcustom org-table-number-fraction 0.5 "Fraction of numbers in a column required to make the column align right. diff --git a/lisp/org/org.el b/lisp/org/org.el index 568f5b9b873..e8e1ef99f26 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -11410,8 +11410,8 @@ D Show deadlines and scheduled items between a date range." (setq type (or type org-sparse-tree-default-date-type)) (setq org-ts-type type) (message "Sparse tree: [r]egexp [t]odo [T]odo-kwd [m]atch [p]roperty - \[d]eadlines [b]efore-date [a]fter-date [D]ates range - \[c]ycle through date types: %s" + [d]eadlines [b]efore-date [a]fter-date [D]ates range + [c]ycle through date types: %s" (cl-case type (all "all timestamps") (scheduled "only scheduled") diff --git a/lisp/org/ox-latex.el b/lisp/org/ox-latex.el index edb3150796f..2f61abad9cc 100644 --- a/lisp/org/ox-latex.el +++ b/lisp/org/ox-latex.el @@ -1239,7 +1239,7 @@ calling `org-latex-compile'." :package-version '(Org . "8.3") :type '(repeat (cons - (string :tag "Regexp") + (regexp :tag "Regexp") (string :tag "Message")))) diff --git a/lisp/org/ox-odt.el b/lisp/org/ox-odt.el index 51cb42a49a5..a1486318a7d 100644 --- a/lisp/org/ox-odt.el +++ b/lisp/org/ox-odt.el @@ -940,7 +940,7 @@ See `org-odt--build-date-styles' for implementation details." (has-time-p (or (not timestamp) (org-timestamp-has-time-p timestamp))) (iso-date (let ((format (if has-time-p "%Y-%m-%dT%H:%M:%S" - "%Y-%m-%dT%H:%M:%S"))) + "%Y-%m-%d"))) (funcall format-timestamp timestamp format end)))) (if iso-date-p iso-date (let* ((style (if has-time-p "OrgDate2" "OrgDate1")) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 75ebc29710c..02af263ec34 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -72,7 +72,7 @@ so that it is considered safe, see `enable-local-variables'.") "\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z+-]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" "Regular expression matching bug references. The second subexpression should match the bug reference (usually a number)." - :type 'string + :type 'regexp :version "24.3" ; previously defconst :group 'bug-reference) diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 1071191775b..a60812230b8 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -512,11 +512,11 @@ function to control that." (let ((src (default-value 'post-self-insert-hook))) (while src (unless (memq (car src) c--unsafe-post-self-insert-hook-functions) - (add-hook 'dest (car src) t)) ; Preserve the order of the functions. + (push (car src) dest)) (setq src (cdr src))))) - (t (add-hook 'dest (car src) t))) ; Preserve the order of the functions. + (t (push (car src) dest))) (setq src (cdr src))) - (run-hooks 'dest))) + (mapc #'funcall (nreverse dest)))) ; Preserve the order of the functions. (defmacro c--call-post-self-insert-hook-more-safely () ;; Call post-self-insert-hook, if such exists. See comment for @@ -2024,6 +2024,23 @@ other top level construct with a brace block." (c-backward-syntactic-ws) (point)))) + ((and (c-major-mode-is 'objc-mode) (looking-at "[-+]\\s-*(")) ; Objective-C method + ;; Move to the beginning of the method name. + (c-forward-token-2 2 t) + (let* ((class + (save-excursion + (when (re-search-backward + "^\\s-*@\\(implementation\\|class\\|interface\\)\\s-+\\(\\sw+\\)" nil t) + (match-string-no-properties 2)))) + (limit (save-excursion (re-search-forward "[;{]" nil t))) + (method (when (re-search-forward "\\(\\sw+:?\\)" limit t) + (match-string-no-properties 1)))) + (when (and class method) + ;; Add the parameter labels onto name. They always end in ':'. + (while (re-search-forward "\\(\\sw+:\\)" limit 1) + (setq method (concat method (match-string-no-properties 1)))) + (concat "[" class " " method "]")))) + (t ; Normal function or initializer. (when (looking-at c-defun-type-name-decl-key) ; struct, etc. (goto-char (match-end 0)) diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el index dfb987bf99a..6cd2fa3ec05 100644 --- a/lisp/progmodes/cwarn.el +++ b/lisp/progmodes/cwarn.el @@ -168,6 +168,8 @@ deactivated." :tag "Load Hook" :group 'cwarn :type 'hook) +(make-obsolete-variable 'cwarn-load-hook + "use `with-eval-after-load' instead." "28.1") ;;}}} ;;{{{ The modes diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el index d5820bbfe0a..d5dddfc2b7c 100644 --- a/lisp/progmodes/ebnf2ps.el +++ b/lisp/progmodes/ebnf2ps.el @@ -1157,21 +1157,6 @@ Please send all bug fixes and enhancements to (and (string< ps-print-version "5.2.3") (error "`ebnf2ps' requires `ps-print' package version 5.2.3 or later")) - -;; to avoid gripes with Emacs 20 -(or (fboundp 'assq-delete-all) - (defun assq-delete-all (key alist) - "Delete from ALIST all elements whose car is KEY. -Return the modified alist. -Elements of ALIST that are not conses are ignored." - (let ((tail alist)) - (while tail - (if (and (consp (car tail)) - (eq (car (car tail)) key)) - (setq alist (delq (car tail) alist))) - (setq tail (cdr tail))) - alist))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User Variables: @@ -2053,8 +2038,7 @@ It must be a float between 0.0 (top) and 1.0 (bottom)." ;; Printing color requires x-color-values. -(defcustom ebnf-color-p (or (fboundp 'x-color-values) ; Emacs - (fboundp 'color-instance-rgb-components)) ; XEmacs +(defcustom ebnf-color-p t "Non-nil means use color." :type 'boolean :version "20" @@ -2738,8 +2722,7 @@ Used in functions `ebnf-reset-style', `ebnf-push-style' and (ebnf-eps-footer-font . '(7 Helvetica "Black" "White" bold)) (ebnf-eps-footer . nil) (ebnf-entry-percentage . 0.5) - (ebnf-color-p . (or (fboundp 'x-color-values) ; Emacs - (fboundp 'color-instance-rgb-components))) ; XEmacs + (ebnf-color-p . t) (ebnf-line-width . 1.0) (ebnf-line-color . "Black") (ebnf-debug-ps . nil) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index e785acd2840..da5a2a503a6 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -105,13 +105,24 @@ (defvar speedbar-initial-expansion-list-name) (defvar speedbar-frame) -(defvar gdb-memory-address "main") -(defvar gdb-memory-last-address nil +(defvar-local gdb-memory-address-expression "main" + "This expression is passed to gdb. +Possible value: main, $rsp, x+3.") +(defvar-local gdb-memory-address nil + "Address of memory display.") +(defvar-local gdb-memory-last-address nil "Last successfully accessed memory address.") (defvar gdb-memory-next-page nil "Address of next memory page for program memory buffer.") (defvar gdb-memory-prev-page nil "Address of previous memory page for program memory buffer.") +(defvar-local gdb--memory-display-warning nil + "Display warning on memory header if t. + +When error occurs when retrieving memory, gdb-mi displays the +last successful page. In that case the expression might not +match the memory displayed. We want to let the user be aware of +that, so display a warning exclamation mark in the header line.") (defvar gdb-thread-number nil "Main current thread. @@ -3450,7 +3461,7 @@ line." (def-gdb-trigger-and-handler gdb-invalidate-memory (format "-data-read-memory %s %s %d %d %d" - gdb-memory-address + (gdb-mi-quote gdb-memory-address-expression) gdb-memory-format gdb-memory-unit gdb-memory-rows @@ -3490,6 +3501,9 @@ in `gdb-memory-format'." (err-msg (bindat-get-field res 'msg))) (if (not err-msg) (let ((memory (bindat-get-field res 'memory))) + (when gdb-memory-last-address + ;; Nil means last retrieve emits error or just started the session. + (setq gdb--memory-display-warning nil)) (setq gdb-memory-address (bindat-get-field res 'addr)) (setq gdb-memory-next-page (bindat-get-field res 'next-page)) (setq gdb-memory-prev-page (bindat-get-field res 'prev-page)) @@ -3503,10 +3517,15 @@ in `gdb-memory-format'." gdb-memory-format))))) (newline))) ;; Show last page instead of empty buffer when out of bounds - (progn - (let ((gdb-memory-address gdb-memory-last-address)) + (when gdb-memory-last-address + (let ((gdb-memory-address-expression gdb-memory-last-address)) + ;; If we don't set `gdb-memory-last-address' to nil, + ;; `gdb-invalidate-memory' eventually calls + ;; `gdb-read-memory-custom', making an infinite loop. + (setq gdb-memory-last-address nil + gdb--memory-display-warning t) (gdb-invalidate-memory 'update) - (error err-msg)))))) + (user-error "Error when retrieving memory: %s Displaying last successful page" err-msg)))))) (defvar gdb-memory-mode-map (let ((map (make-sparse-keymap))) @@ -3540,7 +3559,7 @@ in `gdb-memory-format'." "Set the start memory address." (interactive) (let ((arg (read-from-minibuffer "Memory address: "))) - (setq gdb-memory-address arg)) + (setq gdb-memory-address-expression arg)) (gdb-invalidate-memory 'update)) (defmacro def-gdb-set-positive-number (name variable echo-string &optional doc) @@ -3723,7 +3742,19 @@ DOC is an optional documentation string." (defvar gdb-memory-header '(:eval (concat - "Start address[" + "Start address " + ;; If `gdb-memory-address-expression' is nil, `propertize' would error. + (propertize (or gdb-memory-address-expression "N/A") + 'face font-lock-warning-face + 'help-echo "mouse-1: set start address" + 'mouse-face 'mode-line-highlight + 'local-map (gdb-make-header-line-mouse-map + 'mouse-1 + #'gdb-memory-set-address-event)) + (if gdb--memory-display-warning + (propertize " !" 'face '(:inherit error :weight bold)) + "") + " [" (propertize "-" 'face font-lock-warning-face 'help-echo "mouse-1: decrement address" @@ -3740,13 +3771,9 @@ DOC is an optional documentation string." 'mouse-1 #'gdb-memory-show-next-page)) "]: " - (propertize gdb-memory-address - 'face font-lock-warning-face - 'help-echo "mouse-1: set start address" - 'mouse-face 'mode-line-highlight - 'local-map (gdb-make-header-line-mouse-map - 'mouse-1 - #'gdb-memory-set-address-event)) + ;; If `gdb-memory-address' is nil, `propertize' would error. + (propertize (or gdb-memory-address "N/A") + 'face font-lock-warning-face) " Rows: " (propertize (number-to-string gdb-memory-rows) 'face font-lock-warning-face diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index d4aca28bd7c..7731be59659 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -64,8 +64,7 @@ SYMBOL should be one of `grep-command', `grep-template', "Number of lines in a grep window. If nil, use `compilation-window-height'." :type '(choice (const :tag "Default" nil) integer) - :version "22.1" - :group 'grep) + :version "22.1") (defcustom grep-highlight-matches 'auto-detect "Use special markers to highlight grep matches. @@ -98,9 +97,8 @@ To change the default value, use \\[customize] or call the function (const :tag "Use --color=always" always) (const :tag "Use --color" auto) (other :tag "Not Set" auto-detect)) - :set 'grep-apply-setting - :version "22.1" - :group 'grep) + :set #'grep-apply-setting + :version "22.1") (defcustom grep-scroll-output nil "Non-nil to scroll the *grep* buffer window as output appears. @@ -109,8 +107,7 @@ Setting it causes the grep commands to put point at the end of their output window so that the end of the output is always visible rather than the beginning." :type 'boolean - :version "22.1" - :group 'grep) + :version "22.1") ;;;###autoload (defcustom grep-command nil @@ -124,8 +121,7 @@ by `grep-compute-defaults'; to change the default value, use \\[customize] or call the function `grep-apply-setting'." :type '(choice string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :group 'grep) + :set #'grep-apply-setting) (defcustom grep-template nil "The default command to run for \\[lgrep]. @@ -141,9 +137,8 @@ by `grep-compute-defaults'; to change the default value, use \\[customize] or call the function `grep-apply-setting'." :type '(choice string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :version "22.1" - :group 'grep) + :set #'grep-apply-setting + :version "22.1") (defcustom grep-use-null-device 'auto-detect "If t, append the value of `null-device' to `grep' commands. @@ -157,8 +152,7 @@ by `grep-compute-defaults'; to change the default value, use :type '(choice (const :tag "Do Not Append Null Device" nil) (const :tag "Append Null Device" t) (other :tag "Not Set" auto-detect)) - :set 'grep-apply-setting - :group 'grep) + :set #'grep-apply-setting) (defcustom grep-use-null-filename-separator 'auto-detect "If non-nil, use `grep's `--null' option. @@ -167,8 +161,7 @@ This is done to disambiguate file names in `grep's output." :type '(choice (const :tag "Do Not Use `--null'" nil) (const :tag "Use `--null'" t) (other :tag "Not Set" auto-detect)) - :set 'grep-apply-setting - :group 'grep) + :set #'grep-apply-setting) ;;;###autoload (defcustom grep-find-command nil @@ -178,8 +171,7 @@ by `grep-compute-defaults'; to change the default value, use \\[customize] or call the function `grep-apply-setting'." :type '(choice string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :group 'grep) + :set #'grep-apply-setting) (defcustom grep-find-template nil "The default command to run for \\[rgrep]. @@ -194,9 +186,8 @@ by `grep-compute-defaults'; to change the default value, use \\[customize] or call the function `grep-apply-setting'." :type '(choice string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :version "22.1" - :group 'grep) + :set #'grep-apply-setting + :version "22.1") (defcustom grep-files-aliases '(("all" . "* .[!.]* ..?*") ;; Don't match `..'. See bug#22577 @@ -213,8 +204,7 @@ by `grep-compute-defaults'; to change the default value, use ("texi" . "*.texi") ("asm" . "*.[sS]")) "Alist of aliases for the FILES argument to `lgrep' and `rgrep'." - :type 'alist - :group 'grep) + :type 'alist) (defcustom grep-find-ignored-directories vc-directory-exclusion-list "List of names of sub-directories which `rgrep' shall not recurse into. @@ -223,8 +213,7 @@ to determine whether cdr should not be recursed into. The default value is inherited from `vc-directory-exclusion-list'." :type '(choice (repeat :tag "Ignored directories" string) - (const :tag "No ignored directories" nil)) - :group 'grep) + (const :tag "No ignored directories" nil))) (defcustom grep-find-ignored-files (cons ".#*" (delq nil (mapcar (lambda (s) @@ -235,8 +224,7 @@ The default value is inherited from `vc-directory-exclusion-list'." If an element is a cons cell, the car is called on the search directory to determine whether cdr should not be excluded." :type '(choice (repeat :tag "Ignored file" string) - (const :tag "No ignored files" nil)) - :group 'grep) + (const :tag "No ignored files" nil))) (defcustom grep-save-buffers 'ask "If non-nil, save buffers before running the grep commands. @@ -251,22 +239,19 @@ to limit saving to files located under `my-grep-root'." (const :tag "Ask before saving" ask) (const :tag "Don't save buffers" nil) function - (other :tag "Save all buffers" t)) - :group 'grep) + (other :tag "Save all buffers" t))) (defcustom grep-error-screen-columns nil "If non-nil, column numbers in grep hits are screen columns. See `compilation-error-screen-columns'." :type '(choice (const :tag "Default" nil) integer) - :version "22.1" - :group 'grep) + :version "22.1") ;;;###autoload (defcustom grep-setup-hook nil "List of hook functions run by `grep-process-setup' (see `run-hooks')." - :type 'hook - :group 'grep) + :type 'hook) (defvar grep-mode-map (let ((map (make-sparse-keymap))) @@ -333,7 +318,10 @@ See `compilation-error-screen-columns'." ;; When bootstrapping, tool-bar-map is not properly initialized yet, ;; so don't do anything. (when (keymapp (butlast tool-bar-map)) + ;; We have to `copy-keymap' rather than use keymap inheritance because + ;; we want to put the new items at the *end* of the tool-bar. (let ((map (butlast (copy-keymap tool-bar-map))) + ;; FIXME: Nowadays the last button is not "help" but "search"! (help (last tool-bar-map))) ;; Keep Help last in tool bar (tool-bar-local-item "left-arrow" 'previous-error-no-select 'previous-error-no-select map @@ -439,15 +427,13 @@ and reveals the entire command line. The visibility of the abbreviated part can also be toggled with `grep-find-toggle-abbreviation'." :type 'boolean - :version "27.1" - :group 'grep) + :version "27.1") (defcustom grep-search-path '(nil) "List of directories to search for files named in grep messages. Elements should be directory names, not file names of directories. The value nil as an element means the grep messages buffer `default-directory'." - :group 'grep :version "27.1" :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) @@ -528,9 +514,8 @@ This variable's value takes effect when `grep-compute-defaults' is called." (const :tag "find -print0 | sort -z | xargs -0'" gnu-sort) string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :version "27.1" - :group 'grep) + :set #'grep-apply-setting + :version "27.1") ;; History of grep commands. ;;;###autoload @@ -562,7 +547,7 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." (setenv "GREP_COLORS" "mt=01;31:fn=:ln=:bn=:se=:sl=:cx=:ne")) (setq-local grep-num-matches-found 0) (set (make-local-variable 'compilation-exit-message-function) - 'grep-exit-message) + #'grep-exit-message) (run-hooks 'grep-setup-hook)) (defun grep-exit-message (status code msg) @@ -612,7 +597,7 @@ This function is called from `compilation-filter-hook'." (defun grep-probe (command args &optional func result) (let (process-file-side-effects) (equal (condition-case nil - (apply (or func 'process-file) command args) + (apply (or func #'process-file) command args) (error nil)) (or result 0)))) @@ -808,7 +793,7 @@ The value depends on `grep-command', `grep-template', (buffer-substring-no-properties (point) (mark))) (funcall (or find-tag-default-function (get major-mode 'find-tag-default-function) - 'find-tag-default)) + #'find-tag-default)) "")) (defun grep-default-command () @@ -863,11 +848,11 @@ The value depends on `grep-command', `grep-template', (set (make-local-variable 'compilation-directory-matcher) (list regexp-unmatchable)) (set (make-local-variable 'compilation-process-setup-function) - 'grep-process-setup) + #'grep-process-setup) (set (make-local-variable 'compilation-disable-input) t) (set (make-local-variable 'compilation-error-screen-columns) grep-error-screen-columns) - (add-hook 'compilation-filter-hook 'grep-filter nil t)) + (add-hook 'compilation-filter-hook #'grep-filter nil t)) (defun grep--save-buffers () (when grep-save-buffers @@ -914,7 +899,7 @@ list is empty)." (compilation-start (if (and grep-use-null-device null-device) (concat command-args " " null-device) command-args) - 'grep-mode)) + #'grep-mode)) ;;;###autoload @@ -993,23 +978,31 @@ these include `opts', `dir', `files', `null-device', `excl' and "Read regexp arg for interactive grep using `read-regexp'." (read-regexp "Search for" 'grep-tag-default 'grep-regexp-history)) +(defvar grep-read-files-function #'grep-read-files--default) + +(defun grep-read-files--default () + ;; Instead of a `grep-read-files-function' variable, we used to lookup + ;; mode-specific functions in the major mode's symbol properties, so preserve + ;; this behavior for backward compatibility. + (let ((old-function (get major-mode 'grep-read-files))) ;Obsolete since 28.1 + (if old-function + (funcall old-function) + (let ((file-name-at-point + (run-hook-with-args-until-success 'file-name-at-point-functions))) + (or (if (and (stringp file-name-at-point) + (not (file-directory-p file-name-at-point))) + file-name-at-point) + (buffer-file-name) + (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name))))))) + (defun grep-read-files (regexp) "Read a file-name pattern arg for interactive grep. -The pattern can include shell wildcards. As whitespace triggers +The pattern can include shell wildcards. As SPC can triggers completion when entering a pattern, including it requires quoting, e.g. `\\[quoted-insert]<space>'. REGEXP is used as a string in the prompt." - (let* ((grep-read-files-function (get major-mode 'grep-read-files)) - (file-name-at-point - (run-hook-with-args-until-success 'file-name-at-point-functions)) - (bn (if grep-read-files-function - (funcall grep-read-files-function) - (or (if (and (stringp file-name-at-point) - (not (file-directory-p file-name-at-point))) - file-name-at-point) - (buffer-file-name) - (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name))))) + (let* ((bn (funcall grep-read-files-function)) (fn (and bn (stringp bn) (file-name-nondirectory bn))) @@ -1022,7 +1015,7 @@ REGEXP is used as a string in the prompt." (setq alias (car aliases) aliases (cdr aliases)) (if (string-match (mapconcat - 'wildcard-to-regexp + #'wildcard-to-regexp (split-string (cdr alias) nil t) "\\|") fn) @@ -1043,11 +1036,11 @@ REGEXP is used as a string in the prompt." "\" in files matching wildcard" (if default (concat " (default " default ")")) ": ") - 'read-file-name-internal + #'read-file-name-internal nil nil nil 'grep-files-history (delete-dups (delq nil (append (list default default-alias default-extension) - (mapcar 'car grep-files-aliases))))))) + (mapcar #'car grep-files-aliases))))))) (and files (or (cdr (assoc files grep-files-aliases)) files)))) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index d5fd1dce6f5..567f452b935 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -486,9 +486,8 @@ The value t means that there is no stack, and we are in display-file mode.") "Additional menu items to add to the speedbar frame.") ;; Make sure our special speedbar mode is loaded -(if (featurep 'speedbar) - (gud-install-speedbar-variables) - (add-hook 'speedbar-load-hook 'gud-install-speedbar-variables)) +(with-eval-after-load 'speedbar + (gud-install-speedbar-variables)) (defun gud-expansion-speedbar-buttons (_directory _zero) "Wrapper for call to `speedbar-add-expansion-list'. diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 10416ead603..0b1ba80edcb 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -162,7 +162,7 @@ This behavior is generally undesirable. If this option is non-nil, the outermos "\\.h\\(h\\|xx\\|pp\\|\\+\\+\\)?\\'" "C/C++ header file name patterns to determine if current buffer is a header. Effective only if `hide-ifdef-expand-reinclusion-protection' is t." - :type 'string + :type 'regexp :version "25.1") (defvar hide-ifdef-mode-submap diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index 69385d7060f..d3a2308e06b 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -182,14 +182,14 @@ definition is displayed instead." which specifies the `name' section. Can be used for localization support." :group 'idlwave-online-help - :type 'string) + :type 'regexp) (defcustom idlwave-help-doclib-keyword "KEYWORD" "A regexp for the heading word to search for in doclib headers which specifies the `keywords' section. Can be used for localization support." :group 'idlwave-online-help - :type 'string) + :type 'regexp) (defface idlwave-help-link '((t :inherit link)) diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index 2601c2e1653..3092d4c45b0 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -314,7 +314,7 @@ split then a terminal beep and warning are issued." expression will not be changed. Note that the indentation of a comment at the beginning of a line is never changed." :group 'idlwave-code-formatting - :type 'string) + :type 'regexp) (defcustom idlwave-begin-line-comment nil "A comment anchored at the beginning of line. @@ -1096,6 +1096,8 @@ class-arrows Object Arrows with class property" "Normal hook. Executed when idlwave.el is loaded." :group 'idlwave-misc :type 'hook) +(make-obsolete-variable 'idlwave-load-hook + "use `with-eval-after-load' instead." "28.1") (defvar idlwave-experimental nil "Non-nil means turn on a few experimental features. @@ -1870,7 +1872,6 @@ The main features of this mode are 8. Hooks ----- - Loading idlwave.el runs `idlwave-load-hook'. Turning on `idlwave-mode' runs `idlwave-mode-hook'. 9. Documentation and Customization diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index a24b94073fc..9f34a377f4a 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -130,9 +130,8 @@ mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword ;;; "This function binds many inferior-lisp commands to C-c <letter> bindings, ;;;where they are more accessible. C-c <letter> bindings are reserved for the -;;;user, so these bindings are non-standard. If you want them, you should -;;;have this function called by the inferior-lisp-load-hook: -;;; (add-hook 'inferior-lisp-load-hook 'inferior-lisp-install-letter-bindings) +;;;user, so these bindings are non-standard. If you want them: +;;; (with-eval-after-load 'inf-lisp 'inferior-lisp-install-letter-bindings) ;;;You can modify this function to install just the bindings you want." (defun inferior-lisp-install-letter-bindings () (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go) @@ -632,6 +631,8 @@ See variable `lisp-describe-sym-command'." ;;;=============================== (defvar inferior-lisp-load-hook nil "This hook is run when the library `inf-lisp' is loaded.") +(make-obsolete-variable 'inferior-lisp-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'inferior-lisp-load-hook) diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el index 6f0e535def8..4a5d872b790 100644 --- a/lisp/progmodes/meta-mode.el +++ b/lisp/progmodes/meta-mode.el @@ -895,6 +895,8 @@ The environment marked is the one that contains point or follows point." "Hook evaluated when first loading Metafont or MetaPost mode." :type 'hook :group 'meta-font) +(make-obsolete-variable 'meta-mode-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom meta-common-mode-hook nil "Hook evaluated by both `metafont-mode' and `metapost-mode'." diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 107b29189f5..a2d85d0bef8 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -1993,7 +1993,7 @@ position, else returns nil." ;; IPython prompts activated, this adds some safeguard for that. "In : " "\\.\\.\\.: ") "List of regular expressions matching input prompts." - :type '(repeat string) + :type '(repeat regexp) :version "24.4") (defcustom python-shell-prompt-output-regexps @@ -2001,28 +2001,28 @@ position, else returns nil." "Out\\[[0-9]+\\]: " ; IPython "Out :") ; ipdb safeguard "List of regular expressions matching output prompts." - :type '(repeat string) + :type '(repeat regexp) :version "24.4") (defcustom python-shell-prompt-regexp ">>> " "Regular expression matching top level input prompt of Python shell. It should not contain a caret (^) at the beginning." - :type 'string) + :type 'regexp) (defcustom python-shell-prompt-block-regexp "\\.\\.\\.:? " "Regular expression matching block input prompt of Python shell. It should not contain a caret (^) at the beginning." - :type 'string) + :type 'regexp) (defcustom python-shell-prompt-output-regexp "" "Regular expression matching output prompt of Python shell. It should not contain a caret (^) at the beginning." - :type 'string) + :type 'regexp) (defcustom python-shell-prompt-pdb-regexp "[(<]*[Ii]?[Pp]db[>)]+ " "Regular expression matching pdb input prompt of Python shell. It should not contain a caret (^) at the beginning." - :type 'string) + :type 'regexp) (define-obsolete-variable-alias 'python-shell-enable-font-lock 'python-shell-font-lock-enable "25.1") @@ -2111,7 +2111,7 @@ virtualenv." "(" (group (1+ digit)) ")" (1+ (not (any "("))) "()") 1 2)) "`compilation-error-regexp-alist' for inferior Python." - :type '(alist string) + :type '(alist regexp) :group 'python) (defmacro python-shell--add-to-path-with-priority (pathvar paths) @@ -3785,7 +3785,7 @@ the top stack frame has been reached. Filename is expected in the first parenthesized expression. Line number is expected in the second parenthesized expression." - :type 'string + :type 'regexp :version "27.1" :safe 'stringp) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index cc6d5b46ed2..a241a1e69ba 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -64,61 +64,10 @@ ;; * Indent right half sh-basic-offset ;; / Indent left half sh-basic-offset. ;; -;; There are 4 commands to help set the indentation variables: -;; -;; `sh-show-indent' -;; This shows what variable controls the indentation of the current -;; line and its value. -;; -;; `sh-set-indent' -;; This allows you to set the value of the variable controlling the -;; current line's indentation. You can enter a number or one of a -;; number of special symbols to denote the value of sh-basic-offset, -;; or its negative, or half it, or twice it, etc. If you've used -;; cc-mode this should be familiar. If you forget which symbols are -;; valid simply press C-h at the prompt. -;; -;; `sh-learn-line-indent' -;; Simply make the line look the way you want it, then invoke this -;; command. It will set the variable to the value that makes the line -;; indent like that. If called with a prefix argument then it will set -;; the value to one of the symbols if applicable. -;; -;; `sh-learn-buffer-indent' -;; This is the deluxe function! It "learns" the whole buffer (use -;; narrowing if you want it to process only part). It outputs to a -;; buffer *indent* any conflicts it finds, and all the variables it has -;; learned. This buffer is a sort of Occur mode buffer, allowing you to -;; easily find where something was set. It is popped to automatically -;; if there are any conflicts found or if `sh-popup-occur-buffer' is -;; non-nil. -;; `sh-indent-comment' will be set if all comments follow the same -;; pattern; if they don't it will be set to nil. -;; Whether `sh-basic-offset' is set is determined by variable -;; `sh-learn-basic-offset'. -;; -;; Unfortunately, `sh-learn-buffer-indent' can take a long time to run -;; (e.g. if there are large case statements). Perhaps it does not make -;; sense to run it on large buffers: if lots of lines have different -;; indentation styles it will produce a lot of diagnostics in the -;; *indent* buffer; if there is a consistent style then running -;; `sh-learn-buffer-indent' on a small region of the buffer should -;; suffice. -;; ;; Saving indentation values ;; ------------------------- -;; After you've learned the values in a buffer, how to you remember -;; them? Originally I had hoped that `sh-learn-buffer-indent' -;; would make this unnecessary; simply learn the values when you visit -;; the buffer. -;; You can do this automatically like this: -;; (add-hook 'sh-set-shell-hook #'sh-learn-buffer-indent) -;; -;; However... `sh-learn-buffer-indent' is extremely slow, -;; especially on large-ish buffer. Also, if there are conflicts the -;; "last one wins" which may not produce the desired setting. -;; -;; So...There is a minimal way of being able to save indentation values and +;; After you've learned the values in a buffer, how to you remember them? +;; There is a minimal way of being able to save indentation values and ;; to reload them in another buffer or at another point in time. ;; ;; Use `sh-name-style' to give a name to the indentation settings of @@ -132,7 +81,7 @@ ;; Indentation variables - buffer local or global? ;; ---------------------------------------------- ;; I think that often having them buffer-local makes sense, -;; especially if one is using `sh-learn-buffer-indent'. However, if +;; especially if one is using `smie-config-guess'. However, if ;; a user sets values using customization, these changes won't appear ;; to work if the variables are already local! ;; @@ -175,18 +124,10 @@ ;; - Indenting many lines is slow. It currently does each line ;; independently, rather than saving state information. ;; -;; - `sh-learn-buffer-indent' is extremely slow. -;; -;; - "case $x in y) echo ;; esac)" the last ) is mis-identified as being -;; part of a case-pattern. You need to add a semi-colon after "esac" to -;; coerce sh-script into doing the right thing. -;; ;; - "echo $z in ps | head)" the last ) is mis-identified as being part of ;; a case-pattern. You need to put the "in" between quotes to coerce ;; sh-script into doing the right thing. ;; -;; - A line starting with "}>foo" is not indented like "} >foo". -;; ;; Richard Sharman <rsharman@pobox.com> June 1999. ;;; Code: @@ -474,10 +415,10 @@ This is buffer-local in every such buffer.") (define-key map "\C-c\C-i" 'sh-if) (define-key map "\C-c\C-f" 'sh-for) (define-key map "\C-c\C-c" 'sh-case) - (define-key map "\C-c?" 'sh-show-indent) - (define-key map "\C-c=" 'sh-set-indent) - (define-key map "\C-c<" 'sh-learn-line-indent) - (define-key map "\C-c>" 'sh-learn-buffer-indent) + (define-key map "\C-c?" #'smie-config-show-indent) + (define-key map "\C-c=" #'smie-config-set-indent) + (define-key map "\C-c<" #'smie-config-set-indent) + (define-key map "\C-c>" #'smie-config-guess) (define-key map "\C-c\C-\\" 'sh-backslash-region) (define-key map "\C-c+" 'sh-add) @@ -493,17 +434,14 @@ This is buffer-local in every such buffer.") (define-key map [remap backward-sentence] 'sh-beginning-of-command) (define-key map [remap forward-sentence] 'sh-end-of-command) (define-key map [menu-bar sh-script] (cons "Sh-Script" menu-map)) - (define-key menu-map [sh-learn-buffer-indent] - '(menu-item "Learn buffer indentation" sh-learn-buffer-indent + (define-key menu-map [smie-config-guess] + '(menu-item "Learn buffer indentation" smie-config-guess :help "Learn how to indent the buffer the way it currently is.")) - (define-key menu-map [sh-learn-line-indent] - '(menu-item "Learn line indentation" sh-learn-line-indent - :help "Learn how to indent a line as it currently is indented")) - (define-key menu-map [sh-show-indent] - '(menu-item "Show indentation" sh-show-indent + (define-key menu-map [smie-config-show-indent] + '(menu-item "Show indentation" smie-config-show-indent :help "Show the how the current line would be indented")) - (define-key menu-map [sh-set-indent] - '(menu-item "Set indentation" sh-set-indent + (define-key menu-map [smie-config-set-indent] + '(menu-item "Set indentation" smie-config-set-indent :help "Set the indentation for the current line")) (define-key menu-map [sh-pair] @@ -1196,20 +1134,8 @@ and command `sh-reset-indent-vars-to-global-values'." :options '(sh-electric-here-document-mode) :group 'sh-script) -(defcustom sh-learn-basic-offset nil - "When `sh-guess-basic-offset' should learn `sh-basic-offset'. - -nil mean: never. -t means: only if there seems to be an obvious value. -Anything else means: whenever we have a \"good guess\" as to the value." - :type '(choice - (const :tag "Never" nil) - (const :tag "Only if sure" t) - (const :tag "If have a good guess" usually)) - :group 'sh-indentation) - (defcustom sh-popup-occur-buffer nil - "Controls when `sh-learn-buffer-indent' pops the `*indent*' buffer. + "Controls when `smie-config-guess' pops the `*indent*' buffer. If t it is always shown. If nil, it is shown only when there are conflicts." :type '(choice @@ -1217,14 +1143,6 @@ are conflicts." (const :tag "Always" t)) :group 'sh-indentation) -(defcustom sh-blink t - "If non-nil, `sh-show-indent' shows the line indentation is relative to. -The position on the line is not necessarily meaningful. -In some cases the line will be the matching keyword, but this is not -always the case." - :type 'boolean - :group 'sh-indentation) - (defcustom sh-first-lines-indent 0 "The indentation of the first non-blank non-comment line. Usually 0 meaning first column. @@ -1567,11 +1485,9 @@ following commands are available, based on the current shell's syntax: \\[sh-while] while loop For sh and rc shells indentation commands are: -\\[sh-show-indent] Show the variable controlling this line's indentation. -\\[sh-set-indent] Set then variable controlling this line's indentation. -\\[sh-learn-line-indent] Change the indentation variable so this line -would indent to the way it currently is. -\\[sh-learn-buffer-indent] Set the indentation variables so the +\\[smie-config-show-indent] Show the rules controlling this line's indentation. +\\[smie-config-set-indent] Change the rules controlling this line's indentation. +\\[smie-config-guess] Try to tweak the indentation rules so the buffer indents as it currently is indented. @@ -1738,13 +1654,6 @@ This adds rules for comments and assignments." (require 'smie) -;; The SMIE code should generally be preferred, but it currently does not obey -;; the various indentation custom-vars, and it misses some important features -;; of the old code, mostly: sh-learn-line/buffer-indent, sh-show-indent, -;; sh-name/save/load-style. -(defvar sh-use-smie t - "Whether to use the SMIE code for navigation and indentation.") - (defun sh-smie--keyword-p () "Non-nil if we're at a keyword position. A keyword position is one where if we're looking at something that looks @@ -2279,60 +2188,6 @@ Point should be before the newline." (defvar sh-regexp-for-done nil "A buffer-local regexp to match opening keyword for done.") -(defvar sh-kw-alist nil - "A buffer-local, since it is shell-type dependent, list of keywords.") - -;; ( key-word first-on-this on-prev-line ) -;; This is used to set `sh-kw-alist' which is a list of sublists each -;; having 3 elements: -;; a keyword -;; a rule to check when the keyword appears on "this" line -;; a rule to check when the keyword appears on "the previous" line -;; The keyword is usually a string and is the first word on a line. -;; If this keyword appears on the line whose indentation is to be -;; calculated, the rule in element 2 is called. If this returns -;; non-zero, the resulting point (which may be changed by the rule) -;; is used as the default indentation. -;; If it returned false or the keyword was not found in the table, -;; then the keyword from the previous line is looked up and the rule -;; in element 3 is called. In this case, however, -;; `sh-get-indent-info' does not stop but may keep going and test -;; other keywords against rules in element 3. This is because the -;; preceding line could have, for example, an opening "if" and an -;; opening "while" keyword and we need to add the indentation offsets -;; for both. -;; -(defconst sh-kw - '((sh - ("if" nil sh-handle-prev-if) - ("elif" sh-handle-this-else sh-handle-prev-else) - ("else" sh-handle-this-else sh-handle-prev-else) - ("fi" sh-handle-this-fi sh-handle-prev-fi) - ("then" sh-handle-this-then sh-handle-prev-then) - ("(" nil sh-handle-prev-open) - ("{" nil sh-handle-prev-open) - ("[" nil sh-handle-prev-open) - ("}" sh-handle-this-close nil) - (")" sh-handle-this-close nil) - ("]" sh-handle-this-close nil) - ("case" nil sh-handle-prev-case) - ("esac" sh-handle-this-esac sh-handle-prev-esac) - (case-label nil sh-handle-after-case-label) ;; ??? - (";;" nil sh-handle-prev-case-alt-end) ;; ??? - (";;&" nil sh-handle-prev-case-alt-end) ;Like ";;" with diff semantics. - (";&" nil sh-handle-prev-case-alt-end) ;Like ";;" with diff semantics. - ("done" sh-handle-this-done sh-handle-prev-done) - ("do" sh-handle-this-do sh-handle-prev-do)) - - ;; Note: we don't need specific stuff for bash and zsh shells; - ;; the regexp `sh-regexp-for-done' handles the extra keywords - ;; these shells use. - (rc - ("{" nil sh-handle-prev-open) - ("}" sh-handle-this-close nil) - ("case" sh-handle-this-rc-case sh-handle-prev-rc-case)))) - - (defun sh-set-shell (shell &optional no-query-flag insert-flag) "Set this buffer's shell to SHELL (a string). @@ -2400,16 +2255,6 @@ whose value is the shell name (don't quote it)." (funcall mksym "rules") :forward-token (funcall mksym "forward-token") :backward-token (funcall mksym "backward-token"))) - (unless sh-use-smie - (setq-local sh-kw-alist (sh-feature sh-kw)) - (let ((regexp (sh-feature sh-kws-for-done))) - (if regexp - (setq-local sh-regexp-for-done - (sh-mkword-regexpr (regexp-opt regexp t))))) - (message "setting up indent stuff") - ;; sh-mode has already made indent-line-function local - ;; but do it in case this is called before that. - (setq-local indent-line-function #'sh-indent-line)) (if sh-make-vars-local (sh-make-vars-local)) (message "Indentation setup for shell type %s" sh-shell)) @@ -2564,11 +2409,6 @@ region, clear header." (eq -1 (% (save-excursion (skip-chars-backward "\\\\")) 2))) ;; Indentation stuff. -(defun sh-must-support-indent () - "Signal an error if the shell type for this buffer is not supported. -Also, the buffer must be in Shell-script mode." - (unless sh-indent-supported-here - (error "This buffer's shell does not support indentation through Emacs"))) (defun sh-make-vars-local () "Make the indentation variables local to this buffer. @@ -2589,654 +2429,12 @@ Then, if variable `sh-make-vars-local' is non-nil, make them local." (if sh-make-vars-local (mapcar 'make-local-variable sh-var-list))) - -;; Theoretically these are only needed in shell and derived modes. -;; However, the routines which use them are only called in those modes. -(defconst sh-special-keywords "then\\|do") - -(defun sh-help-string-for-variable (var) - "Construct a string for `sh-read-variable' when changing variable VAR ." - (let ((msg (documentation-property var 'variable-documentation)) - (msg2 "")) - (unless (memq var '(sh-first-lines-indent sh-indent-comment)) - (setq msg2 - (format "\n -You can enter a number (positive to increase indentation, -negative to decrease indentation, zero for no change to indentation). - -Or, you can enter one of the following symbols which are relative to -the value of variable `sh-basic-offset' -which in this buffer is currently %s. - -\t%s." - sh-basic-offset - (mapconcat (lambda (x) - (nth (1- (length x)) x)) - sh-symbol-list "\n\t")))) - (concat - ;; The following shows the global not the local value! - ;; (format "Current value of %s is %s\n\n" var (symbol-value var)) - msg msg2))) - -(defun sh-read-variable (var) - "Read a new value for indentation variable VAR." - (let ((minibuffer-help-form `(sh-help-string-for-variable - (quote ,var))) - val) - (setq val (read-from-minibuffer - (format "New value for %s (press %s for help): " - var (single-key-description help-char)) - (format "%s" (symbol-value var)) - nil t)) - val)) - - - (defun sh-in-comment-or-string (start) "Return non-nil if START is in a comment or string." (save-excursion (let ((state (syntax-ppss start))) (or (nth 3 state) (nth 4 state))))) -(defun sh-goto-matching-if () - "Go to the matching if for a fi. -This handles nested if..fi pairs." - (let ((found (sh-find-prev-matching "\\bif\\b" "\\bfi\\b" 1))) - (if found - (goto-char found)))) - - -;; Functions named sh-handle-this-XXX are called when the keyword on the -;; line whose indentation is being handled contain XXX; -;; those named sh-handle-prev-XXX are when XXX appears on the previous line. - -(defun sh-handle-prev-if () - (list '(+ sh-indent-after-if))) - -(defun sh-handle-this-else () - (if (sh-goto-matching-if) - ;; (list "aligned to if") - (list "aligned to if" '(+ sh-indent-for-else)) - nil - )) - -(defun sh-handle-prev-else () - (if (sh-goto-matching-if) - (list '(+ sh-indent-after-if)) - )) - -(defun sh-handle-this-fi () - (if (sh-goto-matching-if) - (list "aligned to if" '(+ sh-indent-for-fi)) - nil - )) - -(defun sh-handle-prev-fi () - ;; Why do we have this rule? Because we must go back to the if - ;; to get its indent. We may continue back from there. - ;; We return nil because we don't have anything to add to result, - ;; the side affect of setting align-point is all that matters. - ;; we could return a comment (a string) but I can't think of a good one... - (sh-goto-matching-if) - nil) - -(defun sh-handle-this-then () - (let ((p (sh-goto-matching-if))) - (if p - (list '(+ sh-indent-for-then)) - ))) - -(defun sh-handle-prev-then () - (let ((p (sh-goto-matching-if))) - (if p - (list '(+ sh-indent-after-if)) - ))) - -(defun sh-handle-prev-open () - (save-excursion - (let ((x (sh-prev-stmt))) - (if (and x - (progn - (goto-char x) - (or - (looking-at "function\\b") - (looking-at "\\s-*\\S-+\\s-*()") - ))) - (list '(+ sh-indent-after-function)) - (list '(+ sh-indent-after-open))) - ))) - -(defun sh-handle-this-close () - (forward-char 1) ;; move over ")" - (if (sh-safe-forward-sexp -1) - (list "aligned to opening paren"))) - -(defun sh-goto-matching-case () - (let ((found (sh-find-prev-matching "\\bcase\\b" "\\besac\\b" 1))) - (if found (goto-char found)))) - -(defun sh-handle-prev-case () - ;; This is typically called when point is on same line as a case - ;; we shouldn't -- and can't find prev-case - (if (looking-at ".*\\<case\\>") - (list '(+ sh-indent-for-case-label)) - (error "We don't seem to be on a line with a case"))) ;; debug - -(defun sh-handle-this-esac () - (if (sh-goto-matching-case) - (list "aligned to matching case"))) - -(defun sh-handle-prev-esac () - (if (sh-goto-matching-case) - (list "matching case"))) - -(defun sh-handle-after-case-label () - (if (sh-goto-matching-case) - (list '(+ sh-indent-for-case-alt)))) - -(defun sh-handle-prev-case-alt-end () - (if (sh-goto-matching-case) - (list '(+ sh-indent-for-case-label)))) - -(defun sh-safe-forward-sexp (&optional arg) - "Try and do a `forward-sexp', but do not error. -Return new point if successful, nil if an error occurred." - (condition-case nil - (progn - (forward-sexp (or arg 1)) - (point)) ;; return point if successful - (error - (sh-debug "oops!(1) %d" (point)) - nil))) ;; return nil if fail - -(defun sh-goto-match-for-done () - (let ((found (sh-find-prev-matching sh-regexp-for-done sh-re-done 1))) - (if found - (goto-char found)))) - -(defun sh-handle-this-done () - (if (sh-goto-match-for-done) - (list "aligned to do stmt" '(+ sh-indent-for-done)))) - -(defun sh-handle-prev-done () - (if (sh-goto-match-for-done) - (list "previous done"))) - -(defun sh-handle-this-do () - (if (sh-goto-match-for-done) - (list '(+ sh-indent-for-do)))) - -(defun sh-handle-prev-do () - (cond - ((save-restriction - (narrow-to-region (point) (line-beginning-position)) - (sh-goto-match-for-done)) - (sh-debug "match for done found on THIS line") - (list '(+ sh-indent-after-loop-construct))) - ((sh-goto-match-for-done) - (sh-debug "match for done found on PREV line") - (list '(+ sh-indent-after-do))) - (t - (message "match for done NOT found") - nil))) - -;; for rc: -(defun sh-find-prev-switch () - "Find the line for the switch keyword matching this line's case keyword." - (re-search-backward "\\<switch\\>" nil t)) - -(defun sh-handle-this-rc-case () - (if (sh-find-prev-switch) - (list '(+ sh-indent-after-switch)) - ;; (list '(+ sh-indent-for-case-label)) - nil)) - -(defun sh-handle-prev-rc-case () - (list '(+ sh-indent-after-case))) - -(defun sh-check-rule (n thing) - (let ((rule (nth n (assoc thing sh-kw-alist))) - (val nil)) - (if rule - (progn - (setq val (funcall rule)) - (sh-debug "rule (%d) for %s at %d is %s\n-> returned %s" - n thing (point) rule val))) - val)) - - -(defun sh-get-indent-info () - "Return indent-info for this line. -This is a list. nil means the line is to be left as is. -Otherwise it contains one or more of the following sublists: -\(t NUMBER) NUMBER is the base location in the buffer that indentation is - relative to. If present, this is always the first of the - sublists. The indentation of the line in question is - derived from the indentation of this point, possibly - modified by subsequent sublists. -\(+ VAR) -\(- VAR) Get the value of variable VAR and add to or subtract from - the indentation calculated so far. -\(= VAR) Get the value of variable VAR and *replace* the - indentation with its value. This only occurs for - special variables such as `sh-indent-comment'. -STRING This is ignored for the purposes of calculating - indentation, it is printed in certain cases to help show - what the indentation is based on." - ;; See comments before `sh-kw'. - (save-excursion - (let ((have-result nil) - this-kw - val - (result nil) - (align-point nil) - prev-line-end x) - (beginning-of-line) - ;; Note: setting result to t means we are done and will return nil. - ;;(This function never returns just t.) - (cond - ((or (nth 3 (syntax-ppss (point))) - (eq (get-text-property (point) 'face) 'sh-heredoc)) - ;; String continuation -- don't indent - (setq result t) - (setq have-result t)) - ((looking-at "\\s-*#") ; was (equal this-kw "#") - (if (bobp) - (setq result t) ;; return nil if 1st line! - (setq result (list '(= sh-indent-comment))) - ;; we still need to get previous line in case - ;; sh-indent-comment is t (indent as normal) - (setq align-point (sh-prev-line nil)) - (setq have-result nil) - )) - ) ;; cond - - (unless have-result - ;; Continuation lines are handled specially - (if (sh-this-is-a-continuation) - (progn - (setq result - (if (save-excursion - (beginning-of-line) - (not (memq (char-before (- (point) 2)) '(?\s ?\t)))) - ;; By convention, if the continuation \ is not - ;; preceded by a SPC or a TAB it means that the line - ;; is cut at a place where spaces cannot be freely - ;; added/removed. I.e. do not indent the line. - (list '(= nil)) - ;; We assume the line being continued is already - ;; properly indented... - ;; (setq prev-line-end (sh-prev-line)) - (setq align-point (sh-prev-line nil)) - (list '(+ sh-indent-for-continuation)))) - (setq have-result t)) - (beginning-of-line) - (skip-chars-forward " \t") - (setq this-kw (sh-get-kw))) - - ;; Handle "this" keyword: first word on the line we're - ;; calculating indentation info for. - (if this-kw - (if (setq val (sh-check-rule 1 this-kw)) - (progn - (setq align-point (point)) - (sh-debug - "this - setting align-point to %d" align-point) - (setq result (append result val)) - (setq have-result t) - ;; set prev-line to continue processing remainder - ;; of this line as a previous line - (setq prev-line-end (point)) - )))) - - (unless have-result - (setq prev-line-end (sh-prev-line 'end))) - - (if prev-line-end - (save-excursion - ;; We start off at beginning of this line. - ;; Scan previous statements while this is <= - ;; start of previous line. - (goto-char prev-line-end) - (setq x t) - (while (and x (setq x (sh-prev-thing))) - (sh-debug "at %d x is: %s result is: %s" (point) x result) - (cond - ((and (equal x ")") - (equal (get-text-property (1- (point)) 'syntax-table) - sh-st-punc)) - (sh-debug "Case label) here") - (setq x 'case-label) - (if (setq val (sh-check-rule 2 x)) - (progn - (setq result (append result val)) - (setq align-point (point)))) - (or (bobp) - (forward-char -1)) - (skip-chars-forward "*0-9?[]a-z") - ) - ((string-match "[])}]" x) - (setq x (sh-safe-forward-sexp -1)) - (if x - (progn - (setq align-point (point)) - (setq result (append result - (list "aligned to opening paren"))) - ))) - ((string-match "[[({]" x) - (sh-debug "Checking special thing: %s" x) - (if (setq val (sh-check-rule 2 x)) - (setq result (append result val))) - (forward-char -1) - (setq align-point (point))) - ((string-match "[\"'`]" x) - (sh-debug "Skipping back for %s" x) - ;; this was oops-2 - (setq x (sh-safe-forward-sexp -1))) - ((stringp x) - (sh-debug "Checking string %s at %s" x (point)) - (if (setq val (sh-check-rule 2 x)) - ;; (or (eq t (car val)) - ;; (eq t (car (car val)))) - (setq result (append result val))) - ;; not sure about this test Wed Jan 27 23:48:35 1999 - (setq align-point (point)) - (unless (bolp) - (forward-char -1))) - (t - (error "Don't know what to do with %s" x)) - ) - ) ;; while - (sh-debug "result is %s" result) - ) - (sh-debug "No prev line!") - (sh-debug "result: %s align-point: %s" result align-point) - ) - - (if align-point - ;; was: (setq result (append result (list (list t align-point)))) - (setq result (append (list (list t align-point)) result)) - ) - (sh-debug "result is now: %s" result) - - (or result - (setq result (list (if prev-line-end - (list t prev-line-end) - (list '= 'sh-first-lines-indent))))) - - (if (eq result t) - (setq result nil)) - (sh-debug "result is: %s" result) - result - ) ;; let - )) - - -(defun sh-get-indent-var-for-line (&optional info) - "Return the variable controlling indentation for this line. -If there is not [just] one such variable, return a string -indicating the problem. -If INFO is supplied it is used, else it is calculated." - (let ((var nil) - (result nil) - (reason nil) - sym elt) - (or info - (setq info (sh-get-indent-info))) - (if (null info) - (setq result "this line to be left as is") - (while (and info (null result)) - (setq elt (car info)) - (cond - ((stringp elt) - (setq reason elt) - ) - ((not (listp elt)) - (error "sh-get-indent-var-for-line invalid elt: %s" elt)) - ;; so it is a list - ((eq t (car elt)) - ) ;; nothing - ((symbolp (setq sym (nth 1 elt))) - ;; A bit of a kludge - when we see the sh-indent-comment - ;; ignore other variables. Otherwise it is tricky to - ;; "learn" the comment indentation. - (if (eq var 'sh-indent-comment) - (setq result var) - (if var - (setq result - "this line is controlled by more than 1 variable.") - (setq var sym)))) - (t - (error "sh-get-indent-var-for-line invalid list elt: %s" elt))) - (setq info (cdr info)) - )) - (or result - (setq result var)) - (or result - (setq result reason)) - (if (null result) - ;; e.g. just had (t POS) - (setq result "line has default indentation")) - result)) - - - -;; Finding the previous line isn't trivial. -;; We must *always* go back one more and see if that is a continuation -;; line -- it is the PREVIOUS line which is continued, not the one -;; we are going to! -;; Also, we want to treat a whole "here document" as one big line, -;; because we may want to align to the beginning of it. -;; -;; What we do: -;; - go back to previous non-empty line -;; - if this is in a here-document, go to the beginning of it -;; - while previous line is continued, go back one line -(defun sh-prev-line (&optional end) - "Back to end of previous non-comment non-empty line. -Go to beginning of logical line unless END is non-nil, in which case -we go to the end of the previous line and do not check for continuations." - (save-excursion - (beginning-of-line) - (forward-comment (- (point-max))) - (unless end (beginning-of-line)) - (when (and (not (bobp)) - (eq (get-text-property (1- (point)) 'face) 'sh-heredoc)) - (let ((p1 (previous-single-property-change (1- (point)) 'face))) - (when p1 - (goto-char p1) - (if end - (end-of-line) - (beginning-of-line))))) - (unless end - ;; we must check previous lines to see if they are continuation lines - ;; if so, we must return position of first of them - (while (and (sh-this-is-a-continuation) - (>= 0 (forward-line -1)))) - (beginning-of-line) - (skip-chars-forward " \t")) - (point))) - - -(defun sh-prev-stmt () - "Return the address of the previous stmt or nil." - ;; This is used when we are trying to find a matching keyword. - ;; Searching backward for the keyword would certainly be quicker, but - ;; it is hard to remove "false matches" -- such as if the keyword - ;; appears in a string or quote. This way is slower, but (I think) safer. - (interactive) - (save-excursion - (let ((going t) - (start (point)) - (found nil) - (prev nil)) - (skip-chars-backward " \t;|&({[") - (while (and (not found) - (not (bobp)) - going) - ;; Do a backward-sexp if possible, else backup bit by bit... - (if (sh-safe-forward-sexp -1) - (progn - (if (looking-at sh-special-keywords) - (progn - (setq found prev)) - (setq prev (point)) - )) - ;; backward-sexp failed - (if (zerop (skip-chars-backward " \t()[]{};`'")) - (forward-char -1)) - (if (bolp) - (let ((back (sh-prev-line nil))) - (if back - (goto-char back) - (setq going nil))))) - (unless found - (skip-chars-backward " \t") - (if (or (and (bolp) (not (sh-this-is-a-continuation))) - (eq (char-before) ?\;) - (looking-at "\\s-*[|&]")) - (setq found (point))))) - (if found - (goto-char found)) - (if found - (progn - (skip-chars-forward " \t|&({[") - (setq found (point)))) - (if (>= (point) start) - (progn - (debug "We didn't move!") - (setq found nil)) - (or found - (sh-debug "Did not find prev stmt."))) - found))) - - -(defun sh-get-word () - "Get a shell word skipping whitespace from point." - (interactive) - (skip-chars-forward "\t ") - (let ((start (point))) - (while - (if (looking-at "[\"'`]") - (sh-safe-forward-sexp) - ;; (> (skip-chars-forward "^ \t\n\"'`") 0) - (> (skip-chars-forward "-_$[:alnum:]") 0) - )) - (buffer-substring start (point)) - )) - -(defun sh-prev-thing () - "Return the previous thing this logical line." - ;; This is called when `sh-get-indent-info' is working backwards on - ;; the previous line(s) finding what keywords may be relevant for - ;; indenting. It moves over sexps if possible, and will stop - ;; on a ; and at the beginning of a line if it is not a continuation - ;; line. - ;; - ;; Added a kludge for ";;" - ;; Possible return values: - ;; nil - nothing - ;; a string - possibly a keyword - ;; - (if (bolp) - nil - (let ((start (point)) - (min-point (if (sh-this-is-a-continuation) - (sh-prev-line nil) - (line-beginning-position)))) - (skip-chars-backward " \t;" min-point) - (if (looking-at "\\s-*;[;&]") - ;; (message "Found ;; !") - ";;" - (skip-chars-backward "^)}];\"'`({[" min-point) - (let ((c (if (> (point) min-point) (char-before)))) - (sh-debug "stopping at %d c is %s start=%d min-point=%d" - (point) c start min-point) - (if (not (memq c '(?\n nil ?\;))) - ;; c -- return a string - (char-to-string c) - ;; Return the leading keyword of the "command" we supposedly - ;; skipped over. Maybe we skipped too far (e.g. past a `do' or - ;; `then' that precedes the actual command), so check whether - ;; we're looking at such a keyword and if so, move back forward. - (let ((boundary (point)) - kwd next) - (while - (progn - ;; Skip forward over white space newline and \ at eol. - (skip-chars-forward " \t\n\\\\" start) - (if (>= (point) start) - (progn - (sh-debug "point: %d >= start: %d" (point) start) - nil) - (if next (setq boundary next)) - (sh-debug "Now at %d start=%d" (point) start) - (setq kwd (sh-get-word)) - (if (member kwd (sh-feature sh-leading-keywords)) - (progn - (setq next (point)) - t) - nil)))) - (goto-char boundary) - kwd))))))) - - -(defun sh-this-is-a-continuation () - "Return non-nil if current line is a continuation of previous line." - (save-excursion - (and (zerop (forward-line -1)) - (looking-at ".*\\\\$") - (not (nth 4 (parse-partial-sexp (match-beginning 0) (match-end 0) - nil nil nil t)))))) - -(defun sh-get-kw (&optional where and-move) - "Return first word of line from WHERE. -If AND-MOVE is non-nil then move to end of word." - (let ((start (point))) - (if where - (goto-char where)) - (prog1 - (buffer-substring (point) - (progn (skip-chars-forward "^ \t\n;&|")(point))) - (unless and-move - (goto-char start))))) - -(defun sh-find-prev-matching (open close &optional depth) - "Find a matching token for a set of opening and closing keywords. -This takes into account that there may be nested open..close pairings. -OPEN and CLOSE are regexps denoting the tokens to be matched. -Optional parameter DEPTH (usually 1) says how many to look for." - (let ((parse-sexp-ignore-comments t) - (forward-sexp-function nil) - prev) - (setq depth (or depth 1)) - (save-excursion - (condition-case nil - (while (and - (/= 0 depth) - (not (bobp)) - (setq prev (sh-prev-stmt))) - (goto-char prev) - (save-excursion - (if (looking-at "\\\\\n") - (progn - (forward-char 2) - (skip-chars-forward " \t"))) - (cond - ((looking-at open) - (setq depth (1- depth)) - (sh-debug "found open at %d - depth = %d" (point) depth)) - ((looking-at close) - (setq depth (1+ depth)) - (sh-debug "found close - depth = %d" depth)) - (t - )))) - (error nil)) - (if (eq depth 0) - prev ;; (point) - nil) - ))) - (defun sh-var-value (var &optional ignore-error) "Return the value of variable VAR, interpreting symbols. @@ -3268,620 +2466,16 @@ IGNORE-ERROR is non-nil." "Don't know how to handle %s's value of %s" var val) 0)))) -(defun sh-set-var-value (var value &optional no-symbol) - "Set variable VAR to VALUE. -Unless optional argument NO-SYMBOL is non-nil, then if VALUE is -can be represented by a symbol then do so." - (cond - (no-symbol - (set var value)) - ((= value sh-basic-offset) - (set var '+)) - ((= value (- sh-basic-offset)) - (set var '-)) - ((eq value (* 2 sh-basic-offset)) - (set var '++)) - ((eq value (* 2 (- sh-basic-offset))) - (set var '--)) - ((eq value (/ sh-basic-offset 2)) - (set var '*)) - ((eq value (/ (- sh-basic-offset) 2)) - (set var '/)) - (t - (set var value))) - ) - - -(defun sh-calculate-indent (&optional info) - "Return the indentation for the current line. -If INFO is supplied it is used, else it is calculated from current line." - (let ((ofs 0) - (base-value 0) - elt a b val) - (or info - (setq info (sh-get-indent-info))) - (when info - (while info - (sh-debug "info: %s ofs=%s" info ofs) - (setq elt (car info)) - (cond - ((stringp elt)) ;; do nothing? - ((listp elt) - (setq a (car (car info))) - (setq b (nth 1 (car info))) - (cond - ((eq a t) - (save-excursion - (goto-char b) - (setq val (current-indentation))) - (setq base-value val)) - ((symbolp b) - (setq val (sh-var-value b)) - (cond - ((eq a '=) - (cond - ((null val) - ;; no indentation - ;; set info to nil so we stop immediately - (setq base-value nil ofs nil info nil)) - ((eq val t) (setq ofs 0)) ;; indent as normal line - (t - ;; The following assume the (t POS) come first! - (setq ofs val base-value 0) - (setq info nil)))) ;; ? stop now - ((eq a '+) (setq ofs (+ ofs val))) - ((eq a '-) (setq ofs (- ofs val))) - (t - (error "sh-calculate-indent invalid a a=%s b=%s" a b)))) - (t - (error "sh-calculate-indent invalid elt: a=%s b=%s" a b)))) - (t - (error "sh-calculate-indent invalid elt %s" elt))) - (sh-debug "a=%s b=%s val=%s base-value=%s ofs=%s" - a b val base-value ofs) - (setq info (cdr info))) - ;; return value: - (sh-debug "at end: base-value: %s ofs: %s" base-value ofs) - - (cond - ((or (null base-value)(null ofs)) - nil) - ((and (numberp base-value)(numberp ofs)) - (sh-debug "base (%d) + ofs (%d) = %d" - base-value ofs (+ base-value ofs)) - (+ base-value ofs)) ;; return value - (t - (error "sh-calculate-indent: Help. base-value=%s ofs=%s" - base-value ofs) - nil))))) +(define-obsolete-function-alias 'sh-show-indent + #'smie-config-show-indent "28.1") +(define-obsolete-function-alias 'sh-set-indent #'smie-config-set-indent "28.1") -(defun sh-indent-line () - "Indent the current line." - (interactive) - (let ((indent (sh-calculate-indent)) - (pos (- (point-max) (point)))) - (when indent - (beginning-of-line) - (skip-chars-forward " \t") - (indent-line-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))))) - - -(defun sh-blink (blinkpos &optional msg) - "Move cursor momentarily to BLINKPOS and display MSG." - ;; We can get here without it being a number on first line - (if (numberp blinkpos) - (save-excursion - (goto-char blinkpos) - (if msg (message "%s" msg) (message nil)) - (sit-for blink-matching-delay)) - (if msg (message "%s" msg) (message nil)))) - -(defun sh-show-indent (arg) - "Show how the current line would be indented. -This tells you which variable, if any, controls the indentation of -this line. -If optional arg ARG is non-null (called interactively with a prefix), -a pop up window describes this variable. -If variable `sh-blink' is non-nil then momentarily go to the line -we are indenting relative to, if applicable." - (interactive "P") - (sh-must-support-indent) - (if sh-use-smie - (smie-config-show-indent) - (let* ((info (sh-get-indent-info)) - (var (sh-get-indent-var-for-line info)) - (curr-indent (current-indentation)) - val msg) - (if (stringp var) - (message "%s" (setq msg var)) - (setq val (sh-calculate-indent info)) - - (if (eq curr-indent val) - (setq msg (format "%s is %s" var (symbol-value var))) - (setq msg - (if val - (format "%s (%s) would change indent from %d to: %d" - var (symbol-value var) curr-indent val) - (format "%s (%s) would leave line as is" - var (symbol-value var))) - )) - (if (and arg var) - (describe-variable var))) - (if sh-blink - (let ((info (sh-get-indent-info))) - (if (and info (listp (car info)) - (eq (car (car info)) t)) - (sh-blink (nth 1 (car info)) msg) - (message "%s" msg))) - (message "%s" msg)) - ))) +(define-obsolete-function-alias 'sh-learn-line-indent + #'smie-config-set-indent "28.1") -(defun sh-set-indent () - "Set the indentation for the current line. -If the current line is controlled by an indentation variable, prompt -for a new value for it." - (interactive) - (sh-must-support-indent) - (if sh-use-smie - (smie-config-set-indent) - (let* ((info (sh-get-indent-info)) - (var (sh-get-indent-var-for-line info)) - val old-val indent-val) - (if (stringp var) - (message "Cannot set indent - %s" var) - (setq old-val (symbol-value var)) - (setq val (sh-read-variable var)) - (condition-case nil - (progn - (set var val) - (setq indent-val (sh-calculate-indent info)) - (if indent-val - (message "Variable: %s Value: %s would indent to: %d" - var (symbol-value var) indent-val) - (message "Variable: %s Value: %s would leave line as is." - var (symbol-value var))) - ;; I'm not sure about this, indenting it now? - ;; No. Because it would give the impression that an undo would - ;; restore thing, but the value has been altered. - ;; (sh-indent-line) - ) - (error - (set var old-val) - (message "Bad value for %s, restoring to previous value %s" - var old-val) - (sit-for 1) - nil)) - )))) - - -(defun sh-learn-line-indent (arg) - "Learn how to indent a line as it currently is indented. - -If there is an indentation variable which controls this line's indentation, -then set it to a value which would indent the line the way it -presently is. - -If the value can be represented by one of the symbols then do so -unless optional argument ARG (the prefix when interactive) is non-nil." - (interactive "*P") - (sh-must-support-indent) - (if sh-use-smie - (smie-config-set-indent) - ;; I'm not sure if we show allow learning on an empty line. - ;; Though it might occasionally be useful I think it usually - ;; would just be confusing. - (if (save-excursion - (beginning-of-line) - (looking-at "\\s-*$")) - (message "sh-learn-line-indent ignores empty lines.") - (let* ((info (sh-get-indent-info)) - (var (sh-get-indent-var-for-line info)) - ival sval diff new-val - (no-symbol arg) - (curr-indent (current-indentation))) - (cond - ((stringp var) - (message "Cannot learn line - %s" var)) - ((eq var 'sh-indent-comment) - ;; This is arbitrary... - ;; - if curr-indent is 0, set to curr-indent - ;; - else if it has the indentation of a "normal" line, - ;; then set to t - ;; - else set to curr-indent. - (setq sh-indent-comment - (if (= curr-indent 0) - 0 - (let* ((sh-indent-comment t) - (val2 (sh-calculate-indent info))) - (if (= val2 curr-indent) - t - curr-indent)))) - (message "%s set to %s" var (symbol-value var)) - ) - ((numberp (setq sval (sh-var-value var))) - (setq ival (sh-calculate-indent info)) - (setq diff (- curr-indent ival)) - - (sh-debug "curr-indent: %d ival: %d diff: %d var:%s sval %s" - curr-indent ival diff var sval) - (setq new-val (+ sval diff)) - ;; I commented out this because someone might want to replace - ;; a value of `+' with the current value of sh-basic-offset - ;; or vice-versa. - ;;(if (= 0 diff) - ;; (message "No change needed!") - (sh-set-var-value var new-val no-symbol) - (message "%s set to %s" var (symbol-value var)) - ) - (t - (debug) - (message "Cannot change %s" var))))))) - - - -(defun sh-mark-init (buffer) - "Initialize a BUFFER to be used by `sh-mark-line'." - (with-current-buffer (get-buffer-create buffer) - (erase-buffer) - (occur-mode))) - - -(defun sh-mark-line (message point buffer &optional add-linenum occur-point) - "Insert MESSAGE referring to location POINT in current buffer into BUFFER. -Buffer BUFFER is in `occur-mode'. -If ADD-LINENUM is non-nil the message is preceded by the line number. -If OCCUR-POINT is non-nil then the line is marked as a new occurrence -so that `occur-next' and `occur-prev' will work." - (let ((m1 (make-marker)) - start - (line "")) - (when point - (set-marker m1 point (current-buffer)) - (if add-linenum - (setq line (format "%d: " (1+ (count-lines 1 point)))))) - (save-excursion - (if (get-buffer buffer) - (set-buffer (get-buffer buffer)) - (set-buffer (get-buffer-create buffer)) - (occur-mode) - ) - (goto-char (point-max)) - (setq start (point)) - (let ((inhibit-read-only t)) - (insert line) - (if occur-point - (setq occur-point (point))) - (insert message) - (if point - (add-text-properties - start (point) - '(mouse-face highlight - help-echo "mouse-2: go to the line where I learned this"))) - (insert "\n") - (when point - (put-text-property start (point) 'occur-target m1) - (if occur-point - (put-text-property start occur-point - 'occur-match t)) - ))))) - -;; Is this really worth having? -(defvar sh-learned-buffer-hook nil - "An abnormal hook, called with an alist of learned variables.") -;; Example of how to use sh-learned-buffer-hook -;; -;; (defun what-i-learned (list) -;; (let ((p list)) -;; (with-current-buffer "*scratch*" -;; (goto-char (point-max)) -;; (insert "(setq\n") -;; (while p -;; (insert (format " %s %s \n" -;; (nth 0 (car p)) (nth 1 (car p)))) -;; (setq p (cdr p))) -;; (insert ")\n") -;; ))) -;; -;; (add-hook 'sh-learned-buffer-hook #'what-i-learned) - - -;; Originally this was sh-learn-region-indent (beg end) -;; However, in practice this was awkward so I changed it to -;; use the whole buffer. Use narrowing if need be. -(defun sh-learn-buffer-indent (&optional arg) - "Learn how to indent the buffer the way it currently is. - -If `sh-use-smie' is non-nil, call `smie-config-guess'. -Otherwise, run the sh-script specific indent learning command, as -described below. - -Output in buffer \"*indent*\" shows any lines which have conflicting -values of a variable, and the final value of all variables learned. -When called interactively, pop to this buffer automatically if -there are any discrepancies. - -If no prefix ARG is given, then variables are set to numbers. -If a prefix arg is given, then variables are set to symbols when -applicable -- e.g. to symbol `+' if the value is that of the -basic indent. -If a positive numerical prefix is given, then `sh-basic-offset' -is set to the prefix's numerical value. -Otherwise, sh-basic-offset may or may not be changed, according -to the value of variable `sh-learn-basic-offset'. - -Abnormal hook `sh-learned-buffer-hook' if non-nil is called when the -function completes. The function is abnormal because it is called -with an alist of variables learned. - -This command can often take a long time to run." - (interactive "P") - (sh-must-support-indent) - (if sh-use-smie - (smie-config-guess) - (save-excursion - (goto-char (point-min)) - (let ((learned-var-list nil) - (out-buffer "*indent*") - (num-diffs 0) - previous-set-info - (max 17) - vec - msg - (comment-col nil) ;; number if all same, t if seen diff values - (comments-always-default t) ;; nil if we see one not default - initial-msg - (specified-basic-offset (and arg (numberp arg) - (> arg 0))) - (linenum 0) - suggested) - (setq vec (make-vector max 0)) - (sh-mark-init out-buffer) - - (if specified-basic-offset - (progn - (setq sh-basic-offset arg) - (setq initial-msg - (format "Using specified sh-basic-offset of %d" - sh-basic-offset))) - (setq initial-msg - (format "Initial value of sh-basic-offset: %s" - sh-basic-offset))) - - (while (< (point) (point-max)) - (setq linenum (1+ linenum)) - ;; (if (zerop (% linenum 10)) - (message "line %d" linenum) - ;; ) - (unless (looking-at "\\s-*$") ;; ignore empty lines! - (let* ((sh-indent-comment t) ;; info must return default indent - (info (sh-get-indent-info)) - (var (sh-get-indent-var-for-line info)) - sval ival diff new-val - (curr-indent (current-indentation))) - (cond - ((null var) - nil) - ((stringp var) - nil) - ((numberp (setq sval (sh-var-value var 'no-error))) - ;; the numberp excludes comments since sval will be t. - (setq ival (sh-calculate-indent)) - (setq diff (- curr-indent ival)) - (setq new-val (+ sval diff)) - (sh-set-var-value var new-val 'no-symbol) - (unless (looking-at "\\s-*#") ;; don't learn from comments - (if (setq previous-set-info (assoc var learned-var-list)) - (progn - ;; it was already there, is it same value ? - (unless (eq (symbol-value var) - (nth 1 previous-set-info)) - (sh-mark-line - (format "Variable %s was set to %s" - var (symbol-value var)) - (point) out-buffer t t) - (sh-mark-line - (format " but was previously set to %s" - (nth 1 previous-set-info)) - (nth 2 previous-set-info) out-buffer t) - (setq num-diffs (1+ num-diffs)) - ;; (delete previous-set-info learned-var-list) - (setcdr previous-set-info - (list (symbol-value var) (point))) - ) - ) - (setq learned-var-list - (append (list (list var (symbol-value var) - (point))) - learned-var-list))) - (if (numberp new-val) - (progn - (sh-debug - "This line's indent value: %d" new-val) - (if (< new-val 0) - (setq new-val (- new-val))) - (if (< new-val max) - (aset vec new-val (1+ (aref vec new-val)))))) - )) - ((eq var 'sh-indent-comment) - (unless (= curr-indent (sh-calculate-indent info)) - ;; this is not the default indentation - (setq comments-always-default nil) - (if comment-col ;; then we have see one before - (or (eq comment-col curr-indent) - (setq comment-col t)) ;; seen a different one - (setq comment-col curr-indent)) - )) - (t - (sh-debug "Cannot learn this line!!!") - )) - (sh-debug - "at %s learned-var-list is %s" (point) learned-var-list) - )) - (forward-line 1) - ) ;; while - (if sh-debug - (progn - (setq msg (format - "comment-col = %s comments-always-default = %s" - comment-col comments-always-default)) - ;; (message msg) - (sh-mark-line msg nil out-buffer))) - (cond - ((eq comment-col 0) - (setq msg "\nComments are all in 1st column.\n")) - (comments-always-default - (setq msg "\nComments follow default indentation.\n") - (setq comment-col t)) - ((numberp comment-col) - (setq msg (format "\nComments are in col %d." comment-col))) - (t - (setq msg "\nComments seem to be mixed, leaving them as is.\n") - (setq comment-col nil) - )) - (sh-debug msg) - (sh-mark-line msg nil out-buffer) - - (sh-mark-line initial-msg nil out-buffer t t) - - (setq suggested (sh-guess-basic-offset vec)) - - (if (and suggested (not specified-basic-offset)) - (let ((new-value - (cond - ;; t => set it if we have a single value as a number - ((and (eq sh-learn-basic-offset t) (numberp suggested)) - suggested) - ;; other non-nil => set it if only one value was found - (sh-learn-basic-offset - (if (numberp suggested) - suggested - (if (= (length suggested) 1) - (car suggested)))) - (t - nil)))) - (if new-value - (progn - (setq learned-var-list - (append (list (list 'sh-basic-offset - (setq sh-basic-offset new-value) - (point-max))) - learned-var-list)) - ;; Not sure if we need to put this line in, since - ;; it will appear in the "Learned variable settings". - (sh-mark-line - (format "Changed sh-basic-offset to: %d" sh-basic-offset) - nil out-buffer)) - (sh-mark-line - (if (listp suggested) - (format "Possible value(s) for sh-basic-offset: %s" - (mapconcat 'int-to-string suggested " ")) - (format "Suggested sh-basic-offset: %d" suggested)) - nil out-buffer)))) - - - (setq learned-var-list - (append (list (list 'sh-indent-comment comment-col (point-max))) - learned-var-list)) - (setq sh-indent-comment comment-col) - (let ((name (buffer-name))) - (sh-mark-line "\nLearned variable settings:" nil out-buffer) - (if arg - ;; Set learned variables to symbolic rather than numeric - ;; values where possible. - (dolist (learned-var (reverse learned-var-list)) - (let ((var (car learned-var)) - (val (nth 1 learned-var))) - (when (and (not (eq var 'sh-basic-offset)) - (numberp val)) - (sh-set-var-value var val))))) - (dolist (learned-var (reverse learned-var-list)) - (let ((var (car learned-var))) - (sh-mark-line (format " %s %s" var (symbol-value var)) - (nth 2 learned-var) out-buffer))) - (with-current-buffer out-buffer - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (insert - (format "Indentation values for buffer %s.\n" name) - (format "%d indentation variable%s different values%s\n\n" - num-diffs - (if (= num-diffs 1) - " has" "s have") - (if (zerop num-diffs) - "." ":")))))) - (run-hook-with-args 'sh-learned-buffer-hook learned-var-list) - (and (called-interactively-p 'any) - (or sh-popup-occur-buffer (> num-diffs 0)) - (pop-to-buffer out-buffer)))))) - -(defun sh-guess-basic-offset (vec) - "See if we can determine a reasonable value for `sh-basic-offset'. -This is experimental, heuristic and arbitrary! -Argument VEC is a vector of information collected by -`sh-learn-buffer-indent'. -Return values: - number - there appears to be a good single value - list of numbers - no obvious one, here is a list of one or more - reasonable choices - nil - we couldn't find a reasonable one." - (let* ((max (1- (length vec))) - (i 1) - (totals (make-vector max 0))) - (while (< i max) - (cl-incf (aref totals i) (* 4 (aref vec i))) - (if (zerop (% i 2)) - (cl-incf (aref totals i) (aref vec (/ i 2)))) - (if (< (* i 2) max) - (cl-incf (aref totals i) (aref vec (* i 2)))) - (setq i (1+ i))) - - (let ((x nil) - (result nil) - tot sum p) - (setq i 1) - (while (< i max) - (if (/= (aref totals i) 0) - (push (cons i (aref totals i)) x)) - (setq i (1+ i))) - - (setq x (sort (nreverse x) (lambda (a b) (> (cdr a) (cdr b))))) - (setq tot (apply '+ (append totals nil))) - (sh-debug (format "vec: %s\ntotals: %s\ntot: %d" - vec totals tot)) - (cond - ((zerop (length x)) - (message "no values!")) ;; we return nil - ((= (length x) 1) - (message "only value is %d" (car (car x))) - (setq result (car (car x)))) ;; return single value - ((> (cdr (car x)) (/ tot 2)) - ;; 1st is > 50% - (message "basic-offset is probably %d" (car (car x))) - (setq result (car (car x)))) ;; again, return a single value - ((>= (cdr (car x)) (* 2 (cdr (car (cdr x))))) - ;; 1st is >= 2 * 2nd - (message "basic-offset could be %d" (car (car x))) - (setq result (car (car x)))) - ((>= (+ (cdr (car x))(cdr (car (cdr x)))) (/ tot 2)) - ;; 1st & 2nd together >= 50% - return a list - (setq p x sum 0 result nil) - (while (and p - (<= (setq sum (+ sum (cdr (car p)))) (/ tot 2))) - (setq result (append result (list (car (car p))))) - (setq p (cdr p))) - (message "Possible choices for sh-basic-offset: %s" - (mapconcat 'int-to-string result " "))) - (t - (message "No obvious value for sh-basic-offset. Perhaps %d" - (car (car x))) - ;; result is nil here - )) - result))) +(define-obsolete-function-alias 'sh-learn-buffer-indent + #'smie-config-guess "28.1") ;; ======================================================================== diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 400e304ecf4..5eb8701d08a 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -905,7 +905,7 @@ it automatically." (const :tag "Default Terminator" t) (string :tag "Terminator String") (cons :tag "Terminator Pattern and String" - (string :tag "Terminator Pattern") + (regexp :tag "Terminator Pattern") (string :tag "Terminator String"))) :version "22.2" :group 'SQL) @@ -1033,7 +1033,7 @@ All products share this list; products should define a regexp to identify additional keywords in a variable defined by the :statement feature." :version "24.1" - :type 'string + :type 'regexp :group 'SQL) ;; Customization for Oracle diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index b225a9b1d9a..0677d36fbc7 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -16148,7 +16148,7 @@ expansion function)." ;; initialize speedbar (if (not (boundp 'speedbar-frame)) - (add-hook 'speedbar-load-hook 'vhdl-speedbar-initialize) + (with-no-warnings (add-hook 'speedbar-load-hook 'vhdl-speedbar-initialize)) (vhdl-speedbar-initialize) (when speedbar-frame (vhdl-speedbar-refresh))) diff --git a/lisp/recentf.el b/lisp/recentf.el index b636e594864..27918a9739c 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -277,6 +277,8 @@ If `file-name-history' is not empty, do nothing." "Normal hook run at end of loading the `recentf' package." :group 'recentf :type 'hook) +(make-obsolete-variable 'recentf-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom recentf-filename-handlers nil "Functions to post process recent file names. diff --git a/lisp/registry.el b/lisp/registry.el index 7d95d91ad2c..ef47f07aec5 100644 --- a/lisp/registry.el +++ b/lisp/registry.el @@ -317,7 +317,7 @@ Errors out if the key exists already." (message "reindexing: %d of %d (%.2f%%)" count expected (/ (* 100.0 count) expected))) (dolist (val (cdr-safe (assq tr v))) - (let* ((value-keys (registry-lookup-secondary-value db tr val))) + (let ((value-keys (registry-lookup-secondary-value db tr val))) (push key value-keys) (registry-lookup-secondary-value db tr val value-keys)))) (oref db data)))))) diff --git a/lisp/sb-image.el b/lisp/sb-image.el deleted file mode 100644 index 1e8b1057bc8..00000000000 --- a/lisp/sb-image.el +++ /dev/null @@ -1,107 +0,0 @@ -;;; sb-image --- Image management for speedbar - -;; Copyright (C) 1999-2003, 2005-2020 Free Software Foundation, Inc. - -;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Keywords: file, tags, tools - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: -;; -;; Supporting Image display for Emacs 20 and less, Emacs 21, and XEmacs, -;; is a challenging task, which doesn't take kindly to being byte compiled. -;; When sharing speedbar.elc between these three applications, the Image -;; support can get lost. -;; -;; By splitting out that hard part into this file, and avoiding byte -;; compilation, one copy speedbar can support all these platforms together. -;; -;; This file requires the `image' package if it is available. - -(require 'ezimage) - -;;; Code: -(defcustom speedbar-use-images ezimage-use-images - "Non-nil if speedbar should display icons." - :group 'speedbar - :version "21.1" - :type 'boolean) - -(defalias 'defimage-speedbar 'defezimage) - -(defvar speedbar-expand-image-button-alist - '(("<+>" . ezimage-directory-plus) - ("<->" . ezimage-directory-minus) - ("< >" . ezimage-directory) - ("[+]" . ezimage-page-plus) - ("[-]" . ezimage-page-minus) - ("[?]" . ezimage-page) - ("[ ]" . ezimage-page) - ("{+}" . ezimage-box-plus) - ("{-}" . ezimage-box-minus) - ("<M>" . ezimage-mail) - ("<d>" . ezimage-document-tag) - ("<i>" . ezimage-info-tag) - (" =>" . ezimage-tag) - (" +>" . ezimage-tag-gt) - (" ->" . ezimage-tag-v) - (">" . ezimage-tag) - ("@" . ezimage-tag-type) - (" @" . ezimage-tag-type) - ("*" . ezimage-checkout) - ("#" . ezimage-object) - ("!" . ezimage-object-out-of-date) - ("//" . ezimage-label) - ("%" . ezimage-lock) - ) - "List of text and image associations.") - -(defun speedbar-insert-image-button-maybe (start length) - "Insert an image button based on text starting at START for LENGTH chars. -If buttontext is unknown, just insert that text. -If we have an image associated with it, use that image." - (when speedbar-use-images - (let ((ezimage-expand-image-button-alist - speedbar-expand-image-button-alist)) - (ezimage-insert-image-button-maybe start length)))) - -(defun speedbar-image-dump () - "Dump out the current state of the Speedbar image alist. -See `speedbar-expand-image-button-alist' for details." - (interactive) - (with-output-to-temp-buffer "*Speedbar Images*" - (with-current-buffer "*Speedbar Images*" - (goto-char (point-max)) - (insert "Speedbar image cache.\n\n") - (let ((start (point)) (end nil)) - (insert "Image\tText\tImage Name") - (setq end (point)) - (insert "\n") - (put-text-property start end 'face 'underline)) - (let ((ia speedbar-expand-image-button-alist)) - (while ia - (let ((start (point))) - (insert (car (car ia))) - (insert "\t") - (speedbar-insert-image-button-maybe start - (length (car (car ia)))) - (insert (car (car ia)) "\t" (format "%s" (cdr (car ia))) "\n")) - (setq ia (cdr ia))))))) - -(provide 'sb-image) - -;;; sb-image.el ends here diff --git a/lisp/simple.el b/lisp/simple.el index 0d8072bf5f0..688dbcc947b 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1213,6 +1213,10 @@ that uses or sets the mark." ;; Counting lines, one way or another. +(defvar goto-line-history nil + "History of values entered with `goto-line'.") +(make-variable-buffer-local 'goto-line-history) + (defun goto-line (line &optional buffer) "Go to LINE, counting from line 1 at beginning of buffer. If called interactively, a numeric prefix argument specifies @@ -1257,7 +1261,8 @@ rather than line counts." ""))) ;; Read the argument, offering that number (if any) as default. (list (read-number (format "Goto line%s: " buffer-prompt) - (list default (line-number-at-pos))) + (list default (line-number-at-pos)) + 'goto-line-history) buffer)))) ;; Switch to the desired buffer, one way or another. (if buffer @@ -1783,23 +1788,36 @@ to get different commands to edit and resubmit." ;; and it serves as a shorthand for "Extended command: ". "M-x ") (lambda (string pred action) - (let ((pred - (if (memq action '(nil t)) - ;; Exclude obsolete commands from completions. - (lambda (sym) - (and (funcall pred sym) - (or (equal string (symbol-name sym)) - (not (get sym 'byte-obsolete-info))))) - pred))) - (complete-with-action action obarray string pred))) + (if (and suggest-key-bindings (eq action 'metadata)) + '(metadata + (annotation-function . read-extended-command--annotation) + (category . command)) + (let ((pred + (if (memq action '(nil t)) + ;; Exclude obsolete commands from completions. + (lambda (sym) + (and (funcall pred sym) + (or (equal string (symbol-name sym)) + (not (get sym 'byte-obsolete-info))))) + pred))) + (complete-with-action action obarray string pred)))) #'commandp t nil 'extended-command-history))) +(defun read-extended-command--annotation (command-name) + (let* ((function (and (stringp command-name) (intern-soft command-name))) + (binding (where-is-internal function overriding-local-map t))) + (when (and binding (not (stringp binding))) + (format " (%s)" (key-description binding))))) + (defcustom suggest-key-bindings t "Non-nil means show the equivalent key-binding when M-x command has one. The value can be a length of time to show the message for. If the value is non-nil and not a number, we wait 2 seconds. -Also see `extended-command-suggest-shorter'." +Also see `extended-command-suggest-shorter'. + +Equivalent key-bindings are also shown in the completion list of +M-x for all commands that have them." :group 'keyboard :type '(choice (const :tag "off" nil) (integer :tag "time" 2) @@ -2514,6 +2532,11 @@ A redo record for ordinary undo maps to the following (earlier) undo.") "Within a run of consecutive undo commands, list remaining to be undone. If t, we undid all the way to the end of it.") +(defun undo--last-change-was-undo-p (undo-list) + (while (and (consp undo-list) (eq (car undo-list) nil)) + (setq undo-list (cdr undo-list))) + (gethash undo-list undo-equiv-table)) + (defun undo (&optional arg) "Undo some previous changes. Repeat this command to undo more changes. @@ -2549,12 +2572,7 @@ as an argument limits undo to changes within the current region." (or (eq pending-undo-list t) ;; If something (a timer or filter?) changed the buffer ;; since the previous command, don't continue the undo seq. - (let ((list buffer-undo-list)) - (while (eq (car list) nil) - (setq list (cdr list))) - ;; If the last undo record made was made by undo - ;; it shows nothing else happened in between. - (gethash list undo-equiv-table)))) + (undo--last-change-was-undo-p buffer-undo-list))) (setq undo-in-region (and (or (region-active-p) (and arg (not (numberp arg)))) (not inhibit-region))) @@ -2644,6 +2662,25 @@ Contrary to `undo', this will not redo a previous undo." (interactive "*p") (let ((undo-no-redo t)) (undo arg))) +(defun undo-redo (&optional arg) + "Undo the last ARG undos." + (interactive "*p") + (cond + ((not (undo--last-change-was-undo-p buffer-undo-list)) + (user-error "No undo to undo")) + (t + (let* ((ul buffer-undo-list) + (new-ul + (let ((undo-in-progress t)) + (while (and (consp ul) (eq (car ul) nil)) + (setq ul (cdr ul))) + (primitive-undo arg ul))) + (new-pul (undo--last-change-was-undo-p new-ul))) + (message "Redo%s" (if undo-in-region " in region" "")) + (setq this-command 'undo) + (setq pending-undo-list new-pul) + (setq buffer-undo-list new-ul))))) + (defvar undo-in-progress nil "Non-nil while performing an undo. Some change-hooks test this variable to do something different.") diff --git a/lisp/so-long.el b/lisp/so-long.el index dcf7e62ca74..6b05f4821b1 100644 --- a/lisp/so-long.el +++ b/lisp/so-long.el @@ -353,7 +353,7 @@ ;; this caveat is the `mode' pseudo-variable, which is processed early in all ;; versions of Emacs, and can be set to `so-long-mode' if desired. -;;; * Change Log: +;; * Change Log: ;; ;; 1.0 - Included in Emacs 27.1, and in GNU ELPA for prior versions of Emacs. ;; - New global mode `global-so-long-mode' to enable/disable the library. @@ -944,8 +944,10 @@ This command calls `so-long' with the selected action as an argument.") (cl-letf (((symbol-function 'finder-summary) #'ignore)) (finder-commentary "so-long")) (let ((inhibit-read-only t)) - (when (looking-at "^Commentary:\n\n") - (replace-match "so-long.el\n\n")) + (if (looking-at "^Commentary:\n\n") + (replace-match "so-long.el\n\n") + (insert "so-long.el\n") + (forward-line 1)) (save-excursion (while (re-search-forward "^-+$" nil :noerror) (replace-match "")))) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index 4cd4fb9161d..faa0bcc540d 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -115,7 +115,7 @@ this version is not backward compatible to 0.14 or earlier.") (require 'easymenu) (require 'dframe) -(require 'sb-image) +(require 'ezimage) ;; customization stuff (defgroup speedbar nil @@ -141,6 +141,12 @@ this version is not backward compatible to 0.14 or earlier.") :prefix "speedbar-" :group 'speedbar) +(defcustom speedbar-use-images ezimage-use-images + "Non-nil if speedbar should display icons." + :group 'speedbar + :version "21.1" + :type 'boolean) + ;;; Code: ;; Note: `inversion-test' requires parts of the CEDET package that are @@ -296,6 +302,8 @@ The default buffer is the buffer in the selected window in the attached frame." "Hooks run when speedbar is loaded." :group 'speedbar :type 'hook) +(make-obsolete-variable 'speedbar-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom speedbar-reconfigure-keymaps-hook nil "Hooks run when the keymaps are regenerated." @@ -641,7 +649,7 @@ They should include commonly existing directories which are not useful. It is no longer necessary to include version-control directories here; see `vc-directory-exclusion-list'." :group 'speedbar - :type 'string) + :type 'regexp) (defcustom speedbar-file-unshown-regexp (let ((nstr "") (noext completion-ignored-extensions)) @@ -654,7 +662,7 @@ directories here; see `vc-directory-exclusion-list'." "Regexp matching files we don't want displayed in a speedbar buffer. It is generated from the variable `completion-ignored-extensions'." :group 'speedbar - :type 'string) + :type 'regexp) (defvar speedbar-file-regexp nil "Regular expression matching files we know how to expand. @@ -1703,7 +1711,7 @@ argument." (put-text-property start end 'help-echo #'dframe-help-echo)) (if function (put-text-property start end 'speedbar-function function)) (if token (put-text-property start end 'speedbar-token token)) - ;; So far the only text we have is less that 3 chars. + ;; So far the only text we have is less than 3 chars. (if (<= (- end start) 3) (speedbar-insert-image-button-maybe start (- end start))) ) @@ -4022,6 +4030,68 @@ TEXT is the buffer's name, TOKEN and INDENT are unused." (setq font-lock-global-modes (delq 'speedbar-mode font-lock-global-modes))))) +;;; Image management + +(defvar speedbar-expand-image-button-alist + '(("<+>" . ezimage-directory-plus) + ("<->" . ezimage-directory-minus) + ("< >" . ezimage-directory) + ("[+]" . ezimage-page-plus) + ("[-]" . ezimage-page-minus) + ("[?]" . ezimage-page) + ("[ ]" . ezimage-page) + ("{+}" . ezimage-box-plus) + ("{-}" . ezimage-box-minus) + ("<M>" . ezimage-mail) + ("<d>" . ezimage-document-tag) + ("<i>" . ezimage-info-tag) + (" =>" . ezimage-tag) + (" +>" . ezimage-tag-gt) + (" ->" . ezimage-tag-v) + (">" . ezimage-tag) + ("@" . ezimage-tag-type) + (" @" . ezimage-tag-type) + ("*" . ezimage-checkout) + ("#" . ezimage-object) + ("!" . ezimage-object-out-of-date) + ("//" . ezimage-label) + ("%" . ezimage-lock) + ) + "List of text and image associations.") + +(defun speedbar-insert-image-button-maybe (start length) + "Insert an image button based on text starting at START for LENGTH chars. +If buttontext is unknown, just insert that text. +If we have an image associated with it, use that image." + (when speedbar-use-images + (let ((ezimage-expand-image-button-alist + speedbar-expand-image-button-alist)) + (ezimage-insert-image-button-maybe start length)))) + +(defun speedbar-image-dump () + "Dump out the current state of the Speedbar image alist. +See `speedbar-expand-image-button-alist' for details." + (interactive) + (with-output-to-temp-buffer "*Speedbar Images*" + (with-current-buffer "*Speedbar Images*" + (goto-char (point-max)) + (insert "Speedbar image cache.\n\n") + (let ((start (point)) (end nil)) + (insert "Image\tText\tImage Name") + (setq end (point)) + (insert "\n") + (put-text-property start end 'face 'underline)) + (let ((ia speedbar-expand-image-button-alist)) + (while ia + (let ((start (point))) + (insert (car (car ia))) + (insert "\t") + (speedbar-insert-image-button-maybe start + (length (car (car ia)))) + (insert (car (car ia)) "\t" (format "%s" (cdr (car ia))) "\n")) + (setq ia (cdr ia))))))) + + (provide 'speedbar) ;; run load-time hooks diff --git a/lisp/strokes.el b/lisp/strokes.el index 7a88744540b..7c00305835b 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -296,6 +296,8 @@ the corresponding interactive function.") (defvar strokes-load-hook nil "Functions to be called when Strokes is loaded.") +(make-obsolete-variable 'strokes-load-hook + "use `with-eval-after-load' instead." "28.1") ;;; ### NOT IMPLEMENTED YET ### ;;(defvar edit-strokes-menu diff --git a/lisp/subr.el b/lisp/subr.el index c1c4cad18d1..b5ec0de156a 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2521,10 +2521,15 @@ by doing (clear-string STRING)." ;; And of course, don't keep the sensitive data around. (erase-buffer)))))))) -(defun read-number (prompt &optional default) +(defvar read-number-history nil + "The default history for the `read-number' function.") + +(defun read-number (prompt &optional default hist) "Read a numeric value in the minibuffer, prompting with PROMPT. DEFAULT specifies a default value to return if the user just types RET. The value of DEFAULT is inserted into PROMPT. +HIST specifies a history list variable. See `read-from-minibuffer' +for details of the HIST argument. This function is used by the `interactive' code letter `n'." (let ((n nil) (default1 (if (consp default) (car default) default))) @@ -2538,7 +2543,7 @@ This function is used by the `interactive' code letter `n'." (while (progn (let ((str (read-from-minibuffer - prompt nil nil nil nil + prompt nil nil nil (or hist 'read-number-history) (when default (if (consp default) (mapcar 'number-to-string (delq nil default)) diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index fac27f41ba9..873f54a27db 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1467,8 +1467,7 @@ This is an action function for buffer display, see Info node `(elisp) Buffer Display Action Functions'. It should be called only by `display-buffer' or a function directly or indirectly called by the latter." - (let* ((tab-name (alist-get 'tab-name alist)) - (reusable-frames (alist-get 'reusable-frames alist)) + (let* ((reusable-frames (alist-get 'reusable-frames alist)) (reusable-tab (when reusable-frames (tab-bar-get-buffer-tab buffer reusable-frames)))) (if reusable-tab @@ -1480,26 +1479,55 @@ indirectly called by the latter." (tab-bar-select-tab (1+ index))) (when (get-buffer-window buffer frame) (select-window (get-buffer-window buffer frame)))) + (let ((tab-name (alist-get 'tab-name alist))) + (when (functionp tab-name) + (setq tab-name (funcall tab-name buffer alist))) + (if tab-name + (let ((tab-index (tab-bar--tab-index-by-name tab-name))) + (if tab-index + (progn + (tab-bar-select-tab (1+ tab-index)) + (when (get-buffer-window buffer) + (select-window (get-buffer-window buffer)))) + (display-buffer-in-new-tab buffer alist))) + (display-buffer-in-new-tab buffer alist)))))) + +(defun display-buffer-in-new-tab (buffer alist) + "Display BUFFER in a new tab. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. + +Like `display-buffer-in-tab', but always creates a new tab unconditionally, +without checking if a suitable tab already exists. + +If ALIST contains a `tab-name' entry, it creates a new tab with that name +and displays BUFFER in a new tab. The `tab-name' entry can be a function, +then it is called with two arguments: BUFFER and ALIST, and should return +the tab name. When a `tab-name' entry is omitted, create a new tab without +an explicit name. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." + (let ((tab-bar-new-tab-choice t)) + (tab-bar-new-tab) + (let ((tab-name (alist-get 'tab-name alist))) (when (functionp tab-name) (setq tab-name (funcall tab-name buffer alist))) - (if tab-name - (let ((tab-index (tab-bar--tab-index-by-name tab-name))) - (if tab-index - (tab-bar-select-tab (1+ tab-index)) - (let ((tab-bar-new-tab-choice t)) - (tab-bar-new-tab) - (tab-bar-rename-tab tab-name)))) - (let ((tab-bar-new-tab-choice t)) - (tab-bar-new-tab)))))) + (when tab-name + (tab-bar-rename-tab tab-name))) + (window--display-buffer buffer (selected-window) 'tab alist))) (defun switch-to-buffer-other-tab (buffer-or-name &optional norecord) "Switch to buffer BUFFER-OR-NAME in another tab. Like \\[switch-to-buffer-other-frame] (which see), but creates a new tab." (interactive (list (read-buffer-to-switch "Switch to buffer in other tab: "))) - (display-buffer buffer-or-name '((display-buffer-in-tab - display-buffer-same-window) - (inhibit-same-window . nil)) + (display-buffer buffer-or-name '((display-buffer-in-tab) + (inhibit-same-window . nil) + (reusable-frames . t)) norecord)) (defun find-file-other-tab (filename &optional wildcards) diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 90024b001f7..6acf6cd1992 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -314,10 +314,9 @@ The overlay is assigned the face `ns-working-text-face'." (interactive) (ns-delete-working-text) (let ((start (point))) - (insert ns-working-text) - (overlay-put (setq ns-working-overlay (make-overlay start (point) - (current-buffer) nil t)) - 'face 'ns-working-text-face))) + (overlay-put (setq ns-working-overlay (make-overlay start (point))) + 'after-string + (propertize ns-working-text 'face 'ns-working-text-face)))) (defun ns-echo-working-text () "Echo contents of `ns-working-text' in message display area. @@ -340,8 +339,7 @@ See `ns-insert-working-text'." ;; Still alive? (overlay-buffer ns-working-overlay)) (with-current-buffer (overlay-buffer ns-working-overlay) - (delete-region (overlay-start ns-working-overlay) - (overlay-end ns-working-overlay)) + (overlay-put ns-working-overlay 'after-string nil) (delete-overlay ns-working-overlay))) ((integerp ns-working-overlay) (let ((msg (current-message)) diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 4c24e70d1f7..39a1b488a74 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -89,7 +89,7 @@ EXCEPTION-LIST is a list of strings. The checked word is downcased before comparing with these exceptions." :group 'flyspell :type '(alist :key-type (choice (const :tag "All dictionaries" nil) - string) + regexp) :value-type (repeat string)) :version "24.1") @@ -234,7 +234,7 @@ Ispell's ultimate default dictionary." "A string that is the regular expression that matches TeX commands." :group 'flyspell :version "21.1" - :type 'string) + :type 'regexp) (defcustom flyspell-check-tex-math-command nil "Non-nil means check even inside TeX math environment. diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el index 99c3e471241..e22e3f48994 100644 --- a/lisp/textmodes/paragraphs.el +++ b/lisp/textmodes/paragraphs.el @@ -168,7 +168,7 @@ to obtain the value of this variable." (defcustom sentence-end-base "[.?!…‽][]\"'”’)}»›]*" "Regexp matching the basic end of a sentence, not including following space." :group 'paragraphs - :type 'string + :type 'regexp :version "25.1") (put 'sentence-end-base 'safe-local-variable 'stringp) diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index ca92541331e..50dd6cd5f5a 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -2100,6 +2100,8 @@ construct: \\bbb [xxx] {aaa}." "Hook which is being run when loading reftex.el." :group 'reftex-miscellaneous-configurations :type 'hook) +(make-obsolete-variable 'reftex-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom reftex-mode-hook nil "Hook which is being run when turning on RefTeX mode." diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el index 542f1fef14e..4071c0dd074 100644 --- a/lisp/textmodes/reftex.el +++ b/lisp/textmodes/reftex.el @@ -2371,7 +2371,7 @@ what in fact did happen. Check if the bug is reproducible with an up-to-date version of RefTeX available from https://www.gnu.org/software/auctex/. -If the bug is triggered by a specific \(La)TeX file, you should try +If the bug is triggered by a specific (La)TeX file, you should try to produce a minimal sample file showing the problem and include it in your report. diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index 4482e7d4d23..7f87ee3646d 100644 --- a/lisp/textmodes/table.el +++ b/lisp/textmodes/table.el @@ -793,6 +793,8 @@ simply by any key input." "List of functions to be called after the table is first loaded." :type 'hook :group 'table-hooks) +(make-obsolete-variable 'table-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom table-point-entered-cell-hook nil "List of functions to be called after point entered a table cell." @@ -3206,11 +3208,7 @@ CALS (DocBook DTD): (while (and (re-search-forward "$" nil t) (not (eobp))) (insert "<br />") - (forward-char 1))) - (unless (and table-html-delegate-spacing-to-user-agent - (progn - (goto-char (point-min)) - (looking-at "\\s *\\'"))))) + (forward-char 1)))) ((eq language 'cals) (table--remove-eol-spaces (point-min) (point-max)) (if (re-search-forward "\\s +\\'" nil t) diff --git a/lisp/textmodes/tildify.el b/lisp/textmodes/tildify.el index 25f37ffa23d..398f7fdc232 100644 --- a/lisp/textmodes/tildify.el +++ b/lisp/textmodes/tildify.el @@ -67,7 +67,7 @@ matching the white space). The pattern is matched case-sensitive regardless of the value of `case-fold-search' setting." :version "25.1" :group 'tildify - :type 'string + :type 'regexp :safe t) (defcustom tildify-pattern-alist () @@ -417,7 +417,7 @@ of a space at point. The regexp is always case sensitive, regardless of the current `case-fold-search' setting." :version "25.1" :group 'tildify - :type 'string) + :type 'regexp) (defcustom tildify-space-predicates '(tildify-space-region-predicate) "A list of predicate functions for `tildify-space' function." diff --git a/lisp/thread.el b/lisp/thread.el index d40d7bed538..00a0084f81f 100644 --- a/lisp/thread.el +++ b/lisp/thread.el @@ -43,8 +43,6 @@ An EVENT has the format (err (cddr event))) (message "Error %s: %S" thread err)))) -(make-obsolete 'thread-alive-p 'thread-live-p "27.1") - ;;; The thread list buffer and list-threads command (defcustom thread-list-refresh-seconds 0.5 diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index 82617b76a71..4e44eedb122 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -430,6 +430,8 @@ Should be one of: "Hook run after initializing the URL library." :group 'url :type 'hook) +(make-obsolete-variable 'url-load-hook + "use `with-eval-after-load' instead." "28.1") (defconst url-working-buffer " *url-work") diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el index fb1f25b6c6d..cbd8c0d322c 100644 --- a/lisp/vc/ediff-init.el +++ b/lisp/vc/ediff-init.el @@ -452,6 +452,8 @@ For each buffer, the hooks are run with that buffer made current." "Hook run after Ediff is loaded. Can be used to change defaults." :type 'hook :group 'ediff-hook) +(make-obsolete-variable 'ediff-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom ediff-mode-hook nil "Hook run just after ediff-mode is set up in the control buffer. @@ -1282,7 +1284,7 @@ Do not start with `~/' or `~USERNAME/'." (defcustom ediff-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]" "Regexp that matches characters that must be quoted with `\\' in shell command line. This default should work without changes." - :type 'string + :type 'regexp :group 'ediff) ;; needed to simulate frame-char-width in XEmacs. diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el index a8af9ba37a2..5f8a4a86b15 100644 --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@ -1540,10 +1540,10 @@ the width of the A/B/C windows." ;; hscrolling. (if (= last-command-event ?<) (lambda (arg) - (let ((prefix-arg arg)) + (let ((current-prefix-arg arg)) (call-interactively #'scroll-left))) (lambda (arg) - (let ((prefix-arg arg)) + (let ((current-prefix-arg arg)) (call-interactively #'scroll-right)))) ;; calculate argument to scroll-left/right ;; if there is an explicit argument diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 61e6c642d1f..2caa287bce2 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -166,7 +166,7 @@ format string (which is passed to \"git log\" via the argument \"--pretty=tformat:FORMAT\"), REGEXP is a regular expression matching the resulting Git log output, and KEYWORDS is a list of `font-lock-keywords' for highlighting the Log View buffer." - :type '(list string string (repeat sexp)) + :type '(list string regexp (repeat sexp)) :version "24.1") (defcustom vc-git-commits-coding-system 'utf-8 diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index d00b69c0d08..40d75738063 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -182,7 +182,7 @@ is the \"--template\" argument string to pass to Mercurial, REGEXP is a regular expression matching the resulting Mercurial output, and KEYWORDS is a list of `font-lock-keywords' for highlighting the Log View buffer." - :type '(list string string (repeat sexp)) + :type '(list string regexp (repeat sexp)) :group 'vc-hg :version "24.5") diff --git a/lisp/whitespace.el b/lisp/whitespace.el index db7c023324b..0137ddcf04f 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -716,8 +716,8 @@ and the cons cdr is used for TABs visualization. Used when `whitespace-style' includes `indentation', `indentation::tab' or `indentation::space'." - :type '(cons (string :tag "Indentation SPACEs") - (string :tag "Indentation TABs")) + :type '(cons (regexp :tag "Indentation SPACEs") + (regexp :tag "Indentation TABs")) :group 'whitespace) @@ -747,8 +747,8 @@ and the cons cdr is used for TABs visualization. Used when `whitespace-style' includes `space-after-tab', `space-after-tab::tab' or `space-after-tab::space'." - :type '(cons (string :tag "SPACEs After TAB") - string) + :type '(cons (regexp :tag "SPACEs After TAB") + regexp) :group 'whitespace) (defcustom whitespace-big-indent-regexp diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 62846523be4..284fd1d6cbd 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -236,8 +236,7 @@ minibuffer." ;; Construct a menu of the choices ;; and then use it for prompting for a single character. (let* ((next-digit ?0) - (map (make-sparse-keymap)) - choice some-choice-enabled value) + alist choice some-choice-enabled value) (with-current-buffer (get-buffer-create " widget-choose") (erase-buffer) (insert "Available choices:\n\n") @@ -247,7 +246,7 @@ minibuffer." (let* ((name (substitute-command-keys (car choice))) (function (cdr choice))) (insert (format "%c = %s\n" next-digit name)) - (define-key map (vector next-digit) function) + (push (cons next-digit function) alist) (setq some-choice-enabled t))) ;; Allocate digits to disabled alternatives ;; so that the digit of a given alternative never varies. @@ -257,33 +256,17 @@ minibuffer." (forward-line)) (or some-choice-enabled (error "None of the choices is currently meaningful")) - (define-key map [?\M-\C-v] 'scroll-other-window) - (define-key map [?\M--] 'negative-argument) (save-window-excursion - (let ((buf (get-buffer " widget-choose"))) - (display-buffer buf - '(display-buffer-in-direction - (direction . bottom) - (window-height . fit-window-to-buffer))) - (let ((cursor-in-echo-area t) - (arg 1)) - (while (not value) - (setq value (lookup-key map (read-key-sequence (format "%s: " title)))) - (unless value - (user-error "Canceled")) - (when - (cond ((eq value 'scroll-other-window) - (let ((minibuffer-scroll-window - (get-buffer-window buf))) - (if (> 0 arg) - (scroll-other-window-down - (window-height minibuffer-scroll-window)) - (scroll-other-window)) - (setq arg 1))) - ((eq value 'negative-argument) - (setq arg -1))) - (setq value nil)))))) - value)))) + ;; Select window to be able to scroll it from minibuffer + (with-selected-window + (display-buffer (get-buffer " widget-choose") + '(display-buffer-in-direction + (direction . bottom) + (window-height . fit-window-to-buffer))) + (setq value (read-char-from-minibuffer + (format "%s: " title) + (mapcar #'car alist))))) + (cdr (assoc value alist)))))) ;;; Widget text specifications. ;; diff --git a/lisp/windmove.el b/lisp/windmove.el index 6e62e161548..40adb49e20f 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -467,18 +467,19 @@ When `switch-to-buffer-obey-display-actions' is non-nil, (minibuffer-depth (minibuffer-depth)) (action (lambda (buffer alist) (unless (> (minibuffer-depth) minibuffer-depth) - (let ((window (cond - ((eq dir 'new-tab) - (let ((tab-bar-new-tab-choice t)) - (tab-bar-new-tab)) - (selected-window)) - ((eq dir 'same-window) - (selected-window)) - (t (window-in-direction - dir nil nil - (and arg (prefix-numeric-value arg)) - windmove-wrap-around)))) - (type 'reuse)) + (let* ((type 'reuse) + (window (cond + ((eq dir 'new-tab) + (let ((tab-bar-new-tab-choice t)) + (tab-bar-new-tab)) + (setq type 'tab) + (selected-window)) + ((eq dir 'same-window) + (selected-window)) + (t (window-in-direction + dir nil nil + (and arg (prefix-numeric-value arg)) + windmove-wrap-around))))) (unless window (setq window (split-window nil nil dir) type 'window)) (setq new-window (window--display-buffer buffer window diff --git a/lisp/window.el b/lisp/window.el index 40c4bf5ad47..bd825c09e16 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -5009,6 +5009,13 @@ nil means to not handle the buffer in a particular way. This quad entry) (cond ((and (not prev-buffer) + (eq (nth 1 quit-restore) 'tab) + (eq (nth 3 quit-restore) buffer)) + (tab-bar-close-tab) + ;; If the previously selected window is still alive, select it. + (when (window-live-p (nth 2 quit-restore)) + (select-window (nth 2 quit-restore)))) + ((and (not prev-buffer) (or (eq (nth 1 quit-restore) 'frame) (and (eq (nth 1 quit-restore) 'window) ;; If the window has been created on an existing @@ -6367,7 +6374,12 @@ fourth element is BUFFER." ;; WINDOW has been created on a new frame. (set-window-parameter window 'quit-restore - (list 'frame 'frame (selected-window) buffer))))) + (list 'frame 'frame (selected-window) buffer))) + ((eq type 'tab) + ;; WINDOW has been created on a new tab. + (set-window-parameter + window 'quit-restore + (list 'tab 'tab (selected-window) buffer))))) (defcustom display-buffer-function nil "If non-nil, function to call to handle `display-buffer'. @@ -7034,7 +7046,7 @@ Return WINDOW if BUFFER and WINDOW are live." ;; use that. (display-buffer-mark-dedicated (set-window-dedicated-p window display-buffer-mark-dedicated)))) - (when (memq type '(window frame)) + (when (memq type '(window frame tab)) (set-window-prev-buffers window nil)) (let ((quit-restore (window-parameter window 'quit-restore)) (height (cdr (assq 'window-height alist))) diff --git a/lisp/woman.el b/lisp/woman.el index 8465ab7c32e..beebde95e9a 100644 --- a/lisp/woman.el +++ b/lisp/woman.el @@ -674,7 +674,7 @@ These normally have names of the form `man?'. Its default value is \"[Mm][Aa][Nn]\", which is case-insensitive mainly for the benefit of Microsoft platforms. Its purpose is to avoid `cat?', `.', `..', etc." ;; Based on a suggestion by Wei-Xue Shi. - :type 'string + :type 'regexp :group 'woman-interface) (defcustom woman-path @@ -753,7 +753,7 @@ Default is t." An alist with elements of the form (MENU-TITLE REGEXP INDEX) -- see the documentation for `imenu-generic-expression'." :type '(alist :key-type (choice :tag "Title" (const nil) string) - :value-type (group (choice (string :tag "Regexp") + :value-type (group (choice (regexp :tag "Regexp") function) integer)) :group 'woman-interface) diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index ea9d119e2ff..b22af5cc770 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -412,19 +412,13 @@ FRAME is the frame and W is the window where the drop happened. If W is a window, return its absolute coordinates, otherwise return the frame coordinates." (let* ((frame-left (frame-parameter frame 'left)) - ;; If the frame is outside the display, frame-left looks like - ;; '(0 -16). Extract the -16. - (frame-real-left (if (consp frame-left) (car (cdr frame-left)) - frame-left)) - (frame-top (frame-parameter frame 'top)) - (frame-real-top (if (consp frame-top) (car (cdr frame-top)) - frame-top))) + (frame-top (frame-parameter frame 'top))) (if (windowp w) (let ((edges (window-inside-pixel-edges w))) (cons - (+ frame-real-left (nth 0 edges)) - (+ frame-real-top (nth 1 edges)))) - (cons frame-real-left frame-real-top)))) + (+ frame-left (nth 0 edges)) + (+ frame-top (nth 1 edges)))) + (cons frame-left frame-top)))) (declare-function x-get-atom-name "xselect.c" (value &optional frame)) (declare-function x-send-client-message "xselect.c" @@ -434,15 +428,11 @@ otherwise return the frame coordinates." (defun x-dnd-version-from-flags (flags) "Return the version byte from the 32 bit FLAGS in an XDndEnter message." - (if (consp flags) ;; Long as cons - (ash (car flags) -8) - (ash flags -24))) ;; Ordinary number + (ash flags -24)) (defun x-dnd-more-than-3-from-flags (flags) "Return the nmore-than3 bit from the 32 bit FLAGS in an XDndEnter message." - (if (consp flags) - (logand (cdr flags) 1) - (logand flags 1))) + (logand flags 1)) (defun x-dnd-handle-xdnd (event frame window message _format data) "Receive one XDND event (client message) and send the appropriate reply. @@ -454,7 +444,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (version (x-dnd-version-from-flags flags)) (more-than-3 (x-dnd-more-than-3-from-flags flags)) (dnd-source (aref data 0))) - (message "%s %s" version more-than-3) + (message "%s %s" version more-than-3) (if version ;; If flags is bad, version will be nil. (x-dnd-save-state window nil nil @@ -495,10 +485,12 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." ((equal "XdndDrop" message) (if (windowp window) (select-window window)) (let* ((dnd-source (aref data 0)) + (timestamp (aref data 2)) (value (and (x-dnd-current-type window) (x-get-selection-internal 'XdndSelection - (intern (x-dnd-current-type window))))) + (intern (x-dnd-current-type window)) + timestamp))) success action) (setq action (if value @@ -545,14 +537,14 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." ((eq size 4) (if (eq byteorder ?l) - (cons (+ (ash (aref data (+ 3 offset)) 8) - (aref data (+ 2 offset))) - (+ (ash (aref data (1+ offset)) 8) - (aref data offset))) - (cons (+ (ash (aref data offset) 8) - (aref data (1+ offset))) - (+ (ash (aref data (+ 2 offset)) 8) - (aref data (+ 3 offset)))))))) + (+ (ash (aref data (+ 3 offset)) 24) + (ash (aref data (+ 2 offset)) 16) + (ash (aref data (1+ offset)) 8) + (aref data offset)) + (+ (ash (aref data offset) 24) + (ash (aref data (1+ offset)) 16) + (ash (aref data (+ 2 offset)) 8) + (aref data (+ 3 offset))))))) (defun x-dnd-motif-value-to-list (value size byteorder) (let ((bytes (cond ((eq size 2) @@ -560,15 +552,10 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (logand value ?\xff))) ((eq size 4) - (if (consp value) - (list (logand (ash (car value) -8) ?\xff) - (logand (car value) ?\xff) - (logand (ash (cdr value) -8) ?\xff) - (logand (cdr value) ?\xff)) - (list (logand (ash value -24) ?\xff) - (logand (ash value -16) ?\xff) - (logand (ash value -8) ?\xff) - (logand value ?\xff))))))) + (list (logand (ash value -24) ?\xff) + (logand (ash value -16) ?\xff) + (logand (ash value -8) ?\xff) + (logand value ?\xff)))))) (if (eq byteorder ?l) (reverse bytes) bytes))) |